Option Compare Database
 Option Explicit
 'IO constants
 Private Const CREATE_NEW As Long = 1
 Private Const FILE_BEGIN As Long = 0
 Private Const FILE_SHARE_READ As Long = &H1
 Private Const FILE_SHARE_WRITE As Long = &H2
 Private Const GENERIC_READ As Long = &H80000000
 Private Const GENERIC_WRITE As Long = &H40000000
 Private Const MOVEFILE_REPLACE_EXISTING As Long = &H1
 Private Const OPEN_EXISTING As Long = 3

 'DLL table Name constant
 Private Const K_STR_TABLE_NAME As String = "Libraries"

 'API File Functions
 Private Declare Function ReadFile Lib "kernel32" ( _
 ByVal hFile As Long, _
 lpBuffer As Any, _
 ByVal nNumberOfBytesToRead As Long, _
 lpNumberOfBytesRead As Long, _
 lpOverlapped As Any) As Long

 Private Declare Function WriteFile Lib "kernel32" ( _
 ByVal hFile As Long, _
 lpBuffer As Any, _
 ByVal nNumberOfBytesToWrite As Long, _
 lpNumberOfBytesWritten As Long, _
 lpOverlapped As Any) As Long

 Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
 ByVal lpFileName As String, _
 ByVal dwDesiredAccess As Long, _
 ByVal dwShareMode As Long, _
 lpSecurityAttributes As Any, _
 ByVal dwCreationDisposition As Long, _
 ByVal dwFlagsAndAttributes As Long, _
 ByVal hTemplateFile As Long) As Long

 Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
 ByVal lpFileName As String) As Long

 Private Declare Function GetFileSize Lib "kernel32" ( _
 ByVal hFile As Long, _
 lpFileSizeHigh As Long) As Long

 Private Declare Function SetFilePointer Lib "kernel32" ( _
 ByVal hFile As Long, _
 ByVal lDistanceToMove As Long, _
 lpDistanceToMoveHigh As Long, _
 ByVal dwMoveMethod As Long) As Long

 Private Declare Function CloseHandle Lib "kernel32" ( _
 ByVal hObject As Long) As Long

 Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" ( _
 ByVal lpszFile As String, _
 ByVal lpszTitle As String, _
 ByVal cbBuf As Integer) As Integer

 Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _
  ByVal lpLibFileName As String) As Long

 Private Declare Function FreeLibrary Lib "kernel32" ( _
   ByVal hLibModule As Long) As Long

 Private Declare Function GetProcAddress Lib "kernel32" ( _
  ByVal hModule As Long, _
  ByVal lpProcName As String) As Long

 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
  ByVal lpPrevWndFunc As Long, _
  ByVal hWnd As Long, _
  ByVal Msg As Any, _
  ByVal wParam As Any, _
  ByVal lParam As Any) As Long

 Private Function Unpack(Fname As String, flag As Integer)

'Unpack the data from the table and write to app folder then register library

 Dim hFile As Long, bBytes() As Byte
 Dim nSize As Long, ret As Long, buffer
 Dim rst As DAO.Recordset, DBPath As String
 DBPath = GetDBPath()
 Set rst = Application.CurrentDb().OpenRecordset(K_STR_TABLE_NAME)
 With rst
   Select Case flag
   Case Is = 0
   .Index = "RefName"
   Case 1
   .Index = "FileName"
   Case 2
   .Index = "sGUID"
   End Select
   .Seek "=", Fname
   If Not .NoMatch Then
      On Error Resume Next
      VBA.Kill DBPath & rst("FileName")
      buffer = rst("dll")
      ReDim bBytes(0 To UBound(buffer)) As Byte
      bBytes = buffer
      DeleteFile (DBPath & rst("FileName"))
      hFile = CreateFile(DBPath & rst("FileName"), GENERIC_WRITE, FILE_SHARE_READ Or _
      FILE_SHARE_WRITE, ByVal 0&, CREATE_NEW, 0, 0)
      WriteFile hFile, bBytes(0), UBound(bBytes) + 1, ret, ByVal 0&
      CloseHandle hFile
      ReReg rst("RefName"), DBPath & rst("FileName")
   Else
      VBA.MsgBox "Library entry not found"
   End If
 End With
 End Function

 Public Function EnumRefs()
 '*********************************************************
 'This is the main procedure to be called during startup.
 'If it is called by form class code then that code must
 'use fully qualified library methods and properties. And
 'must not use libraries other then Access, VBA or DAO
 '*********************************************************
 On Error GoTo ErrorTrap:
 Dim strList As String, ref As Access.Reference
 Dim buffer As String * 255
 For Each ref In Access.References
   'Dummy code to test as is broken is broken in '97
   strList = strList & ref.Name & "...... " & ref.FullPath & " " & vbCrLf
 Next ref

