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

Question

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

Answer 1

用分块读/写的办法可以显示进度条,但是,已不是流读写了.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

Answer 2

MSTOP(陈建华(东莞立晨企业资讯服务有限公司))：
这确实是一个好方法。
只是差1％就达到完美了，有没有可以用流的方法？（其实就解决问题而言，这已经足够了，我只是想再纯粹地追求一下技术问题，呵呵）