64 Bit

Alle anderen Themen ...

Moderator: ModerationP

Re: 64 Bit

Beitragvon volti » 22. Feb 2021, 16:55

Hallo Max,

das Programm führt bei mir zum Absturz bzw. Neustart von Excel.

Ich habe hier auch 1, 2mal die Callbackfunktion für BrowseFoFolder im Einsatz. Also grundsätzlich geht das.

Bei meiner CB habe ich den wParam auch als LongPtr definiert. Allerdings benutzen wir den innerhalb der CB ja beide nicht. Wahrscheinlich ist es noch ein anderer Grund.


Meine (funktionierende) Callback:
Code: Alles auswählen
Private Function BrowseCallbackProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long


viele Grüße
Karl-Heinz
volti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 155
Registriert: 22. Jul 2020, 13:55
Wohnort: Freigericht-Somborn

Re: 64 Bit

Beitragvon Nepumuk » 22. Feb 2021, 17:21

Hallo Karl-Heinz,

hast du es mit dem geänderten Callback getestet?
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon volti » 22. Feb 2021, 19:14

Ja,

habe ich. Meine Variante wParam as LongPtr und CB als Long und LongPtr.

Stürzt leider ab. Muss noch irgendwo anders sein.
Wenn ich Zeit habe, kann ich ja noch mal alles durchgucken, ob was auffällt. Falls Du nicht bis dahin eine andere Idee hast :-)

VG KH
volti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 155
Registriert: 22. Jul 2020, 13:55
Wohnort: Freigericht-Somborn

Re: 64 Bit

Beitragvon volti » 23. Feb 2021, 12:22

Hallo Max,

hier ist der Übeltäter:
Code: Alles auswählen
.Root = ILCreateFromPath(StrConv(opvstrOnlyInRoot, vbUnicode))

.Root erhält einen negativen Wert -24067280.
Wenn ich den rausnehme oder auf 0 setze, kommen keine Fehler mehr.


Ich habe das nicht. Wozu brauchst Du das, was soll damit bezweckt werden?


Bzgl.der Callbackfuntion können sowohl wParam als auch die CB selbst Long oder LongPtr sein.
Hat keinen Einfluss und läuft beides durch.

Gruß
Karl-Heinz
volti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 155
Registriert: 22. Jul 2020, 13:55
Wohnort: Freigericht-Somborn

Re: 64 Bit

Beitragvon Nepumuk » 23. Feb 2021, 13:19

Hallo Karl-Heinz,

damit kann ich angeben dass nur in einem bestimmten Ordner gesucht werden kann. Ohne das, steht der gesamte Rechner zur Auswahl.

Ich habe es jetzt nochmal umgebaut. Teste bitte mal:

Code: Alles auswählen
Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function SHBrowseForFolderA Lib "Shell32.dll" ( _
    lpBrowseInfo As InfoT) As LongPtr
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32.dll" ( _
    ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function SHGetPathFromIDListA Lib "Shell32.dll" ( _
    ByVal pidl As LongPtr, _
    ByVal pszPath As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function ILCreateFromPathW Lib "Shell32.dll" ( _
    ByVal pszPath As Long) As Long
Private Declare PtrSafe Sub ILFree Lib "Shell32.dll" ( _
    ByVal pidl As Long)
Private Declare PtrSafe Function SetWindowTextA Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpString As String) As Long

Private Type InfoT
    hwnd As LongPtr
    Root As Long
    DisplayName As String
    Title As String
    Flags As Long
    FName As LongPtr
    lParam As LongPtr
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX As Long = &H10
Private Const BIF_VALIDATE  As Long = &H20
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_SHAREABLE As Long = &H8000

Private Const SM_CXFULLSCREEN As Long = &H10
Private Const SM_CYFULLSCREEN As Long = &H11

Private Const BFFM_SETSELECTION As Long = &H466
Private Const BFFM_INITIALIZED As Long = &H1

Private Const MAX_PATH As Long = 260

Private lstrInitDir As String
Private lstrTitelText As String

