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

我有一个Excel文件，其中包括列B中的图片，我想要将它们导出到多个文件（如.jpg（或任何其他图片文件格式））。 该文件的名称应该从列A中的文本生成。我尝试以下VBAmacros：

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 ？

有谁能够帮助我？ 谢谢！

Answer 1

此代码：

 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 

直接从这里复制，并为我testing的情况下美丽的作品。

Answer 2

如果我没有记错，你需要使用你的工作表的“形状”属性。

每个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 

Answer 3

这里是另一个很酷的方式来做到这一点 – 使用外部查看器，接受命令行开关（在这种情况下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 

Answer 4

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

如果需要，将代码减less到绝对最小值。

Answer 5

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

工作簿（“您的工作簿名称”）表格（“您的工作表名称”）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