[轉]VB圖片讀取！

1. '将二进制文件添加到数据库中(该记录必须在存在)
2. '函数名:FileToRecode
3. '参数:  P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名
4. '返回值:
5. '例:    CALL  FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:/Tmp.Bmp")
6. Public Function FileToRecode(ByRef P_Cnn As ADODB.Connection, _
7.                              TabName As String, _
8.                              FldName As String, _
9.                              WhereStr As String, _
10.                              Filename As String) As Boolean
11.     
12.     Dim RsB As New ADODB.Recordset
13.     Dim Person_name As String
14.     Dim StrSql As String
16.     Dim File_Num As String
17.     Dim File_Length As String
18.     Dim Bytes() As Byte
19.     Dim Num_Blocks As Long
20.     Dim Left_Over As Long
21.     Dim Block_Num As Long
22.     
23.     Err.Clear
24.     On Error Resume Next
25.     
26.     File_Num = FreeFile
27.     Filename = Trim$(Filename)
28.     
29.     If P_Cnn.State <> 1 Then P_Cnn.Open
30.     
31.     If Len(Dir$(Filename)) = 0 Or Len(Filename) = 0 Then FileToRecode = False: Exit Function
32.     
33.     Open Filename For Binary Access Read As #File_Num
34.         File_Length = LOF(File_Num)                 '取文件大小
35.         If File_Length > 0 Then
36.             Num_Blocks = File_Length / Block_Size
37.             Left_Over = File_Length Mod Block_Size
38.             
39.             If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
40.             StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
41.             Set RsB = RsOpen(P_Cnn, StrSql, False) '连接式记录集
42.             If Not (RsB.EOF And RsB.BOF) Then
43.             
44. '/            '不分块写
45. '/            ReDim Bytes(File_Length)
46. '/            Get #File_Num, , Bytes()
47. '/            DoEvents
48. '/            RsB.Fields(FldName).AppendChunk Bytes()
50.             '/分块写
51.                 ReDim Bytes(Block_Size)
52.                 For Block_Num = 1 To Num_Blocks
53.                     Get #File_Num, , Bytes()
54.                     RsB.Fields(FldName).AppendChunk Bytes()
55.                 Next
56.                 
57.                 If Left_Over > 0 Then
58.                     ReDim Bytes(Left_Over)
59.                     Get #File_Num, , Bytes()
60.                     RsB.Fields(FldName).AppendChunk Bytes()
61.                 End If
62.                 RsB.Update
63.                 DoEvents
64.             End If
65.             If RsB.State = adStateOpen Then
66.                RsB.Close
67.                Set RsB = Nothing
68.             End If
69.         End If
70.     Close #File_Num
71.     Erase Bytes
72.     FileToRecode = (Err.Number = 0)
73.     Err.Clear
74. End Function
76. '
77. '将二进制数据从记录中取出
78. '函数名:RecodeToFile
79. '参数:  P_Cnn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型
80. '返回值:'一个临时文件名
81. '例:    GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp")
83. Public Function RecodeToFile(ByRef P_Cnn As ADODB.Connection, _
84.                              TabName As String, _
85.                              FldName As String, _
86.                              WhereStr As String, _
87.                              Optional FileType As String = "Bmp") As String
88.     
89.     Dim Rs As New ADODB.Recordset
90.     Dim StrSql As String
91.     
92.     Dim Bytes() As Byte
93.     Dim File_Name As String
94.     Dim File_Num As Integer
95.     Dim File_Length As Long
96.     Dim Num_Blocks As Long
97.     Dim Left_Over As Long
98.     Dim Block_Num As Long
99.     Dim WorkPath As String
100.     Dim TmpDir As New SmSysCls
101.     
102.     Err.Clear
103.     On Error Resume Next
104.     
105.      WorkPath = TmpDir.GetFolder(SmWinTempDirectory)
106.      If Dir$(WorkPath, vbDirectory) = "" Then WorkPath = App.Path
107.      If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
108.     
109.      If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
110.      StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
111.      Set Rs = RsOpen(P_Cnn, StrSql)
112.      If Rs.BOF And Rs.EOF Then Exit Function
113.      
114.      If P_Cnn.State <> 1 Then P_Cnn.Open
115.      
116.      If Not IsNull(Rs.Fields(FldName)) Then
117.          File_Name = WorkPath & "TmpFile." & FileType
118.          If Len(Dir(File_Name)) <> 0 Then Kill File_Name
119.          File_Num = FreeFile
120.          Open File_Name For Binary As #File_Num
121.              File_Length = CT.ToLng(Rs.Fields(FldName).ActualSize) '取字段的实际大小
122. '/不分块读写
123. '/             If File_Length > 0 Then
124. '/                Bytes() = Rs.Fields(FldName).GetChunk(File_Length)
125. '/                Put #File_Num, , Bytes()
126. '/             Else
127. '/                Err = -1
128. '/             End If
129. '/分块读写
130.              Num_Blocks = File_Length / Block_Size
131.              Left_Over = File_Length Mod Block_Size
132.              For Block_Num = 1 To Num_Blocks
133.                  Bytes() = Rs.Fields(FldName).GetChunk(Block_Size)
134.                  Put #File_Num, , Bytes()
135.              Next
137.              If Left_Over > 0 Then
138.                  Bytes() = Rs.Fields(FldName).GetChunk(Left_Over)
139.                  Put #File_Num, , Bytes()
140.              End If
141.              Erase Bytes
142.          Close #File_Num
143.          
144.         If Rs.State = adStateOpen Then
145.            Rs.Close
146.            Set Rs = Nothing
147.         End If
148.             
149.          Erase Bytes
150.     End If
151.     RecodeToFile = IIf(Err.Number = 0, File_Name, "")
152.     Set TmpDir = Nothing
153.     Err.Clear
154. End Function