Адаптация базы Под Аксесс 64бит

Option Compare Database
Option Explicit
'Блокировка закрытия окна Access
 
#If VBA7 Then
'-----------------------------------------[Api функции 64 бит]
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, _
   ByVal bRevert As LongPtr) As LongPtr
Private Declare PtrSafe Function EnableMenuItem Lib "user32" (ByVal hMenu As _
   LongPtr, ByVal wIDEnableItem As LongPtr, ByVal wEnable As LongPtr) As LongPtr
Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As _
   LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
   
#Else
'-----------------------------------------[Api функции 32 бит]
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
   ByVal bRevert As Long) As Long
 
Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As _
   Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
 
Private Declare Function GetMenuItemInfo Lib "user32" Alias _
   "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As _
   Long, lpMenuItemInfo As MENUITEMINFO) As Long
 
#End If
 
#If VBA7 Then
Private Type MENUITEMINFO
#Else
Private Type MENUITEMINFO
#End If
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
#If VBA7 Then
    hSubMenu As LongPtr
    hbmpChecked As LongPtr
    hbmpUnchecked As LongPtr
    dwItemData As LongPtr
#Else
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
#End If
    dwTypeData As String
    cch As Long
#If VBA7 Then
    '#if(WINVER >= 0x0500)
    hbmpItem As LongPtr
    '#endif /* WINVER >= 0x0500 */
#End If
End Type
 
Const MF_GRAYED = &H1&
Const MF_BYCOMMAND = &H0&
Const SC_CLOSE = &HF060&
 
Public Property Get Enabled() As Boolean
    #If VBA7 Then
    Dim hwnd As LongPtr
    #Else
    Dim hwnd As Long
    #End If
    #If VBA7 Then
    Dim hMenu As Long
    #Else
    Dim hMenu As LongPtr
    #End If
 
    Dim result As Long
    Dim MI As MENUITEMINFO
    
    MI.cbSize = Len(MI)
    MI.dwTypeData = String(80, 0)
    MI.cch = Len(MI.dwTypeData)
    MI.fMask = MF_GRAYED
    MI.wID = SC_CLOSE
    hwnd = Application.hWndAccessApp
    hMenu = GetSystemMenu(hwnd, 0)
    result = GetMenuItemInfo(hMenu, MI.wID, 0, MI)
    Enabled = (MI.fState And MF_GRAYED) = 0
End Property
 
Public Property Let Enabled(boolClose As Boolean)
    #If VBA7 Then
    Dim hwnd As LongPtr
    #Else
    Dim hwnd As Long
    #End If
    Dim wFlags As Long
    #If VBA7 Then
    Dim hMenu As Long
    #Else
    Dim hMenu As LongPtr
    #End If
    Dim result As Long
    
    hwnd = Application.hWndAccessApp
    hMenu = GetSystemMenu(hwnd, 0)
    If Not boolClose Then
        wFlags = MF_BYCOMMAND Or MF_GRAYED
    Else
        wFlags = MF_BYCOMMAND And Not MF_GRAYED
    End If
    result = EnableMenuItem(hMenu, SC_CLOSE, wFlags)
End Property

Option Compare Database
 
' класс вызова диалога открытия и сохранения файла "clsOpenDialog"
Private Type OpenFileName
lpStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private mstrStartDir As String
Private mstrFilter As String
Private mstrTitle As String
Private mstrFileExt As String
Private mstrPath As String
Private mstrFileName As String
Private mstrFullName As String
 
#If VBA7 Then
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
#Else
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (pOpenFileName As OpenFileName) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (pOpenFileName As OpenFileName) As Long
#End If
    
    
Private Sub Initialize()
   mstrStartDir = "c:"
   mstrFilter = "Все файлы;*.*"
   mstrTitle = "Открытие файла"
   mstrFileExt = ""
   mstrPath = ""
   mstrFileName = ""
    
End Sub
 
Public Function OpenDialogFileName(Optional lngHwin As Long = 0) As String
    Dim ofs As OpenFileName
    Dim Res As Long
    Dim s As String
    Dim SS As String
    Dim i As Byte
   ofs.lpstrInitialDir = mstrStartDir ' Здесь твой каталог по умолчанию
   ofs.lpStructSize = 76
   ofs.nMaxFile = 1024
   ofs.nMaxFileTitle = 256
   ofs.lpstrFile = String(1024, vbNullChar)
   ofs.lpstrFileTitle = String(1024, vbNullChar)
   ofs.hWndOwner = lngHwin
   ofs.lpstrTitle = mstrTitle
   ofs.lpstrFilter = CreateFilterString(mstrFilter)
   Res = GetOpenFileName(ofs)
   s = ""
    For i = 1 To 255
      SS = Mid(ofs.lpstrFile, i, 1)
      If SS <> Chr(0) Then s = s & SS Else Exit For
    Next i
   OpenDialogFileName = s
   mstrFullName = s
   mstrFileExt = Mid(s, ofs.nFileExtension + 1, Len(s) - ofs.nFileExtension)
   mstrPath = Left(s, ofs.nFileOffset)
   mstrFileName = Mid(s, ofs.nFileOffset + 1, Len(s) - ofs.nFileOffset)
End Function
Public Function SaveDialogFileName(Optional lngHwin As Long = 0) As String
    Dim ofs As OpenFileName
    Dim Res As Long
    Dim s As String
    Dim SS As String
    Dim i As Byte
   ofs.lpstrInitialDir = mstrStartDir ' Здесь твой каталог по умолчанию
   ofs.lpStructSize = 76
   ofs.nMaxFile = 1024
   ofs.nMaxFileTitle = 256
   ofs.lpstrFile = String(1024, vbNullChar)
   ofs.lpstrFileTitle = String(1024, vbNullChar)
   ofs.hWndOwner = lngHwin
   ofs.lpstrTitle = mstrTitle
   ofs.lpstrFilter = CreateFilterString(mstrFilter)
   Res = GetSaveFileName(ofs)
   s = ""
    For i = 1 To 255
      SS = Mid(ofs.lpstrFile, i, 1)
      If SS <> Chr(0) Then s = s & SS Else Exit For
    Next i
   SaveDialogFileName = s
   mstrFullName = s
   mstrFileExt = Mid(s, ofs.nFileExtension + 1, Len(s) - ofs.nFileExtension)
   mstrPath = Left(s, ofs.nFileOffset)
   mstrFileName = Mid(s, ofs.nFileOffset + 1, Len(s) - ofs.nFileOffset)
End Function