Private Function GetFolder( _
    Optional ByVal opvstrMsg As String = "Bitte wählen Sie ein Verzeichnis", _
    Optional ByVal opvstrTitelText As String = "Ordner auswählen", _
    Optional ByVal opvlngFlag As Long = BIF_RETURNONLYFSDIRS, _
    Optional ByVal opvstrInitDir As String = "C:\", _
    Optional ByVal opvstrOnlyInRoot As String = vbNullString) As String

    Dim udtInfo As InfoT
    Dim lngptrIDList As LongPtr
    Dim strPath As String
    Dim lngRoot As Long

    lstrInitDir = opvstrInitDir
    lstrTitelText = opvstrTitelText

    lngRoot = ILCreateFromPathW(StrPtr(opvstrOnlyInRoot))

    With udtInfo

        .hwnd = Application.hwnd
        .Root = lngRoot
        .Title = opvstrMsg
        .Flags = opvlngFlag
        .FName = Callback(AddressOf BrowseCallback)

    End With

    lngptrIDList = SHBrowseForFolderA(udtInfo)

    Call ILFree(lngRoot)

    If lngptrIDList <> 0 Then

        strPath = Space$(MAX_PATH)
        Call SHGetPathFromIDListA(lngptrIDList, strPath)
        Call CoTaskMemFree(lngptrIDList)
        strPath = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)

    End If

    GetFolder = strPath

End Function

Private Function BrowseCallback( _
    ByVal pvlngptrHwnd As LongPtr, _
    ByVal pvlngMsg As Long, _
    ByVal pvlngwParam As Long, _
    ByVal pvlngptrlParam As LongPtr) As LongPtr

    If pvlngMsg = BFFM_INITIALIZED Then

        Call SendMessageA(pvlngptrHwnd, BFFM_SETSELECTION, _
            ByVal 1, ByVal lstrInitDir)
        Call SetWindowTextA(pvlngptrHwnd, lstrTitelText)
        Call CenterDialog(pvlngptrHwnd)

    End If

    BrowseCallback = 0

End Function

Private Function Callback( _
    ByVal pvlngptrParam As LongPtr) As LongPtr

    Callback = pvlngptrParam

End Function

Private Sub CenterDialog( _
    ByVal pvlngptrHwnd As LongPtr)

    Dim udtWinRect As RECT
    Dim lngScrWidth As Long, lngScrHeight As Long
    Dim lngDlgWidth As Long, lngDlgHeight As Long

    Call GetWindowRect(pvlngptrHwnd, udtWinRect)

    lngDlgWidth = udtWinRect.Right - udtWinRect.Left
    lngDlgHeight = udtWinRect.Bottom - udtWinRect.Top

    lngScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    lngScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)

    Call MoveWindow(pvlngptrHwnd, (lngScrWidth - lngDlgWidth) / 2, _
        (lngScrHeight - lngDlgHeight) / 2, lngDlgWidth, lngDlgHeight, 1)

End Sub

