如何用VBA实现将EMF矢量格式转成JPG、PNG之类的位图格式

batmanbbs

请教各位老师，如何用VBA实现将EMF矢量格式转成JPG、PNG之类的位图格式。
看了很多帖子，都是不同格式的位图之间的转换，没有看到转换矢量图的方法，请指教。

谢谢先

fxl447098457

利用powershell转换很方便。调用system.drawing.

Sub 转换emf()
Dim wshell As Object, inputFile$, outputFile$, psShellstr$

inputFile = ThisWorkbook.Path & "\1.emf"
outputFile = ThisWorkbook.Path & "\1.png"

psShellstr = "powershell -command ""Add-Type -AssemblyName System.Drawing;" _
            & "$emf=[System.Drawing.Image]::FromFile('" & inputFile & "');" _
            & "$emf.Save('" & outputFile & "',[System.Drawing.Imaging.ImageFormat]ng);$emf.Dispose();"""
Shell psShellstr, vbHide
End Sub

约定的童话

Const LR_DEFAULTCOLOR = &H00

Declare Function GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpName As String) As Long
Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function GetEnhMetaFileBits Lib "gdi32" (ByVal hemf As Long, ByVal cbBuffer As Long, ByRef lpbBuffer As Any) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal nXDest As Long, ByVal nYDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal dwRop As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Sub ConvertEMFToJPG(EMFFilePath As String, JPGFilePath As String)
    Dim hEmf As Long
    Dim hDC As Long
    Dim hMemDC As Long
    Dim hBitmap As Long
    Dim pEMFData As Long
    Dim nBytes As Long
    Dim Width As Long
    Dim Height As Long
   
    ' Load the EMF file into memory
    hEmf = GetEnhMetaFile(EMFFilePath)
   
    ' Get the EMF data
    nBytes = GetEnhMetaFileBits(hEmf, 0, 0)
    pEMFData = VarPtr(VarPtr(0))
    GetEnhMetaFileBits hEmf, nBytes, ByVal pEMFData
   
    ' Create a memory device context
    hDC = CreateCompatibleDC(0)
   
    ' Create a memory DC compatible with the screen
    hMemDC = CreateCompatibleDC(hDC)
   
    ' Create a bitmap compatible with the screen
    hBitmap = CreateBitmap(Width, Height, 1, 32, 0)
   
    ' Select the bitmap into the memory DC
    SelectObject hMemDC, hBitmap
   
    ' Play the EMF file into the memory DC
    PlayEnhMetaFile hMemDC, hEmf, 0, 0, Width, Height
   
    ' Transfer the image from memory DC to screen DC
    BitBlt hDC, 0, 0, Width, Height, hMemDC, 0, 0, SRCCOPY
   
    ' Save the bitmap as JPG file
    SaveJPG hDC, JPGFilePath
   
    ' Delete resources
    DeleteEnhMetaFile hEmf
    DeleteObject hBitmap
    DeleteDC hDC
    DeleteDC hMemDC
End Sub

Function SaveJPG(SourceDC As Long, JPGFilePath As String)
    Dim hJPG As Long
    Dim image As IPicture
    Dim jpegData As IStream
    Dim encoder As Gdiplus.ImageCodecInfo
    Dim encoderParams As Gdiplus.EncoderParameters

    ' Create a new IPicture from the SourceDC
    Set image = CreatePicture(SourceDC, 0, 0)
   
    ' Create a new JPEG encoder
    Set encoder = GetJPEGEncoder()
   
    ' Create a new memory stream
    Set jpegData = CreateStream()
   
    ' Save the image as JPEG to the memory stream
    image.SaveJPG jpegData, encoder
   
    ' Save the memory stream to file
    jpegData.SaveToFile JPGFilePath, adSaveCreateOverWrite
End Function

Function GetJPEGEncoder() As Gdiplus.ImageCodecInfo
    Dim numEncoders As Long
    Dim bufferSize As Long
    Dim encoderPtr As Long
    Dim encoder As Gdiplus.ImageCodecInfo
   
    ' Get the number of image encoders
    GetImageEncodersSize numEncoders, bufferSize
   
    ' Allocate memory for the encoder array
    encoderPtr = GlobalAlloc(GMEM_FIXED, bufferSize)
   
    ' Get the image encoders
    GetImageEncoders numEncoders, bufferSize, encoderPtr
   
    ' Copy the JPEG encoder info
    CopyMemory VarPtr(encoder), encoderPtr, Len(encoder)
   
    ' Release memory for encoder array
    GlobalFree encoderPtr
   
    Set GetJPEGEncoder = encoder
End Function

Function CreateStream() As IStream
    Dim stream As IStream
    CreateStreamOnHGlobal 0, True, stream
    Set CreateStream = stream
End Function

batmanbbs

谢谢楼上两位老师