'这是SQL SERVER数据库,除了连接数据库的地方不一致之外,其余的一样!!Option ExplicitDim cn As New ADODB.Connection, rs As New ADODB.Recordset'保存 Private Sub Command1_Click() Dim bteContent() As Byte
Open "C:\aa.bmp" For Binary Access Read As #1 bteContent = InputB(LOF(1), #1) Close #1
If rs.State = adStateOpen Then rs.Close rs.Open "select * from tablename", cn, adOpenDynamic, adLockPessimistic rs.AddNew rs!Name = "张三" rs!AGE = 22 rs!SEX = "男" rs.Fields("PHOTO").AppendChunk bteContent rs.Update
Erase bteContent End Sub'打开 Private Sub Command2_Click() Dim bteContent() As Byte If rs.State = adStateOpen Then rs.Close rs.Open "select * from tablename", cn, adOpenForwardOnly, adLockReadOnly bteContent = rs.Fields("PHOTO").GetChunk(rs.Fields("PHOTO").ActualSize) Open "C:\aa.bmp" For Binary Access Write As #1 Put #1, , bteContent Close #1 End SubPrivate Sub Form_Load() On Error GoTo Errhandle cn.ConnectionString = "Driver={SQL Server};SERVER=DataServer;DATABASE=zxzx;UID=information;PWD=information*&#" cn.Open
Exit Sub Errhandle: MsgBox Err.Description, vbExclamation End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) On Error Resume Next rs.Close Set rs = Nothing cn.Close Set cn = Nothing End Sub
'**************************读图片文件************************************** Sub GetPicFromDB(cn As ADODB.Connection) On Error Resume Next Dim fld As Field Dim strTemp As String Dim stm As ADODB.Stream Set stm = New ADODB.Stream 'strTemp = "c:\temp.bmp" Set rs1 = New ADODB.Recordset rs1.Open "select * from rs_http where htbh='" & frm_manage.Grid2.TextMatrix(frm_manage.Grid2.RowSel, 0) & "'", cn, , , adCmdText While Not rs1.EOF '*********将数据库中的文件读到硬盘上************************* ' strTemp = App.Path + "\temp\" + rs1!Name '`临时文件,用来保存读出的图片 With stm .Type = adTypeBinary .Open .Write rs1("tp").value strTemp = App.Path & "\temp1\" & rs1!Name .SaveToFile strTemp, adSaveCreateOverWrite .Close End With Set itemX = lvwPic.ListItems.add(, App.Path & "\temp1\" & rs1!Name, rs1!Name, 1, 1) itemX.SubItems(1) = rs1!bz rs1.MoveNext Wend Set stm = Nothing rs1.Close Set rs1 = Nothing End Sub'******************将图片文件保存到数据库中************************* Sub SavePicToDb(cn As ADODB.Connection, table1 As String, field1 As String, file1 As String, id1 As String) On Error Resume Next Dim stm As ADODB.Stream Set stm = New ADODB.Stream Set rs1 = New ADODB.Recordset rs1.Open "select * from " & table1 & " where id = " & id1, cn, adOpenKeyset, adLockOptimistic With stm .Type = adTypeBinary .Open .LoadFromFile file1 'DLG.FileName End With With rs1 .Fields(field1) = stm.Read .Update End With rs1.Close Set rs1 = Nothing End Sub
mymap (id ROWID,name CHAR(20),imap BLOB) 当表带有BLOB字段时是不支持以下SQL语句的: select * from mymap
'存储照片文件到数据库 Public Function WriteToDB(ByRef col As ADODB.Field, ByVal FileName As String) As Boolean On Error GoTo ErrMsg Dim mStream As ADODB.Stream Set mStream = New ADODB.Stream
mStream.Close Set mStream = Nothing WriteToDB = True Exit Function ErrMsg: MsgBox "存储照片到数据库时出现错误." & vbCrLf & Err.Description, vbExclamation + vbOKOnly, "提示" End Function'设置临时照片文件 Public Function ReadDB(col As ADODB.Field, ByRef imgFile As String) As Boolean On Error GoTo ErrRead Dim mStream As New ADODB.Stream ReadDB = False
If col.ActualSize < 200 Then Exit Function
mStream.Type = adTypeBinary mStream.Open mStream.Write col.Value mStream.SaveToFile imgFile, adSaveCreateOverWrite ReadDB = True Exit Function ErrRead: MsgBox "设置临时照片文件时出现错误:" & vbCrLf & Err.Description, vbInformation, "提示" ReadDB = False End Function
Private Sub Command1_Click()
Dim bteContent() As Byte
Open "C:\aa.bmp" For Binary Access Read As #1
bteContent = InputB(LOF(1), #1)
Close #1
If rs.State = adStateOpen Then rs.Close
rs.Open "select * from tablename", cn, adOpenDynamic, adLockPessimistic
rs.AddNew
rs!Name = "张三"
rs!AGE = 22
rs!SEX = "男"
rs.Fields("PHOTO").AppendChunk bteContent
rs.Update
Erase bteContent
End Sub'打开
Private Sub Command2_Click()
Dim bteContent() As Byte
If rs.State = adStateOpen Then rs.Close
rs.Open "select * from tablename", cn, adOpenForwardOnly, adLockReadOnly
bteContent = rs.Fields("PHOTO").GetChunk(rs.Fields("PHOTO").ActualSize) Open "C:\aa.bmp" For Binary Access Write As #1
Put #1, , bteContent
Close #1
End SubPrivate Sub Form_Load()
On Error GoTo Errhandle
cn.ConnectionString = "Driver={SQL Server};SERVER=DataServer;DATABASE=zxzx;UID=information;PWD=information*&#"
cn.Open
Exit Sub
Errhandle:
MsgBox Err.Description, vbExclamation
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
'**************************读图片文件**************************************
Sub GetPicFromDB(cn As ADODB.Connection)
On Error Resume Next
Dim fld As Field
Dim strTemp As String
Dim stm As ADODB.Stream
Set stm = New ADODB.Stream
'strTemp = "c:\temp.bmp"
Set rs1 = New ADODB.Recordset
rs1.Open "select * from rs_http where htbh='" & frm_manage.Grid2.TextMatrix(frm_manage.Grid2.RowSel, 0) & "'", cn, , , adCmdText
While Not rs1.EOF
'*********将数据库中的文件读到硬盘上*************************
' strTemp = App.Path + "\temp\" + rs1!Name '`临时文件,用来保存读出的图片 With stm
.Type = adTypeBinary
.Open
.Write rs1("tp").value
strTemp = App.Path & "\temp1\" & rs1!Name
.SaveToFile strTemp, adSaveCreateOverWrite
.Close
End With
Set itemX = lvwPic.ListItems.add(, App.Path & "\temp1\" & rs1!Name, rs1!Name, 1, 1)
itemX.SubItems(1) = rs1!bz
rs1.MoveNext
Wend
Set stm = Nothing
rs1.Close
Set rs1 = Nothing
End Sub'******************将图片文件保存到数据库中*************************
Sub SavePicToDb(cn As ADODB.Connection, table1 As String, field1 As String, file1 As String, id1 As String)
On Error Resume Next
Dim stm As ADODB.Stream
Set stm = New ADODB.Stream
Set rs1 = New ADODB.Recordset
rs1.Open "select * from " & table1 & " where id = " & id1, cn, adOpenKeyset, adLockOptimistic
With stm
.Type = adTypeBinary
.Open
.LoadFromFile file1 'DLG.FileName
End With
With rs1
.Fields(field1) = stm.Read
.Update
End With
rs1.Close
Set rs1 = Nothing
End Sub
当表带有BLOB字段时是不支持以下SQL语句的: select * from mymap
Public Function WriteToDB(ByRef col As ADODB.Field, ByVal FileName As String) As Boolean
On Error GoTo ErrMsg
Dim mStream As ADODB.Stream
Set mStream = New ADODB.Stream
WriteToDB = False
mStream.Type = adTypeBinary
mStream.Open
mStream.LoadFromFile FileName
col.Value = mStream.Read
mStream.Close
Set mStream = Nothing
WriteToDB = True
Exit Function
ErrMsg:
MsgBox "存储照片到数据库时出现错误." & vbCrLf & Err.Description, vbExclamation + vbOKOnly, "提示"
End Function'设置临时照片文件
Public Function ReadDB(col As ADODB.Field, ByRef imgFile As String) As Boolean
On Error GoTo ErrRead
Dim mStream As New ADODB.Stream
ReadDB = False
If col.ActualSize < 200 Then Exit Function
mStream.Type = adTypeBinary
mStream.Open
mStream.Write col.Value
mStream.SaveToFile imgFile, adSaveCreateOverWrite
ReadDB = True
Exit Function
ErrRead:
MsgBox "设置临时照片文件时出现错误:" & vbCrLf & Err.Description, vbInformation, "提示"
ReadDB = False
End Function