logo标签列表

使用VBA将Excel文件中的图片导出为JPG格式

imageexcelvbaexport
17

我有一个包含图片的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吗？
有人能帮忙吗？谢谢！
1
你可以使用这个插件。 - user2140173
图片是如何存储的？如果它们在ActiveX图像控件中，保存图片只需要一行简单的代码；如果不是，则需要更复杂的代码或建议的插件。 - JosieP
嗨，我无法运行插件（2007版本）。错误信息为：“参数数量错误和无效的属性赋值”。Kerstin - KEK79
https://social.msdn.microsoft.com/Forums/vstudio/en-US/5695fa5d-74c6-4a83-8563-11c6caf475da/extract-image-with-original-size-from-excel?forum=vbgeneral <- 这是一个更难的问题讨论 - 提取原始大小的图像，即100％像素比例。 - Li-aung Yip
世界国旗图标，超级压缩，提供.png和Base64格式：https://github.com/ashleedawg/flags - ashleedawg
7个回答
14

如果我记得正确的话，您需要使用工作表的“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
1
工作得非常好！“图片格式初始化”似乎是您在使用案例中的要求，我只是将其注释掉了。图表对象用作桥梁，以弥合剪贴板和文件系统之间的差距。 - Cee McSharpface
11

这段代码：

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

本文是直接从这里复制的，经过我测试可以完美地运行。

3

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

Workbooks("你的工作簿名称").Sheets("你的工作表名称").Select

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
1
感谢您提供的想法！我使用上述想法制作了一个宏，用于批量文件转换 - 将文件夹中的每个格式相同的文件转换为另一种格式。
此代码需要一个名为“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
1
Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"

将代码最简化，若需要则至绝对最少。
1
新版本的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
0

这里有另一种很酷的方法 - 使用接受命令行开关的外部查看器（在本例中为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:
    ' https://dev59.com/k2Uo5IYBdhLWcg3wkADB
   ' 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
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接