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

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

vba vb6

Vba 如何在Visual Basic中创建PNG文件？,vba,vb6,Vba,Vb6,可能重复：如何在Visual Basic 6.5中创建高度为10、宽度为6的PNG文件绘制png文件所包含的头文件是什么？VB6和VBA（您正在使用的VB6.5）本机不支持png。您需要使用GDI+（标记链接到）、WIA或其他外部/第三方库。VB6和VBA（您正在使用的VB6.5）本机不支持PNG。您需要使用GDI+（标记链接到）、WIA或其他外部/第三方库。我以前见过一个模块使用GDI+将BMP转换为PNG 下面是该模块的.bas文件： Option Explicit Private

可能重复：

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

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

VB6和VBA（您正在使用的VB6.5）本机不支持png。您需要使用GDI+（标记链接到）、WIA或其他外部/第三方库。

VB6和VBA（您正在使用的VB6.5）本机不支持PNG。您需要使用GDI+（标记链接到）、WIA或其他外部/第三方库。

我以前见过一个模块使用GDI+将BMP转换为PNG

下面是该模块的.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

如何调用：

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%

例如：

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

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

下面是该模块的.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

如何调用：

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%

例如：

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

看看这是否适用于“创建”如“将空白（全黑？）PNG文件写入磁盘”或什么？然后你说“画”。你真正的意思是什么？是的，这是我的下一个问题？如何只启用一个特定像素，比如我想启用第（2,4）个位置，我想禁用第（3,4）个像素？怎么做？@danison：这应该是另一个问题，一旦你在VB6中创建了一张图片（使用DIB、PictureBox等），那么这个函数将只为你保存为PNG。看看这是否适用于你“创建”为“将空白（全黑？）PNG文件写入磁盘”或什么？然后你说“画”。你真正的意思是什么？是的，这是我的下一个问题？如何只启用一个特定像素，比如我想启用第（2,4）个位置，我想禁用第（3,4）个像素？怎么做？@danison：这应该是另一个问题，一旦你在VB6中创建了一张图片（使用DIB、PictureBox等），那么这个函数将只为你保存为PNG。事实上，自从WIA 2.0出现以来，它们就是这样做的。是的，它是一个帮助程序库，但它已经是标准的十年了，并且自Vista问世以来就在Windows中发布。这仍然不是VB的固有特性，这是“第三方库”所暗示的。更改为“外部”以澄清。这有点像说脚本控件或ADO或MSXML或。。。他们不是本地人。它们都是VB6生态系统的一部分，在本例中，WIA被专门作为支持VB6和脚本的补充。主要的一点是，您可以使用WIA来支持PNG。它们不是“原生VB6”。是的，您可以从VB6使用它们，但它们不是“VB的一部分”，它们是Windows或数据访问工具的一部分。我并不是说你不能用VB，你只需要使用一个外部库，比如GDI+或WIA。有了WIA，我认为内存位图必须保存为位图文件，然后进行压缩（2500 KB的BMP是B&W文本为35 KB JPG的情况下）。因为我不能将内存位映射到工作表上的形状（保持在那里）。但是形状可以更好地加载图片和JPG…感谢您的出色努力。我尝试使用内存位图，以提高其处理文本的速度，例如混合14X14、14x12和14X8字体的页面，将格式信息打包到小A6小册子中。实际上，自WIA 2.0问世以来，它们都是这样做的。是的，这是一个帮助程序库，但它一直在使用自Vista问世以来，Windows就已经发布了十年的标准。这仍然不是VB的固有特性，这是“第三方库”所暗示的。改为“外部”澄清一下。这有点像说脚本控件、ADO或MSXML或…不是本机的。它们都是VB6生态系统的一部分，在本例中，WIA专门作为支持VB6和脚本的补充。要点是，您可以使用WIA支持PNG。它们不是“本机VB6”是的，你可以从VB6中使用它们，但它们不是“VB的一部分”，它们是Windows或数据访问工具的一部分。我不是说你不能从VB中使用它们，你只需要使用外部库，如GDI+或WIA。使用WIA，我认为内存位图必须保存为位图文件，然后进行压缩（2500 KB的BMP是指黑白文本为35 KB的JPG..因为我无法将内存位映射到图纸上的形状（保持在那里）。但是形状可以更好地加载图片和JPG…感谢您的出色努力。我正在尝试使用内存位图，以提高其处理文本的速度，例如混合14X14、14x12和14X8字体的页面，将格式信息打包到小A6小册子。我可以使用此代码，然后GDI+将从位图转换为png，对吗？我不知道我做了什么这是一个.bas文件吗？它会做什么？@danison:它会做什么？它会按照你的要求将一张VB图片转换成PNG（以及其他）文件。最后一个示例演示了如何转换。无可否认，这些示例可以进行注释。这不起作用，我刚刚测试过。如果你以

SavePic Picture1，“C:\Test.PNG”，“.PNG”的形式运行它

pict.Handle将始终返回0，这是不对的。我所做的只是创建一个新的

PictureBox

设置

AutoRedraw

为

True

并在其上使用

SetPixel

。似乎

StdPicture

不是

PictureBox

。无论如何，我解决了它的问题是与您的代码有关。假设是be

SavePic，Picture1.Image，“C:\Test.png”和“.png”

我可以使用这个代码，然后GDI+将从bitmapp转换为png，对吗？我不知道这个.bas文件是什么？它会做什么？@danison:它会做什么？它会将一张VB图片转换为png（包括其他内容）文件，正如您所要求的。最后一个示例演示了如何操作。无可否认，示例可以进行注释。我刚刚测试过，这不起作用。如果您以

SavePic Picture1，“C:\Test.png”，“.png”的形式运行它

pict.Handle将始终返回0，这是不对的。我所做的只是创建一个新的

PictureBox

设置

AutoRedraw

为

True

并在其上使用

SetPixel

。似乎

StdPicture

不是

PictureBox

。无论如何，我解决了它的问题是与您的代码有关。假设是be

SavePic，Picture1.Image，“C:\Test.png”，“.png”