Office中国论坛/Access中国论坛

标题: Show 一个没有菜单的界面(ADP) [打印本页]

作者: zhuyiwen    时间: 2011-7-19 00:29
标题: Show 一个没有菜单的界面(ADP)
[attach]46110[/attach]


[attach]46107[/attach]

[attach]46108[/attach]
[attach]46109[/attach]

界面导航元素:选项卡、子窗体、按钮

(注:照片的存储格式为直接的JPG文件存储在image字段,显示采用MSFORM2.0.Image控件,非ACCESS的Image和绑定对象控件, 这样的好处是占用空间小。)

请大家评评。







作者: zhufree    时间: 2011-7-19 06:05
好早呀
作者: t小宝    时间: 2011-7-19 10:01
界面布置紧凑合理,赞!
照片显示采用MSFORM2.0.Image控件,是否还要释放临时图片文件?
作者: zhuyiwen    时间: 2011-7-19 10:44
t小宝 发表于 2011-7-19 10:01
界面布置紧凑合理,赞!
照片显示采用MSFORM2.0.Image控件,是否还要释放临时图片文件?

不用产生临时文件,直接读字段内容。
注:MSFORM2.0为Office自带控件,通常用于UserForm(用户窗体)。

作者: chaosheng    时间: 2011-7-19 10:58
漂亮啊,学习.
作者: zhuyiwen    时间: 2011-7-19 11:03
贴一段读图片的代码:
  1. Option Compare Database
  2. Option Explicit

  3. Private Const S_OK = 0    ' indicates successful HRESULT
  4. Private Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
  5. Private Const GMEM_MOVEABLE = &H2

  6. Private Type GUID    ' 16 bytes (128 bits)
  7.   dwData1 As Long    ' 4 bytes
  8.   wData2 As Integer  ' 2 bytes
  9.   wData3 As Integer  ' 2 bytes
  10.   abData4(7) As Byte ' 8 bytes, zero based
  11. End Type

  12. Public Enum CBoolean   ' enum members are Long data types
  13.   CFalse = 0
  14.   CTrue = 1
  15. End Enum

  16. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
  17. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  18. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  19. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

  20. Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
  21. Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As CBoolean, riid As GUID, ppvObj As Any) As Long

  22. Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As CBoolean, ppstm As Any) As Long

  23. Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)


  24. Public Function PictureFromBits(abPic() As Byte) As IPicture  ' not a StdPicture!!
  25.     Dim nLow As Long, cbMem  As Long, hMem  As Long
  26.     Dim lpMem  As Long, IID_IPicture As GUID
  27.     Dim IStm As stdole.IUnknown, IPic As IPicture
  28.     ' Get the size of the picture's bits
  29.     On Error GoTo Out
  30.     nLow = LBound(abPic)
  31.     On Error GoTo 0
  32.     cbMem = (UBound(abPic) - nLow) + 1
  33.     ' Allocate a global memory object
  34.     hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
  35.     If hMem Then
  36.         ' Lock the memory object and get a pointer to it.
  37.         lpMem = GlobalLock(hMem)
  38.         If lpMem Then
  39.             ' Copy the picture file bytes to the memory pointer
  40.             ' and unlock the handle.
  41.             MoveMemory ByVal lpMem, abPic(nLow), cbMem
  42.             Call GlobalUnlock(hMem)
  43.             ' Create an ISteam from the pictures bits (we can
  44.             ' explicitly free hMem below, but we'll have the
  45.             ' call do it here...)
  46.             If (CreateStreamOnHGlobal(hMem, CTrue, IStm) = S_OK) Then
  47.                 If (CLSIDFromString(StrPtr(sIID_IPicture), _
  48.                     IID_IPicture) = S_OK) Then
  49.                     ' Create an IPicture from the IStream (the docs
  50.                     ' say the call does not AddRef its last param, but
  51.                     'it looks like the reference counts are correct..)
  52.                     Call OleLoadPicture(ByVal ObjPtr(IStm), cbMem, CFalse, IID_IPicture, PictureFromBits)
  53.                 End If   ' CLSIDFromString
  54.             End If   ' CreateStreamOnHGlobal
  55.         End If   ' lpMem
  56.         Call GlobalFree(hMem)
  57.     End If   ' hMem
  58. Out:
  59. End Function


  60. 'With Form Inet1 Control
  61. 'Private Function GetPicFromHTTP(strURL As String, Optional Username As String, Optional Password As String) As IPicture
  62. '    Dim bytearray() As Byte
  63. '
  64. '    Inet1.URL = strURL
  65. '    Inet1.Username = Username
  66. '    Inet1.Password = Password
  67. '    bytearray() = Inet1.OpenURL(, icByteArray)
  68. '
  69. '    Set GetPicFromHTTP = PictureFromBits(bytearray)
  70. '
  71. 'End Function


  72. '
  73. 'Private Sub Command1_Click()
  74. '    Picture1.Picture = GetPicFromHTTP("http://msdn.microsoft.com/library/shared/toolbar/graphics/banners/MSDN_banner.gif";) '("http://www.wandtv.com/rdrimg.jpg";)
  75. 'End Sub


  76. Public Function LoadPictureFromField(f As ADODB.field) As StdPicture
  77.     Dim b1() As Byte
  78.    
  79.     If f.ActualSize <> 0 Then
  80.         ReDim b1(1 To f.ActualSize) As Byte
  81.         b1 = f.GetChunk(f.ActualSize)
  82.         Set LoadPictureFromField = PictureFromBits(b1)
  83.     End If
  84. End Function


  85. Public Function LoadPictureFromFile(filePath As String) As StdPicture
  86.     Dim b1() As Byte
  87.    
  88.     Open filePath For Binary As #1
  89.     ReDim b1(1 To LOF(1))
  90.     Get 1, , b1
  91.     Close 1
  92.    
  93.     Set LoadPictureFromFile = PictureFromBits(b1)
  94. End Function
