Option Compare Database
Option Explicit
Public gbl_fields_string As String
' ******** Code Start ********
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
' structure contains version information about a file. This
' information is language and code page independent.
Private Type VS_FIXEDFILEINFO
' Contains the value 0xFEEFO4BD (szKey)
dwSignature As Long
' Specifies the binary version number of this structure.
dwStrucVersion As Long
' most significant 32 bits of the file's binary version number.
dwFileVersionMS As Long
' least significant 32 bits of the file's binary version number.
dwFileVersionLS As Long
' most significant 32 bits of the binary version number of
' the product with which this file was distributed
dwProductVersionLS As Long
' least significant 32 bits of the binary version number of
' the product with which this file was distributed
dwFileFlagsMask As Long
' Contains a bitmask that specifies the valid bits in dwFileFlags.
dwProductVersionMS As Long
' Contains a bitmask that specifies the
' Boolean attributes of the file.
dwFileFlags As Long
' operating system for which this file was designed.
dwFileOS As Long
' general type of file.
dwFileType As Long
' function of the file.
dwFileSubtype As Long
' most significant 32 bits of the file's 64-bit
' binary creation date and time stamp.
dwFileDateMS As Long
' least significant 32 bits of the file's 64-bit binary
' creation date and time stamp.
dwFileDateLS As Long
End Type
' Returns size of version info in Bytes
Private Declare Function apiGetFileVersionInfoSize _
Lib "version.dll" Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, _
lpdwHandle As Long) _
As Long
' Read version info into buffer
' /* Length of buffer for info *
' /* Information from GetFileVersionSize *
' /* Filename of version stamped file *
Private Declare Function apiGetFileVersionInfo Lib _
"version.dll" Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) _
As Long
' returns selected version information from the specified
' version-information resource.
Private Declare Function apiVerQueryValue Lib _
"version.dll" Alias "VerQueryValueA" _
(pBlock As Any, _
ByVal lpSubBlock As String, _
lplpBuffer As Long, _
puLen As Long) _
As Long
Private Declare Sub sapiCopyMem _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Function fGetProductVersion(strExeFullPath As String) As String
'
' Returns the build number for Office exes
'
' Sample usage (Access 2000)
' ?fGetProductVersion(SysCmd(acSysCmdAccessDir) & "Frontpg.exe") '
' Product Pre-SR1 Post-SR1
' ---------------------------------------------------------
' MSAccess.exe 9.0.0.2719 9.0.0.3822
' WinWord.exe 9.0.0.2717 9.0.0.3822
' Excel.exe 9.0.0.2719 9.0.0.3822
' FrontPg.exe 4.0.2.2717 4.0.2.3821
' Outlook.exe 9.0.0.2416 9.0.0.2416
' PowerPnt.exe 9.0.0.2716 9.0.0.3821
' WinProj.exe 8.0.98.407 Don't have it, sorry.
'
On Error GoTo ErrHandler
Dim lngSize As Long
Dim lngRet As Long
Dim pBlock() As Byte
Dim lpfi As VS_FIXEDFILEINFO
Dim lppBlock As Long
' GetFileVersionInfo requires us to get the size
' of the file version information first, this info is in the format
' of VS_FIXEDFILEINFO struct
lngSize = apiGetFileVersionInfoSize( _
strExeFullPath, _
lngRet)
' If the OS can obtain version info, then proceed on
If lngSize Then
' the info in pBlock is always in Unicode format
ReDim pBlock(lngSize)
lngRet = apiGetFileVersionInfo(strExeFullPath, 0, _
lngSize, pBlock(0))
If Not lngRet = 0 Then
' the same pointer to pBlock can be passed to VerQueryValue
lngRet = apiVerQueryValue(pBlock(0), _
"\", lppBlock, lngSize)
' fill the VS_FIXEDFILEINFO struct with bytes from pBlock
' VerQueryValue fills lngSize with the length of the block.
Call sapiCopyMem(lpfi, ByVal lppBlock, lngSize)
' build the version info strings
With lpfi
fGetProductVersion = HIWord(.dwFileVersionMS) & "." & _
LOWord(.dwFileVersionMS) & "." & _
HIWord(.dwFileVersionLS) & "." & _
LOWord(.dwFileVersionLS)
End With
End If
End If
exithere:
Erase pBlock
Exit Function
ErrHandler:
Resume exithere
End Function
Private Function LOWord(dw As Long) As Integer
' retrieves the low-order word from the given 32-bit value.
If dw And &H8000& Then
LOWord = dw Or &HFFFF0000
Else
LOWord = dw And &HFFFF&
End If
End Function
Private Function HIWord(dw As Long) As Integer
' retrieves the high-order word from the given 32-bit value.
HIWord = (dw And &HFFFF0000) \ &H10000
End Function
' ******** Code End *********
Sub ListReferences()
Dim refCurr As Reference
Dim strg As String
strg = ""
For Each refCurr In Application.References
strg = strg & vbCrLf & refCurr.Name & ": " & refCurr.FullPath & _
" (" & fGetProductVersion(refCurr.FullPath) & ")"
Next
Call MsgBox(strg, vbInformation)
End Sub
Sub DetectRefs(tname As String)
Dim loRef As Access.Reference
Dim intCount As Integer
Dim intX As Integer
Dim blnBroke As Boolean
Dim strPath As String
Dim x As Long
Dim strg As String
Dim kinds(2) As String
Dim sqlstrg As String
kinds(0) = "TypeLib"
kinds(1) = "Project"
On Error Resume Next
'Count the number of references in the database
intCount = Access.References.Count
'Loop through each reference in the database
'and determine if the reference is broken.
For intX = intCount To 1 Step -1
Set loRef = Access.References(intX)
With loRef
sqlstrg = "INSERT INTO " & tname & " " & _
"(refname, refpath, refmajor, refminor, refbuiltin, reftype, refversion, refbroken) " & _
"SELECT" & _
Chr(34) & .Name & Chr(34) & " , " & _
Chr(34) & .FullPath & Chr(34) & " , " & _
Chr(34) & .Major & Chr(34) & " , " & _
Chr(34) & .Minor & Chr(34) & " , " & _
.BuiltIn & " , " & _
Chr(34) & kinds(.Kind) & Chr(34) & " , " & _
Chr(34) & fGetProductVersion(.FullPath) & Chr(34) & " , " & _
.IsBroken
On Error GoTo fail
' MsgBox (sqlstrg)
currentdb.Execute sqlstrg, dbFailOnError
GoTo refloop
fail:
Call MsgBox("Error inserting reference: " & vbCrLf & vbCrLf & _
"Error: " & Err & " Desc: " & Err.Description)
Resume Next
End With
refloop:
Next
Set loRef = Nothing
MsgBox ("References Table Updated")
End Sub
Sub Fix_References(showme As Boolean)
Dim loRef As Access.Reference
Dim intCount As Integer
Dim intX As Integer
Dim blnBroke As Boolean
Dim NoFile As Boolean
Dim strPath As String
Dim fixstrg As String
Dim okstrg As String
Dim fixcount As Long
On Error Resume Next
'Count the number of references in the database
intCount = Access.References.Count
'Loop through each reference in the database
'and determine if the reference is broken.
'If it is broken, remove the Reference and add it back.
fixcount = 0
fixstrg = ""
okstrg = ""
For intX = intCount To 1 Step -1
Set loRef = Access.References(intX)
With loRef
NoFile = Len(Dir(.FullPath)) = 0
blnBroke = .IsBroken
If blnBroke = True Or NoFile = True Or Err <> 0 Then
MsgBox (loRef.Name & " is broken, or the dll does not exist. " & vbCrLf & "Full Path: " & .FullPath)
strPath = .FullPath
On Error GoTo fail
Access.References.Remove loRef
Access.References.AddFromFile strPath
fixstrg = fixstrg & loRef.Name & vbCrLf
fixcount = fixcount + 1
Else
okstrg = okstrg & loRef.Name & vbCrLf
End If
GoTo refloop
fail:
Call MsgBox("Error rebuilding reference: " & vbCrLf & "Name: " & loRef.Name & vbCrLf & _
"Path: " & loRef.FullPath)
Resume Next
End With
refloop:
Next
Set loRef = Nothing
If fixcount > 0 Then
Call MsgBox(fixcount & " References rebuilt. " & vbCrLf & vbCrLf & _
fixstrg)
Else
Call MsgBox("All References OK. No changes required. " & vbCrLf & vbCrLf & okstrg)
End If
' Call a hidden SysCmd to automatically compile/save all modules.
' Call SysCmd(504, 16483)
End Sub
