VBA를 사용하여 Excel 파일에서 jpg로 사진 내보내기

VBA를 사용하여 Excel 파일에서 jpg로 사진 내보내기

저는 B열의 사진이 포함된 Excel 파일을 가지고 있으며 여러 파일로 .jpg(또는 다른 사진 파일 형식)로 내보내기를 원합니다.파일 이름은 A열의 텍스트에서 생성되어야 합니다.VBA 매크로를 따라 해봤습니다.

Private Sub CommandButton1_Click()
Dim oTxt As Object
 For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count)
 ' you can change the sheet1 to your own choice
 saveText = cell.Text
 Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1
 Print #1, cell.Offset(0, 1).text
 Close #1
 Next cell
End Sub

결과적으로 콘텐츠 없이 파일(jpg)을 생성합니다.내 생각에 그 말은Print #1, cell.Offset(0, 1).text.틀렸습니다.무엇으로 바꿔야 할지 모르겠어요cell.Offset(0, 1).pix?

누가 나를 도와줄 수 있습니까?감사합니다!

제 기억이 맞다면, 당신은 시트의 "모양" 속성을 사용해야 합니다.

각 Shape 객체에는 이미지의 위치를 알려주는 TopLeftCell 및 BottomRightCell 특성이 있습니다.

여기 제가 얼마 전에 사용한 코드가 있는데요, 대략 당신의 필요에 맞게 조정되었습니다.모든 ChartObjects에 대한 자세한 내용은 기억나지 않지만 다음과 같습니다.

For Each oShape In ActiveSheet.Shapes
    strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
    oShape.Select
    'Picture format initialization
    Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
    '/Picture format initialization
    Application.Selection.CopyPicture
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
    Set oChartArea = oDia.Chart
    oDia.Activate
    With oChartArea
        .ChartArea.Select
        .Paste
        .Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg")
    End With
    oDia.Delete 'oChartArea.Delete
Next

다음 코드:

Option Explicit

Sub ExportMyPicture()

     Dim MyChart As String, MyPicture As String
     Dim PicWidth As Long, PicHeight As Long

     Application.ScreenUpdating = False
     On Error GoTo Finish

     MyPicture = Selection.Name
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With

     Charts.Add
     ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight
           End With

           .Shapes(MyPicture).Copy

           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With

           .ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
           .Shapes(MyChart).Cut
     End With

     Application.ScreenUpdating = True
     Exit Sub

Finish:
     MsgBox "You must select a picture"
End Sub

여기서 직접 복사한 것이고, 제가 테스트한 케이스에 잘 맞습니다.

폴더로 내보낼 범위 설정

워크북("워크북 이름").시트("시트 이름").선택한다.

Dim rgExp As Range: Set rgExp = Range("A1:H31")
''' Copy range as picture onto Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
''' Create an empty chart with exact size of range copied
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete

Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"

필요한 경우 코드를 최소화합니다.

새로운 버전의 Excel은 오래된 답변을 쓸모없게 만들었습니다.이것을 만드는 데 오랜 시간이 걸렸지만, 꽤 잘 만듭니다.최대 이미지 크기가 제한되고 가로 세로 비율이 약간 어긋나므로 재구성 연산을 완벽하게 최적화할 수 없습니다.제 워크시트 중 하나에 wsTMP라는 이름을 붙였으니 Sheet1 등으로 대체하시면 됩니다.스크린샷을 대상 경로로 인쇄하는 데 약 1초가 걸립니다.

Option Explicit

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Sub weGucciFam()

Dim tmp As Variant, str As String, h As Double, w As Double

Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"

keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28

str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height

Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
    .PageSetup.PaperSize = xlPaper11x17
    .PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
    .PageSetup.BottomMargin = 0
    .PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
    .PageSetup.LeftMargin = 0
    .PageSetup.HeaderMargin = 0
    .PageSetup.FooterMargin = 0
    .SeriesCollection(1).Delete
    DoEvents
    .Paste
    DoEvents
    .Export Filename:=str, Filtername:="jpeg"
    .Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
    wsTMP.Shapes(1).Delete
Loop

Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

아이디어 감사합니다!저는 위의 아이디어를 사용하여 대량 파일 변환을 수행하는 매크로를 만들었습니다. 즉, 폴더에 있는 한 형식의 모든 파일을 다른 형식으로 변환하는 것입니다.

이 코드에는 "FilePath"(\), "StartExt"(원래 파일 확장명) 및 "EndExt"(원하는 파일 확장명)라는 셀이 있는 시트가 필요합니다.경고: 기존 파일을 동일한 이름과 확장자로 바꾸기 전에 확인을 요청하지 않습니다.

Private Sub CommandButton1_Click()
    Dim path As String
    Dim pathExt As String
    Dim file As String
    Dim oldExt As String
    Dim newExt As String
    Dim newFile As String
    Dim shp As Picture
    Dim chrt As ChartObject
    Dim chrtArea As Chart

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'Get settings entered by user
    path = Range("FilePath")
    oldExt = Range("StartExt")
    pathExt = path & "*." & oldExt
    newExt = Range("EndExt")

    file = Dir(pathExt)

    Do While Not file = "" 'cycle through all images in folder of selected format
        Set shp = ActiveSheet.Pictures.Insert(path & file) 'Import image
        newFile = Replace(file, "." & oldExt, "." & newExt) 'Determine new file name
        Set chrt = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height) 'Create blank chart for embedding image
        Set chrtArea = chrt.Chart
        shp.CopyPicture 'Copy image to clipboard
        With chrtArea 'Paste image to chart, then export
            .ChartArea.Select
            .Paste
            .Export (path & newFile)
        End With
        chrt.Delete 'Delete chart
        shp.Delete 'Delete imported image

        file = Dir 'Advance to next file
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

여기 또 다른 멋진 방법이 있습니다 - 명령행 스위치를 수락하는 외부 뷰어 사용(이 경우 IrfanView): * 위에 Michal Krzych가 작성한 내용을 기반으로 루프를 만들었습니다.

Sub ExportPicturesToFiles()
    Const saveSceenshotTo As String = "C:\temp\"
    Const pictureFormat As String = ".jpg"

    Dim pic As Shape
    Dim sFileName As String
    Dim i As Long

    i = 1

    For Each pic In ActiveSheet.Shapes
        pic.Copy
        sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat

        Call ExportPicWithIfran(sFileName)

        i = i + 1
    Next
End Sub

Public Sub ExportPicWithIfran(sSaveAsPath As String)
    Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe"
    Dim sRunIfran As String

    sRunIfran = sIfranPath & " /clippaste /convert=" & _
                            sSaveAsPath & " /killmesoftly"

    ' Shell is no good here. If you have more than 1 pic, it will
    ' mess things up (pics will over run other pics, becuase Shell does
    ' not make vba wait for the script to finish).
    ' Shell sRunIfran, vbHide

    ' Correct way (it will now wait for the batch to finish):
    call MyShell(sRunIfran )
End Sub

편집:

  Private Sub MyShell(strShell As String)
  ' based on:
    ' http://stackoverflow.com/questions/15951837/excel-vba-wait-for-shell-command-to-complete
   ' by Nate Hekman

    Dim wsh As Object
    Dim waitOnReturn As Boolean:
    Dim windowStyle As VbAppWinStyle

    Set wsh = VBA.CreateObject("WScript.Shell")
    waitOnReturn = True
    windowStyle = vbHide

    wsh.Run strShell, windowStyle, waitOnReturn
End Sub

언급URL : https://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba