Show 一个没有菜单的界面(ADP)

t小宝

回复 zhuyiwen 的帖子

1. 
   
2. 下面的代码从位图句柄获取位图数据
   
3. 
   
4. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
   
5. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
   
6. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
   
7. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
   
8. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
   
9. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
   
10. 
    
11. Private Type bitmap
    
12.     bmType As Long
    
13.     bmWidth As Long
    
14.     bmHeight As Long
    
15.     bmWidthBytes As Long
    
16.     bmPlanes As Integer
    
17.     bmBitsPixel As Integer
    
18.     bmBits As Long
    
19. End Type
    
20. 
    
21. Private Type BITMAPINFOHEADER
    
22.         biSize As Long
    
23.         biWidth As Long
    
24.         biHeight As Long
    
25.         biPlanes As Integer
    
26.         biBitCount As Integer
    
27.         biCompression As Long
    
28.         biSizeImage As Long
    
29.         biXPelsPerMeter As Long
    
30.         biYPelsPerMeter As Long
    
31.         biClrUsed As Long
    
32.         biClrImportant As Long
    
33. End Type
    
34. Private Type RGBQUAD
    
35.         rgbBlue As Byte
    
36.         rgbGreen As Byte
    
37.         rgbRed As Byte
    
38.         rgbReserved As Byte
    
39. End Type
    
40. 
    
41. Private Type BITMAPINFO
    
42.         bmiHeader As BITMAPINFOHEADER
    
43.         bmiColors As RGBQUAD
    
44. End Type
    
45. 
    
46. Private Const DIB_RGB_COLORS = 0
    
47. Private Const BI_RGB = 0&
    
48. 
    
49. Private Function GetPictureDataFromBitmap(hBitmap As Long, bPictureData() As Byte) As Boolean
    
50.     Dim bm As bitmap
    
51.     Dim bi24BitInfo As BITMAPINFO
    
52.     Dim hMemDc As Long
    
53.     Dim bBytes() As Byte
    
54. 
    
55.     GetObject hBitmap, Len(bm), bm
    
56.     With bi24BitInfo.bmiHeader
    
57.         .biWidth = bm.bmWidth
    
58.         .biHeight = bm.bmHeight
    
59.         .biBitCount = 24
    
60.         .biCompression = BI_RGB
    
61.         .biPlanes = 1
    
62.         .biSize = Len(bi24BitInfo.bmiHeader)
    
63.     End With
    
64.     ReDim bBytes(1 To ((bm.bmWidth * 3 + 3) \ 4) * 4 * bm.bmHeight) As Byte
    
65.     hMemDc = CreateCompatibleDC(0)
    
66.     GetDIBits hMemDc, hBitmap, 0, bm.bmHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
    
67.    
    
68.     ReDim bPictureData(bi24BitInfo.bmiHeader.biSizeImage + 40)
    
69.     CopyMemory bPictureData(40), bBytes(1), bi24BitInfo.bmiHeader.biSizeImage
    
70.     CopyMemory bPictureData(0), bi24BitInfo.bmiHeader, 40
    
71. 
    
72.     DeleteDC hMemDc
    
73.     DeleteObject hBitmap
    
74. 
    
75. End Function

复制代码

6楼的代码可以获得StdPicture对象，此代码可将StdPicture对象转为access.image控件支持的位图数据，此代码结合6楼的代码如下使用即可：
Dim  bPictureData()  As  Byte
GetPictureDataFromBitmap  LoadPictureFromField(f).Handle,  bPictureData()
Me.Image1.PictureData = bPictureData()

zhuyiwen

If you have a valid PictureData prop then there is a SysCmd method
available that will return a StdPicture interface from the contents of
an Image control.

Dim pic As stdole.IPictureDisp
set pic = SysCmd(712,NameofYourImageControlHere)

可以这样将PictureData转换成StdPicture？
有待测试

zhuyiwen

Function FPictureDataToStdPicture(PictureData As Variant) As IPicture
' Memory Vars
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long

'Fill picture description
Dim lngRet As Long
Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID

' Cf_metafilepict structure
Dim cfm As MetaFilePict

' Handle to a Memory Metafile
Dim hMetafile As Long

' Which ClipBoard format is contained in the PictureData prop
Dim CBFormat As Long

' Byte array to hold the PictureData prop
Dim bArray() As Byte

' Temp var

'On Error GoTo Err_PtoC

' Resize to hold entire PictureData prop
ReDim bArray(LenB(PictureData) - 1)
APGDebug "Len of PictureData=" & (LenB(PictureData) - 1)
' Copy to our array
bArray = PictureData

' Determine which ClipBoard format we are using
Select Case bArray(0)

Case 40
' This is a straight DIB.
CBFormat = CF_DIB
' MSDN states to Allocate moveable|Shared Global memory
' for ClipBoard operations.
hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE Or
GMEM_ZEROINIT, UBound(bArray) + 1)
If hGlobalMemory = 0 Then _
Err.Raise vbObjectError + 515, "ImageToClipBoard.modImageToClipBoard",
_
"GlobalAlloc Failed..not enough memory"

' Lock this block to get a pointer we can use to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
If lpGlobalMemory = 0 Then _
Err.Raise vbObjectError + 516, "ImageToClipBoard.modImageToClipBoard",
_
"GlobalLock Failed"

' Copy DIB as is in its entirety
apiCopyMemory ByVal lpGlobalMemory, bArray(0), UBound(bArray) + 1

' Unlock the memory and then copy to the clipboard
If GlobalUnlock(hGlobalMemory) <> 0 Then _
Err.Raise vbObjectError + 517, "ImageToClipBoard.modImageToClipBoard",
_
"GlobalUnLock Failed"

Case CF_ENHMETAFILE
' New Enhanced Metafile(EMF)
CBFormat = CF_ENHMETAFILE
hMetafile = SetEnhMetaFileBits(UBound(bArray) + 1 - 8, bArray(8))

Case CF_METAFILEPICT
' Old Metafile format(WMF)
CBFormat = CF_METAFILEPICT
' Copy the Metafile Header over to our Local Structure
apiCopyMemory cfm, bArray(8), Len(cfm)
' Let's convert older WMF to EMF.
' Allows us to have a single solution for Metafiles.
' 24 is the number of bytes in the sum of the
' METAFILEPICT structure and the 8 byte ClipBoard Format struct.
hMetafile = SetWinMetaFileBits(UBound(bArray) + 24 + 1 - 8, bArray(24),
0&, cfm)

Case Else
'Should not happen
Err.Raise vbObjectError + 514, "ImageToClipBoard.modImageToClipBoard",
_
"Unrecognized PictureData ClipBoard format"

End Select

' Can we open the ClipBoard.
If OpenClipboard(0&) = 0 Then _
Err.Raise vbObjectError + 518, "ImageToClipBoard.modImageToClipBoard",
_
"OpenClipBoard Failed"

' Always empty the ClipBoard First. Not the friendliest thing
' to do if you have several programs interacting!
Call EmptyClipboard

' Now set the Image to the ClipBoard
If CBFormat = CF_ENHMETAFILE Or CBFormat = CF_METAFILEPICT Then

' Remember we can use this logic for both types of Metafiles
' because we converted the older WMF to the newer EMF.
'hClipMemory = SetClipboardData(CF_ENHMETAFILE, hMetafile)

picdes.Size = Len(picdes)
picdes.type = vbPicTypeEMetafile
picdes.hBmp = hMetafile

' No palette info here
' Everything is 24bit for now

'picdes.hPal = hPal
' ' Fill in magic IPicture GUID
{7BF80980-BF32-101A-8BBB-00AA00300CAB}
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
'' Create picture from bitmap handle
lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
'' Result will be valid Picture or Nothing-either way set it
Set FPictureDataToStdPicture = IPic

Else
'' We are dealing with a standard DIB.
hClipMemory = SetClipboardData(CBFormat, hGlobalMemory)

End If

Exit_PtoC:
Exit Function

Err_PtoC:
Set FPictureDataToStdPicture = Nothing
APGDebug Err.Description & Err.Source & ":" & Err.Number
Resume Exit_PtoC

End Function

zhuyiwen

1. ' Benötigte API-Deklarationen
   
2. Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
   
3.   ByVal hGlobal As Long, _
   
4.   ByVal fDeleteOnRelease As Long, _
   
5.   lpIStream As IUnknown) As Long
   
6. 
   
7. Private Declare Function OleLoadPicture Lib "oleaut32.dll" ( _
   
8.   ByVal lpStream As IUnknown, _
   
9.   ByVal lSize As Long, _
   
10.   ByVal fRunmode As Long, _
    
11.   riid As Any, _
    
12.   lpIPicture As IPicture) As Long
    
13. 
    
14. ' Bild aus Bytearray laden und
    
15. ' als StdPicture-Objekt zurückgeben
    
16. 
    
17. Public Function BytesToPicture(PictureData() As Byte) As StdPicture
    
18. 
    
19.     Dim IID_IPicture(3) As Long
    
20.     Dim oPicture As IPicture
    
21.     Dim nResult As Long
    
22.     Dim oStream As IUnknown
    
23.     Dim hGlobal As Long
    
24. 
    
25.     ' Array füllen um den KlassenID (CLSID) IID_IPICTURE
    
26.     ' zu simulieren
    
27.     IID_IPicture(0) = &H7BF80980
    
28.     IID_IPicture(1) = &H101ABF32
    
29.     IID_IPicture(2) = &HAA00BB8B
    
30.     IID_IPicture(3) = &HAB0C3000
    
31. 
    
32.   ' Stream erstellen
    
33.     Call CreateStreamOnHGlobal(VarPtr(PictureData( _
    
34.     LBound(PictureData))), 0, oStream)
    
35. 
    
36.   ' OLE IPicture-Objekt erstellen
    
37.     nResult = OleLoadPicture(oStream, 0, 0, IID_IPicture(0), oPicture)
    
38.     If nResult = 0 Then
    
39.         Set BytesToPicture = oPicture
    
40.     End If
    
41. 
    
42. End Function

复制代码

richang_li

轻风

先收藏

qczvba

老师，照顾新人，啥时上传附件？

zhengjialon

很早就用老朱的这段代码了，谢谢老朱当时的共享{:soso_e113:}

CHX

{:soso_e179:}

海军下士

能否公开代码哟，嘻嘻...