VB 修改图片的尺寸并保存，比如现有图片256*128，我要修改成15*15的尺寸，要源码！

Posted 2023-05-17

首先，声明以下核心代码部分完全照抄，由CSDN上laviewpbt提供，我在之前一篇VB常见问题里给出过链接。当时提到VB的效率问题，我举
出图片缩放的例子，用VB写的图片缩放，效率居然很高，以此证明算法的重要性。laviewpbt又是受到了CSDN上zyl910，本名好像叫周岳灵的
激发，结果做出的程序效率更加惊人。有兴趣的可以看看我这篇文章里给出的论坛链接。
所以，我这里用的解决方法就是从他们这里得来。不过这些高人们关注的是效率，程序里面有很大篇幅是不同算法比较，已经时间测试。而对于更加关心使用的人来说，代码需要裁剪。我粗略的筛选了下，对模块内容没有改动，而只是从主程序里拨出我们需要的内容。
那么，就开始吧。
首先，用到三个模块和一个类模块，这部分代码我们不用重写了。程序搭建时候添加进去。需要说明的是，如果你已经有一个在做的项目，那么简单的导入模块可能是不行的。laviewpbt给我们做了一个很好的示范，他的API声明都是在一个模块里面的，那么你的项目最好也这样，然后，把他的API声明贴在后面，运行程序时候如果有重复，会自动找到，然后你就停掉他，注释掉或者删除。这几个模块的内容我最后贴出，这里到现在也不能上传附件。
那么，我们重点要介绍怎么用。
Private DIBData As CImagePrivate DIBWork As CImage
首先要声明两个类变量。这个是我们自定义的类。在模块里。
接着两段代码，一个加载图片，一个改变图片大小。
我们要打开图片，初始化上面这两个量，初始化过程写在 form_load里面
Set DIBData = New CImage
Set DIBWork = New CImage
scaNum = 1 '这个是比例
scaWidth = Me.Width '这个是窗体宽度的初始参照值
Picture1.Picture = LoadPicture(App.Path & "\手球场地小图.jpg")
Dim DIBTemp As New CImage
If DIBTemp.LoadPictureFromFile(App.Path & "\手球场地小图.jpg") = True Then
Set DIBData = DIBTemp
DIBWork.DisposeResource

Picture1.Width = DIBData.Width
Picture1.Height = DIBData.Height
DIBData.Render Picture1.Hdc
Picture1.Refresh
Else
MsgBox "错误的图像文件", vbCritical
End If
Set DIBTemp = Nothing

当窗体大小变化的时候，我们再写一段代码改变图片大小已经PictureBox大小任务就完成了。
需要说明的是，以下调用的代码，对尺寸的计量单位是pixel，而VB窗体默认的计量单位是Tiwp，显示器上一个pixel里面可以有很多twip，如果你做出来的程序，图像顺畅显示了，但是就是很小，那么，恭喜你，你成功了，只是需要将尺寸转换成vb里面的tiwp，
乘以 Screen.TwipsPerPixelX
这段代码如下：
Dim W As Long, H As Long
W = DIBData.Width * scaNum
H = DIBData.Height * scaNum
If W < 1 Then W = 1 If H < 1 Then H = 1
Dim DIBTemp As New CImage
Dim t As Currency
Me.MousePointer = vbHourglass
t = Utility.GetCurrentTime
Set DIBTemp = Resample(DIBData, W, H, 2) '这里固定选择一个算法，双线性内插值
' t = GetCurrentTime - t
Me.MousePointer = vbDefault
' Me.Caption = " 处理时间：" & Format(t / 1000, "##,###,##0.000") & "秒"
Set DIBWork = DIBTemp
Set DIBTemp = Nothing
PicData.Width = DIBWork.Width * Screen.TwipsPerPixelX
PicData.Height = DIBWork.Height * Screen.TwipsPerPixelX
DIBWork.Render PicData.Hdc
' SolNum
PicData.Refresh
代码被我注释掉一部分，原代码中有时间测试内容。
把这段代码独立成一个Sub，然后在form_reSize里面调用，当然，调用之前首先要计算变化比例scaNum