复制代码




作者: zhuyiwen    时间: 2011-7-19 11:08
调用Public Function LoadPictureFromField(f As ADODB.field) As StdPicture函数从字段读图片到MSFORM20.Image控件。当然,这个Field可以是SQL Server的Image字段,也可以是mdb的OLE字段,关键是这个字段存储的图片的内容,而非OLE对象。
作者: yanwei82123300    时间: 2011-7-19 12:31
老师就是厉害!!
作者: t小宝    时间: 2011-7-19 12:56
回复 zhuyiwen 的帖子

朱总的代码好呀,我也曾用了类似的方法。
其实jpg图片数据也可用代码转换后,在ACCESS.image控件显示。
作者: zhuyiwen    时间: 2011-7-19 12:58
t小宝 发表于 2011-7-19 12:56


朱总的代码好呀,我也曾用了类似的方法。其实jpg图片数据也可用代码转换后,在ACCESS.image控件显示。

能否共享一下?
作者: t小宝    时间: 2011-7-19 14:08
回复 zhuyiwen 的帖子

  1. 下面的代码从位图句柄获取位图数据

  2. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  3. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  4. 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
  5. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  6. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  7. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

  8. Private Type bitmap
  9.     bmType As Long
  10.     bmWidth As Long
  11.     bmHeight As Long
  12.     bmWidthBytes As Long
  13.     bmPlanes As Integer
  14.     bmBitsPixel As Integer
  15.     bmBits As Long
  16. End Type

  17. Private Type BITMAPINFOHEADER
  18.         biSize As Long
  19.         biWidth As Long
  20.         biHeight As Long
  21.         biPlanes As Integer
  22.         biBitCount As Integer
  23.         biCompression As Long
  24.         biSizeImage As Long
  25.         biXPelsPerMeter As Long
  26.         biYPelsPerMeter As Long
  27.         biClrUsed As Long
  28.         biClrImportant As Long
  29. End Type
  30. Private Type RGBQUAD
  31.         rgbBlue As Byte
  32.         rgbGreen As Byte
  33.         rgbRed As Byte
  34.         rgbReserved As Byte
  35. End Type

  36. Private Type BITMAPINFO
  37.         bmiHeader As BITMAPINFOHEADER
  38.         bmiColors As RGBQUAD
  39. End Type

  40. Private Const DIB_RGB_COLORS = 0
  41. Private Const BI_RGB = 0&

  42. Private Function GetPictureDataFromBitmap(hBitmap As Long, bPictureData() As Byte) As Boolean
  43.     Dim bm As bitmap
  44.     Dim bi24BitInfo As BITMAPINFO
  45.     Dim hMemDc As Long
  46.     Dim bBytes() As Byte

  47.     GetObject hBitmap, Len(bm), bm
  48.     With bi24BitInfo.bmiHeader
  49.         .biWidth = bm.bmWidth
  50.         .biHeight = bm.bmHeight
  51.         .biBitCount = 24
  52.         .biCompression = BI_RGB
  53.         .biPlanes = 1
  54.         .biSize = Len(bi24BitInfo.bmiHeader)
  55.     End With
  56.     ReDim bBytes(1 To ((bm.bmWidth * 3 + 3) \ 4) * 4 * bm.bmHeight) As Byte
  57.     hMemDc = CreateCompatibleDC(0)
  58.     GetDIBits hMemDc, hBitmap, 0, bm.bmHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
  59.    
  60.     ReDim bPictureData(bi24BitInfo.bmiHeader.biSizeImage + 40)
  61.     CopyMemory bPictureData(40), bBytes(1), bi24BitInfo.bmiHeader.biSizeImage
  62.     CopyMemory bPictureData(0), bi24BitInfo.bmiHeader, 40

  63.     DeleteDC hMemDc
  64.     DeleteObject hBitmap

  65. End Function
