VBA 코드를 사용하여 Excel 2003에서 Excel 워크시트를 이미지로 내보내는 방법은 무엇입니까?

VBA 코드를 사용하여 Excel 2003에서 Excel 워크시트를 이미지로 내보내는 방법은 무엇입니까?

Excel 워크시트에서 .jpeg 또는 .png 또는 .gif의 이미지로 데이터 범위를 내보내는 더 나은 방법을 제안하십시오.

당신은 제가 몇 달 전에 인터넷에서 찾아 사용한 아래의 코드를 시도하고 싶습니까?

Range 객체의 CopyPicture 메서드와 함께 Chart 객체의 Export 기능을 사용합니다.

참조:

• MSDN - 차트 개체에 적용되는 방법을 내보냅니다.클립보드를 이미지로 저장하는 방법

• MSDN - 범위를 그림으로 복사하기 위해 범위 개체에 적용되는 CopyPicture 메서드

  dim sSheetName as string
  dim oRangeToCopy as range
  Dim oCht As Chart
  
  sSheetName ="Sheet1" ' worksheet to work on
  set  oRangeToCopy =Range("B2:H8") ' range to be copied
  
  Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
  set oCht =charts.add
  
  with oCht
      .paste
      .Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
  end with
  

저는 이 솔루션을 여러 가지 방법으로 개선하려고 노력했습니다.이제 결과 이미지의 비율이 적절합니다.

Set sheet = ActiveSheet
output = "D:\SavedRange4.png"

zoom_coef = 100 / sheet.Parent.Windows(1).Zoom
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export output, "png"
chartobj.Delete

여러분 감사합니다!워크시트를 사용하는 사용자와 상관없이 Winand의 코드를 사용자의 데스크톱으로 내보내기 위해 약간 수정했습니다.저는 코드에서 아이디어를 얻은 부분을 인정했습니다(Kyle에게 감사합니다).

Sub ExportImage()


Dim sFilePath As String
Dim sView As String

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating = False

Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:" & Chr(10) & Chr(10) & sFilePath)

End Sub

Winand, 품질 또한 저에게 중요한 문제였기 때문에 저는 이렇게 했습니다.

For Each ws In ActiveWorkbook.Worksheets
    If ws.PageSetup.PrintArea <> "" Then
        'Reverse the effects of page zoom on the exported image
        zoom_coef = 100 / ws.Parent.Windows(1).Zoom
        areas = Split(ws.PageSetup.PrintArea, ",")
        areaNo = 0
        For Each a In areas
            Set area = ws.Range(a)
            ' Change xlPrinter to xlScreen to see zooming white space
            area.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
            Set chartobj = ws.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
            chartobj.Chart.Paste
            'scale the image before export
            ws.Shapes(chartobj.Index).ScaleHeight 3, msoFalse, msoScaleFromTopLeft
            ws.Shapes(chartobj.Index).ScaleWidth 3, msoFalse, msoScaleFromTopLeft
            chartobj.Chart.Export ws.Name & "-" & areaNo & ".png", "png"
            chartobj.delete
            areaNo = areaNo + 1
        Next
    End If
Next

다음을 참조하십시오.https://robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/

차트가 없는 솔루션

Function SelectionToPicture(nome)

'save location ( change if you want )
FName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & nome & ".jpg"

'copy selection and get size
Selection.CopyPicture xlScreen, xlBitmap
w = Selection.Width
h = Selection.Height



With ThisWorkbook.ActiveSheet

    .Activate

    Dim chtObj As ChartObject
    Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
    chtObj.Name = "TemporaryPictureChart"

    'resize obj to picture size
    chtObj.Width = w
    chtObj.Height = h

    ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
    ActiveChart.Paste

    ActiveChart.Export FileName:=FName, FilterName:="jpg"

    chtObj.Delete

End With
End Function

Ryan Bradley 코드에 Selection and save to workbook 경로를 추가하면 보다 탄력적입니다.

 Sub ExportImage()

Dim sheet, zoom_coef, area, chartobj
Dim sFilePath As String
Dim sView As String

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating = False

Set sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
'sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'##################
'Łukasz : Save to  workbook directory
'Asking for filename insted of ActiveSheet.Name is also good idea, without file extension
dim FileID as string
FileID=inputbox("Type a file name","Filename...?",ActiveSheet.Name)
sFilePath = ThisWorkbook.Path & "\" & FileID & ".png"

'Łukasz:Change code to use Selection
'Simply select what you want to export and run the macro
'ActiveCell should be: Top Left 
'it means select from top left corner to right bottom corner

Dim r As Long, c As Integer, ar As Long, ac As Integer

    r = Selection.rows.Count
    c = Selection.Columns.Count
    ar = ActiveCell.Row
    ac = ActiveCell.Column
    ActiveSheet.PageSetup.PrintArea = Range(Cells(ar, ac), Cells(ar, ac)).Resize(r, c).Address

'Export print area as correctly scaled PNG image, courtasy of Winand
'Łukasz: zoom_coef can be constant = 0 to 5 can work too, but save is 0 to 4
zoom_coef = 5 '100 / sheet.Parent.Windows(1).Zoom
'#############
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter  'xlBitmap '
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here: :" & Chr(10) & Chr(10) & sFilePath)
'Close
End Sub

이를 통해 가장 신뢰할 수 있는 결과를 얻을 수 있습니다.

