我想用VB写一个压缩图片的程序，应该怎么写

Posted 2023-05-11

经常拍照片上传，但是拍出来的照片很大，经常是2MB，3MB，要上传就会很慢，所以就用画板的拉伸功能进行压缩，但是每次都压缩很麻烦，想写一个程序直接压缩，请高手不吝赐教

如果你是仅仅为了压缩，而不是为了编程，你可以用ACDSee，他可以批量操作，方法是在ACDSee中选择你需要压缩的全部文件，点 工具 调整大小 选项很明显，你试一试。

你非要用程序的话，看看一下参考
注意：
PicClipD的ScaleMode=vbPixels
源图像是ImgSrc
目的图像是PicDest，注意它的属性
最关键的实现过程在CmdMake_Click

将下列内容复制到记事本，并保存为相应的文件

PicScale.vbp
--------------------

Type=Exe
Form=FrmMain.frm
Reference=*\G00020430-0000-0000-C000-000000000046#2.0#0#..\..\..\..\WINDOWS\system32\stdole2.tlb#OLE Automation
Object=F9043C88-F6F2-101A-A3C9-08002B2F49FB#1.2#0; COMDLG32.OCX
IconForm="FrmMain"
Startup="FrmMain"
HelpFile=""
ExeName32="PicScale.exe" "
Command32="" "
Name="PicScale"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1

FrmMain.frm
----------------------------------

VERSION 5.00
Object = "F9043C88-F6F2-101A-A3C9-08002B2F49FB#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmMain
Caption = "简单图像文件缩放"
ClientHeight = 3810
ClientLeft = 165
ClientTop = 855
ClientWidth = 5505
HasDC = 0 'False
LinkTopic = "Form1"
ScaleHeight = 254
ScaleMode = 3 'Pixel
ScaleWidth = 367
StartUpPosition = 3 '窗口缺省
Begin MSComDlg.CommonDialog CDlgFile
Left = 2160
Top = 1320
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.PictureBox PicClipD
BackColor = &H8000000C&
HasDC = 0 'False
Height = 1695
Left = 2520
ScaleHeight = 109
ScaleMode = 3 'Pixel
ScaleWidth = 117
TabIndex = 8
TabStop = 0 'False
Top = 840
Width = 1815
Begin VB.PictureBox PicDest
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
BorderStyle = 0 'None
Height = 495
Left = 240
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 65
TabIndex = 9
TabStop = 0 'False
Top = 360
Width = 975
End
End
Begin VB.PictureBox PicClipS
BackColor = &H8000000C&
HasDC = 0 'False
Height = 1575
Left = 360
ScaleHeight = 101
ScaleMode = 3 'Pixel
ScaleWidth = 101
TabIndex = 7
TabStop = 0 'False
Top = 840
Width = 1575
Begin VB.Image ImgSrc
Height = 855
Left = 240
Top = 240
Width = 855
End
End
Begin VB.PictureBox PicToolBar
Align = 1 'Align Top
HasDC = 0 'False
Height = 495
Left = 0
ScaleHeight = 29
ScaleMode = 3 'Pixel
ScaleWidth = 363
TabIndex = 0
TabStop = 0 'False
Top = 0
Width = 5505
Begin VB.CommandButton CmdReset
Caption = "复位"
Height = 255
Left = 3960
TabIndex = 6
Top = 120
Width = 780
End
Begin VB.CommandButton CmdMake
Caption = "生成"
Height = 255
Left = 3120
TabIndex = 5
Top = 120
Width = 780
End
Begin VB.TextBox TxtHeight
Height = 270
Left = 2280
TabIndex = 4
Text = "Text1"
Top = 120
Width = 750
End
Begin VB.TextBox TxtWidth
Height = 270
Left = 720
TabIndex = 2
Text = "Text1"
Top = 120
Width = 750
End
Begin VB.Label LblHeight
AutoSize = -1 'True
Caption = "Height:"
Height = 180
Left = 1680
TabIndex = 3
Top = 120
Width = 630
End
Begin VB.Label LblWidth
AutoSize = -1 'True
Caption = "&Width:"
Height = 180
Left = 120
TabIndex = 1
Top = 120
Width = 540
End
End
Begin VB.Menu mnuFile
Caption = "文件(&F)"
Begin VB.Menu mnuOpen
Caption = "打开(&O)..."
End
Begin VB.Menu mnuSave
Caption = "保存(&S)..."
End
Begin VB.Menu mnuSep0_0
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "退出(&X)"
End
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const CtlSpace = 4 '控件之间的距离

