Access-o-Mania

Guten Morgen,

in einem 32bit Access (Access 2016) rufe ich ein eignes Kontextmenue auf.
"NeuTermPopup Me![DatControl]"
Private Sub KaMo_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me![DatControl] = Me![DaMon].Value
Me![TimeControl] = Me![h].Value
If Button = 2 Then
NeuTermPopup Me![DatControl]
End If
End Sub

Das Kontextmenü wird geöffnet.

Sub NeuTermPopup(LabelDate As Date)
Dim oRs As ADODB.Recordset
Dim varData() As String
Dim lData() As Long
Dim lTyp() As Long
Dim Result As Long, lRs As Long, L As Long, lAdr As Long
Dim strPop As String
Dim TermID As String
Dim Kunde As String
Dim KalAGNR As String

    KalAGNR = Nz(Forms![frm_Kalender]![KalAGKDNR])

       If Nz([KalAGNR]) <> "" Then
        Kunde = DLookup("Name", "tab_ex_Kunden", "[AGKDNR]=Forms![frm_Kalender]![KalAGKDNR]")
       
        strPop = strPop & "neuen Termin für "
        strPop = strPop & " • " & Kunde & " • "
        strPop = strPop & "|" & "Agenturtermin (To Do) eintragen|" & "|" & "=|abbrechen"
       Else
         strPop = strPop & "sorry, ...es ist kein Kunde ausgewählt|" & "Agenturtermin (To Do) eintragen|" & "|" & "=|abbrechen"
       
        End If
           
    Result = DoPopup(strPop)
          If Nz([KalAGNR]) <> "" Then
     Select Case Result
            Case 1
                DoCmd.OpenForm "frm_Kalender_Termin_bearbeiten_neuen", , , , acFormEdit
            Case 2
                DoCmd.OpenForm "frm_Kalender_Termin_Agenturtermin_neuen", , , , acFormEdit
            Case 3
            Case Else
          Exit Sub
    End Select
    Else
     Select Case Result
            Case 1
            Case 2
              DoCmd.OpenForm "frm_Kalender_Termin_Agenturtermin_neuen", , , , acFormEdit
            Case Else
          Exit Sub
     End Select
   
          End If

Err_Res:
    On Error GoTo 0
    Exit Sub

TermPopup_Error:
    If Err <> 9 Then
        MsgBox Err.Number & vbCrLf & Err.Description, , "Fehler"
    End If
    Resume Err_Res
End Sub

In dem 64bit Access (Access 365) führt das Kontextmenü aber leider die Aktionen z.B:

ZitatDoCmd.OpenForm "frm_Kalender_Termin_Agenturtermin_neuen", , , , acFormEdit

nicht aus. Es kommt keine Fehlermeldung.

Hat jemand eine Idee/Lösung?

Danke und
LG
jagger

Auch hier; der wirkliche relevante Teil deines Codes ist die Funktion DoPopup, die leider fehlt.

Schau vielleicht erstmal,  ob du es mit den Informationen aus Windows API declarations in VBA for 64-bit (https://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit) selbst lösen kannst. - Wenn nicht, poste die o.g. Funktion hier.

Hallo PhilS,

ZitatAuch hier; der wirkliche relevante Teil deines Codes ist die Funktion DoPopup, die leider fehlt.

:o

Function DoPopup(strEntries As String, Optional OnForm As Boolean = True) As Integer
Dim hMenu As Long, hwnd As Long, strX As String
Dim intCnt As Integer
Dim CurrPos As tPoint, aRect As tRect, aMsg As tMsg
Dim Result As Variant

    intCnt = 1
    hMenu = 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...
            Result = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
        ElseIf Left$(strX, 1) = ">" Then    'Neue Spalte...
            strX = Mid$(strX, 2)
            Result = AppendMenu(hMenu, MF_MENUBARBREAK, intCnt, strX)
            intCnt = intCnt + 1
        ElseIf Left$(strX, 1) = "~" Then    'Deaktiviert...
            strX = Mid$(strX, 2)
            Result = AppendMenu(hMenu, MF_GRAYED, intCnt, strX)
            intCnt = intCnt + 1
        ElseIf Left$(strX, 1) = "+" Then    'Mit Häkchen...
            strX = Mid$(strX, 2)
            Result = AppendMenu(hMenu, MF_ENABLED + MF_CHECKED, intCnt, strX)
            intCnt = intCnt + 1
        Else    'Normaler Eintrag...
            Result = AppendMenu(hMenu, MF_ENABLED, intCnt, strX)
            intCnt = intCnt + 1
        End If
    Wend

    GetCursorPos CurrPos          'Aktuelle Cursorposition?
    If OnForm Then
        hwnd = Screen.ActiveForm.hwnd    'Handle auf das Formular
    Else
        hwnd = Application.hWndAccessApp
    End If
    Result = TrackPopUpMenu(hMenu, TPM_LEFTALIGN, CurrPos.X, CurrPos.Y, 0, hwnd, aRect)
    Result = GetMessage(aMsg, hwnd, WM_COMMAND, WM_LBUTTONUP)

    If aMsg.Message = WM_COMMAND Then
        DoPopup = aMsg.wParam
    Else
        DoPopup = 0
    End If

    Result = DestroyMenu(hMenu)

End Function

ZitatSchau vielleicht erstmal,  ob du es mit den Informationen aus Windows API declarations in VBA for 64-bit selbst lösen kannst. - Wenn nicht, poste die o.g. Funktion hier.

Leider verstehe ich das nicht wirklich. :-(

LG
jagger

Hallo PhilS,

bin ich hier auf der richtigen Spur?
"Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long"
ändern in:
"Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr"

Wenn ich das ändere, läuft es auf dem 32bit Access.
Auf 64bit kann ich gerade nicht testen. Ich habe den Rechner nicht hier.

LG
jagger

Zitat von: jagger am März 25, 2019, 12:11:52
bin ich hier auf der richtigen Spur?
"Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long"
ändern in:
"Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr"

Das geht in die richtige Richtung.
Du hast aber noch eine ganze Reihe anderer PopMenü-Funktionen drin, deren Deklaration und/oder Implementierung nicht zu sehen ist. - In diesem Kontext ist mir aber bisher nicht so recht klar, wo die Ursache liegen könnte. Die üblichen Verdächtigen (UDFs) gibt es hier eigentlich nicht (keine problematischen).

Hallo PhiS,
hier sind die anderen PopMenü-Funktionen.

Option Compare Database
Option Explicit

Private Const WM_COMMAND = &H111
Private Const WM_LBUTTONUP = &H202

Private Const MF_INSERT = &H0&
Private Const MF_CHANGE = &H80&
Private Const MF_APPEND = &H100&
Private Const MF_DELETE = &H200&
Private Const MF_REMOVE = &H1000&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_SEPARATOR = &H800&
Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_UNCHECKED = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_STRING = &H0&
Private Const MF_BITMAP = &H4&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_POPUP = &H10&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_UNHILITE = &H0&
Private Const MF_HILITE = &H80&
Private Const MF_SYSMENU = &H2000&
Private Const MF_HELP = &H4000&
Private Const MF_MOUSESELECT = &H8000&

Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_CENTERALIGN = &H4&
Private Const TPM_RIGHTALIGN = &H8&

'---API-Strukturen
Type tPoint
        X As Long
        Y As Long
End Type

Type tRect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Type tMsg
    hwnd As Long
    Message As Long
    wParam As Long
    LParam As Long
    Time As Long
    P As tPoint
End Type


'---API-Deklarationen
Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long
Declare PtrSafe 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 PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Declare PtrSafe 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 PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As tMsg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As tPoint) As Long

Ich hoffe, es sind jetzt alle.
Würde es Sinn machen, wenn ich da bei allen aus
"As Long" ein As LongPtr" mache?
Wahrscheinlich müsste da noch eine "Weiche" rein. So in etwa wie Du (in einem dem Link) schreibst:

If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "USER32" _
        (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Boolean
       
    Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Else
    Private Declare Function ShowWindow Lib "USER32" _
        (ByVal hwnd As Long, ByVal nCmdShow As Long) As Boolean
       
    Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
End If



LG
jagger

Zitat von: jagger am März 25, 2019, 13:54:52Ich hoffe, es sind jetzt alle.
Würde es Sinn machen, wenn ich da bei allen aus
"As Long" ein As LongPtr" mache?
Wahrscheinlich müsste da noch eine "Weiche" rein. So in etwa wie Du (in einem dem Link) schreibst:

LongPtr ist für die Argumente gedacht, deren Größe sich von 32bit zu 64bit ändert. Für die reinen Funktionsdeklarationen würde es vermutlich sogar funktionieren, wenn du es überall änderst, aber ausdrücklich nicht für die Typdeklarationen.Dort würde ich auch die konkrete Problemursache vermuten.

Ich würde mal die Deklaration von tMsg ändern wie folgt:

Type tMsg
    hwnd As LongPtr
    Message As Long
    wParam As LongPtr
    LParam As LongPtr
    Time As Long
    P As tPoint
End Type


Bedingte Kompilierung (die "Weiche") ist nur erforderlich, wenn du noch Access 2007 und ältere Versionen unterstützen musst, andernfalls nicht.

@Jagger,
google einfach nach "Win32API_PtrSafe".
Microsoft bietet die Datei zum Downlaod.
Darin finden sich die Deklarationen der wichtigsten API Funktionen für 64Bit.
Die Datei win32api hat die Deklarationen für 32Bit.
Da bekommt man dann zumindest ein Gefühl dafür, wann man LongPtr verwenden soll.
Aber das Prinzip ist recht einfach.
Wann immer es sich um die Adresse einer Ressource handelt wird LongPtr verlangt.

LG Markus

Edit:
Ich habe früher auch mal ein Kontextmenü via API verwendet.
Bin aber wieder davon abgekommen, da es mühsam ist, sich selbst um die Bilder zu kümmern.
Da ich aber hauptsächlich mit Klassen arbeite,  und es da recht mühsam ist über Public Funktionen auf das Kontextmenü zu reagieren, verwende ich auch bei den Menüs eine Eventsteuerung.
Wirkt im ersten Moment kompliziert, ist aber recht praktisch.
Wenn ich mal Zeit habe werden ich eine kleine Muster DB erstellen.

Hallo PhilS,

nach den Änderungen, die Du vorgeschlagen hast, kommt
"Fehler beim Kompilieren, Typen unverträglich"
er springt dann in der
"Function DoPopup(strEntries As String, Optional OnForm As Boolean = True) As Integer"   ==> #2
zu

...
If aMsg.Message = WM_COMMAND Then
        DoPopup = aMsg.wParam
    Else
        DoPopup = 0
    End If
...

und markiert "wParam",

Jetzt bin ich echt ratlos.

LG
jagger

hallo
versuch DoPopup = cint(aMsg.wParam)

Hallo daolix,

genau das war der richtige Tipp!
Daaaaanke!

Danke auch an alle anderen Helfer und Tippgeber!

@Markus.

ZitatWenn ich mal Zeit habe werden ich eine kleine Muster DB erstellen.

das klingt gut, würde mich sehr interessieren.

LG
jagger

Hier das Beispiel.

https://www.access-o-mania.de/forum/index.php?action=downloads;sa=view;down=171