Access 代码实现缩略图，求完善

yedaoan

网上抄了一个缩略图实现代码，但Access中没有PictureBox 控件，用Access下Image控件的，有些方法和属性不能用，求高手完善附件中的程序，模块代码如下：

1. Option Compare Database
   
2. Option Explicit
   
3. '----------------------------------------------------------------------
   
4. '----------------------------------------------------------------------
   
5. '----------------使用者请保留作者版权----------------------------------
   
6. '--  作者:BEAR-BEN  ---------------------------------------------------
   
7. '--  QQ:453628001  ----------------------------------------------------
   
8. '--  天才动力 --- GENIUS POWER  ---------------------------------------
   
9. '--  WebSite:www.tcdongli.com  ----------------------------------------
   
10. '----------------------------------------------------------------------
    
11. '----------------------------------------------------------------------
    
12. '****************模块
    
13. 
    
14. Public Type ImageInfo
    
15.    Height As Long
    
16.    Width As Long
    
17.    FilePath As String
    
18.    ImageName As String
    
19.    Type As String
    
20.    FileSize As Long   'KB
    
21. End Type
    
22. 
    
23. Private Type GdiplusStartupInput
    
24.     GdiplusVersion As Long
    
25.     DebugEventCallback As Long
    
26.     SuppressBackgroundThread As Long
    
27.     SuppressExternalCodecs As Long
    
28. End Type
    
29. Private Enum GpStatus   'Status
    
30.     Ok = 0
    
31.     GenericError = 1
    
32.     InvalidParameter = 2
    
33.     OutOfMemory = 3
    
34.     ObjectBusy = 4
    
35.     InsufficientBuffer = 5
    
36.     NotImplemented = 6
    
37.     Win32Error = 7
    
38.     WrongState = 8
    
39.     Aborted = 9
    
40.     FileNotFound = 10
    
41.     ValueOverflow = 11
    
42.     AccessDenied = 12
    
43.     UnknownImageFormat = 13
    
44.     FontFamilyNotFound = 14
    
45.     FontStyleNotFound = 15
    
46.     NotTrueTypeFont = 16
    
47.     UnsupportedGdiplusVersion = 17
    
48.     GdiplusNotInitialized = 18
    
49.     PropertyNotFound = 19
    
50.     PropertyNotSupported = 20
    
51. End Enum
    
52. 
    
53. Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
    
54. Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
    
55. Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Single, ByVal Y As Single) As GpStatus
    
56. Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
    
57. Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, graphics As Long) As GpStatus
    
58. Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
    
59. Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, Image As Long) As GpStatus
    
60. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As GpStatus
    
61. Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As Long, Width As Long) As GpStatus
    
62. Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As Long, Height As Long) As GpStatus
    
63. 
    
64. Private Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As GpStatus
    
65. 
    
66. Dim gdip_Token As Long
    
67. Dim gdip_Image As Long
    
68. Dim gdip_Graphics As Long
    
69. 
    
70. '-------------缩略图函数-----------
    
71. Public Function ShowTNImg(PBox As Object, ImagePath As String, WMax As Long, HMax As Long) As ImageInfo
    
72. 'WMax为最大宽度，HMax为最大高度，这段代码会根据最大宽度和高度调整图片大小。
    
73. 
    
74. Dim Wid As Long, Hgt As Long, Top As Long, Left As Long
    
75. 
    
76. LoadGDIP
    
77. '
    
78. '' If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> 0 Then
    
79. If GdipCreateFromHDC(PBox.Picture, gdip_Graphics) <> 0 Then
    
80.      MsgBox "出现错误！", vbCritical, "错误"
    
81.      GdiplusShutdown gdip_Token
    
82.      End
    
83. End If
    
84. 
    
85. '载入图片到内存中
    
86. GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image
    
87. 
    
88. '获取图片长和宽
    
89. GdipGetImageWidth gdip_Image, Wid
    
90. GdipGetImageHeight gdip_Image, Hgt
    
91. 
    
92. With ShowTNImg
    
93.    .Width = Wid
    
94.    .Height = Hgt
    
95.    .FilePath = ImagePath
    
96.    .FileSize = FileLen(ImagePath) / 1024
    
97.    .ImageName = Right(ImagePath, Len(ImagePath) - InStrRev(ImagePath, ""))
    
98.    .Type = Right(ImagePath, Len(ImagePath) - InStrRev(ImagePath, "."))
    
99. End With
    
100. 
     
101. 
     
102. '智能调整图片大小和留空处理，根据最长边调整
     
103. If (Wid > WMax) Or (Hgt > HMax) Then
     
104.    If Wid > Hgt Then
     
105.      Hgt = Hgt / Wid * WMax
     
106.      Wid = WMax
     
107.      Top = (HMax - Hgt) / 2
     
108.    Else
     
109.      Wid = Wid / Hgt * HMax
     
110.      Hgt = HMax
     
111.      Left = (WMax - Wid) / 2
     
112.    End If
     
113. Else
     
114.    Top = (HMax - Hgt) / 2
     