下面开贴模块代码
模块一、ImageResize模块：
Option Explicit
Public Enum ResizeModeConst
SMC_Nearest = 0 '最邻近插值
SMC_StretchBlt = 1 'StretchBlt
SMC_BiliNear = 2 '双线性内插值
End Enum

Public
Function Resample(Img As CImage, NewWidth As Long, NewHeight As Long,
Optional Method As ResizeModeConst = SMC_BiliNear) As CImage
Dim X As Long, Y As Long
Dim XX As Long, YY As Long
Dim OldYY As Long
Dim Width As Long, Height As Long
Dim Sa As SAFEARRAY, SaN As SAFEARRAY
Dim ImageData() As Byte, NewImageData() As Byte
Dim Stride As Long, NewStride As Long
Dim Offset As Long

Dim Speed As Long, SpeedN As Long
Dim NewImg As New CImage
If NewImg.CreateNewImage(NewWidth, NewHeight) = True Then

With Sa
.Element = 1
.Dimension = 1
.Bounds.Elements = Img.Stride * Img.Height
.Pointer = Img.Pointer
End With
CopyMemory ByVal VarPtrArray(ImageData()), VarPtr(Sa), 4

With SaN
.Element = 1
.Dimension = 1
.Bounds.Elements = NewImg.Stride * NewImg.Height
.Pointer = NewImg.Pointer
End With
CopyMemory ByVal VarPtrArray(NewImageData()), VarPtr(SaN), 4

Width = Img.Width: Height = Img.Height
Stride = Img.Stride: NewStride = NewImg.Stride

ReDim LinearRow(NewWidth - 1) As Long

Select Case Method

Case ResizeModeConst.SMC_Nearest

OldYY = -1
For X = 0 To NewWidth - 1
LinearRow(X) = (X * Width \ NewWidth) * 3
Next
For Y = 0 To NewHeight - 1
SpeedN = Y * NewStride
YY = Y * Height \ NewHeight
Offset = YY * Stride
If YY = OldYY Then
CopyMemory NewImageData(SpeedN), NewImageData(SpeedN - NewStride), NewStride
Else
OldYY = YY
For X = 0 To NewWidth - 1
Speed = Offset + LinearRow(X)
NewImageData(SpeedN) = ImageData(Speed)
NewImageData(SpeedN + 1) = ImageData(Speed + 1)
NewImageData(SpeedN + 2) = ImageData(Speed + 2)
SpeedN = SpeedN + 3
Next
End If
Next

Case ResizeModeConst.SMC_StretchBlt
Img.Render NewImg.Hdc, 0, 0, NewImg.Width, NewImg.Height, 0, 0, Img.Width, Img.Height

Case ResizeModeConst.SMC_BiliNear
Dim PartXX As Long, PartYY As Long
Dim InvertXX As Long, InvertYY As Long
Dim NewX As Long, NewY As Long
Dim SpeedP As Long, ColOffset As Long
Dim Pos As Double
ReDim RowOffset(NewWidth - 1) As Long
ReDim RowPartXX(NewWidth - 1) As Long
For X = 0 To NewWidth - 1
Pos = X * (Width - 1) / NewWidth
RowOffset(X) = Int(Pos) * 3
RowPartXX(X) = (Pos - Int(Pos)) * 2048
Next

For Y = 0 To NewHeight - 1
SpeedN = Y * NewStride
Pos = Y * (Height - 1) / NewHeight
PartYY = (Pos - Int(Pos)) * 2048
InvertYY = 2048 - PartYY
ColOffset = Int(Pos) * Stride
For X = 0 To NewWidth - 1
PartXX = RowPartXX(X)
InvertXX = 2048 - PartXX
Speed = ColOffset + RowOffset(X)
SpeedP = Speed + Stride

NewImageData(SpeedN + 2) = ((ImageData(Speed + 2) * InvertXX +
ImageData(Speed + 5) * PartXX) * InvertYY + (ImageData(SpeedP + 2) *
InvertXX + ImageData(SpeedP + 5) * PartXX) * PartYY) \ 4194304

NewImageData(SpeedN + 1) = ((ImageData(Speed + 1) * InvertXX +
ImageData(Speed + 4) * PartXX) * InvertYY + (ImageData(SpeedP + 1) *
InvertXX + ImageData(SpeedP + 4) * PartXX) * PartYY) \ 4194304

