VB 如何用GDI+更改图像分辨率

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 GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long

Public Sub SaveJPG(ByVal pict As StdPicture, ByVal Filename As String, Optional ByVal Quality As Byte = 80, Optional ByVal DPI As Single = 0)

Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long

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
       
        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
       
       
       
        If DPI > 0 Then Call GdipBitmapSetResolution(lBitmap, DPI, DPI) '0 不修改DPI, 大于0才修改  如果不修改 保存的DPI为 当前显示器的DPI数值
       
       
       
        lRes = GdipSaveImageToFile(lBitmap, StrPtr(Filename), tJpgEncoder, tParams)
        GdipDisposeImage lBitmap

    End If
   

    GdiplusShutdown lGDIP
   
End If

If lRes Then
    Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
End If

End Sub

'调用方法， 可修改压缩比例 和 修改分辨率。Picture1要有加载图才行，稍微改改可以直接读文件，直接转 无需加载到图像框里再保存。

Private Sub Command2_Click()
SaveJPG Picture1, "C:\123.jpg", 80, 200
End Sub