Hallo
wir haben einen Access-Applikation die auf 32bit und 64bit Systemen laufen, bis auf eine Typenunverträglichkeit und ich weiß nicht, was ich da noch ändern könnte. Hier ist das Modul (die Fehlerzeile habe ich fett markiert, ziemlich weit unten).
Option Compare Database Option Explicit Private Const WM_COMMAND = &H111 Private Const WM_LBUTTONUP = &H202 Private Const MF_SEPARATOR = &H800& Private Const MF_ENABLED = &H0& Private Const MF_GRAYED = &H1& Private Const MF_CHECKED = &H8& Private Const MF_MENUBARBREAK = &H20& Private Const TPM_LEFTALIGN = &H0& '---API-Strukturen '---API-Deklarationen '--- 64bit Änderung #If Win64 Then Type tPoint lngX As LongPtr lngY As LongPtr End Type Type tRect lngLeft As LongPtr lngTop As LongPtr lngRight As LongPtr lngBottom As LongPtr End Type Type tMsg hWnd As LongPtr lngMessage As LongPtr lngWParam As LongPtr lngLParam As LongPtr lngTime As LongPtr tP As tPoint End Type Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu _ As LongPtr, ByVal wFlags As LongPtr, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As _ String) As LongPtr Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As LongPtr Declare PtrSafe Function TrackPopUpMenu Lib "user32" Alias "TrackPopupMenu" (ByVal _ hMenu As LongPtr, ByVal wFlags As LongPtr, ByVal X As LongPtr, ByVal Y As LongPtr, _ ByVal nReserved As LongPtr, ByVal hWnd As LongPtr, lprc As tRect) As LongPtr Declare PtrSafe Function getMessage Lib "user32" Alias "GetMessageA" (lpMsg As tMsg, _ ByVal hWnd As LongPtr, ByVal wMsgFilterMin As LongPtr, ByVal wMsgFilterMax As _ LongPtr) As LongPtr Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As tPoint) As LongPtr #Else Type tPoint lngX As Long lngY As Long End Type Type tRect lngLeft As Long lngTop As Long lngRight As Long lngBottom As Long End Type Type tMsg hWnd As Long lngMessage As Long lngWParam As Long lngLParam As Long lngTime As Long tP As tPoint End Type Declare Function CreatePopupMenu Lib "user32" () As Long Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu _ As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As _ String) As Long Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Declare Function TrackPopUpMenu Lib "user32" Alias "TrackPopupMenu" (ByVal _ hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nReserved As Long, ByVal hWnd As Long, lprc As tRect) As Long Declare Function getMessage Lib "user32" Alias "GetMessageA" (lpMsg As tMsg, _ ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As _ Long) As Long Declare Function GetCursorPos Lib "user32" (lpPoint As tPoint) As Long #End If Function DoPopup(strEntries As String, Optional bolOnForm As Boolean = _ True) As Integer If HANDLE_ERRORS Then On Error GoTo DoPopup_Error PushCallStack "DoPopup" #If Win64 Then Dim lngMenu As LongPtr, hWnd As LongPtr, strX As String #Else Dim lngMenu As Long, hWnd As Long, strX As String #End If Dim intCnt As Integer Dim tCurrPos As tPoint, tRect As tRect, tMsg As tMsg Dim varResult As Variant intCnt = 1 lngMenu = CreatePopupMenu() If Right$(strEntries, 1) <> "|" Then strEntries = strEntries + "|" While strEntries <> "" strX = Left$(strEntries, InStr(strEntries, "|") - 1) strEntries = Mid$(strEntries, InStr(strEntries, "|") + 1) If strX = "=" Then 'Separator... varResult = AppendMenu(lngMenu, MF_SEPARATOR, 0, "") ElseIf Left$(strX, 1) = ">" Then 'Neue Spalte... strX = Mid$(strX, 2) varResult = AppendMenu(lngMenu, MF_MENUBARBREAK, intCnt, strX) intCnt = intCnt + 1 ElseIf Left$(strX, 1) = "~" Then 'Deaktiviert... strX = Mid$(strX, 2) varResult = AppendMenu(lngMenu, MF_GRAYED, intCnt, strX) intCnt = intCnt + 1 ElseIf Left$(strX, 1) = "+" Then 'Mit Häkchen... strX = Mid$(strX, 2) varResult = AppendMenu(lngMenu, MF_ENABLED + MF_CHECKED, intCnt, _ strX) intCnt = intCnt + 1 Else 'Normaler Eintrag... varResult = AppendMenu(lngMenu, MF_ENABLED, intCnt, strX) intCnt = intCnt + 1 End If Wend GetCursorPos tCurrPos ' Aktuelle Cursorposition If bolOnForm Then hWnd = Screen.ActiveForm.hWnd 'Handle auf das Formular Else hWnd = Application.hWndAccessApp End If varResult = TrackPopUpMenu(lngMenu, TPM_LEFTALIGN, tCurrPos.lngX, _ tCurrPos.lngY, 0, hWnd, tRect) varResult = getMessage(tMsg, hWnd, WM_COMMAND, WM_LBUTTONUP) If tMsg.lngMessage = WM_COMMAND Then DoPopup = tMsg.lngWParam ' ------------------------------ Type-Fehler unverträglich bei bit64 Else DoPopup = 0 End If varResult = DestroyMenu(lngMenu) ErrorHandlerDoPopupExit: PopCallStack Exit Function DoPopup_Error: If Err.Number = 3146 Then OdbcErrHandler DBEngine.Errors(0), Err.description, "DoPopup", _"modPopup", True Else GlobalErrHandler Err.Number, Err.description, "DoPopup", "modPopup", _ True End If Resume ErrorHandlerDoPopupExit End Function
und hier ist der Aufruf
Private Sub aufrufPopup_Click() Dim strPop As String #If Win64 Then Dim lngRet As LongPtr #Else Dim lngRet As Long #End If strPop = "test 1|test 2|test 3|..." ' Starte das Menü lngRet = DoPopup(strPop) Select Case lngRet Case 1 [...] Case Else Exit Sub End Select
Hat jemand Lust, mal darüber zu schauen?
Lieben Dank im voraus.
Liebe Grüße, die Luzie!