Public Sub Test()

    Const PRE_SELECT As String = "C:\Users\Public\"

    Dim strFolder As String

    If MakeSureDirectoryPathExists(PRE_SELECT) = 1 Then

        strFolder = GetFolder("Zielverzeichnis auswählen", _
            "Ordner auswählen", BIF_RETURNONLYFSDIRS, PRE_SELECT, "C:\Users\")

        If strFolder <> vbNullString Then MsgBox strFolder

    Else
        MsgBox "Kein Zugriff auf Ordner " & PRE_SELECT
    End If
End Sub
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon Nepumuk » 23. Feb 2021, 13:49

Nochwas,

die Deklaration von ILCreateFromPathW muss wahrscheinlich so aussehen:

Code: Alles auswählen
Private Declare PtrSafe Function ILCreateFromPathW Lib "Shell32.dll" ( _
    ByVal pszPath As LongPtr) As Long


Der Rückgabewert ist ein Pointer auf eine ITEMIDLIST Struktur und da weiß ich nicht ob das nicht auch ein LongPtr ist. Wenn ja, dann müsste .Root im "InfoT"-Type auch LongPtr sein.
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon volti » 23. Feb 2021, 19:12

Hallo Max,

so passt es. Musste ich an ein paar Stellen als Pointer machen. Werde mal meinen API-Viewer auch anpassen.
Ägän watt lörnt.

Code: Alles auswählen
Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function SHBrowseForFolderA Lib "Shell32.dll" ( _
    lpBrowseInfo As InfoT) As LongPtr
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32.dll" ( _
    ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function SHGetPathFromIDListA Lib "Shell32.dll" ( _
    ByVal pidl As LongPtr, _
    ByVal pszPath As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function ILCreateFromPathW Lib "Shell32.dll" ( _
    ByVal pszPath As LongPtr) As LongPtr
Private Declare PtrSafe Sub ILFree Lib "Shell32.dll" ( _
    ByVal pidl As LongPtr)
Private Declare PtrSafe Function SetWindowTextA Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpString As String) As Long

Private Type InfoT
    hwnd As LongPtr
    Root As LongPtr
    DisplayName As String
    Title As String
    Flags As Long
    FName As LongPtr
    lParam As LongPtr
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX As Long = &H10
Private Const BIF_VALIDATE  As Long = &H20
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_SHAREABLE As Long = &H8000

Private Const SM_CXFULLSCREEN As Long = &H10
Private Const SM_CYFULLSCREEN As Long = &H11

Private Const BFFM_SETSELECTION As Long = &H466
Private Const BFFM_INITIALIZED As Long = &H1

Private Const MAX_PATH As Long = 260

Private lstrInitDir As String
Private lstrTitelText As String

Private Function GetFolder( _
    Optional ByVal opvstrMsg As String = "Bitte wählen Sie ein Verzeichnis", _
    Optional ByVal opvstrTitelText As String = "Ordner auswählen", _
    Optional ByVal opvlngFlag As Long = BIF_RETURNONLYFSDIRS, _
    Optional ByVal opvstrInitDir As String = "C:\", _
    Optional ByVal opvstrOnlyInRoot As String = vbNullString) As String

    Dim udtInfo As InfoT
    Dim lngptrIDList As LongPtr
    Dim strPath As String
    Dim lngptrRoot As LongPtr

    lstrInitDir = opvstrInitDir
    lstrTitelText = opvstrTitelText

    lngptrRoot = ILCreateFromPathW(StrPtr(opvstrOnlyInRoot))

    With udtInfo

        .hwnd = Application.hwnd
        .Root = lngptrRoot
        .Title = opvstrMsg
        .Flags = opvlngFlag
        .FName = Callback(AddressOf BrowseCallback)

    End With

    lngptrIDList = SHBrowseForFolderA(udtInfo)

    Call ILFree(lngptrRoot)

    If lngptrIDList <> 0 Then

        strPath = Space$(MAX_PATH)
        Call SHGetPathFromIDListA(lngptrIDList, strPath)
        Call CoTaskMemFree(lngptrIDList)
        strPath = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)

    End If

    GetFolder = strPath

End Function

Private Function BrowseCallback( _
    ByVal pvlngptrHwnd As LongPtr, _
    ByVal pvlngMsg As Long, _
    ByVal pvlngwParam As Long, _
    ByVal pvlngptrlParam As LongPtr) As LongPtr

    If pvlngMsg = BFFM_INITIALIZED Then

        Call SendMessageA(pvlngptrHwnd, BFFM_SETSELECTION, _
            ByVal 1, ByVal lstrInitDir)
        Call SetWindowTextA(pvlngptrHwnd, lstrTitelText)
        Call CenterDialog(pvlngptrHwnd)

    End If

    BrowseCallback = 0

End Function

Private Function Callback( _
    ByVal pvlngptrParam As LongPtr) As LongPtr

    Callback = pvlngptrParam

End Function

Private Sub CenterDialog( _
    ByVal pvlngptrHwnd As LongPtr)

    Dim udtWinRect As RECT
    Dim lngScrWidth As Long, lngScrHeight As Long
    Dim lngDlgWidth As Long, lngDlgHeight As Long

    Call GetWindowRect(pvlngptrHwnd, udtWinRect)

    lngDlgWidth = udtWinRect.Right - udtWinRect.Left
    lngDlgHeight = udtWinRect.Bottom - udtWinRect.Top

    lngScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    lngScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)

    Call MoveWindow(pvlngptrHwnd, (lngScrWidth - lngDlgWidth) / 2, _
        (lngScrHeight - lngDlgHeight) / 2, lngDlgWidth, lngDlgHeight, 1)

