'假设数据库中对应的表为tb1,
'结构如:create tabel tb1(id int identity(1,1),WordValue image)
'那么我就可以将word文档存入此表的WordValue字段
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim stm As ADODB.Stream
Private Sub SaveDocToDB(cn As ADODB.Connection)
On Error GoTo EH
Set stm = New ADODB.Stream
rs.Open "select WordValue from tbl", cn, adOpenKeyset, adLockOptimistic
CommonDialog1.ShowOpen
Text1.Text = CommonDialog1.FileName
With stm
.Type = adTypeBinary
.Open
.LoadFromFile CommonDialog1.FileName
End With
With rs
.AddNew
.Fields("wordValue") = stm.Read
.Update
End With
rs.Close
Set rs = Nothing
Exit Sub
EH: MsgBox Err.Description, vbInformation, "Error"
End Sub
Private Sub LoadDcFromDB(cn As ADODB.Connection)
'读出
On Error GoTo EH
Dim strTemp As String
Set stm = New ADODB.Stream
strTemp = "c:\temp.doc" '临时文件,用来保存读出的文档
rs.Open "select WordValue from tbl where id=1", cn, , , adCmdText
With stm
.Type = adTypeBinary
.Open
.Write rs("WordValue")
.SaveToFile strTemp, adSaveCreateOverWrite
.Close
End With
Set stm = Nothing
rs.Close
Set rs = Nothing
Exit Sub
EH: MsgBox Err.Description, vbInformation, "Error"
End Sub
Dim 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
Image1.Picture = LoadPicture("C:\aa.bmp")
End Sub
Private 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 Sub
Private 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
'读取文件到内容
Set iStm = New ADODB.Stream
With iStm
.Type = adTypeBinary '二进制模式
.Open
.LoadFromFile "c:\test.doc"
End With
'打开保存文件的表
Set iRe = New ADODB.Recordset
With iRe
.Open "表", iConc, adOpenKeyset, adLockOptimistic
.AddNew '新增一条记录
.Fields("保存文件内容的字段") = iStm.Read
.Update
End With
'完成后关闭对象
iRe.Close
iStm.Close
End Sub
'从数据库中读取数据,保存成文件
Sub s_ReadFile()
Dim iStm As ADODB.Stream
Dim iRe As ADODB.Recordset
Dim iConc As String
'存储文件到数据库
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
'应用实例:
'把图片写入到数据库
strSQL = "select * from " & strTable _
& " where BBID='" & strBBID & "'" _
& " and ReportIndex=" & objControl.Index _
& " and ReportType=" & WPhoto
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
WriteToDB rsTemp("ReportPhoto"), mstrTempFile
rsTemp.Update
rsTemp.Close
If mobjRst.RecordCount <> 0 Then
If Not IsNull(mobjRst!LastName) Then txtField(0) = mobjRst!FirstName Else txtField(0) = ""
If Not IsNull(mobjRst!FirstName) Then txtField(1) = mobjRst!LastName Else txtField(1) = ""
If Not IsNull(mobjRst!Title) Then txtField(2) = mobjRst!Title Else txtField(2) = ""
If Not IsNull(mobjRst!ReportsTo) Then txtField(3) = mobjRst!ReportsTo Else txtField(3) = ""
If Not IsNull(mobjRst!HireDate) Then txtField(4) = mobjRst!HireDate Else txtField(4) = ""
If Not IsNull(mobjRst!Extension) Then txtField(5) = mobjRst!Extension Else txtField(5) = ""
If Not IsNull(mobjRst!Address) Then txtField(6) = mobjRst!Address Else txtField(6) = ""
If Not IsNull(mobjRst!City) Then txtField(7) = mobjRst!City Else txtField(7) = ""
If Not IsNull(mobjRst!Region) Then txtField(8) = mobjRst!Region Else txtField(8) = ""
If Not IsNull(mobjRst!PostalCode) Then txtField(9) = mobjRst!PostalCode Else txtField(9) = ""
If Not IsNull(mobjRst!Country) Then txtField(10) = mobjRst!Country Else txtField(10) = ""
If Not IsNull(mobjRst!HomePhone) Then txtField(11) = mobjRst!HomePhone Else txtField(11) = ""
If Not IsNull(mobjRst!Notes) Then txtField(12) = mobjRst!Notes Else txtField(12) = ""
If Not IsNull(mobjRst!TitleOfCourtesy) Then txtField(13) = mobjRst!TitleOfCourtesy Else txtField(13) = ""
If Not IsNull(mobjRst!BirthDate) Then txtField(14) = mobjRst!BirthDate Else txtField(14) = ""
If Not IsNull(mobjRst!PhotoPath) Then txtPhoto = mobjRst!PhotoPath Else txtPhoto = ""