vba 如何在 Visual Basic 中创建 PNG 文件？

How to create a PNG file in Visual Basic?

提问by danison

Possible Duplicate:
VB6 PictureBox SavePicture - save picture as png?

可能重复：
VB6 PictureBox SavePicture - 将图片另存为 png？

How do I create a PNG file in Visual Basic 6.5 with a height of 10 and a width of 6?

如何在 Visual Basic 6.5 中创建高度为 10，宽度为 6 的 PNG 文件？

What is the header file inclusion to draw an png file?

绘制png文件的头文件包含什么？

回答by GaryNg

I've seen a module before that uses GDI+ to convert BMP to PNG

我之前看过一个模块，它使用 GDI+ 将 BMP 转换为 PNG

Here's that module as a .bas file:

这是作为 .bas 文件的模块：

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long

Public Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
    Optional ByVal Quality As Byte = 80, _
    Optional ByVal TIFF_ColorDepth As Long = 24, _
    Optional ByVal TIFF_Compression As Long = 6)
    Screen.MousePointer = vbHourglass
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    Dim aEncParams() As Byte
    On Error GoTo ErrHandle:
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)
    If lRes = 0 Then
        lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            Select Case PicType
            Case ".jpg"
                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                tParams.count = 1
                With tParams.Parameter
                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                    .NumberOfValues = 1
                    .type = 4
                    .Value = VarPtr(Quality)
                End With
                ReDim aEncParams(1 To Len(tParams))
                Call CopyMemory(aEncParams(1), tParams, Len(tParams))
            Case ".png"
                CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                ReDim aEncParams(1 To Len(tParams))
            Case ".gif"
                CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                ReDim aEncParams(1 To Len(tParams))
            Case ".tiff"
                CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                tParams.count = 2
                ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
                With tParams.Parameter
                    .NumberOfValues = 1
                    .type = 4
                    CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID
                    .Value = VarPtr(TIFF_Compression)
                End With
                Call CopyMemory(aEncParams(1), tParams, Len(tParams))
                With tParams.Parameter
                    .NumberOfValues = 1
                    .type = 4
                    CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID
                    .Value = VarPtr(TIFF_ColorDepth)
                End With
                Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
            Case ".bmp"
                SavePicture pict, FileName
                Screen.MousePointer = vbDefault
                Exit Sub
            End Select
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))
            GdipDisposeImage lBitmap
        End If
        GdiplusShutdown lGDIP
    End If
    Screen.MousePointer = vbDefault
    Erase aEncParams
    Exit Sub
  ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "Error" & vbCrLf & vbCrLf & "Error No. " & Err.Number & vbCrLf & " Error .Description:  " & Err.Description, vbInformation Or vbOKOnly
End Sub

how to invoke:

如何调用：

SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
    Optional ByVal Quality As Byte = 80, _
    Optional ByVal TIFF_ColorDepth As Long = 24, _
    Optional ByVal TIFF_Compression As Long = 6)

StdPicture -  A picture handle, or a picture box
FileName - The file name to save
PicType - File format to save, available formats: .jpg, .png, .gif, .tiff, .bmp
Quality - Picture quality, default is 80%

example:

例子：

SavePic Picture1.Image, "C:\Test.png", ".png"

回答by Deanna

VB6 and VBA (the VB6.5 you're using) do not natively support PNGs. You will need to use GDI+ (as Mark linked to), WIA or another external/3rd party library.

VB6 和 VBA（您使用的 VB6.5）本身不支持 PNG。您将需要使用 GDI+（作为 Mark 链接到的）、WIA 或其他外部/第 3 方库。