' 建立表 Ver 表结构为: f001 标识增量字段,f002 nvarchar(50) 文件名,f003 nvarchar(50) 版本号,f004 image  存储文件,f005 datetime 上传日期时间,f006 存储f004中exe文件的最后修改时间,以上字段均非空
'                      f007 nvarchar(50)SQL文件名称 ,f008 image SQL文件 ,f009 nvarchar(50)控件文件名称,f010 image 控件文件,f011 nvarchar(50)控件注册文件名,f012 image 控件注册文件‘

'保存为文件
Public Sub SaveToFile(ByVal sFileName As String, Field As String)
'
' Export the file from the database to the passed filename
'
    Dim iFileNum As Integer
    Dim lFileLen As Long
    Dim lChunks As Long
    Dim lFragment As Long
    Dim bChunk() As Byte
    Dim lCount As Long
    Dim oField As Field
    Dim oRS As New ADODB.Recordset
    Const CHUNKSIZE As Long = 16384 ' internal chunksize
  
    On Error GoTo ErrorHandler
'
' Get the field from the database
'
    DBOpen oRS, "select * from ver where f001=(select max(f001) from ver)"
       
    If oRS.BOF Or oRS.EOF Then GoTo PROC_EXIT
   
    iFileNum = FreeFile
'
' Create the Named File
'
    Open sFileName For Binary Access Write As iFileNum
   
    Set oField = oRS.Fields(Field)
    '
' Get the length of the file and the number of chunks required

    lFileLen = oField.ActualSize
    lFragment = lFileLen Mod CHUNKSIZE
'
' Write away the chunks to the file
   
    lChunks = 0
    Do While lChunks < lFileLen
        ReDim bChunk(CHUNKSIZE)
        bChunk() = oField.GetChunk(CHUNKSIZE)
        Put iFileNum, , bChunk()
        lChunks = lChunks + CHUNKSIZE
    Loop

    Close iFileNum
   
    oRS.Close
    Set oRS = Nothing

PROC_EXIT:
    Exit Sub
ErrorHandler:
    Call ShowError("Public", "SaveToFile", Err.Number, Err.Description, "Y")
End Sub

    '文件写入数据库表中

Private Sub putFile(FileDirName As String)
    '文件写入数据库表中
    Dim rs As New ADODB.Recordset
    Dim verNo As String
    Dim irtn As Long
    Dim i As Integer

    Dim sFilename As String
   
    sFilename = FileDirName

'    On Error GoTo ErrorHandle
    '判定文件是否存在
    If Exists(sFilename) = False Then
        MsgBox "找不到源文件 !", vbCritical, "源文件错误"
        GoTo PROC_EXIT
    End If
      
    '下载文件和表中文件版本比较
    DBOpen rs, "select * from ver where f001=(select max(f001) from ver)"
    If rs.BOF Or rs.EOF Then GoTo PROC_EXIT

    verNo = DisplayVerInfo(sFilename)
    If Len(verNo) > 0 Then
        If Len(Trim(verNo)) = Len(Trim(rs.Fields("f003"))) Then
            If Trim(verNo) <= Trim(rs.Fields("f003")) Then
                List1.AddItem "文件版本相同,不需要更新!!!"
                Command2.Caption = "完成"
                ProgressBar1.value = 10
                GoTo PROC_EXIT
            Else
                InsertToTable sFilename, verNo
            End If
        Else
            InsertToTable sFilename, verNo
        End If
    End If

PROC_EXIT:
    Exit Sub
ErrorHandle:
    Call ShowError("frmTransfer", "putFile", err.Number, err.Description, "Y")
End Sub

Private Sub InsertToTable(FileDirName As String, verNo As String)
    '写入数据库字段
    Dim Res As New ADODB.Recordset
    Dim sFilename As String

    On Error GoTo ErrorHandler

    sFilename = FileDirName
   
    If Len(Trim(sFilename)) = 0 Then GoTo PROC_EXIT
 
    '删除不需的要执行文件版本
    Cn.Execute "delete from ver where f001 not in(select max(f001) from ver)"

    DBOpen Res, "select * from ver"

    With Res
        .AddNew
        .Fields("f002").value = PrjName
        .Fields("f003").value = Trim(verNo)

        Dim lLen As Long
        Dim lCount As Long
        Dim lFragment As Long
        Dim lChunks As Long
        Dim bChunk() As Byte
        Dim iFileNum As Integer
        Dim oField As Field
        Dim mdteOrigDate As Variant

        '写EXE文件
        iFileNum = FreeFile
        Open sFilename For Binary Access Read As iFileNum
        mdteOrigDate = FileDateTime(sFilename)
        lLen = LOF(iFileNum)
        lChunks = lLen \ CHUNKSIZE
        lFragment = lLen Mod CHUNKSIZE
        ReDim bChunk(lFragment)
        Get iFileNum, , bChunk
        Set oField = Res("f004")
        'oField.Value = Null
        oField.AppendChunk bChunk
        ReDim bChunk(CHUNKSIZE)
        For lCount = 1 To lChunks
            Get iFileNum, , bChunk()
            oField.AppendChunk bChunk
        Next
        Close iFileNum
        .Fields("f005").value = Now()
        If Len(Trim(mdteOrigDate)) > 4 Then .Fields("f006").value = mdteOrigDate
        .Update
        .Close
   
    End With

PROC_EXIT:
    Exit Sub
ErrorHandler:
    Set Res = Nothing
    Call ShowError("frmTransfer", "insertToTable", err.Number, err.Description, "Y")
End Sub

Private Function GetFileName() As String
   
On Error GoTo vbErrorHandler
   
    If Len(CommonDialog1.InitDir) = 0 Then
        CommonDialog1.InitDir = App.Path
    End If
   
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "文件存入数据库"
   
    CommonDialog1.FileName = ""
   
    CommonDialog1.Filter = "All Files|" & PrjName
   
    CommonDialog1.Flags = cdlOFNExplorer + cdlOFNHideReadOnly
  
    CommonDialog1.ShowOpen
  
    GetFileName = CommonDialog1.FileName
  
    Exit Function
   
vbErrorHandler:
    If err.Number = 32755 Then
        GetFileName = ""
        Exit Function
    Else
        MsgBox err.Number & " " & err.Source & " " & err.Description, vbCritical, App.ProductName
    End If
End Function

Private Sub AddFile()

    On Error GoTo vbErrorHandler
   
    sFilename = GetFileName()
      
    Exit Sub

vbErrorHandler:
    MsgBox err.Number & " " & err.Description & " " & err.Source & "::ctlFileDetails_AddFile"
End Sub