115.    Left = (WMax - Wid) / 2
     
116. End If
     
117.    
     
118. 
     
119. '使用GDI+直接从内存中缩略并绘图，GDI+有很好的抗锯齿能力
     
120. If GdipDrawImageRect(gdip_Graphics, gdip_Image, Left, Top, Wid, Hgt) <> 1 Then Debug.Print "显示失败。。。"
     
121. 
     
122. DisposeGDIP
     
123. 
     
124. End Function
     
125. 
     
126. 
     
127. '加载显示完整图片
     
128. Public Sub ShowFullImg(PBox As Picture, ImagePath As String)
     
129. 
     
130. LoadGDIP
     
131. 
     
132. If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> Ok Then
     
133.      MsgBox "出现错误！", vbCritical, "错误"
     
134.      GdiplusShutdown gdip_Token
     
135.      End
     
136. End If
     
137. 
     
138. GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image
     
139. 
     
140. If GdipDrawImage(gdip_Graphics, gdip_Image, 0, 0) <> Ok Then Debug.Print "显示失败。。。"
     
141. 
     
142. DisposeGDIP
     
143. 
     
144. End Sub
     
145. 
     
146. 
     
147. Public Sub LoadGDIP()
     
148. Dim GpInput As GdiplusStartupInput
     
149. GpInput.GdiplusVersion = 1
     
150. 
     
151. If GdiplusStartup(gdip_Token, GpInput) <> 0 Then
     
152.      MsgBox "加载GDI+失败！", vbCritical, "加载错误"
     
153.      End
     
154. End If
     
155. End Sub
     
156. 
     
157. Public Sub DisposeGDIP()
     
158.    GdipDisposeImage gdip_Image
     
159.    GdipDeleteGraphics gdip_Graphics
     
160.    GdiplusShutdown gdip_Token
     
161. End Sub
     
162. 
     

复制代码

roych

Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, graphics As Long) As GpStatus

这个hDC应该是设备场景的句柄，应该等同于hwnd之类。没时间一步步帮你调试了。
picture如何获取句柄，请参考下小宝发的帖子：
http://www.office-cn.net/thread-106783-1-1.html
不过这个不是用GDI+，而是GDI的。
---------------------------------------------------------------------
'另外可以考虑使用这个API。
' 从内存中用指定大小和格式建立位图，位图句柄在Bitmap参数内返回
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Stride As Long, ByVal PixelFormat As GpPixelFormat, Scan0 As Any, Bitmap As Long) As Long

-----------------------------------------------------------------------
不过，在VBA里使用GDI+困难始终很大。

ganlinlao

很在意性能吗？
如果不那么在意，可以参看一下冬瓜汤的这篇文章，用法要简单地多了
http://www.office-cn.net/home.ph ... o=blog&id=15233

yedaoan

谢谢roych，对API不懂，还是搞不起来，但是还是要谢谢，希望有高手继续完善……

yedaoan

谢谢ganlinlao，WIA确实很强大，也很方便，虽然不能用代码动态来显示缩略图，而且还有锯齿，但也提供了另一种解决方法

cgsilicone

API其实很简单的，采用API按以下三步，简单修改就可以实现动态显示缩略图：

1、先新建立一个没有记录选择器、导航按钮、滚动条的窗体（特别注意，必需完全按以上要求建新窗体），然后将Image控件改为子窗体控件（新建窗体为子窗体），子窗体控件名为“子窗体”。

2、然后在模块程序中加入三句代码：
Public Declare Function 获取DC Lib "user32" Alias "GetDC" (ByVal 窗体句柄 As Long) As Long

Public Declare Function 释放DC Lib "user32" Alias "ReleaseDC" (ByVal 窗体句柄 As Long, ByVal 设备场景句柄 As Long) As Long

Public Declare Function 寻找窗体 Lib "user32" Alias "FindWindowExA" (ByVal 窗体句柄 As Long, ByVal 起始窗体句柄 As Long, ByVal 窗体类名 As String, ByVal 窗体名称 As String) As Long
   
同时修改代码： PBox As Object,为 hDC as long，PBox.hDC 为hDC。

3、将窗体Click()中代码修改为如下代码：

Dim 窗体句柄 As Long

Dim 绘图场景DC As Long

窗体句柄 = 0

窗体句柄 = 寻找窗体(Me.子窗体.Form.hWnd, 窗体句柄, vbNullString, vbNullString)

窗体句柄 = 寻找窗体(Me.子窗体.Form.hWnd, 窗体句柄, vbNullString, vbNullString)

绘图场景DC = 获取DC(窗体句柄)

ShowTNImg 绘图场景DC, "文件名", 100, 200 ' 根据实际修改文件名

释放DC Me.hWnd, 绘图场景DC

p51219

序        设备编号        设备名称        制造厂        出厂编号        安装地点        原值        启用时间        保养周期        设备类别 3        B123456        家用        滨江        789        黄山        ￥50.00        2004/9/4        6个月        办公用品