'***********这儿有,以下由吴文智提供,******************存文件到数据库
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
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
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货