用stream传输文件时（sql到硬盘)如何显示进度条？

[jafi]

Dim gcn As new adodb.connection
Dim rs As New ADODB.Recordset
Dim mstream As New ADODB.Stream


gcn的open过程略

rs.Open "Select truename,filematter from yw_file where id=1" , gcn, adOpenKeyset, adLockOptimistic
mstream.Type = adTypeBinary
mstream.Open
mstream.Write rs.Fields("filematter").Value
LStrFileName = App.Path & "\" & rs("truename").Value
mstream.SaveToFile LStrFileName, adSaveCreateOverWrite
rs.Close

由于数据库是在远程，所以需要在下载时，显示一个进度条，请问如何
让它实时（或者不完全实时）显示进度？

[华芸智森]

用分块读/写的办法可以显示进度条,但是,已不是流读写了.

Public Const Block_Size = 1024 * 2 '对二进制数据每次读写块大小

'将二进制文件添加到数据库中(该记录必须在存在)
'函数名:FileToRecode
'参数: M_Conn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名
'返回值:
'例: CALL FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:\Tmp.Bmp")
Public Function FileToRecode(ByRef M_Conn As ADODB.Connection, _
TabName As String, _
FldName As String, _
WhereStr As String, _
Filename As String) As Boolean

Dim RsB As New ADODB.Recordset
Dim Person_name As String
Dim StrSql 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

On Error Resume Next

File_Num = FreeFile
Filename = Trim$(Filename)

If Len(Dir$(Filename)) = 0 Or Len(Filename) = 0 Then FileToRecode = False: Exit Function

Open 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

If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
Set RsB = RsOpen(M_Conn, StrSql, False) '连接式记录集
If Not (RsB.EOF And RsB.BOF) Then

'/ '不分块写
'/ ReDim Bytes(File_Length)
'/ Get #File_Num, , Bytes()
'/ DoEvents
'/ RsB.Fields(FldName).AppendChunk Bytes()

'/分块写
ReDim Bytes(Block_Size)
For Block_Num = 1 To Num_Blocks
Get #File_Num, , Bytes()
RsB.Fields(FldName).AppendChunk Bytes()
Next

If Left_Over > 0 Then
ReDim Bytes(Left_Over)
Get #File_Num, , Bytes()
RsB.Fields(FldName).AppendChunk Bytes()
End If
RsB.Update
DoEvents
End If
RsB.Close
Set RsB = Nothing
End If
Close #File_Num
Erase Bytes
FileToRecode = (Err.Number = 0)
Err.Clear
End Function

'
'将二进制数据从记录中取出
'函数名:RecodeToFile
'参数: M_Conn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型
'返回值:'一个临时文件名
'例: GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp")

Public Function RecodeToFile(ByRef M_Conn As ADODB.Connection, _
TabName As String, _
FldName As String, _
WhereStr As String, _
Optional FileType As String = "Bmp") As String

Dim Rs As New ADODB.Recordset
Dim StrSql As String

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 WorkPath As String
Dim TmpDir As New SmSysCls

On Error Resume Next

WorkPath = TmpDir.GetFolder(SmWinTempDirectory)
If Dir$(WorkPath, vbDirectory) = "" Then WorkPath = App.Path
If Right$(WorkPath, 1) <> "\" Then WorkPath = WorkPath & "\"

If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
Set Rs = RsOpen(M_Conn, StrSql)
If Rs.BOF And Rs.EOF Then Exit Function
If Not IsNull(Rs.Fields(FldName)) Then
File_Name = WorkPath & "TmpFile." & FileType
If Len(Dir(File_Name)) <> 0 Then Kill File_Name
File_Num = FreeFile
Open File_Name For Binary As #File_Num
File_Length = CT.ToLng(Rs.Fields(FldName).ActualSize) '取字段的实际大小
'/不分块读写
'/ If File_Length > 0 Then
'/ Bytes() = Rs.Fields(FldName).GetChunk(File_Length)
'/ Put #File_Num, , Bytes()
'/ Else
'/ Err = -1
'/ End If
'/分块读写
Num_Blocks = File_Length \ Block_Size
Left_Over = File_Length Mod Block_Size
For Block_Num = 1 To Num_Blocks
Bytes() = Rs.Fields(FldName).GetChunk(Block_Size)
Put #File_Num, , Bytes()
Next

If Left_Over > 0 Then
Bytes() = Rs.Fields(FldName).GetChunk(Left_Over)
Put #File_Num, , Bytes()
End If
Erase Bytes
Close #File_Num
Rs.Close: Erase Bytes
End If
RecodeToFile = IIf(Err.Number = 0, File_Name, "")
Set TmpDir = Nothing
Err.Clear
End Function

[jafi]

MSTOP(陈建华(东莞立晨企业资讯服务有限公司))：
这确实是一个好方法。
只是差1％就达到完美了，有没有可以用流的方法？

（其实就解决问题而言，这已经足够了，我只是想再纯粹地追求一下技术问题，呵呵）