64 Bit

Alle anderen Themen ...

Moderator: ModerationP

Re: 64 Bit

Beitragvon mumpel » 23. Jan 2021, 11:46

Ich habe 1920x1080. Aber vielleicht baust Du eine Möglichkeit ein, die Userform vergrößern oder verkleinern zu können, das ist in VBA aber nicht ganz so einfach. So wie es in Gerd's (alias Bamberg) "Tab2HTML" ist.
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8327
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: 64 Bit

Beitragvon Nepumuk » 23. Jan 2021, 19:29

Hallo Karl-Heinz,

noch was zum testen:
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: 15212
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon PIVPQ » 23. Jan 2021, 19:50

Hallo Nepumuk

Habe gerade deine letzte Datei mit Microsoft 365 64 bit geöffnet, bei mir kommt keine Fehlermeldung.
Viele Grüße
PIVPQ
PIVPQ
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 121
Registriert: 19. Dez 2020, 15:11

Re: 64 Bit

Beitragvon Nepumuk » 23. Jan 2021, 19:56

Hallo,

funktioniert das minimieren / maximieren des Userforms und kommt die entsprechende MsgBox?
De fontibus non est disputandum

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

Re: 64 Bit

Beitragvon mumpel » 23. Jan 2021, 19:57

Auf meinem Surface ist die Darstellung normal, ohne "Zeilenumbruch".
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8327
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: 64 Bit

Beitragvon volti » 23. Jan 2021, 20:02

Sieht gut aus Max,

wird Mini/Maxi/Restoriert mit MsgBox.
Keine Fehlermeldung.

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

Re: 64 Bit

Beitragvon PIVPQ » 23. Jan 2021, 20:03

Hallo Nepumuk
Ich sage ja funktioniert siehe Fotos.
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Viele Grüße
PIVPQ
PIVPQ
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 121
Registriert: 19. Dez 2020, 15:11

Re: 64 Bit

Beitragvon Nepumuk » 24. Jan 2021, 11:44

Hallo,

die nächste:
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: 15212
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon Nepumuk » 24. Jan 2021, 13:04

Hallo,

da ist noch ein Fehler drin

Code: Alles auswählen
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

    lstrInitDir = opvstrInitDir
    lstrTitelText = opvstrTitelText

    With udtInfo

        .hwnd = Application.hwnd
        .Root = ILCreateFromPath(StrConv(opvstrOnlyInRoot, vbUnicode))
        .Title = opvstrMsg
        .Flags = opvlngFlag
        .FName = Callback(AddressOf BrowseCallback)

    End With

    lngptrIDList = SHBrowseForFolderA(udtInfo)

    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
De fontibus non est disputandum

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

Re: 64 Bit

Beitragvon volti » 24. Jan 2021, 15:52

Hallo Max,

das klappt (bei mir ) leider auch nicht.

Es kommt bei dieser Zeile "lngptrIDList = SHBrowseForFolderA(udtInfo)" die Msgbox "Automatisierungsfehler Ausnamefehler eingetreten" und nach Wegklicken erfolgt immer wieder ein Neustart der Mappe:

Die Member der udtInfo sind alle mit gut aussehenden Werten ausgefüllt. Mehr kann ich nicht dazu sagen...

Code: Alles auswählen
 With udtInfo

        .hwnd = Application.hwnd
        .Root = ILCreateFromPath(StrConv(opvstrOnlyInRoot, vbUnicode))
        .Title = opvstrMsg
        .Flags = opvlngFlag
        .FName = Callback(AddressOf BrowseCallback)

    End With

    lngptrIDList = SHBrowseForFolderA(udtInfo)


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

Re: 64 Bit

Beitragvon Nepumuk » 24. Jan 2021, 16:07

Hallo Karl-Heinz,

schade, trotzdem Danke fürs testen.
De fontibus non est disputandum

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

Re: 64 Bit

Beitragvon Nepumuk » 25. Jan 2021, 13:55

Hallo Karl-Heinz,

kannst du den Kalendern nochmal testen? Ich habe noch eine falsche Variablendeklaration gefunden (Long an Stelle von LongPtr).
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: 15212
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

Re: 64 Bit

Beitragvon volti » 25. Jan 2021, 17:54

Hallo Max,

habe grad mal so alles durchgezappt. Es kommen keine Fehler mehr.
Drucken habe ich nur bis zum Punkt "Drucker ist offline" getestet. Der Drucker steht woanders und ist nicht immer an.

Gehe davon aus, dass jetzt alles passt.

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

Re: 64 Bit

Beitragvon Nepumuk » 25. Jan 2021, 18:12

Hallo Karl-Heinz,

vielen Dank fürs testen.
De fontibus non est disputandum

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

Re: 64 Bit

Beitragvon Nepumuk » 22. Feb 2021, 14:28

Hallo Karl-Heinz,

ich habe mir die BrowseCallback-Funktion in den Microsoft-Docs nomal genauer angesehen und zu folgenden Schluss gelangt:

Würdest du das bitte nochmal für mich testen?

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 ILCreateFromPath Lib "shell32.dll" Alias "#157" ( _
    ByVal sPath As String) 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

    lstrInitDir = opvstrInitDir
    lstrTitelText = opvstrTitelText

    With udtInfo

        .hwnd = Application.hwnd
        .Root = ILCreateFromPath(StrConv(opvstrOnlyInRoot, vbUnicode))
        .Title = opvstrMsg
        .Flags = opvlngFlag
        .FName = Callback(AddressOf BrowseCallback)

    End With

    lngptrIDList = SHBrowseForFolderA(udtInfo)

    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)
        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: 15212
Registriert: 10. Aug 2004, 08:40
Wohnort: Regensburg

VorherigeNächste

Zurück zu Offtopic (provisorisch)

Wer ist online?

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

cron