TA貢獻1829條經驗 獲得超7個贊
SavePicture 語句
從對象或控件（如果有一個與其相關）的 Picture 或 Image 屬性中將圖形保存到文件中。
SavePicture 語句示例
本例使用 SavePicture 語句保存畫在 Form 對象的 Picture
屬性中的圖形。要試用此例，可將以下代碼粘貼到 Form 對象的聲明部分，然后運行此例，單擊 Form 對象。
Private Sub Form_Click () ' 聲明變量。 Dim CX, CY, Limit, Radius as Integer, Msg as String ScaleMode = vbPixels ' 設置比例模型為像素。 AutoRedraw = True ' 打開 AutoRedraw。 Width = Height ' 改變寬度以便和高度匹配。 CX = ScaleWidth / 2 ' 設置 X 位置。 CY = ScaleHeight / 2 ' 設置 Y 位置。 Limit = CX ' 圓的尺寸限制。 For Radius = 0 To Limit ' 設置半徑。 Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255) DoEvents ' 轉移到其它操作。 Next Radius Msg = "Choose OK to save the graphics from this form " Msg = Msg & "to a bitmap file." MsgBox Msg SavePicture Image, "TEST.BMP" ' 將圖片保存到文件。End Sub |
TA貢獻1858條經驗 獲得超8個贊
Private 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
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
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 Sub Form_click()
Me.Hide
Me.AutoRedraw = True
Picture1.Width = Screen.Width + 30
Picture1.Height = Screen.Height + 30
BitBlt Picture1.hDC, 0, 0, Screen.Width + 30, Screen.Height + 30, GetDC(0), 0, 0, vbSrcCopy
Set Picture1.Picture = Picture1.Image
Call PictureBoxSaveJPG(Picture1.Picture, Replace(App.Path & "\" & "test.JPG", "\\", "\")) '保存壓縮后的圖片
End
End Sub
Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 70) As Boolean
'直接修改quality參數 即可縮小圖片保存大小
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'從句柄創建 GDI+ 圖像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解碼器的GUID標識
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'設置解碼器參數
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality參數的GUID標識
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
'保存圖像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
'銷毀GDI+圖像
GdipDisposeImage lBitmap
End If
'銷毀 GDI+
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
舉報