mdl_comdown.bas

适合于中小型企业管理

Attribute VB_Name = "Mdl_common"
Public sArrVer() As String       '存储要下载的文件版本号列表，下标与主界面的lable下标一致
Public sLabelEnable() As String  '存储要下载该文件的用户是否有权限

Public Type FileInfoType
    Filename As String
    Version As String
    CreateTime As Date
    FileSize As Long
    Available As Boolean
End Type

Private Type VS_FIXEDFILEINFO
   dwSignature As Long
   dwStrucVersionl As Integer     '  e.g. = &h0000 = 0
   dwStrucVersionh As Integer     '  e.g. = &h0042 = .42
   dwFileVersionMSl As Integer    '  e.g. = &h0003 = 3
   dwFileVersionMSh As Integer    '  e.g. = &h0075 = .75
   dwFileVersionLSl As Integer    '  e.g. = &h0000 = 0
   dwFileVersionLSh As Integer    '  e.g. = &h0031 = .31
   dwProductVersionMSl As Integer '  e.g. = &h0003 = 3
   dwProductVersionMSh As Integer '  e.g. = &h0010 = .1
   dwProductVersionLSl As Integer '  e.g. = &h0000 = 0
   dwProductVersionLSh As Integer '  e.g. = &h0031 = .31
   dwFileFlagsMask As Long        '  = &h3F for version "0.42"
   dwFileFlags As Long            '  e.g. VFF_DEBUG Or VFF_PRERELEASE
   dwFileOS As Long               '  e.g. VOS_DOS_WINDOWS16
   dwFileType As Long             '  e.g. VFT_DRIVER
   dwFileSubtype As Long          '  e.g. VFT2_DRV_KEYBOARD
   dwFileDateMS As Long           '  e.g. 0
   dwFileDateLS As Long           '  e.g. 0
End Type
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Private Declare Sub MoveMemory Lib "KERNEL32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Long, ByVal length As Long)


Public Function getVersion(FullFileName As String) As String
    
    
    Dim StrucVer As String, ProdVer As String
    Dim rc As Long, lDummy As Long, sBuffer() As Byte
    Dim lBufferLen As Long, lVerPointer As Long, udtVerBuffer As VS_FIXEDFILEINFO
    Dim lVerbufferLen As Long

   '*** Get size ****
   lBufferLen = GetFileVersionInfoSize(FullFileName, lDummy)
   If lBufferLen < 1 Then
      getVersion = "-1"
      Exit Function
   End If

   '**** Store info to udtVerBuffer struct ****
   ReDim sBuffer(lBufferLen)
   rc = GetFileVersionInfo(FullFileName, 0&, lBufferLen, sBuffer(0))
   rc = VerQueryValue(sBuffer(0), "\", lVerPointer, lVerbufferLen)
   MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)
   getVersion = Format$(udtVerBuffer.dwFileVersionMSh, "0000") & "." & Format$(udtVerBuffer.dwFileVersionMSl, "0000") & "." & Format$(udtVerBuffer.dwFileVersionLSh, "0000") & "." & Format$(udtVerBuffer.dwFileVersionLSl, "0000")

End Function

Public Function fun_NewVerExist() As Boolean
'判断有无新版本,比较依据是版本号，并且初始化下载列表数组

Dim sSql As String
Dim sCurrentVer As String
Dim rs As New ADODB.Recordset
Dim fs, f
Dim i As Integer

    fun_NewVerExist = False
    On Error GoTo errD

    
    sSql = "SELECT isnull(SUM(FileSize),0),COUNT(1) FROM EboSys..Sys_Update"
    Set rs = Cw_DataEnvi.DataConnect.Execute(sSql)
    If Not rs.EOF Then
        If rs.Fields(0) = 0 Or rs.Fields(1) = 0 Then Exit Function
    End If
    
    sSql = "SELECT  ModelName, Version FROM EboSys..Sys_Update "
    If rs.State = 1 Then rs.Close
    Set rs = Cw_DataEnvi.DataConnect.Execute(sSql)
    
    While Not rs.EOF
        With MainFrm
            For i = 0 To .Label1.Count - 2
                If sArrVer(i) & "" <> rs.Fields("Version") & "" And UCase(Trim(.Label1(i).Tag)) = UCase(Trim(rs.Fields("ModelName"))) Then
                    sArrVer(i) = "1"
                End If
            Next i
        End With
        rs.MoveNext
    Wend
    
    '只要有一个为1，就说明需要下载新版本
    For i = 0 To MainFrm.Label1.Count - 2
        If sArrVer(i) = "1" Then
            fun_NewVerExist = True
        End If
    Next i
    
    Exit Function

    
errD:
    
End Function

Private Function fun_aLessThanb(a As String, b As String) As Boolean
Dim iPosA As Integer, iPosB As Integer, i As Integer
Dim ta As String, tb As String
    For i = 1 To 3
        iPosA = InStr(iPosA, a, ".", vbTextCompare)
        iPosB = InStr(iPosB, b, ".", vbTextCompare)
        ta = Format(Mid(a, 1, iPosA), "0000")
        tb = Format(Mid(b, 1, iPosB), "0000")
        If ta < tb Then fun_aLessThanb = True: Exit Function
    Next i
    
End Function

Public Function fun_getAttrib(sFullFileName As String) As FileInfoType
'获取文件的属性,参数为带路径的完整文件名
Dim tFIT As FileInfoType
Dim fs, f
    If Dir(sFullFileName) = "" Then Exit Function
    '获取文件创建日期
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(sFullFileName)
    tFIT.Filename = fs.GetFileName(sFullFileName)
    
    tFIT.CreateTime = f.DateCreated
    tFIT.FileSize = f.Size
    tFIT.Version = getVersion(sFullFileName)
    tFIT.Available = True
    fun_getAttrib = tFIT
    Set f = Nothing
End Function

Public Function GetBlobFromDB(rs As ADODB.Recordset, sFieldName As String) As Boolean
'从数据库读取数据，生成磁盘文件
  Dim ByteData() As Byte                                            '以二进制形式存储的字节数组
  Dim DestFileNum As Integer
  Dim DiskFile As String
  Dim FileLength As Long                                            '文件的长度

 'On Error Resume Next
  
   DiskFile = App.Path & "\" & rs.Fields("ModelName")
   DestFileNum = FreeFile
   FileLength = rs.Fields(sFieldName).ActualSize
  '打开数据库,导出文件
    Open DiskFile For Binary As DestFileNum
    ReDim ByteData(FileLength)
    ByteData() = rs.Fields(sFieldName).GetChunk(FileLength)
    Put DestFileNum, , ByteData()
    Close DestFileNum

  '改写进度条
  dTmp = Act_Download.PrgBarMain.Value

   Act_Download.PrgBarMain.Value = dTmp + Act_Download.PrgBarSub.Max
  
   GetBlobFromDB = True

End Function