复制代码
6楼的代码可以获得StdPicture对象,此代码可将StdPicture对象转为access.image控件支持的位图数据,此代码结合6楼的代码如下使用即可:
Dim  bPictureData()  As  Byte
GetPictureDataFromBitmap  LoadPictureFromField(f).Handle,  bPictureData()
Me.Image1.PictureData = bPictureData()
作者: zhuyiwen    时间: 2011-7-19 16:52
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    时间: 2011-7-19 16:56
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    时间: 2011-7-19 17:08
  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. Private Declare Function OleLoadPicture Lib "oleaut32.dll" ( _
  7.   ByVal lpStream As IUnknown, _
  8.   ByVal lSize As Long, _
  9.   ByVal fRunmode As Long, _
  10.   riid As Any, _
  11.   lpIPicture As IPicture) As Long

  12. ' Bild aus Bytearray laden und
  13. ' als StdPicture-Objekt zurückgeben

  14. Public Function BytesToPicture(PictureData() As Byte) As StdPicture

  15.     Dim IID_IPicture(3) As Long
  16.     Dim oPicture As IPicture
  17.     Dim nResult As Long
  18.     Dim oStream As IUnknown
  19.     Dim hGlobal As Long

  20.     ' Array füllen um den KlassenID (CLSID) IID_IPICTURE
  21.     ' zu simulieren
  22.     IID_IPicture(0) = &H7BF80980
  23.     IID_IPicture(1) = &H101ABF32
  24.     IID_IPicture(2) = &HAA00BB8B
  25.     IID_IPicture(3) = &HAB0C3000

  26.   ' Stream erstellen
  27.     Call CreateStreamOnHGlobal(VarPtr(PictureData( _
  28.     LBound(PictureData))), 0, oStream)

  29.   ' OLE IPicture-Objekt erstellen
  30.     nResult = OleLoadPicture(oStream, 0, 0, IID_IPicture(0), oPicture)
  31.     If nResult = 0 Then
  32.         Set BytesToPicture = oPicture
  33.     End If

  34. End Function
复制代码



作者: richang_li    时间: 2011-7-21 19:32

作者: 轻风    时间: 2011-7-22 09:06
先收藏
作者: qczvba    时间: 2011-7-22 16:01
老师,照顾新人,啥时上传附件?
作者: zhengjialon    时间: 2011-9-28 17:23
很早就用老朱的这段代码了,谢谢老朱当时的共享{:soso_e113:}
作者: CHX    时间: 2013-4-27 10:31
{:soso_e179:}
作者: 海军下士    时间: 2013-5-7 08:25
能否公开代码哟,嘻嘻...
作者: 李力军2    时间: 2013-9-23 23:19
朱总厉害,不是一般的厉害啊!{:soso_e179:}
作者: 田小班    时间: 2020-6-2 12:59
ReDim bBytes(1 To ((bm.bmWidth * 3 + 3) \ 4) * 4 * bm.bmHeight) As Byte
这句下标越界,报错。




欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3