Image 使用VBA将excel文件中的图片导出到jpg

我有一个Excel文件，其中包含B列中的图片，我想将它们导出为.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

有人能帮我吗？谢谢

此代码：

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

---

是直接从中复制的，在我测试的案例中效果很好。

如果我没记错，您需要使用工作表的“Shapes”属性

每个形状对象都有一个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

---

下面是另一种很酷的方法-使用接受命令行开关的en external viewer（本例中为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

如果需要，将代码精简到绝对最小值。

''设置要导出到文件夹的范围

工作簿（“您的工作簿名称”）。工作表（“您的工作表名称”）。选择

---

新版本的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

选项显式
Private Declare PtrSafe Sub keybd_事件库“user32”（ByVal bVk为字节，ByVal bScan为字节，ByVal dwFlags为长，ByVal dwExtraInfo为长）
副韦古奇法姆（）
Dim tmp作为变量，str作为字符串，h作为双精度，w作为双精度
Application.PrintCommunication=False
Application.EnableEvents=False
Application.Calculation=xlCalculationManual
Application.ScreenUpdating=False
如果Application.StatusBar=False，则Application.StatusBar=“已禁用事件”
keybd_事件vbKeyMenu，0，0，0'这些仅用于活动窗口
keybd_事件vbKeySnapshot，0,0,0
keybd_事件vbKeySnapshot，0,2,0
keybd_事件vbKeyMenu，0,2,0'sendkeys alt+printscreen不工作
wsTMP.粘贴
多芬特
双精度常数dw=1186.56
常数dh为双=755.28
str=“C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg”
w=wsTMP.形状（1）.宽度
h=wsTMP.形状（1）.高度
Application.DisplayAlerts=False
设置tmp=图表。添加
出错时继续下一步
与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
.系列集合（1）.删除
多芬特
粘贴
多芬特
.Export文件名：=str，过滤器名称：=“jpeg”
.删除
以
错误转到0
直到wsTMP.Shapes.Count<1为止
wsTMP.Shapes（1）.删除
环
Application.PrintCommunication=True
Application.EnableEvents=True
Application.Calculation=xlCalculationAutomatic
Application.ScreenUpdating=True
Application.StatusBar=False
端接头

谢谢你的创意！我用上面的想法制作了一个宏来进行大容量文件转换——将文件夹中一种格式的每个文件转换为另一种格式

这段代码需要一个包含名为“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

---

您可以使用add inhow存储图片吗？如果它们在activex图像控件中，则只需一行代码即可保存图片；如果没有，您将需要更复杂的代码或类似suggestedHi的外接程序，我无法运行外接程序（2007版）。失败：“参数数量错误，属性分配无效”。Kerstin World flag图标，超压缩，在

.png

和Base64中都有：效果非常好！“图片格式初始化”似乎是您在用例中的一个要求，我刚刚注释掉了它。图表对象被用作在剪贴板和文件系统之间架起桥梁的工具。

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

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