① 請問怎麼vb壓縮圖片，內詳
'圖片壓縮處理程序，可以實現高壓縮！
'注JPG壓縮比值為1-255
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Public Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type
Public Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Public Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Public Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Public Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Public Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
'*************************************************************************
'** 作 者 ： laviewpbt
'** 函 數 名 ： SavePic
'** 輸 入 ： pic(StdPicture) - 圖象句柄
'** ： FileName(String) - 保存路徑
'** ： Quality(Byte) - JPG圖象質量
'** ： TIFF_ColorDepth(Long) - TTF格式的顏色深度
'** ： TIFF_Compression(Long) - TTF格式的壓縮比
'** 輸 出 ： 無
'** 功能描述 ： 把圖象保存為JPG、TIFF、PNG、GIF、BMP格式
'** 日 期 ：
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-23 14.43.52
'** 版 本 ： Version 1.2.1
'*************************************************************************
Public Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
Optional ByVal Quality As Byte = 80, _
Optional ByVal TIFF_ColorDepth As Long = 24, _
Optional ByVal TIFF_Compression As Long = 6)
Screen.MousePointer = vbHourglass
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim aEncParams() As Byte
On Error GoTo ErrHandle:
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then ' 從句柄創建 GDI+ 圖像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解碼器的GUID標識
Select Case PicType
Case ".jpg"
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.count = 1 ' 設置解碼器參數
With tParams.Parameter ' Quality
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID ' 得到Quality參數的GUID標識
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Quality)
End With
ReDim aEncParams(1 To Len(tParams))
Call CopyMemory(aEncParams(1), tParams, Len(tParams))
Case ".png"
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
Case ".gif"
CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
Case ".tiff"
CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.count = 2
ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
With tParams.Parameter
.NumberOfValues = 1
.type = 4
CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID ' 得到ColorDepth參數的GUID標識
.Value = VarPtr(TIFF_Compression)
End With
Call CopyMemory(aEncParams(1), tParams, Len(tParams))
With tParams.Parameter
.NumberOfValues = 1
.type = 4
CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID ' 得到Compression參數的GUID標識
.Value = VarPtr(TIFF_ColorDepth)
End With
Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
Case ".bmp" '可以提前寫保存為BMP的代碼，因為並沒有用GDI+
SavePicture pict, FileName
Screen.MousePointer = vbDefault
Exit Sub
End Select
lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1)) '保存圖像
GdipDisposeImage lBitmap ' 銷毀GDI+圖像
End If
GdiplusShutdown lGDIP '銷毀 GDI+
End If
Screen.MousePointer = vbDefault
Erase aEncParams
Exit Sub
ErrHandle:
Screen.MousePointer = vbDefault
MsgBox "在保存圖片的過程中發生錯誤:" & vbCrLf & vbCrLf & "錯誤號: " & Err.Number & vbCrLf & "錯誤描述: " & Err.Description, vbInformation Or vbOKOnly, "錯誤"
End Sub
把以上的代碼復制到模塊
② vb鏂囦歡鍘嬬緝涔嬪悗鍥劇墖涓嶈佷簡
vb鏂囦歡鍘嬬緝涔嬪悗鍥劇墖涓嶈佷簡鍘熷洜濡備笅銆
1銆佸洜涓哄帇緙╂枃浠跺す閲岀殑鍥劇墖琚鎹熷潖浜嗭紝瀵艱嚧鍥劇墖涓嶈佷簡銆
2銆佸洜涓哄帇緙╂枃浠跺す閲岀殑鍥劇墖鏍煎紡涓嶆ｇ『錛屽艱嚧鍥劇墖涓嶈佷簡銆
③ VB壓縮圖片的問題！
不管原格式是什麼，vb 讀取、截圖後，保存的圖片都是 bmp 格式。
可以這樣轉變為 JPG 格式：用 windows 自帶的畫圖程序打開文件，然後單擊文件菜單的「另存為」，保存類型選 JPEG ,最後單擊保存就可以了。
④ 如何用VB把JPG格式的"大圖片"壓縮成視頻，謝謝！
Private Sub Command1_Click() '搜索
Dim strtemp As String '定義變數為字元串型，
Dim a As String '定義變數為字元串型
Dim i As Integer '定義變數為整值
strtemp = Trim(Text1.Text) ' 初始變數Strtemp 等於文本框中的內容 ，也就是要搜索的內容
For i = 0 To List1.ListCount - 1 '循環 列表框里的內容
a = List1.List(i) '把每項內容賦值給變數A
If InStr(a, strtemp) > 0 Then '判斷，當在列表項中找到搜索的關鍵字，那麼
List1.Selected(i) = True '該項被選中