rockyvan的专栏

用户操作
[留言] [发消息] [加为好友]
订阅我的博客
[编辑]rockyvan的公告
[编辑]文章分类
存档
[轉]VB圖片讀取！收藏

'将二进制文件添加到数据库中(该记录必须在存在) 
'函数名:FileToRecode 
'参数:  P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名 
'返回值: 
'例:    CALL  FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:\Tmp.Bmp") 
Public Function FileToRecode(ByRef P_Cnn 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
    
    Err.Clear
    On Error Resume Next
    
    File_Num = FreeFile
    Filename = Trim$(Filename)
    
    If P_Cnn.State <> 1 Then P_Cnn.Open
    
    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(P_Cnn, 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
            If RsB.State = adStateOpen Then
               RsB.Close
               Set RsB = Nothing
            End If
        End If
    Close #File_Num
    Erase Bytes
    FileToRecode = (Err.Number = 0)
    Err.Clear
End Function
' 
'将二进制数据从记录中取出 
'函数名:RecodeToFile 
'参数:  P_Cnn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型 
'返回值:'一个临时文件名 
'例:    GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp") 
Public Function RecodeToFile(ByRef P_Cnn 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
    
    Err.Clear
    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(P_Cnn, StrSql)
     If Rs.BOF And Rs.EOF Then Exit Function
     
     If P_Cnn.State <> 1 Then P_Cnn.Open
     
     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
         
        If Rs.State = adStateOpen Then
           Rs.Close
           Set Rs = Nothing
        End If
            
         Erase Bytes
    End If
    RecodeToFile = IIf(Err.Number = 0, File_Name, "")
    Set TmpDir = Nothing
    Err.Clear
End Function