ErrorTrap:
 If VBA.Err.Number <> 0 Then
   If VBA.Err.Number = -2147319779 Then
      'Error in reference name available
      Unpack ref.GUID, 2
      Resume Next
   ElseIf VBA.Err.Number = 48 Then
      ' error in reference full path available
              GetFileTitle ref.FullPath, buffer, 255&
             Do While VBA.InStr(1, buffer, VBA.Chr$(0)) <> 0
                buffer = VBA.Left$(buffer, VBA.InStr(1, buffer, VBA.Chr$(0)) - 1)
             Loop
        Unpack VBA.Trim(buffer), 1
   Else
     VBA.MsgBox "A Fatal Reference error has occurred with " & ref.Name _
     & "- Contact Software Support"
   End If
 End If
 End Function

 Private Sub ReReg(ByVal RefName As String, ByVal FileName As String)
 On Error Resume Next
   Dim hLibrary As Long, lngAddr As Long
   hLibrary = LoadLibrary(FileName)
   If hLibrary <> 0 Then
      lngAddr = GetProcAddress(hLibrary, "DllRegisterServer")
      If lngAddr <> 0 Then
         CallWindowProc lngAddr, Application.hWndAccessApp, " ", ByVal 0&, ByVal 0&
      Else
         VBA.MsgBox FileName & _
	" Was loaded, but the DllRegisterServer entry point not found!"
      End If
      FreeLibrary hLibrary
   Else
      VBA.MsgBox "Failed to load library for registration"
   End If
 End Sub

 Function ViewRefs() As Boolean
 On Error GoTo ErrorTrap:
 Dim strList As String, ref As Access.Reference
 ViewRefs = True
 For Each ref In Access.References
   strList = strList & ref.Name & "...... " & ref.FullPath & " " & vbCrLf
 Next ref
 VBA.MsgBox strList

ErrorTrap:
 If VBA.Err.Number <> 0 Then
   ViewRefs = False
   Select Case VBA.Err.Number
      Case -2147319779
      strList = strList & ref.Name & "...... " & "**MISSING**" & " " & vbCrLf
      Resume Next
   End Select
   VBA.MsgBox VBA.Err.Number & " " & VBA.Err.Description
 End If
 End Function

 Private Function GetDBPath()
 Dim dbname As String, i As Integer
 dbname = Application.CurrentDb.Name
 For i = VBA.Len(dbname) To 1 Step -1
   If VBA.Mid$(dbname, i, 1) = "\" Then
      GetDBPath = VBA.Left$(dbname, i)
      Exit For
   End If
 Next
 End Function

 Private Sub PackRefs(strRefName As String, strFileName As String, _
 strFullPath As String, strGUID As String)
 'Read existing files and store in ole field.
 Dim hFile As Long, bData() As Byte
 Dim FileSize As Long, ret As Long, buffer
 Dim rst As DAO.Recordset
 On Error GoTo ErrorTrap
 Set rst = Application.CurrentDb().OpenRecordset(K_STR_TABLE_NAME)
rst.AddNew
 hFile = CreateFile(strFullPath, GENERIC_READ, _
 FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)

 FileSize = GetFileSize(hFile, 0)

 SetFilePointer hFile, 0, 0, FILE_BEGIN

 ReDim bData(0 To FileSize - 1) As Byte

 ReadFile hFile, bData(0), UBound(bData) + 1, ret, ByVal 0&

 If ret <> UBound(bData) + 1 Then
   MsgBox "Error Reading File"
   Exit Sub
 End If
 rst("dll") = bData
 rst("FileName") = strFileName
 rst("RefName") = strRefName
 rst("sGUID") = strGUID
 rst.update
ErrorTrap:
 CloseHandle hFile
 Set rst = Nothing
 If VBA.Err.Number <> 0 Then VBA.MsgBox VBA.Err.Number & " " & VBA.Err.Description

 End Sub

 Private Function CreateTable(TableName As String) As Boolean
 On Error GoTo ErrorTrap
Start:
 CreateTable = True
 Application.CurrentDb().Execute "CREATE TABLE " & TableName & " " _
 & "(ID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " _
 & "FileName TEXT NOT NULL CONSTRAINT FileName UNIQUE , " _
 & "RefName TEXT NOT NULL CONSTRAINT RefName UNIQUE , " _
 & "sGUID TEXT NOT NULL CONSTRAINT sGUID UNIQUE , " _
 & "dll LongBINARY);"
CTexit:
 Exit Function

ErrorTrap:  CreateTable = False
 If Err.Number = 3010 Then
   Beep
   If VBA.MsgBox("Table '" & TableName & "' exists - DELETE?", _
      VBA.vbDefaultButton2 + VBA.vbYesNo) = VBA.vbYes Then
      Application.DoCmd.DeleteObject acTable, TableName
      Resume Start
   End If
 Else
   MsgBox VBA.Err.Number & " " & VBA.Err.Description
 End If
 End Function

 Function StoreReferenceFiles()
 '*********************************************************
 'Run this procedure to 'load' the references in the table
 'This part may be remove prior to application distribution
 '*********************************************************
 On Error GoTo ErrorTrap
 If ViewRefs() Then
   Dim ref As Access.Reference, buffer As String * 255
   CreateTable K_STR_TABLE_NAME
   buffer = VBA.Space(255)
      For Each ref In Application.References
        If Not ref.BuiltIn And UCase(ref.Name) <> "DAO" Then
           GetFileTitle ref.FullPath, buffer, 255&
             Do While VBA.InStr(1, buffer, Chr$(0)) <> 0
                buffer = VBA.Left$(buffer, VBA.InStr(1, buffer, Chr$(0)) - 1)
             Loop
        PackRefs ref.Name, VBA.Trim(buffer), VBA.Trim(ref.FullPath), ref.GUID
      End If
      Next
 Else
   MsgBox "References are already broken!!! - Fix prior to importing data"
 End If
ErrorTrap:
 If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
 End Function