VB 如何用GDI+更改图像分辨率
比如用数码相机拍摄出来的数码照片的分辨率一般为300dpi，现在要更改为92dpi，如何用VB6实现？
dim Nf as string '图像文件名
Dim Img as long,MyRe as single,MySw as long,MySH as long
GdipLoadImageFromFile StrConv(Nf, vbUnicode), Img '加载图像，奇怪的是用strptr(Nf)则加载失败
If Img Then
GdipGetImageWidth Img, MySW '读取原始宽度/像素
GdipGetImageHeight Img, MySH '读取原始高度/像素
GdipGetImageHorizontalResolution Img, MyRe '获取原来的DPI分辨率
GdipBitmapSetResolution Img, 92, 92 '设置新的分辨率
SaveImageToJPG Img, Nf, 8 '保存图片
end if
问题是：虽然图像的原先分辨率DPI=300，调用设置分辨率函数后，设置新的分辨率为92，但保存出来的图像仍然是300dpi的，设置无效；如果才能设置生效，或者如何让保存出来的图像生效为dpi=92的？ 展开
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