Private Sub CmdMake_Click()
Dim nWidth As Long
Dim nHeight As Long

'得到数值
On Error GoTo ErrNum
nWidth = CLng(TxtWidth.Text)
nHeight = CLng(TxtHeight.Text)
On Error GoTo 0
If nWidth < 1 Or nHeight < 1 Then GoTo ErrNum

'改变大小
On Error GoTo ErrSetSize
PicDest.Move 0, 0, nWidth, nHeight
On Error GoTo 0

'取消PictureBox的缓存
Set PicDest.Picture = Nothing

'绘制图像
PicDest.PaintPicture ImgSrc, 0, 0, PicDest.ScaleWidth, PicDest.ScaleHeight

Exit Sub

ErrNum:
MsgBox "错误的数值！", vbCritical
Exit Sub

ErrSetSize:
MsgBox "无法创建这么大的图片！", vbCritical
Exit Sub

End Sub

Private Sub CmdReset_Click()
If ImgSrc.Picture.Type = vbPicTypeNone Then '无图片
TxtWidth.Text = CStr(1)
TxtHeight.Text = CStr(1)

CmdMake.Enabled = False

Else
TxtWidth.Text = CStr(ImgSrc.Width)
TxtHeight.Text = CStr(ImgSrc.Height)

CmdMake.Enabled = True

Call CmdMake_Click

End If

End Sub

Private Sub Form_Load()
'-- 初始化坐标定位
Dim SM_Me As Long
Dim SM_Tbr As Long
Dim nTemp As Long

SM_Me = Me.ScaleMode
SM_Tbr = PicToolBar.ScaleMode

'定位PicToolBar的高度
With PicToolBar
'计算边框大小
nTemp = Me.ScaleY(.Height, SM_Me, vbPixels) - .ScaleY(.ScaleHeight, SM_Tbr, vbPixels)
'计算PicToolBar应有高度
nTemp = nTemp + .ScaleY(TxtWidth.Height, SM_Tbr, vbPixels)
'设置高度
.Height = Me.ScaleY(nTemp, vbPixels, SM_Me)
End With

'定位PicToolBar内的控件
nTemp = PicToolBar.ScaleHeight
LblWidth.Move CtlSpace, (nTemp - LblWidth.Height) / 2
TxtWidth.Move LblWidth.Left + LblWidth.Width, 0
LblHeight.Move TxtWidth.Left + TxtWidth.Width + CtlSpace, (nTemp - LblWidth.Height) / 2
TxtHeight.Move LblHeight.Left + LblHeight.Width, 0, TxtHeight.Width, TxtWidth.Height
CmdMake.Move TxtHeight.Left + TxtHeight.Width + CtlSpace, 0, CmdMake.Width, TxtWidth.Height
CmdReset.Move CmdMake.Left + CmdMake.Width + CtlSpace, 0, CmdReset.Width, TxtWidth.Height

ImgSrc.Move 0, 0

PicDest.Move 0, 0

'--设置数值
Call CmdReset_Click

With CDlgFile
.CancelError = True
.Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly
.Filter = "Windows位图(*.bmp)|*.bmp|所有文件(*.*)|*.*"
End With

End Sub

Private Sub Form_Resize()
If Me.WindowState = 1 Then Exit Sub
On Error Resume Next

Dim nTemp As Long
nTemp = PicToolBar.Height
PicClipS.Move 0, nTemp, Me.ScaleWidth / 2, Me.ScaleHeight - nTemp
PicClipD.Move PicClipS.Width, nTemp, Me.ScaleWidth - PicClipS.Width, PicClipS.Height

End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub mnuOpen_Click()
On Error Resume Next

CDlgFile.ShowOpen
If Err.Number Then Exit Sub '点了取消

'打开
Set ImgSrc.Picture = LoadPicture(CDlgFile.FileName)
If Err.Number Then
MsgBox "无法打开文件！", vbCritical
Exit Sub
End If

On Error GoTo 0

Call CmdReset_Click

End Sub

Private Sub mnuSave_Click()
On Error Resume Next

