module4binary.bas

本公司开发得大请油田人事管理系统c/s结构

Attribute VB_Name = "ModuleBinary"
Option Explicit

Public Const BLOCK_SIZE = 16384
Public g_TextStream As TextStream
'Public g_FSO As New FileSystemObject

Sub BlobToFile(Field4Data As ADODB.Field, ByVal strFileName As String, Optional FieldSize As Long = -1, Optional Threshold As Long = 1048576)

'Assumes file does not exist
'Data cannot exceed approx. 2Gb in size

    Dim lFileNO As Long, bData() As Byte, strdata As String
    
    lFileNO = FreeFile
    Open strFileName For Binary As #lFileNO
    
    Select Case Field4Data.Type
    Case adLongVarBinary
        If FieldSize = -1 Then   ' blob field is of unknown size
            WriteFromUnsizedBinary lFileNO, Field4Data
        Else                     ' blob field is of known size
            If FieldSize > Threshold Then   ' very large actual data
                WriteFromBinary lFileNO, Field4Data, FieldSize
            Else                            ' smallish actual data
                bData = Field4Data.Value
                Put #lFileNO, , bData  ' PUT tacks on overhead if use Field4Data.Value
            End If
        End If
    Case adLongVarChar, adLongVarWChar 'add by ljh
        If FieldSize = -1 Then
            WriteFromUnsizedText lFileNO, Field4Data
        Else
            If FieldSize > Threshold Then
                WriteFromText lFileNO, Field4Data, FieldSize
            Else
                strdata = Field4Data.Value
                Put #lFileNO, , strdata  ' PUT tacks on overhead if use Field4Data.Value
            End If
        End If
    
    End Select
    Close #lFileNO

End Sub

Sub WriteFromBinary(ByVal lFileNO As Long, Field4Data As ADODB.Field, ByVal FieldSize As Long)
    
    Dim bData() As Byte, BytesRead As Long
    Do While FieldSize <> BytesRead
        If FieldSize - BytesRead < BLOCK_SIZE Then
            bData = Field4Data.GetChunk(FieldSize - BLOCK_SIZE)
            BytesRead = FieldSize
        Else
            bData = Field4Data.GetChunk(BLOCK_SIZE)
            BytesRead = BytesRead + BLOCK_SIZE
        End If
        Put #lFileNO, , bData
    Loop

End Sub

Sub WriteFromUnsizedBinary(ByVal lFileNO As Long, Field4Data As ADODB.Field)
    
    Dim bData() As Byte, Temp As Variant
    Do
        Temp = Field4Data.GetChunk(BLOCK_SIZE)
        If IsNull(Temp) Then Exit Do
        bData = Temp
        Put #lFileNO, , bData
    Loop While LenB(Temp) = BLOCK_SIZE

End Sub

Sub WriteFromText(ByVal lFileNO As Long, Field4Data As ADODB.Field, ByVal FieldSize As Long)
    
    Dim strdata As String, CharsRead As Long
    Do While FieldSize <> CharsRead
        If FieldSize - CharsRead < BLOCK_SIZE Then
            strdata = Field4Data.GetChunk(FieldSize - BLOCK_SIZE)
            CharsRead = FieldSize
        Else
            strdata = Field4Data.GetChunk(BLOCK_SIZE)
            CharsRead = CharsRead + BLOCK_SIZE
        End If
        Put #lFileNO, , strdata
    Loop

End Sub

Sub WriteFromUnsizedText(ByVal lFileNO As Long, Field4Data As ADODB.Field)
    
    Dim strdata As String, Temp As Variant
    Do
        Temp = Field4Data.GetChunk(BLOCK_SIZE)
        If IsNull(Temp) Then Exit Do
        strdata = Temp
        Put #lFileNO, , strdata
    Loop While Len(Temp) = BLOCK_SIZE

End Sub

Sub FileToBlob(ByVal strFileName As String, Field4Data As ADODB.Field, Optional Threshold As Long = 1048576)

'Assumes file exists
'Assumes calling routine does the UPDATE
'File cannot exceed approx. 2Gb in size

    Dim lFileNO As Long, bData() As Byte, FileSize As Long
    
    lFileNO = FreeFile
    Open strFileName For Binary As #lFileNO
    FileSize = LOF(lFileNO)
    
    Select Case Field4Data.Type
    Case adLongVarBinary
        If g_FSO.FileExists(App.Path & "\~Image") Then
            g_FSO.DeleteFile (App.Path & "\~Image")
        End If
        
        If FileSize > Threshold Then
            ReadToBinary lFileNO, Field4Data, FileSize
        Else
            bData = InputB(FileSize, lFileNO)
            Field4Data.Value = bData
        End If
    'add by ljh
    Case adLongVarWChar
        If g_FSO.FileExists(App.Path & "\~rtf") Then
            g_FSO.DeleteFile (App.Path & "\~rtf")
        End If
        
        If FileSize > Threshold Then
            ReadToText lFileNO, Field4Data, FileSize
        Else
            Field4Data.Value = Input(FileSize, lFileNO)
        End If
        
    Case adLongVarChar
        If g_FSO.FileExists(App.Path & "\~Text") Then
            g_FSO.DeleteFile (App.Path & "\~Text")
        End If
        
        If FileSize > Threshold Then
            ReadToText lFileNO, Field4Data, FileSize
        Else
            Field4Data.Value = Input(FileSize, lFileNO)
        End If
    End Select
    Close #lFileNO
End Sub

Sub ReadToBinary(ByVal lFileNO As Long, Field4Data As ADODB.Field, ByVal FileSize As Long)
    Dim bData() As Byte, BytesRead As Long
    
    Do While FileSize <> BytesRead
        If FileSize - BytesRead < BLOCK_SIZE Then
            bData = InputB(FileSize - BytesRead, lFileNO)
            BytesRead = FileSize
        Else
            bData = InputB(BLOCK_SIZE, lFileNO)
            BytesRead = BytesRead + BLOCK_SIZE
        End If
        Field4Data.AppendChunk bData
    Loop
End Sub

Sub ReadToText(ByVal lFileNO As Long, Field4Data As ADODB.Field, ByVal FileSize As Long)
    Dim strdata As String, CharsRead As Long
    
    Do While FileSize <> CharsRead
        If FileSize - CharsRead < BLOCK_SIZE Then
            strdata = Input(FileSize - CharsRead, lFileNO)
            CharsRead = FileSize
        Else
            strdata = Input(BLOCK_SIZE, lFileNO)
            CharsRead = CharsRead + BLOCK_SIZE
        End If
        Field4Data.AppendChunk strdata
    Loop
End Sub