用VB6读写数据库中的图片

' 1，以人名和相关图片为例说明，数据库为Access，
' 有如下字段：Name char,
'                         picture OLE object,
'                         FileLength Number。
' 当为ms sql时，将picture改为lob即可。 
' 2，示例包含control：commom dialog,picture,listbox。 
' 源码如下： 
Option   Explicit  

Private  Declare  Function  GetTempFileName Lib  " kernel32 "  Alias  " GetTempFileNameA "  (ByVal lpszPath  As  
String , ByVal lpPrefixString  As   String , ByVal wUnique  As   Long , ByVal lpTempFileName  As   String )  As   Long  
Private  Declare  Function  GetTempPath Lib  " kernel32 "  Alias  " GetTempPathA "  (ByVal nBufferLength  As   Long , 
ByVal lpBuffer  As   String )  As   Long  
Private   Const  MAX_PATH  =   260  

Private  m_DBConn  As  ADODB.Connection 

Private   Const  BLOCK_SIZE  =   10000  
注释： Return a temporary file name. 
Private   Function  TemporaryFileName()  As   String  
Dim  temp_path  As   String  
Dim  temp_file  As   String  
Dim  length  As   Long  

注释：  Get  the temporary file path. 
temp_path  =   Space $(MAX_PATH) 
length  =  GetTempPath(MAX_PATH, temp_path) 
temp_path  =   Left $(temp_path, length) 

注释：  Get  the file name. 
temp_file  =   Space $(MAX_PATH) 
GetTempFileName temp_path,  " per " ,  0 , temp_file 
TemporaryFileName  =   Left $(temp_file,  InStr (temp_file,  Chr $( 0 ))  -   1 ) 
End Function  
Private   Sub  Form_Load() 
Dim  db_file  As   String  
Dim  rs  As  ADODB.Recordset 

注释：  Get  the database file name. 
db_file  =  App.Path 
If   Right $(db_file,  1 )  <>   ""   Then  db_file  =  db_file  &   ""  
db_file  =  db_file  &   " dbpict.mdb "  

注释： Open the database connection. 
Set  m_DBConn  =   New  ADODB.Connection 
m_DBConn.Open _ 
" Provider=Microsoft.Jet.OLEDB.4.0; "   &  _ 
" Data Source= "   &  db_file  &   " ; "   &  _ 
" Persist Security Info=False "  

注释：  Get  the list of people. 
Set  rs  =  m_DBConn.Execute( " SELECT Name FROM People ORDER BY Name " , , adCmdText) 
Do   While   Not  rs.EOF 
lstPeople.AddItem rs!Name 
rs.MoveNext 
Loop  

rs.Close 
Set  rs  =   Nothing  
End Sub  
Private   Sub  Form_Resize() 
lstPeople.Height  =  ScaleHeight 
End Sub  


注释： Display the clicked person. 
Private   Sub  lstPeople_Click() 
Dim  rs  As  ADODB.Recordset 
Dim  bytes()  As   Byte  
Dim  file_name  As   String  
Dim  file_num  As   Integer  
Dim  file_length  As   Long  
Dim  num_blocks  As   Long  
Dim  left_over  As   Long  
Dim  block_num  As   Long  
Dim  hgt  As   Single  

picPerson.Visible  =   False  
Screen.MousePointer  =  vbHourglass 
DoEvents 

注释：  Get  the record. 
Set  rs  =  m_DBConn.Execute( " SELECT * FROM People WHERE Name=注释： "   &  _ 
lstPeople.Text  &   " 注释： " , , adCmdText) 
If  rs.EOF  Then   Exit   Sub  

注释：  Get  a temporary file name. 
file_name  =  TemporaryFileName() 

注释： Open the file. 
file_num  =  FreeFile 
Open file_name  For  Binary  As  #file_num 

注释： Copy the data into the file. 
file_length  =  rs!FileLength 
num_blocks  =  file_length  /  BLOCK_SIZE 
left_over  =  file_length  Mod  BLOCK_SIZE 

For  block_num  =   1   To  num_blocks 
bytes()  =  rs!Picture.GetChunk(BLOCK_SIZE) 
Put #file_num, , bytes() 
Next  block_num 

If  left_over  >   0   Then  
bytes()  =  rs!Picture.GetChunk(left_over) 
Put #file_num, , bytes() 
End   If  

Close #file_num 

注释： Display the picture file. 
picPerson.Picture  =   LoadPicture (file_name) 
picPerson.Visible  =   True  

Width  =  picPerson.Left  +  picPerson.Width  +  Width  -  ScaleWidth 
hgt  =  picPerson.Top  +  picPerson.Height  +  Height  -  ScaleHeight 
If  hgt  <   1440   Then  hgt  =   1440  
Height  =  hgt 

Kill file_name 
Screen.MousePointer  =  vbDefault 
End Sub  

Private   Sub  mnuRecordAdd_Click() 
Dim  rs  As  ADODB.Recordset 
Dim  person_name  As   String  
Dim  file_num  As   String  
Dim  file_length  As   String  
Dim  bytes()  As   Byte  
Dim  num_blocks  As   Long  
Dim  left_over  As   Long  
Dim  block_num  As   Long  

person_name  =   InputBox ( " Name " ) 
If   Len (person_name)  =   0   Then   Exit   Sub  

dlgPicture.Flags  =  _ 
cdlOFNFileMustExist  Or  _ 
cdlOFNHideReadOnly  Or  _ 
cdlOFNExplorer 
dlgPicture.CancelError  =   True  
dlgPicture.Filter  =   " Graphics Files|*.bmp;*.ico;*.jpg;*.gif "  

On   Error   Resume   Next  
dlgPicture.ShowOpen 
If  Err.Number  =  cdlCancel  Then  
Exit   Sub  
ElseIf  Err.Number  <>   0   Then  
MsgBox   " Error  "   &  Format$(Err.Number)  &  _ 
"  selecting file. "   &  vbCrLf  &  Err.Description 
Exit   Sub  
End   If  

注释： Open the picture file. 
file_num  =  FreeFile 
Open dlgPicture.FileName  For  Binary Access Read  As  #file_num 

file_length  =  LOF(file_num) 
If  file_length  >   0   Then  
num_blocks  =  file_length  /  BLOCK_SIZE 
left_over  =  file_length  Mod  BLOCK_SIZE 

Set  rs  =   New  ADODB.Recordset 
rs.CursorType  =  adOpenKeyset 
rs.LockType  =  adLockOptimistic 
rs.Open  " Select Name, Picture, FileLength FROM People " , m_DBConn 

rs.AddNew 
rs!Name  =  person_name 
rs!FileLength  =  file_length 

ReDim  bytes(BLOCK_SIZE) 
For  block_num  =   1   To  num_blocks 
Get  #file_num, , bytes() 
rs!Picture.AppendChunk bytes() 
Next  block_num 

If  left_over  >   0   Then  
ReDim  bytes(left_over) 
Get  #file_num, , bytes() 
rs!Picture.AppendChunk bytes() 
End   If  

rs.Update 
Close #file_num 

lstPeople.AddItem person_name 
lstPeople.Text  =  person_name 
End   If  
End Sub