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

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

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

  15. Public Enum CBoolean   ' enum members are Long data types
  16.   CFalse = 0
  17.   CTrue = 1
  18. End Enum

  20. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
  21. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  22. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  23. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

  25. Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
  26. 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

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

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


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


  71. 'With Form Inet1 Control
  72. 'Private Function GetPicFromHTTP(strURL As String, Optional Username As String, Optional Password As String) As IPicture
  73. '    Dim bytearray() As Byte
  74. '
  75. '    Inet1.URL = strURL
  76. '    Inet1.Username = Username
  77. '    Inet1.Password = Password
  78. '    bytearray() = Inet1.OpenURL(, icByteArray)
  79. '
  80. '    Set GetPicFromHTTP = PictureFromBits(bytearray)
  81. '
  82. 'End Function


  85. '
  86. 'Private Sub Command1_Click()
  87. '    Picture1.Picture = GetPicFromHTTP("http://msdn.microsoft.com/library/shared/toolbar/graphics/banners/MSDN_banner.gif";) '("http://www.wandtv.com/rdrimg.jpg";)
  88. 'End Sub


  91. Public Function LoadPictureFromField(f As ADODB.field) As StdPicture
  92.     Dim b1() As Byte
  93.    
  94.     If f.ActualSize <> 0 Then
  95.         ReDim b1(1 To f.ActualSize) As Byte
  96.         b1 = f.GetChunk(f.ActualSize)
  97.         Set LoadPictureFromField = PictureFromBits(b1)
  98.     End If
  99. End Function


  102. Public Function LoadPictureFromFile(filePath As String) As StdPicture
  103.     Dim b1() As Byte
  104.    
  105.     Open filePath For Binary As #1
  106.     ReDim b1(1 To LOF(1))
  107.     Get 1, , b1
  108.     Close 1
  109.    
  110.     Set LoadPictureFromFile = PictureFromBits(b1)
  111. 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 的帖子

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

  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

  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

  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

  41. Private Type BITMAPINFO
  42.         bmiHeader As BITMAPINFOHEADER
  43.         bmiColors As RGBQUAD
  44. End Type

  46. Private Const DIB_RGB_COLORS = 0
  47. Private Const BI_RGB = 0&

  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

  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

  72.     DeleteDC hMemDc
  73.     DeleteObject hBitmap

  75. 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

  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

  14. ' Bild aus Bytearray laden und
  15. ' als StdPicture-Objekt zurückgeben

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

  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

  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

  32.   ' Stream erstellen
  33.     Call CreateStreamOnHGlobal(VarPtr(PictureData( _
  34.     LBound(PictureData))), 0, oStream)

  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

  42. 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