CDlgFile.ShowSave
If Err.Number Then Exit Sub '点了取消

'保存
SavePicture PicDest.Image, CDlgFile.FileName
If Err.Number Then
MsgBox "无法保存图片！", vbCritical
Exit Sub
End If

On Error GoTo 0

End Sub

参考资料：http://topic.csdn.net/t/20040827/14/3315677.html

参考技术A 如果仅仅是为了压缩图片。
用画笔打开一个几M的图片，保存一下就剩几百K了。
也可以用其它的图片压缩软件。 参考技术B 用其它格式保存，如JPG
开始 程序 附件 画图 打开 图片 另存为 其他格式 参考技术C '---------------------------------------------[压缩图片模块]--------------------------------------------------------------------------------------
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) 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 GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
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 Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
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 ' Quality
CLSIDFromString StrPtr("1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
'---------------------------------------------[压缩图片]--------------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim ret As Boolean
Picture1.Picture = LoadPicture("E:\20100201233117.BMP") '打开要压缩的图片
ret = PictureBoxSaveJPG(Picture1, "E:\20100201233111117.jpg") '保存压缩后的图片
If ret = False Then
MsgBox "保存失败"
End If
End Sub

vb中怎么写URLEncode编码?

vb中怎么写URLEncode编码?
我想转换的字 例如是：我们

在网上找到的

Public Function URLEncoding(ByVal vstrIn As String) As String
strreturn = ""
Dim i
Dim thisChr
For i = 1 To Len(vstrIn)
thisChr = Mid(vstrIn, i, 1)
If Abs(Asc(thisChr)) < &HFF Then
If thisChr = " " Then
strreturn = strreturn & "+"
Else
If InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_.", thisChr) > 0 Then
strreturn = strreturn & thisChr
Else
strreturn = strreturn & "%" & IIf(Asc(thisChr) > 16, "", "0") & Hex(Asc(thisChr))
End If
End If
Else
innerCode = Asc(thisChr)
If innerCode < 0 Then
innerCode = innerCode + &H10000
End If
Hight8 = (innerCode And &HFF00) \ &HFF
Low8 = innerCode And &HFF
strreturn = strreturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strreturn
End Function

都是 转换成 %CE%D2%C3%C7 这个的，

而不是转成 %E6%88%91%E4%BB%AC 这个的哦

请大家帮帮忙哦！！谢谢
那VB里有CodePage是65001和936两种情况的么？？
获得的代码 象这个帖子差不多！ 不过是ASP的。我想要VB转换的。
http://zhidao.baidu.com/question/6912615.html?si=4

不知道怎么写第2个代码的function 网上没找到哦。

这个程序就是vb的源程序.
"我们" 转换成"%CE%D2%C3%C7 ",这是asc的编码
"%E6%88%91%E4%BB%AC " 是"我们"的UTF-8的编码.

用这个函数可以获得UTF-8编码

Function GBtoUTF8(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3

'如果输入参数为空，则退出函数
If szInput = "" Then
GBtoUTF8 = szInput
Exit Function
End If

'开始转换
For x = 1 To Len(szInput)
wch = Mid(szInput, x, 1)
nAsc = AscW(wch)

If nAsc < 0 Then nAsc = nAsc + 65536

If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next
GBtoUTF8 = szRet
End Function

参考资料：http://www.asp.org.cn/vbscript/2007-1-25/1961.htm

参考技术A 　　vb中URLEncode编码的写法：
　　代码如下：
　　Public Function URLEncode(ByVal strParameter As String) As String
　　Dim s As String
　　Dim I As Integer
　　Dim intValue As Integer

　　Dim TmpData() As Byte

　　s = ""
　　TmpData = StrConv(strParameter, vbFromUnicode)
　　For I = 0 To UBound(TmpData)
　　intValue = TmpData(I)
　　If (intValue >= 48 And intValue <= 57) Or _
　　(intValue >= 65 And intValue <= 90) Or _
　　(intValue >= 97 And intValue <= 122) Then
　　s = s & Chr(intValue)
　　ElseIf intValue = 32 Then
　　s = s & "+"
　　Else
　　s = s & "%" & Hex(intValue)
　　End If
　　Next I
　　URLEncode = s
　　end Function 参考技术B 多谢楼下回答，解决大问题了。