Sub RangeToPicture()
  Dim FileName As String: FileName = "C:\file.bmp"
  Dim rPrt As Range: Set rPrt = ThisWorkbook.Sheets("Sheet1").Range("A1:C6")
  'Add a Zoom to increase the resolution of the image.          
  ActiveWindow.Zoom = 300
  
  Dim chtObj As ChartObject
  rPrt.CopyPicture xlScreen, xlBitmap
  Set chtObj = ActiveSheet.ChartObjects.Add(1, 1, rPrt.Width, rPrt.Height)
  chtObj.Activate
  ActiveChart.Paste
  ActiveChart.Export FileName
  chtObj.Delete
  'Reset Zoom to innitial zoom of the image.          
  ActiveWindow.Zoom = 100
End Sub

필립이 제공한 링크를 기반으로 저는 이것을 작동하게 되었습니다.

Worksheets("Final Analysis Sheet").Range("A4:G112").CopyPicture xlScreen, xlBitmap

    Application.DisplayAlerts = False
    Set oCht = Charts.Add
    With oCht
        .Paste
        .Export Filename:="C:\FTPDailycheck\TodaysImages\SavedRange.jpg", Filtername:="JPG"
        .Delete
    End With

임시 차트를 만들 필요 없이 범위 이미지를 파일로 직접 내보낼 수 있습니다.PowerShell을 사용하여 클립보드를 .png 파일로 저장합니다.

범위를 클립보드에 이미지로 복사하는 것은 다른 답변에 나와 있는 것처럼 vba CopyPicture 명령을 사용하면 간단합니다.

클립보드를 저장하기 위한 PowerShell 스크립트에는 두 줄만 필요합니다. Thomschmacher가 PowerShell을 사용하여 클립보드에서 이미지 저장에 언급했습니다.

VBA는 PowerShell 스크립트를 시작하고 완료될 때까지 기다릴 수 있습니다(쉘 대기 명령의 완료).

이 아이디어들을 종합하면, 우리는 다음과 같은 루틴을 얻습니다.나는 이것을 오피스 2010 버전의 엑셀을 사용하여 윈도우 10에서만 테스트했습니다.루틴 실행에 대한 추가 피드백을 제공하기 위해 True로 설정할 수 있는 내부 지속적인 AidDebugging이 있습니다.

Option Explicit

' This routine copies the bitmap image of a range of cells to a .png file.
' Input arguments:
'    RangeRef -- the range to be copied. This must be passed as a range object, not as the name
'                or address of the range.
'    Destination -- the name (including path if necessary) of the file to be created, ending in
'                the extension ".png". It will be overwritten without warning if it exists.
'    TempFile -- the name (including path if necessary) of a temporary script file which will be
'                created and destroyed. If this is not supplied, file "RangeToPNG.ps1" will be
'                created in the default folder. If AidDebugging is set to True, then this file
'                will not be deleted, so it can be inspected for debugging.
' If the PowerShell script file cannot be launched, then this routine will display an error message.
' However, if the script can be launched but cannot create the resulting file, this script cannot
' detect that. To diagnose the problem, change AidDebugging from False to True and inspect the
' PowerShell output, which will remain in view until you close its window.

Public Sub RangeToPNG(RangeRef As Range, Destination As String, _
                      Optional TempFile As String = "RangeToPNG.ps1")
Dim WSH As Object
Dim PSCommand As String
Dim WindowStyle As Integer
Dim ErrorCode As Integer
Const WaitOnReturn = True
Const AidDebugging = False ' provide extra feedback about this routine's execution
  ' Create a little PowerShell script to save the clipboard as a .png file
  ' The script is based on a version found on September 13, 2020 at
  '    https://stackoverflow.com/questions/55215482/save-image-from-clipboard-using-powershell
   Open TempFile For Output As #1
   If (AidDebugging) Then ' output some extra feedback
      Print #1, "Set-PSDebug -Trace 1" ' optional -- aids debugging
   End If
   Print #1, "$img = get-clipboard -format image"
   Print #1, "$img.save(""" & Destination & """)"
   If (AidDebugging) Then ' leave the PowerShell execution record on the screen for review
      Print #1, "Read-Host -Prompt ""Press <Enter> to continue"" "
      WindowStyle = 1 ' display window to aid debugging
   Else
      WindowStyle = 0 ' hide window
   End If
   Close #1
  ' Copy the desired range of cells to the clipboard as a bitmap image
   RangeRef.CopyPicture xlScreen, xlBitmap
  ' Execute the PowerShell script
   PSCommand = "POWERSHELL.exe -ExecutionPolicy Bypass -file """ & TempFile & """ "
   Set WSH = VBA.CreateObject("WScript.Shell")
   ErrorCode = WSH.Run(PSCommand, WindowStyle, WaitOnReturn)
   If (ErrorCode <> 0) Then
      MsgBox "The attempt to run a PowerShell script to save a range " & _
             "as a .png file failed -- error code " & ErrorCode
   End If
   If (Not AidDebugging) Then
     ' Delete the script file, unless it might be useful for debugging
      Kill TempFile
   End If
End Sub

' Here's an example which tests the routine above.
Sub Test()
   RangeToPNG Worksheets("Sheet1").Range("A1:F13"), "E:\Temp\ExportTest.png"
End Sub

언급URL : https://stackoverflow.com/questions/16143877/using-vba-code-how-to-export-excel-worksheets-as-image-in-excel-2003