End Sub

Public Sub Test()

    Const PRE_SELECT As String = "C:\Users\Public\"

    Dim strFolder As String

    If MakeSureDirectoryPathExists(PRE_SELECT) = 1 Then

        strFolder = GetFolder("Zielverzeichnis auswählen", _
            "Ordner auswählen", BIF_RETURNONLYFSDIRS, PRE_SELECT, "C:\Users\")

        If strFolder <> vbNullString Then MsgBox strFolder

    Else
        MsgBox "Kein Zugriff auf Ordner " & PRE_SELECT
    End If
End Sub


Gruß
Karl-Heinz
volti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 155
Registriert: 22. Jul 2020, 13:55
Wohnort: Freigericht-Somborn

Re: 64 Bit

Beitragvon Nepumuk » 23. Feb 2021, 19:25

Hallo Karl-Heinz,

SUPER. Danke dir für deine Geduld.

Mal schauen was mir als nächstes einfällt. :-)
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon Nepumuk » 24. Feb 2021, 16:21

Hallo Karl-Heinz,

magst du mal testen? Nicht wundern, die html-Dateien werden eingelesen und dann gelöscht. Funktioniert der Hilfe-Button des MsgBox?
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon volti » 24. Feb 2021, 17:50

Hallo Max,

setze LongPtr ein, dann geht es.

Code: Alles auswählen
Private Sub ShowHelp(ByVal pvlngptrHelpId As LongPtr)

    Dim lngptrStyle As LongPtr
    ...
    ...


PS: Mit der Indirekt-MsgBox hatte ich auch schon mal rumgedockert aber noch kein lohnendes Anwendungsfeld gefunden. :-)

viele Grüße
Karl-Heinz
volti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 155
Registriert: 22. Jul 2020, 13:55
Wohnort: Freigericht-Somborn

Re: 64 Bit

Beitragvon Nepumuk » 24. Feb 2021, 18:15

Hallo Karl-Heinz,

den Name geändert aber den Typ nicht eieieieiei!

Danke fürs testen und die Korrektur.
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon Nepumuk » 27. Feb 2021, 11:03

Hallo Karl-Heinz,

magst du mal testen? Das habe ich geschrieben um eine Webcam zu überwachen. War aber zu empfindlich da bei jedem zittern eines Blattes im Wind Alarm auslöst wurde.

Der überwachte Bereich ist oben links 100x100 Pixel groß.
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon PIVPQ » 27. Feb 2021, 13:33

Hallo Nepumuk

Wenn ich deine Datei öffne und auf Start drücke kommt der Hinweis "Läuft doch schon" bestätige ich das mit ok stürzt bei mir Excel ab.
Habe ich was falsch gemacht?
Den überwachten Bereich konnte ich leider nicht sehen.
Viele Grüße
PIVPQ
PIVPQ
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 133
Registriert: 19. Dez 2020, 15:11

Re: 64 Bit

Beitragvon Nepumuk » 27. Feb 2021, 14:15

Hallo,

kann ich nicht nachvollziehen. Ich habe Excel 32Bit und da funktioniert es einwandfrei,

Den überwachten Bereich kannst du nicht sehen, da war das Bild meiner Webcam.
De fontibus non est disputandum

Gruß
Nepumuk 8-)
Benutzeravatar
Nepumuk
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 15222
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon PIVPQ » 27. Feb 2021, 14:35

Hallo Nepumuk

Sorry wollte dein Code nicht schlecht machen, ich weiß das du immer gute Code lieferts.
Mein Test war 64 bit Excel.
Vielleicht habe ich auch was falsch gemacht, weiß aber nicht was. Hatte es mehrmals so probiert.
Wollte dir nur eingefallen tun um es zu testen.
Viele Grüße
PIVPQ
PIVPQ
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 133
Registriert: 19. Dez 2020, 15:11

VorherigeNächste

Zurück zu Offtopic (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 5 Gäste