Main.bas

 Attribute VB_Name = "modMain"
Public Declare Sub InitCommonControls Lib "comctl32" ()

Option Explicit

Global dbs As Database
Global rs As Recordset

Private Const MyPEstr As String * 2 = "PE"
Private Const My4ZEROstr As String * 4 = "0000"
Private Const MyMZ As String * 2 = "MZ"
Private Const My1ZERO As String * 1 = "0"
Private Const MyH As String * 2 = "&H"

Private Declare Function GetFileVersionInfoSize _
   Lib "version.dll" Alias "GetFileVersionInfoSizeA" _
   (ByVal lptstrFilename As String, _
    lpdwHandle As Long) As Long
Private Declare Function GetFileVersionInfo _
   Lib "version.dll" Alias "GetFileVersionInfoA" _
   (ByVal lptstrFilename As String, _
    ByVal dwHandle As Long, _
    ByVal dwLen As Long, _
    lpData As Byte) As Long
Private Declare Function VerLanguageName _
   Lib "version.dll" Alias "VerLanguageNameA" _
   (ByVal wLang As Long, _
    ByVal szLang As String, _
    ByVal nSize As Long) As Long
Private Declare Function VerQueryValue _
   Lib "version.dll" Alias "VerQueryValueA" _
   (pBlock As Byte, _
    ByVal lpSubBlock As String, _
    lplpBuffer As Long, _
    puLen As Long) As Long
Private Declare Sub CopyMem _
   Lib "kernel32" Alias "RtlMoveMemory" _
   (pTo As Any, _
    uFrom As Any, _
    ByVal lSize As Long)

Private Const PE_FLAG_OFFSET           As Long = 93&
Private Const NE_DLL_OFFSET            As Long = 13&
Private Const NE_OS_OFFSET             As Long = 55&
Private Const DOS_FILE_OFFSET          As Long = 25&
Private Const MACHINE_TYPE_OFFSET      As Long = 5&
Private Const CHARACTERISTICS_OFFSET   As Long = 23&
Private Const IMAGE_FILE_SYSTEM        As Long = &H1000&
Private Const IMAGE_FILE_DLL           As Long = &H2000&
  
Private Type VS_FIXEDFILEINFO
   dwSignature                         As Long
   dwStrucVersion                      As Long
   dwFileVersionMS                     As Long
   dwFileVersionLS                     As Long
   dwProductVersionMS                  As Long
   dwProductVersionLS                  As Long
   dwFileFlagsMask                     As Long
   dwFileFlags                         As Long
   dwFileOS                            As Long
   dwFileType                          As Long
   dwFileSubtype                       As Long
   dwFileDateMS                        As Long
   dwFileDateLS                        As Long
End Type


Public Function FileInfo(ByVal xi_strFullFileName As String, _
                          ByRef xi_strBaseAddr As String) As Boolean
                         
   Dim p_blnRtn As Boolean
  

   p_blnRtn = modMain.GetBaseAddress(xi_strFullFileName, _
                                     xi_strBaseAddr)
  

   If p_blnRtn = True Then
      FileInfo = True
   Else
      FileInfo = False
   End If
  
End Function


Public Function GetBaseAddress(ByVal xi_strFullFileName As String, _
                               ByRef xo_strBaseAddr As String) As Boolean
                              
   Dim p_lngFileNum As Long
   Dim p_lngNewPE_Offset As Long
   Dim p_lngData As Long
   Dim p_lngBaseAddr As Long
   Dim p_curBaseAddr As Currency
   Dim p_strMZ_Header As String * 512
   Dim p_strMagic As String * 2
   Dim p_strMagicPE As String * 2
   Dim p_strImageBase As String * 2


   On Error Resume Next
   p_lngFileNum = FreeFile
   Open xi_strFullFileName For Binary Access Read Shared As p_lngFileNum
   Seek #p_lngFileNum, 1
   Get p_lngFileNum, , p_strMZ_Header
   Close p_lngFileNum
  

   If Mid$(p_strMZ_Header, 1, 2) <> MyMZ Then
      GetBaseAddress = False
      Exit Function
   End If
  

   CopyMem p_lngNewPE_Offset, ByVal Mid$(p_strMZ_Header, 61, 4), 4
  

   p_strMagic = Mid$(p_strMZ_Header, p_lngNewPE_Offset + 1, 2)
   p_strMagicPE = Mid$(p_strMZ_Header, p_lngNewPE_Offset + 3, 2)
   p_strImageBase = Mid$(p_strMZ_Header, p_lngNewPE_Offset + 55, 4)
  
   Select Case p_strMagic

      Case MyPEstr
         If p_strMagicPE <> vbNullChar & vbNullChar Then
            GetBaseAddress = False
            Exit Function
         Else
            GetBaseAddress = True
           

            CopyMem p_lngBaseAddr, ByVal p_strImageBase, 4
            xo_strBaseAddr = Hex$(p_lngBaseAddr) & My4ZEROstr
            If Len(xo_strBaseAddr) < 8 Then

               xo_strBaseAddr = String$((8 - Len(xo_strBaseAddr)), My1ZERO) & xo_strBaseAddr
            End If
            xo_strBaseAddr = MyH & xo_strBaseAddr
         End If
        
      Case Else
         GetBaseAddress = False
         Exit Function
   End Select

End Function


Private Function PointerToInteger(lpDWord As Long) As Integer
   Dim nRet As Integer

   If lpDWord Then
      CopyMem nRet, ByVal lpDWord, 2
      PointerToInteger = nRet
   End If

End Function

Private Function FormatVer(ByVal xi_lngVerNum As Long) As String
   Dim p_lngMajorVer                   As Long
   Dim p_lngMinorVer                   As Long
  
   p_lngMajorVer = CLng(xi_lngVerNum / &H10000)
   p_lngMinorVer = CLng(xi_lngVerNum And &HFFFF&)
  
   FormatVer = CStr(p_lngMajorVer) & "." & CStr(p_lngMinorVer)
  
End Function

Project Homepage: