vb或VBA進(jìn)行StdPicture、IStream、Byte() 互轉(zhuǎn)
- 2020-04-30 08:00:00
- TZWSOHO 轉(zhuǎn)貼
- 4175
Option Explicit
'*********************************************************************************
'StdPicture、IStream、Byte() 互轉(zhuǎn)
'作者：TZWSOHO
'
'蔘考瞭魏滔序的《VB6 結(jié)閤 GDI+ 實(shí)現(xiàn)內(nèi)存（Stream）壓縮/解壓縮 JPG 圖像》
'非常感謝魏滔序的代碼?。?！
'*********************************************************************************
Private Const GMEM_MOVEABLE As Long = &H2
'常量聲明
Private Const ClsidJPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderParameterValueTypeLong As Long = 4&
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const GdiPlusVersion As Long = 1&
'結(jié)構(gòu)聲明
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt 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(15) As EncoderParameter
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThreadAs 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 GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As Status
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, ByRef hbmReturn As Long, ByVal Background As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Status
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IStream, ByRef image 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 GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IStream, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Status
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, ByRef id As GUID) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As IID, ByVal fOwn As Boolean, ByRef lplpvObj As Object)
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
'Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
'Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pstm As IStream, ByRef phglobal As Long) As Long
'By Modest
'根據(jù)版本初始化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
'By Modest
'從圖像轉(zhuǎn)換爲(wèi)流
Public Function PictureToStream(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As IStream
Dim picStream As IStream
Dim lBitmap As Long
Dim tGUID As GUID
Dim bytBuff() As Byte
Dim tParams As EncoderParameters
Dim lngGdipToken As Long
lngGdipToken = StartUpGDIPlus(GdiPlusVersion)
'檢查JPG壓縮比率
If JpegQuality > 100 Then JpegQuality = 100
If JpegQuality < 0 Then JpegQuality = 0
'創(chuàng)建Bitmap
If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then
'創(chuàng)建Stream
If CreateStreamOnHGlobal(ByVal 0&, False, picStream) = 0 Then
'轉(zhuǎn)換GUID
If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
'設(shè)置JPG相關(guān)蔘數(shù)值
tParams.Count = 1
With tParams.Parameter(0)
CLSIDFromString StrPtr(EncoderQuality), .GUID
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JpegQuality)
End With
'將Bitmap數(shù)據(jù)保存到流(JPG格式)
If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then
Set PictureToStream = picStream
End If
End If
Set picStream = Nothing
End If
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function
'By Modest
'從流轉(zhuǎn)換爲(wèi)圖像
Public Function StreamToPicture(ByVal Stream As IStream) As StdPicture
Dim picStream As IStream
Dim lBitmap As Long
Dim hBitmap As Long
Dim lngGdipToken As Long
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
lngGdipToken = StartUpGDIPlus(GdiPlusVersion)
Set picStream = Stream
'從Stream加載Bitmap
If GdipLoadImageFromStream(picStream, lBitmap) = OK Then
'根據(jù)Bitmap創(chuàng)建hBitbmp
If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = vbPicTypeBitmap
.hgdiObj = hBitmap
.hPalOrXYExt = 0
End With
' 初始化IPicture
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
Set StreamToPicture = oPicture
End If
End If
Set picStream = Nothing
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function
'By TZWSOHO
'從圖像轉(zhuǎn)換爲(wèi)流再轉(zhuǎn)爲(wèi)字節(jié)數(shù)組
Public Function PictureToByteArray(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As Byte()
Dim picStream As IStream
Dim lBitmap As Long
Dim tGUID As GUID
Dim bytBuff() As Byte
Dim tParams As EncoderParameters
Dim lngGdipToken As Long
Dim hGlobal As Long, lpBuffer As Long, dwSize As Long, Buff() As Byte
lngGdipToken = StartUpGDIPlus(GdiPlusVersion)
'檢查JPG壓縮比率
If JpegQuality > 100 Then JpegQuality = 100
If JpegQuality < 0 Then JpegQuality = 0
'創(chuàng)建Bitmap
If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then
hGlobal = GlobalAlloc(GMEM_MOVEABLE, Picture.Width * Picture.Height 256) '創(chuàng)建緩衝區(qū)
'創(chuàng)建Stream
If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then
'轉(zhuǎn)換GUID
If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
'設(shè)置JPG相關(guān)蔘數(shù)值
tParams.Count = 1
With tParams.Parameter(0)
CLSIDFromString StrPtr(EncoderQuality), .GUID
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JpegQuality)
End With
'將Bitmap數(shù)據(jù)保存到流(JPG格式)
If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then
'GetHGlobalFromStream picStream, hGlobal
picStream.Seek 0, STREAM_SEEK_CUR, dwSize '穫?cè)D像大小
lpBuffer = GlobalLock(hGlobal) '穫?cè)【徯n區(qū)讀寫(xiě)指針
ReDim Buff(dwSize - 1): CopyMemory Buff(0), ByVal lpBuffer, dwSize '讀取圖像
GlobalUnlock hGlobal: GlobalFree hGlobal '釋放分配的緩衝區(qū)空間
PictureToByteArray = Buff
End If
End If
Set picStream = Nothing
End If
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function
'By TZWSOHO
'從字節(jié)數(shù)組轉(zhuǎn)換爲(wèi)流再轉(zhuǎn)換爲(wèi)圖像
Public Function ByteArrayToPicture(sBuf() As Byte) As StdPicture
Dim picStream As IStream
Dim lBitmap As Long
Dim hBitmap As Long
Dim lngGdipToken As Long
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
Dim hGlobal As Long, lpBuffer As Long
lngGdipToken = StartUpGDIPlus(GdiPlusVersion)
hGlobal = GlobalAlloc(GMEM_MOVEABLE, UBound(sBuf) + 1) '創(chuàng)建緩衝區(qū)
lpBuffer = GlobalLock(hGlobal) '穫?cè)【徯n區(qū)讀寫(xiě)指針
CopyMemory ByVal lpBuffer, sBuf(0), UBound(sBuf) + 1 '複製字節(jié)數(shù)組內(nèi)容到緩衝區(qū)
'創(chuàng)建Stream
If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then
'從Stream加載Bitmap
If GdipLoadImageFromStream(picStream, lBitmap) = OK Then
'根據(jù)Bitmap創(chuàng)建hBitbmp
If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = vbPicTypeBitmap
.hgdiObj = hBitmap
.hPalOrXYExt = 0
End With
' 初始化IPicture
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
Set ByteArrayToPicture = StreamToPicture(picStream)
End If
End If
GlobalUnlock hGlobal: GlobalFree hGlobal '釋放分配的緩衝區(qū)空間
Set picStream = Nothing
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function
窗體代碼：
Option Explicit
'StdPicture、IStream、Byte() 互轉(zhuǎn)示例
Private Sub Command1_Click()
'By Modest
'Dim s As IStream
'Set s = PictureToStream(Picture1.Picture, 5)
'Set Picture2.Picture = StreamToPicture(s)
'By TZWSOHO
Dim Buf() As Byte
Buf = PictureToByteArray(Picture1.Picture, 5)
Set Picture2.Picture = ByteArrayToPicture(Buf)
End Sub
分享
Access數(shù)據(jù)庫(kù)自身
- office課程播放地址及課程明細(xì)
- Excel Word PPT Access VBA等Office技巧學(xué)習(xí)平颱
- 將( .accdb) 文件格式數(shù)據(jù)庫(kù)轉(zhuǎn)換爲(wèi)早期版本(.mdb)的文件格式
- 將早期的數(shù)據(jù)庫(kù)文件格式（.mdb）轉(zhuǎn)換爲(wèi) （.accdb） 文件格式
- KB5002984：配置 Jet Red Database Engine 數(shù)據(jù)庫(kù)引擎和訪問(wèn)連接引擎以阻止對(duì)遠(yuǎn)程數(shù)據(jù)庫(kù)的訪問(wèn)（remote table)
- Access 365 /Access 2019 數(shù)據(jù)庫(kù)中哪些函數(shù)功能和屬性被沙箱模式阻止（如未啟動(dòng)宏時(shí)）
- Access Runtime(運(yùn)行時(shí))最全的下載(2007 2010 2013 2016 2019 Access 365)
Access查詢(xún)技巧
Access VBA函數(shù)模塊
- access vba代碼太長(zhǎng)，換行，分行的寫(xiě)法
- VB6 VBA Access真正可用併且完美支持中英文的 URLEncode 與 URLDecode 函數(shù)源碼
- 自定義VB中的urlencode函數(shù)，將URL中特殊部分進(jìn)行編碼
- Access 函數(shù)簡(jiǎn)化串接sql字符串，減少符號(hào)導(dǎo)緻的書(shū)寫(xiě)錯(cuò)誤
- vba完全關(guān)閉IE瀏覽器及調(diào)用IE瀏覽器的簡(jiǎn)單應(yīng)用
- 利用FollowHyperlink方法打開(kāi)超鏈接提示“無(wú)法下載您要求的信息”的解決方案
- 在access中用代碼打開(kāi)文本框中超鏈接地址
Access Activex第三方控件
- Activex控件或Dll 在某些電腦無(wú)法正常註冊(cè)的解決辦法(regsvr32註冊(cè)時(shí)卡住）
- office使用部分控件時(shí)提示“您沒(méi)有使用該ActiveX控件許可的問(wèn)題”的解決方法
- RTF文件（富文本格式）的一些解析
- Access樹(shù)控件（treeview) 64位Office下齣現(xiàn)橫曏滾動(dòng)條不會(huì)自動(dòng)定位的解決辦法
- Access中國(guó)樹(shù)控件 在win10電腦 節(jié)點(diǎn)行間距太小的解決辦法
- EXCEL 2019 64位版（Office 2019 64位）早就支持64位Treeview 樹(shù)控件 ListView列錶等64位MSCOMMCTL.OCX控件下載
- VBA或VB6調(diào)用WebService（直接Post方式）併解析返迴的XML
Access ADP Sql Server等
- 早期PB程序連接Sqlserver齣現(xiàn)錯(cuò)誤
- MMC 不能打開(kāi)文件C:/Program Files/Microsoft SQL Server/80/Tools/Binn/SQL Server Enterprise Manager.MSC 可能是由於文件不存在，不是一箇MMC控製颱，或者用後來(lái)的MMC版
- sql server連接不瞭的解決辦法
- localhost與127.0.0.1區(qū)彆
- Roych的淺談數(shù)據(jù)庫(kù)開(kāi)髮繫列（Sql Server)
- sqlserver 自動(dòng)備份對(duì)備份目録沒(méi)有存取權(quán)限的解決辦法
- 安裝Sql server 2005 express 和SQLServer2005 Express版企業(yè)管理器 SQLServer2005_SSMSEE
Access 行業(yè)應(yīng)用開(kāi)髮
- 金蝶KIS旂艦版 登録時(shí)“類(lèi)型不匹配”
- access行業(yè)交流QQ群-部分行業(yè)交流群(倉(cāng)庫(kù) 人事 工資 考勤 CRM HRM MRP ERP 等）
- access垃圾分類(lèi)數(shù)據(jù)庫(kù)
- Office提高企業(yè)辦公管理效率
- Access交流網(wǎng)Acccess通用開(kāi)髮平颱樹(shù)導(dǎo)航齣錯(cuò)的解決辦法
- Access交流網(wǎng)Access通用開(kāi)髮平颱的使用幫助教程及FAQ
- Access採(cǎi)購(gòu)倉(cāng)庫(kù)繫統(tǒng)作品源代碼
文章分類(lèi)
聯(lián)繫我們
| 聯(lián)繫人： | 王先生 |
|---|---|
| Email： | 18449932@qq.com |
| QQ： | 18449932 |
| 微博： | officecn01 |