NewImageData(SpeedN) = ((ImageData(Speed) * InvertXX + ImageData(Speed +
3) * PartXX) * InvertYY + (ImageData(SpeedP) * InvertXX +
ImageData(SpeedP + 3) * PartXX) * PartYY) \ 4194304
SpeedN = SpeedN + 3
Next
Next

End Select

CopyMemory ByVal VarPtrArray(ImageData()), 0&, 4
CopyMemory ByVal VarPtrArray(NewImageData()), 0&, 4
End If
Set Resample = NewImg
End Function

模块2、可以忽略的和时间测试有关部分，内容不多，也贴出
Private SystemFrequency As Currency
Public Function GetCurrentTime() As Currency
If SystemFrequency = 0 Then '未初始化
If QueryPerformanceFrequency(SystemFrequency) = 0 Then
SystemFrequency = ERRORINDEX '无高精度计数器
End If
End If
If SystemFrequency <> ERRORINDEX Then
Dim CurCount As Currency
QueryPerformanceCounter CurCount
GetCurrentTime = CurCount * 1000@ / SystemFrequency
Else
GetCurrentTime = GetTickCount()
End If
End Function

模块3、API声明部分，需要你自己解决冲突问题。
Option Explicit
Public Const ERRORINDEX As Long = -1
Public Const DIB_RGB_COLORS As Long = 0
Public Const BI_RGB As Long = 0 '正常
Public Const STRETCH_ANDSCANS As Long = 1
Public Const STRETCH_DELETESCANS As Long = 3
Public Const STRETCH_HALFTONE As Long = 4
Public Const STRETCH_ORSCANS As Long = 2
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Public Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As RGBQUAD
End Type
Public Type SAFEARRAYBOUND
Elements As Long
lLbound As Long
End Type
Public Type SAFEARRAY2D
Dimension As Integer
Features As Integer
Element As Long
Locks As Long
Pointer As Long
Bounds(1) As SAFEARRAYBOUND
End Type
Public Type SAFEARRAY
Dimension As Integer
Features As Integer
Element As Long
Locks As Long
Pointer As Long
Bounds As SAFEARRAYBOUND
End Type
Public Type BITMAPINFOHEADER
Size As Long
Width As Long
Height As Long
Planes As Integer
BitCount As Integer
Compression As Long
SizeImage As Long
XPelsPerMeter As Long
YPelsPerMeter As Long
ClrUsed As Long
ClrImportant As Long
End Type
Public Type BITMAPINFO
Header As BITMAPINFOHEADER
Palette(255) As RGBQUAD
End Type
Public Type Bitmap
Type As Long
Width As Long
Height As Long
WidthBytes As Long
Planes As Integer
BitsPixel As Integer
Bits As Long
End Type
'
'内存操作相关API
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, ByVal numBytes As Long)
Public
Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef
Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
'VB本体API
Public
Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal
lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As
Long
Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
'GDI系统API函数
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal Hdc As Long) As Long
Public
Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal Hdc As Long,
ByRef pBitmapInfo As Any, ByVal un As Long, ByRef Pointer As Long, ByVal
Handle As Long, ByVal Dw As Long) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal Hdc As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Public
Declare Function SetDIBColorTable Lib "gdi32" (ByVal Hdc As Long, ByVal
un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Public
Declare Function GetDIBColorTable Lib "gdi32" (ByVal Hdc As Long, ByVal
un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD) As Long
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Public
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As
Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long,
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal
dwRop As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal Hdc As Long, ByVal nStretchMode As Long) As Long
Public
Declare Function StretchBlt Lib "gdi32" (ByVal Hdc As Long, ByVal X As
Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long,
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal
nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As
Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal Hdc
As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy
As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long,
ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal
wUsage As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
类模块、CImage；文件名CImage.cls
Option Explicit
Private m_Width As Long '层的宽度
Private m_Height As Long '层的高度
Private m_Stride As Long '层数据每个扫描行的大小
Private m_Hdc As Long '层的内存DC
Private m_Pointer As Long '层数据在内存的首地址w
Private m_Handle As Long 'DIBSection的句柄
Private m_OldHandle As Long '原始设备环境的句柄
Public Property Get Width() As Long
Width = m_Width
End Property
Public Property Get Height() As Long
Height = m_Height
End Property
Public Property Get Stride() As Long
Stride = m_Stride
End Property
Public Property Get Hdc() As Long
Hdc = m_Hdc
End Property
Public Property Get Handle() As Long
Handle = m_Handle
End Property
Public Property Get Pointer() As Long
Pointer = m_Pointer
End Property
Private Sub Class_Terminate()
DisposeResource
End Sub
Public Function CreateNewImage(ByVal Width As Long, _ ByVal Height As Long) As Boolean
Dim ScreenDC As Long, BmpInfo As BITMAPINFOHEADER
If Width <= 0 Or Height <= 0 Then Exit Function
DisposeResource '删除原始的内存资源
With BmpInfo
.BitCount = 24
.Height = -Height '为了和GDI对象的坐标系统（起点坐标在左上角），建立一个倒序的DIB
.Width = Width
.Planes = 1
.Size = 40
m_Stride = ((Width * 3 + 3) And &HFFFFFFFC)
.SizeImage = m_Stride * Height
End With
ScreenDC = GetDC(0) '得到屏幕DC
m_Hdc = CreateCompatibleDC(ScreenDC)
ReleaseDC 0, ScreenDC '释放屏幕DC
m_Handle = CreateDIBSection(m_Hdc, BmpInfo, DIB_RGB_COLORS, m_Pointer, 0, 0)
If m_Handle <> 0 Then '希望系统能够让我们成功创建DIB吧
m_OldHandle = SelectObject(m_Hdc, m_Handle)
m_Width = Width: m_Height = Height
CreateNewImage = True
End If
End Function
Public Sub DisposeResource()
If m_Hdc <> 0 Then
SelectObject m_Hdc, m_OldHandle
DeleteDC m_Hdc
DeleteObject m_Handle
m_Width = 0: m_Height = 0 '重置其他的图像相关属性
m_Handle = 0: m_OldHandle = 0
m_Pointer = 0: m_Hdc = 0
End If
End Sub
Public Function Render(ByVal DestDC As Long, _
Optional ByVal DestX As Long, _
Optional ByVal DestY As Long, _
Optional ByVal DestWidth As Long, _
Optional ByVal DestHeight As Long, _
Optional ByVal SrcX As Long, _
Optional ByVal SrcY As Long, _
Optional ByVal SrcWidth As Long, _
Optional ByVal SrcHeight As Long) As Boolean
If m_Handle = 0 Then Exit Function

If DestWidth = 0 Then DestWidth = m_Width
If DestHeight = 0 Then DestHeight = m_Height
If SrcX < 0 Then SrcX = 0 ' 源X,Y不能为负，但目的X,Y可以
If SrcY < 0 Then SrcY = 0
If SrcWidth = 0 Then
SrcWidth = m_Width
ElseIf SrcWidth < 0 Then
DestWidth = -DestWidth
SrcWidth = -SrcWidth
End If
If SrcHeight = 0 Then
SrcHeight = m_Height
ElseIf SrcHeight < 0 Then
DestHeight = -DestHeight
SrcHeight = -SrcHeight
End If
SetStretchBltMode DestDC, STRETCH_HALFTONE
StretchBlt DestDC, DestX, DestY, DestWidth, DestHeight, m_Hdc, SrcX, SrcY, SrcWidth, SrcHeight, vbSrcCopy
End Function
Public Function LoadPictureFromFile(FileName As String) As Boolean
Dim Width As Long, Height As Long
Dim StdPic As StdPicture
On Error GoTo Errhandle:
Set StdPic = LoadPicture(FileName)
Width = ConvertHimetrixToPixels(StdPic.Width, True)
Height = ConvertHimetrixToPixels(StdPic.Height, False)
If CreateNewImage(Width, Height) = True Then

StdPic.Render m_Hdc + 0&, 0&, 0&, Width + 0&, Height +
0&, 0, StdPic.Height, StdPic.Width, -StdPic.Height, ByVal 0
'类似于BMP的逆序存储，所以用-StdPic.Height
LoadPictureFromFile = True
End If
Errhandle:

End Function
Private Function ConvertHimetrixToPixels(HiMetrix As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertHimetrixToPixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX
Else
ConvertHimetrixToPixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelY
End If
End Function
Private Function ConvertPixelsToHimetrix(Pixels As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertPixelsToHimetrix = Pixels * Screen.TwipsPerPixelX * 2540 / 1440
Else
ConvertPixelsToHimetrix = Pixels * Screen.TwipsPerPixelY * 2540 / 1440
End IfEnd Function追问

我复制了代码，但是调试报错，里面有没有可以设置尺寸的地方啊！我的QQ：1017055716

追答Private Sub myloadPic(PicData As PictureBox)
\'PicData.Picture = LoadPicture(App.Path & "\\手球场地小图.jpg")
Dim w As Long, H As Long
w = DIBData.Width * scaNum
H = DIBData.Height * scaNum
\' If W < 1 Then W = 1
\' If H < 1 Then H = 1
Dim DIBTemp As New CImage
Dim t As Currency
Me.MousePointer = vbHourglass
\' t = Utility.GetCurrentTime
Set DIBTemp = Resample(DIBData, w, H, 2)
\' t = GetCurrentTime - t
Me.MousePointer = vbDefault
\' Me.Caption = " 处理时间：" & Format(t / 1000, "##,###,##0.000") & "秒"
Set DIBWork = DIBTemp
Set DIBTemp = Nothing
PicData.Width = DIBWork.Width * Screen.TwipsPerPixelX
PicData.Height = DIBWork.Height * Screen.TwipsPerPixelX
DIBWork.Render PicData.Hdc
\' SolNum
PicData.Refresh
End Sub

能直接复制的只有三个模块代码，改变图像大小是通过修改ScaNum参数值的。我建议用一个独立过程如上，当然你也可以把scaNum作为该过程的一个参数，可能更灵活，我直接调用了，scaNum就作为了全局变量，所以强烈建议把他作为参数写进去。

追问

能加我QQ吗，QQ：1017055716

追答

还没搞成？我忽略了点，ScaNum是缩放比例，你需要的是精确尺寸，那么直接设定W,H两个变量就可以了。不过要注意缇和像素的转换

追问

能加我QQ吗，QQ：1017055716

参考技术A 这个还是用photoshop吧，要批量的话要用控件了。 参考技术B 这里有不要源码的？还用说么？

怎么修改淘宝店铺宝贝图片尺寸的宽度

我用的是淘宝标准版店铺，宝贝图片尺寸最大可以该为220*220，在店铺中我点“装修此页面”—“编辑”—图片尺寸大小调整为：220*220，保存后，我店铺的图片尺寸为146*220，有人说我的图片原本就是长方形的不能该为正方形，但是我看到别的标准版店铺的宝贝图片和我的一样，人家的尺寸就能调整为197*220，哪位高手赐教一下，即使不能改为220*220的尺寸，把宽度变宽一点也可以。（我店铺的图片是从别的网站直接导入的）

可以用Photoshop（简称PS）来处理图片大小，具体操作步骤如下：

1，首先下载安装绘图软件Photoshop（简称PS）打开一张图片。进去后，点击PS最上面的“图像”。

2，然后点击“图片大小”就会弹出一个对话框，再按照对话框中的提示来改变图片的大小，修改图片的尺寸参数后，再点击图中的“确定”。

3，把这长图片保存一下，那么在保存的过程中，就可以来改变图片的容量大小。现在点击PS最上边的“文件”，再点击“储存为”。

 4，点击“储存为”后，会弹出一个对话框。

5，要选择图片保存的格式，点击“保存”后，又会弹出一个对话框，调整好图片的品质大小后，再点击“确定”即可。

参考资料来源：百度百科-photoshop

参考技术A 直接进入图片空间使用美图秀秀修改尺寸。
1.进入卖家中心点击图片空间
2.鼠标放在百宝箱上，点击美图秀秀
3.点击授权，进入美图秀秀网页版
4.选择要修改的图片
5.右边点击修改尺寸
6.不勾选锁定款高比例
7.设置宽度高度，点击确定。
8.点击保存，可保存到图片空间也可保存到电脑 参考技术B 用PS软件处理或者用光影魔术手处理，推荐用光影吧，这个比较简单。 参考技术C 可以先用美图秀秀和可牛软件改一下尺寸.再传上店铺 参考技术D 需要用到PS，可以修改图片尺寸本回答被提问者采纳