시트를 순환하며 선택영역을 지정폴더에 JPG 출판(Ⅰ)

Option Explicit
 
 
Sub Publish_Range_To_JPG()

 '★★시트를 순환하며 선택영역을 지정폴더에 JPG 출판★★

  Application.EnableEvents = False
 
  Rng_To_Image Selection
  
  Application.EnableEvents = True
 
End Sub
 

Sub Rng_To_Image(rngSelection As Range, _
                 Optional FileName As String = "엑셀이미지", _
                 Optional SavePath As String = "", _
                 Optional AddSequence As Boolean = True)
 
 
  Dim NewWs As Worksheet
  Dim picRange As Object: Dim MyObj As Chart
  Dim PicH As Double: Dim PicW As Double
  Dim FilePath As String
  
 'JPG FILE 저장 POLDER 지정
  Dim strPolderName As String
 '확장자를 포함한 워크북명
  Dim LATUS As String
 '확장자를 제거한 워크북명
  Dim strFileName As String
  Dim iSplit As Integer
  Dim sht As Worksheet
  Dim vAry() As Integer
  Dim ShtAry() As String
  Dim i As Integer
  Dim n As Integer
 
 
  If SavePath = "" Then SavePath = KIFolder
  
  LATUS = ActiveWorkbook.Name
  
  
 '확장자를 제거한 워크북명(filename)
  strFileName = ""
  
  iSplit = InStrRev(LATUS, ".")
  
  If iSplit = 0 Then
     strFileName = LATUS
  Else
     strFileName = Left(LATUS, iSplit - 1)
  End If
  
  i = 0
  
 '선택된 시트를 배열에 저장
  For Each sht In ActiveWindow.SelectedSheets
      
      i = i + 1
      
      ReDim Preserve vAry(1 To i)
      ReDim Preserve ShtAry(1 To i)
      vAry(i) = sht.Index
      ShtAry(i) = sht.Name
  
  Next
  
  
 '선택된 시트를 순환하면서 JPG 저장
  For n = LBound(ShtAry) To UBound(ShtAry)
  
  
      FilePath = SavePath & "\" & strFileName & " " _
                                & Format(vAry(n), "000") & " " & ShtAry(n) & "_" _
                                & Format(Now, "yyyymmdd_hhnnss") & ".JPG"
 
      rngSelection.CopyPicture xlScreen, xlPicture
 
      Set NewWs = ActiveWorkbook.Sheets.Add
  
      NewWs.Paste
 
      Set picRange = NewWs.Shapes.Item(1)

      With picRange
           PicH = .Height
           PicW = .Width
                  .Delete
      End With
 
      With NewWs.Shapes.AddChart2
                                 .Height = PicH
                                 .Width = PicW
      End With
 
      Set MyObj = NewWs.Shapes.Item(1).Chart
 
      MyObj.ChartArea.Select
      MyObj.Paste
 
     If AddSequence = True Then
        FilePath = FileSequence(FilePath, 1)
     End If
                            
    '여기서 "JPG" 역시 필터 이름(FilterName)으로, 내보낼 파일 형식을 지정하는 역할을 합니다.
                            
     MyObj.Export FilePath, "JPG"
 
     Application.DisplayAlerts = False

     NewWs.Delete

     Application.DisplayAlerts = True
  
     Set rngSelection = Nothing
     Set NewWs = Nothing
     Set picRange = Nothing
     Set MyObj = Nothing

NextSheet:

  Next n
  
  FileName = ""
  SavePath = ""
  FilePath = ""
  LATUS = ""
  strFileName = ""
  PicH = 0
  PicW = 0
  i = 0
  iSplit = 0
  n = 0
 
 '배열의 초기화
  Erase vAry
  Erase ShtAry

  Application.CutCopyMode = False
    
 'MsgBox "선택한 영역들이 각각 JPG로 저장되었습니다."
 
End Sub
 


Public Function KIFolder(Optional varDir As Variant, Optional strMsg As String = "폴더를 선택하여 주십시오.") As String
  
  Dim Polder_Path As String

  With Application.FileDialog(msoFileDialogFolderPicker)
      .Show
      If .SelectedItems.Count = 0 Then Exit Function
      Polder_Path = .SelectedItems(1)
      KIFolder = .SelectedItems(1)
  End With
  
  
 '지정 폴더를 열기
  Shell "rundll32.exe url.dll,FileProtocolHandler " & Polder_Path, vbNormalFocus
  
End Function
 
 
Function FileSequence(FilePath As String, Optional Sequence As Long = 1) As String
 
  Dim Ext As String: Dim Path As String: Dim newPath As String
  Dim Pnt As Long
 
  Pnt = InStrRev(FilePath, ".")
  Path = Left(FilePath, Pnt - 1)
  Ext = Right(FilePath, Len(FilePath) - Pnt + 1)
 
  newPath = Path & Sequence & Ext
 
  Do Until FileExists(newPath) = False
    
     Sequence = Sequence + 1
     
     newPath = Path & Sequence & Ext
  Loop
 
  FileSequence = newPath
 
End Function


Public Function FileExists(ByVal path_ As String) As Boolean
 
    FileExists = (Dir(path_, vbDirectory) <> "")
 
End Function
 

시트를 순환하며 선택영역을 지정폴더에 JPG 출판(1).txt

0.01MB