189 8069 5689
给你一个模块，简单调用即可：
站在用户的角度思考问题，与客户深入沟通，找到新华网站设计与新华网站推广的解决方案，凭借多年的经验，让设计与互联网技术结合，创造个性化、用户体验好的作品，建站类型包括：做网站、网站建设、企业官网、英文网站、手机端网站、网站推广、空间域名、网络空间、企业邮箱。业务覆盖新华地区。
一、新建一个模块，复制下面代码
Option Explicit
'常量声明
Private Const GdiplusVersion As Long = 1
'结构声明
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
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(15) As EncoderParameter
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type GdiplusStartupOutput
NotificationHook As Long
NotificationUnhook As Long
End Type
'枚举声明
Private Enum Status
OK = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
'API声明
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As Status
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, ByRef BITMAP As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Status
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal Filename As Long, Image As Long) As Status
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As Long, Width As Long) As Status
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As Long, Height As Long) As Status
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Status
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GdiplusStartupInput, ByRef lpOutput As GdiplusStartupOutput) As Status
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Status
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Status
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByRef id As GUID) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
'By Modest
'根据版本初始化GDI+
Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Long
Dim GdipToken As Long
Dim GdipStartupInput As GdiplusStartupInput
Dim GdipStartupOutput As GdiplusStartupOutput
GdipStartupInput.GdiplusVersion = GdipVersion
If GdiplusStartup(GdipToken, GdipStartupInput, GdipStartupOutput) = OK Then
StartUpGDIPlus = GdipToken
End If
End Function
'获取当前窗体(作为临时控件的寄存之处)
Function GetCurForm() As Form
'获取当前可用窗体
For Each GetCurForm In Forms
Exit For
Next
End Function
'图片按指定缩放比例进行显示
Public Function PictureShow(Filename As String, Optional ByVal Compress As Byte = 100)
Dim Stream As IUnknown
Dim lngGdipToken As Long, gdip_Graphics As Long, gdip_pngImage As Long
Dim hdc As Long, lngHeight As Long, lngWidth As Long
Dim ctlNew As PictureBox, Frm As Form
lngGdipToken = StartUpGDIPlus(GdiplusVersion)
If lngGdipToken = 0 Then Exit Function
Call GdipLoadImageFromFile(StrPtr(Filename), gdip_pngImage) '读取显示数据图片(包括png)
Call GdipGetImageHeight(gdip_pngImage, lngHeight) '
Call GdipGetImageWidth(gdip_pngImage, lngWidth)
lngWidth = lngWidth * Compress / 100
lngHeight = lngHeight * Compress / 100
'动态创建一个PictureBox控件
Set Frm = GetCurForm
Set ctlNew = Frm.Controls.Add("VB.PictureBox", "ChangePicSize_1_", Frm)
With ctlNew
.BorderStyle = 0
.AutoRedraw = True
.ScaleMode = 3
.Width = lngWidth * Screen.TwipsPerPixelX
.Height = lngHeight * Screen.TwipsPerPixelY
End With
'在控件上绘图
If GdipCreateFromHDC(ctlNew.hdc, gdip_Graphics) = OK Then
Call GdipDrawImageRect(gdip_Graphics, gdip_pngImage, 0, 0, lngWidth, lngHeight)
GdipDisposeImage gdip_pngImage
Set PictureShow = ctlNew.Image
End If
'善后处理
GdipDeleteGraphics gdip_Graphics
GdiplusShutdown lngGdipToken
Frm.Controls.Remove ctlNew
Set ctlNew = Nothing
Set Frm = Nothing
End Function
'把图片按指定缩放比例进行保存
Function PictureSave(ByVal SrcFilename As String, Optional DstFileName As String, Optional ByVal Compress As Byte = 100) As Boolean
Dim lRes As Long, lngGdipToken As Long
Dim lBitmap As Long
Dim i As Integer
Dim Leix As String, Flt As String
Dim lngHeight As Long, lngWidth As Long
Dim pic As StdPicture
Const quality As Byte = 100
Const TIFF_ColorDepth As Long = 24
Const TIFF_Compression As Long = 6
'对参数的合法性进行处理
If SrcFilename = "" Or Dir(SrcFilename) = "" Or DstFileName = "" Then Exit Function
Flt = "bmp|gif|jpg|jpeg|png|tif)|tiff"
i = InStrRev(SrcFilename, ".")
If i = 0 Then Exit Function
Leix = LCase(Mid(SrcFilename, i + 1))
If InStr(1, Flt, Leix, vbTextCompare) = 0 Then Exit Function
'初始化 GDI+
lRes = StartUpGDIPlus(GdiplusVersion)
If lRes = 0 Then Exit Function
Set pic = PictureShow(SrcFilename, Compress)
'从句柄创建 GDI+ 图像
'lRes = GdipCreateBitmapFromFile(StrPtr(SrcFilename), lBitmap)
lRes = GdipCreateBitmapFromHBITMAP(pic.Handle, 0, lBitmap)
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解码器的GUID标识
Select Case Leix
Case "jpg", "jpeg"
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'设置解码器参数
tParams.Count = 1
With tParams.Parameter(0) ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.Type = 4
.Value = VarPtr(quality)
End With
Case "png"
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
Case "bmp"
CLSIDFromString StrPtr("{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"), tJpgEncoder
SavePicture pic, DstFileName
PictureSave = True
Exit Function
Case "gif"
CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
Case "tiff"
CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.Count = 2
With tParams.Parameter(0)
.NumberOfValues = 1
.Type = 4
CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID
.Value = VarPtr(TIFF_Compression)
End With
With tParams.Parameter(0)
.NumberOfValues = 1
.Type = 4
CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID
.Value = VarPtr(TIFF_ColorDepth)
End With
End Select
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(DstFileName), tJpgEncoder, tParams)
'销毁GDI+图像
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
If lRes Then
PictureSave = False
Else
PictureSave = True
End If
End Function
二、调用举例：
PictureSave "c:\1.bmp", "d:\2.bmp", 50 '表示把c:\1.bmp缩小50%，并保存为d:\2.bmp
PictureBox.SizeMode
属性
默认情况下，在
Normal
模式中，Image
置于
PictureBox
的左上角，凡是因过大而不适合
PictureBox
的任何图像部分都将被剪裁掉。
使用
StretchImage
值会使图像拉伸或收缩，以便适合
PictureBox。
使用
Zoom
的值可以使图像被拉伸或收缩以适应
PictureBox；但是仍然保持原始纵横比。
使用
AutoSize
值会使控件调整大小，以便总是适合图像的大小。
使用
CenterImage
值会使图像居于工作区的中心。
Pegasus的ImagXpress 8.0控件，支持各种格式文件的加载。控件封装了右键局部区域放大的功能，要实现图片的缩放，把AutoResize属性设置为PegasusImaging.WinForms.ImagXpress8.AutoResizeType.CropImage，修改 ZoomFactor的值就可以了。
1.我有个思路可以尝试一下：把一张字节数在280-300K的图片用PS打开看看像素大小；
2.定义一个新的位图，指定像素大小为上面得到的数据；
3.读取你需要修改大小的JPG文件，然后按指定大小复制到上面新建的位图，并保存为JPG格式