mdl_common.bas

适合于中小型企业管理

Attribute VB_Name = "Mdl_common"
Public Type FileInfoType
    Filename As String
    Version As String
    CreateTime As Date
    FileSize As Long
    Available As Boolean
End Type

Public ServerName As String

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)


Private 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
'      MsgBox "No Version Info available!"
      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_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 SaveBlob2DB(ByVal rs As ADODB.Recordset, ByVal sZipFileName As String, ByVal sFieldName As String) As Boolean
  Dim ByteData() As Byte                                      '存储文件的字节数组
  Dim FileLength As Long
  Dim LeftOver As Long
  
  On Error GoTo Line1

  SourceFile = FreeFile
  
  '以二进制形式打开文件
  Open sZipFileName For Binary Access Read As SourceFile
  
  '获得文件长度
  FileLength = LOF(SourceFile) - 1

  If FileLength = 0 Then                                       '字节数为0，退出
    Close SourceFile
    SaveBlob2DB = False
    Exit Function
  Else
    ReDim ByteData(FileLength)
    
    '读取文件到数组
    Get SourceFile, , ByteData()
    rs.Fields(sFieldName).AppendChunk ByteData()
    rs.Update
    '存储成功，返回true
    Close SourceFile
    SaveBlob2DB = True
  End If
  
  
Line1:

End Function