怎么用ado实现存取图片(sql server7.0)

[yuanxy]

写出代码?并给出调用方法.

[fraser01]

查一下以前的贴子，有代码解决的

[fraser01]

'这是早就有的，是吴文智的，感谢他吧
存文件到数据库
Public Function AddFile() As Boolean
'Return boolean to decide whether refresh files list
Dim strBin As String * 3000
Dim btyGet() As Byte
Dim lngBlockIndex As Long
Dim lngBlocks As Long
Dim lngLastBlock As Long
Dim lngPosition As Long
Dim lngFileLenth As Long
Dim lngIndex As Long

With frmBinary.CommonDialog1
'.InitDir = App.Path
.Filter = "All image files¦*.bmp;*.ico;*.jpg;*.gif¦Bitmap files¦*.bmp¦Icon files¦*.ico¦All files¦*.*"
.FileName = ""
On Error GoTo ErrorHandle
.ShowOpen
On Error GoTo 0
If .FileName <> "" Then
Open .FileName For Binary As #1
lngFileLenth = LOF(1)

lngPosition = 0

'Get block count for loop
lngBlocks = lngFileLenth \ BlockSize

'Get lngth of last block for the last read
lngLastBlock = lngFileLenth Mod BlockSize

rsBinary.AddNew
rsBinary.Fields("typecode") = TypeCode

For lngBlockIndex = 1 To lngBlocks
ReDim btyGet(BlockSize)
Get #1, , btyGet()
rsBinary.Fields("content").AppendChunk btyGet()
lngPosition = lngPosition + BlockSize
Next

If lngLastBlock > 0 Then
ReDim btyGet(lngLastBlock)
Get #1, , btyGet()
rsBinary.Fields("content").AppendChunk btyGet()
End If

rsBinary.Update
Close #1

AddFile = True
MsgBox "Save finished", vbInformation
Else
AddFile = False
End If
End With
Exit Function
ErrorHandle:
AddFile = False
End Function


从数据库取文件出来
Public Sub SaveFile(ByVal FileID As Long)
Dim lngBlockCount As Long
Dim lngLastBlock As Long
Dim lngI As Long
Dim btyBlock() As Byte
Dim lngResult As Long

If rsBinary.EOF And rsBinary.BOF Then Exit Sub
rsBinary.MoveFirst
rsBinary.Find " id=" & FileID
If Not rsBinary.EOF Then
With frmBinary.CommonDialog1
.FileName ="TempSave"
'.InitDir = App.Path

'If user cancel save the goto handle
On Error GoTo ErrorHandle
.ShowSave
If .FileName <> "" Then
lngBlockCount = rsBinary.Fields("content").ActualSize \ BlockSize
lngLastBlock = rsBinary.Fields("content").ActualSize Mod BlockSize

If Dir(.FileName) <> "" Then
If MsgBox("File " & .FileName & " is exist,overwrite?", vbYesNo + vbQuestion) = vbYes Then
Kill .FileName
Else
Exit Sub
End If
Else
End If

Open .FileName For Binary As #1

ReDim btyBinary(BlockSize)

For lngI = 1 To lngBlockCount
btyBlock() = rsBinary.Fields("content").GetChunk(BlockSize)
Put #1, , btyBlock
Next

If lngLastBlock <> 0 Then
ReDim btyBlock(lngLastBlock)
btyBlock() = rsBinary.Fields("content").GetChunk(lngLastBlock)
Put #1, , btyBlock
End If

Close #1
MsgBox .FileName & " is saved", vbInformation
Else
End If
End With
End If

Exit Sub
ErrorHandle:

End Sub

[yuanxy]

楼上的怎么调用啊.举个小例子.

[fraser01]

例子？这不是例子吗？如果要得到更详细的，那要问foolishtiger(吴文智)。

[yuanxy]

我是说实际应用啊,这只是几个过程.

[fraser01]

你在窗口里加2个BUTTON，然后
Private sub Button1_CLick()
AddFile()
end Sub
Private sub Button2_CLick()
SaveFile()
end Sub
在设一个表，找一张图片，就行了

[fraser01]

对了，BlockSize表示一次读取长度，你就设3000吧，再大点也没问题

[yuanxy]

什么3000

[yuanxy]

savefile()过程中还有参数呢?你怎么没用.

[acev]

回复人：　fraser01(wang)　(2001-11-15 19:42:15) 得0分
'这是早就有的，是吴文智的，感谢他吧

[pawn]

谢谢代码

[fraser01]

To：foolishtiger(吴文智)　
我可没有盗版，冤！！我这叫参考数目，文章吗总是你的，我不是写明了

[foolishtiger]

你看盗版VCD上不都写着“导演:冯小刚“，这就不是盗版了吗？呵呵！
另外问一下，fraser01(wang)　在什么地方啊？我想找工作，不知兄弟可否帮助？

[foolishtiger]

TO fraser01(wang)　:
你比uguess还不象话,明目张胆地进行盗版啊?呵呵

[foolishtiger]

那个参数是我指定的数据库中文件所对应的ID,你可以用你自己的字段来实现,只要保证能确定数据库中某条记录就行了.

[wjhwdm]

foolishtiger(吴文智)　的这个例子不好，也没有错误扑获，注释也没有,让初学者怎么看
说不定也是哪里COPY来的。
Private Sub SaveToDB(ByRef fld As ADODB.Field, diskfile As String) 'diskfile图片路径，fld 存放图片的字段
Dim byteData() As Byte '定义数据块数组
Dim NumBlocks As Long '定义数据块个数
Dim FileLength As Long '标识文件长度
Dim LeftOver As Long '定义剩余字节长度
Dim SourceFile As Long '定义自由文件号
Dim i As Long '定义循环变量
SourceFile = FreeFile '提供一个尚未使用的文件号
On Error GoTo err:

Open diskfile For Binary Access Read As SourceFile '打开文件
FileLength = LOF(SourceFile) '得到文件长度
If FileLength = 0 Then '判断文件是否存在
Close SourceFile
MsgBox diskfile & " 无 内 容 或 不 存 在 !"
Else
NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
fld.Value = Null
ReDim byteData(BLOCKSIZE) '重新定义数据块的大小
For i = 1 To NumBlocks
Get SourceFile, , byteData() ' 读到内存块中
fld.AppendChunk byteData() '写入FLD
Next i
ReDim byteData(LeftOver) '重新定义数据块的大小
Get SourceFile, , byteData() '读到内存块中
fld.AppendChunk byteData() '写入FLD
Close SourceFile '关闭源文件
End If
Exit Sub
err:
MsgBox err.Number & " " & err.Description
End Sub
Private Sub GetFromDb(PFld As ADODB.Field, diskfile As String)
Dim byteData() As Byte '定义数据块数组
Dim NumBlocks As Long '定义数据块个数
Dim FileLength As Long '标识文件长度
Dim LeftOver As Long '定义剩余字节长度
Dim SourceFile As Long '定义自由文件号
Dim i As Long '定义循环变量

On Error GoTo err:
FileLength = PFld.ActualSize
NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
SourceFile = FreeFile '提供一个尚未使用的文件号

Open diskfile For Binary As SourceFile
ReDim byteData(BLOCKSIZE)
For i = 1 To NumBlocks
byteData(i) = PFld.GetChunk(BLOCKSIZE)
Put SourceFile, , byteData(i)
Next

If LeftOver <> 0 Then
ReDim btyBlock(LeftOver)

byteData() = PFld.GetChunk(LeftOver)
Put SourceFile, , byteData()
End If
Close SourceFile
Exit Sub
err:
MsgBox err.Number & " " & err.Description
End Sub

[wjhwdm]

忘了还要定义
Const BLOCKSIZE = 4096 '每次读写块的大小

[jwing]

多谢各位大侠.

[NightBreak]

以下是摘抄的原程序
前面的感觉有些小问题，以下我经过整理，为了方便使用添加说明，满意了吧！！！呵呵，分来
Public Function AddFile() As Boolean ’添加文件的函数，返回成功与否
'Return boolean to decide whether refresh files list
Dim strBin As String * 3000 ‘定长字符串
Dim btyGet() As Byte
Dim lngBlockIndex As Long
Dim lngBlocks As Long
Dim lngLastBlock As Long
Dim lngPosition As Long
Dim lngFileLenth As Long
Dim lngIndex As Long

With frmBinary.CommonDialog1
'.InitDir = App.Path
.Filter = "All image files（*.bmp;*.ico;*.jpg;*.gif）“
.FileName = ""
On Error GoTo ErrorHandle
.ShowOpen
On Error GoTo 0
If .FileName <> "" Then
Open .FileName For Binary As #1
lngFileLenth = LOF(1)

lngPosition = 0

'Get block count for loop
lngBlocks = lngFileLenth \ BlockSize

'Get lngth of last block for the last read
lngLastBlock = lngFileLenth Mod BlockSize

rsBinary.AddNew
rsBinary.Fields("typecode") = TypeCode

For lngBlockIndex = 1 To lngBlocks
ReDim btyGet(BlockSize)
Get #1, , btyGet()
rsBinary.Fields("content").AppendChunk btyGet()
lngPosition = lngPosition + BlockSize
Next

If lngLastBlock > 0 Then
ReDim btyGet(lngLastBlock)
Get #1, , btyGet()
rsBinary.Fields("content").AppendChunk btyGet()
End If

rsBinary.Update
Close #1

AddFile = True
MsgBox "Save finished", vbInformation
Else
AddFile = False
End If
End With
Exit Function
ErrorHandle:
AddFile = False
End Function


从数据库取文件出来
Public Sub SaveFile(ByVal FileID As Long)
Dim lngBlockCount As Long
Dim lngLastBlock As Long
Dim lngI As Long
Dim btyBlock() As Byte
Dim lngResult As Long

If rsBinary.EOF And rsBinary.BOF Then Exit Sub
rsBinary.MoveFirst
rsBinary.Find " id=" & FileID
If Not rsBinary.EOF Then
With frmBinary.CommonDialog1
.FileName ="TempSave"
'.InitDir = App.Path

'If user cancel save the goto handle
On Error GoTo ErrorHandle
.ShowSave
If .FileName <> "" Then
lngBlockCount = rsBinary.Fields("content").ActualSize \ BlockSize
lngLastBlock = rsBinary.Fields("content").ActualSize Mod BlockSize

If Dir(.FileName) <> "" Then
If MsgBox("File " & .FileName & " is exist,overwrite?", vbYesNo + vbQuestion) = vbYes Then
Kill .FileName
Else
Exit Sub
End If
Else
End If

Open .FileName For Binary As #1

ReDim btyBinary(BlockSize)

For lngI = 1 To lngBlockCount
btyBlock() = rsBinary.Fields("content").GetChunk(BlockSize)
Put #1, , btyBlock
Next

If lngLastBlock <> 0 Then
ReDim btyBlock(lngLastBlock)
btyBlock() = rsBinary.Fields("content").GetChunk(lngLastBlock)
Put #1, , btyBlock
End If

Close #1
MsgBox .FileName & " is saved", vbInformation
Else
End If
End With
End If

Exit Sub
ErrorHandle:

End Sub

[NightBreak]

我看了一下，除了几个小地方不一样外，和楼上的朋友如出一辙。哈哈，看来引用的人还不少呢！