我在用户窗体上有一个图像对象。我想将该图像对象中的图片保存到文件中。我看到很多关于如何将图片加载到图像对象中的示例，但没有其他方法。
我尝试过
stdole.SavePicture obj.Picture, strFilePath我不知道这是否有帮助，但我尝试将 Picture 对象转换为 IPictureDisp 对象，以将其传递给 stdoleSavePicture 函数，它对我有用。
这是代码：
Dim pic As IPictureDisp
Set pic = myForm.Image1.Picture
stdole.SavePicture pic, "C:\myfile.jpg"
我使用 PowerPoint 来做这件事。这是最近一个导出世界地图的项目中的宏：
Public Sub ExportMap()
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShapeRange As PowerPoint.ShapeRange
Dim Path$, File$
Dim oRange As Range
Application.ScreenUpdating = False
myDate$ = Format(Date, "m-d-yyyy")
Set pptApp = CreateObject("PowerPoint.Application")
Path$ = ActiveDocument.Path & Application.PathSeparator
File$ = "WorldMap " & myDate$ & ".png"
Set pptPres = pptApp.Presentations.Add(msoFalse)
Set oRange = ActiveDocument.Bookmarks("WholeMap").Range
oRange.CopyAsPicture
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
On Error Resume Next
With pptPres.PageSetup
.SlideSize = 7
.SlideWidth = 1150
.SlideHeight = 590
End With
Set pptShapeRange = pptSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoFalse)
pptSlide.Export Path$ & File$, "PNG"
pptApp.Quit
Set pptPres = Nothing
Set pptApp = Nothing
Set pptSlide = Nothing
Application.ScreenUpdating = True
MsgBox "All done! Check the folder containing this template for a file called '" & File$ & "'."
End Sub
这是一个非常有效并且非常容易实现的解决方案。您所需要的只是一个名为 Magick.exe 的简单命令行程序，您可以从此处下载 在此处下载 这是我用来首先扫描文档中的图像的代码，您可以根据需要进行更改以达到您的目的。下一部分将是实际保存图像，因为我们使用此网站上的许多方法似乎将文件保存为 PNG 或 JPG，但由于我们都知道，这些不是真正的 PNG 或 JPG 文件，如所讨论的在许多论坛上。
两条主线是：
设置 objShell = CreateObject("WScript.Shell") objShell.exec (ActiveDocument.path & "\magick.exe """ & Environ("TEMP") & "\Temp.png""" & " """ & Environ("TEMP") & "\Temp.jpg “””） 您可以根据需要进行更改。
这是完整的代码片段，效果非常好！ 公共子 ScanImagesInDocument() '==================================================== =================================================== ===== '这是我们运行的代码 将 tempFilePath 变暗为字符串 将 k 调暗为整数 调暗 imgRange 作为范围 暗淡 shapePage 作为整数 对于 k = 1 到 ActiveDocument.InlineShapes.count ' 获取当前内联形状的范围 设置 imgRange = ActiveDocument.InlineShapes(k).range ' 定义图像的临时文件路径 tempFilePath = Environ("TEMP") & "\Temp.png" ' 将图像另存为 PNG 调用 saveImage(ActiveDocument.InlineShapes(k), tempFilePath) ' 将范围折叠到内联形状的末尾 imgRange.Collapse wdCollapseEnd ' 将选择移动到内联形状之后 imgRange.Select 结束如果 下一个 k 结束子
函数 saveImage(shp As InlineShape, path As String) ' 这是首先将文件保存为 png 文件的代码，但据了解这不是真正的 PNG 文件 ’最后就是奇迹发生的地方。
Dim s As String
Dim r As range
Dim i As Long
Dim j As Long
s = shp.range.WordOpenXML
i = InStr(s, "<pkg:binaryData>")
If i = 0 Then
Set r = shp.range.Duplicate
r.End = r.End + 1
s = r.WordOpenXML
i = InStr(s, "<pkg:binaryData>")
If i = 0 Then
r.Start = r.Start - 1
s = r.WordOpenXML
i = InStr(s, "<pkg:binaryData>")
If i = 0 Then
MsgBox "No binary data found"
Exit Function
End If
End If
End If
''move i to end of "<pkg:binaryData>"
i = i + 16
j = InStr(i, s, "</pkg:binaryData>")
s = Mid$(s, i, j - i)
Dim DecodeBase64() As Byte
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
Set objXML = CreateObject("MSXML2.DOMDocument")
'create node with type of base 64 and decode
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.text = s
DecodeBase64 = objNode.nodeTypedValue
Set objNode = Nothing
Set objXML = Nothing
Open path For Binary As #1
Put #1, 1, DecodeBase64
Close #1
Dim objShell As Object
tempPng = Environ("TEMP") & "\Temp.png"
tempJpg = Environ("TEMP") & "\Temp.jpg"
' 这就是我们解决文件没有真正保存为 PNG 文件的整个问题的地方
'==================================================== =============================================
设置 objShell = CreateObject("WScript.Shell")
objShell.exec (ActiveDocument.path & "\magick.exe """ & Environ("TEMP") & "\Temp.png""" & " """ & Environ("TEMP") & "\Temp.jpg “””）
结束功能