Probelem beim speichern mit 97 version

Sub speichern_ohne_makro() Dim i As Integer, y As Integer, totFiles As Integer, Qe As Integer Dim Sind As Long Dim wks As Worksheet Dim gefFile As String Dim Suchbegriff As String, Suchpfad As String Dim oldStatus As Variant 'Neue Funktion erst ab Office XP verwendbar 'bzw. auch unter 2000 wenn ein Verweis auf die Office 10 Library 'gesetzt werden kann. 'Öffnet einen Dialog indem der Pfad elegant wie im normalen 'Datei-Dialog gewählt werden kann. Dim Suchdialog As FileDialog Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker) If Application.Version < 10 Then Qe = MsgBox("Diese Datei bzw. dieser Suchdialog ist erst ab EXCEL XP möglich!", vbCritical + vbOKOnly, "Tut mir leid...") Exit Sub End If oldStatus = Application.DisplayStatusBar Application.DisplayStatusBar = True 'Hier gibt es ein Dialog der kurz zeigt was zutun ist' ModulAnweisung.AW0002 'Hier wird der neue FolderPickerDialog aufgerufen With Suchdialog .Title = "Bitte wählen Sie ein Verzeichnis aus" 'Environ(25) ermittelt den Aktuellen Userpfad .InitialFileName = Environ(25) & "\Eigene Dateien\" .ButtonName = "Auswahl übernehmen" .Show If .SelectedItems.Count = 0 Then MsgBox "Sie haben keine Auswahl getroffen", vbInformation Set Suchdialog = Nothing Exit Sub Else For Sind = 1 To .SelectedItems.Count Suchpfad = Suchpfad & .SelectedItems(Sind) Next Sind End If End With ActiveSheet.Copy Call DelModule Call DelUForms Call DelEvent ActiveWorkbook.SaveAs Suchpfad & "\" & Worksheets("Coordinates").Cells(1, 7) & "_" & Worksheets("Coordinates").Cells(1, 1) & ".xls", xlNormal End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

....für alle Versionen!
Hallo Wuntschi!
Probier mal das!
'BrowseForFolder mit Extra-Funktionen
'VB -Versionen: VB5 , VB6
'Betriebssystem: Win9x , WinNT, Win2000, WinME, WinXP
'Autor: Marco Wünschmann Homepage: ohne
'Datum: 23.08.2004

Option Explicit

' == Dialog-Einstellungen ================================

' String, der vor dem aktuell ausgewählen Verzeichnis angezeigt wird,
' falls der ShowCurrentPath-Paramter True ist.
Private Const DIALOG_CURRENT_SELECTION_TEXT As String = "Auswahl: "

' == API-Deklarationen ===================================

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

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

Private Type Size
    cx As Long
    cy As Long
End Type

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" ( _
    ByVal lPIDL As Long, _
    ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
    ByVal pv As Long)

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)

Private Declare Function ILCreateFromPath Lib "shell32" _
    Alias "#157" ( _
    ByVal sPath As String) As Long

Private Declare Function LocalAlloc Lib "kernel32" ( _
    ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long

Private Declare Function LocalFree Lib "kernel32" ( _
    ByVal hmem As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" ( _
    lpString1 As Any, _
    lpString2 As Any) As Long

Private Declare Function lstrlenA Lib "kernel32" ( _
    lpString As Any) As Long

Private Declare Function FindWindowEx Lib "user32.dll" _
    Alias "FindWindowExA" ( _
    ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Long

Private Declare Function GetWindowDC Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long

Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long

Private Declare Function GetTextExtentPoint Lib "gdi32.dll" _
    Alias "GetTextExtentPointA" ( _
    ByVal hDC As Long, _
    ByVal lpszString As String, _
    ByVal cbString As Long, _
    ByRef lpSize As Size) As Long

Private Declare Function PathCompactPath Lib "shlwapi.dll" _
    Alias "PathCompactPathA" ( _
    ByVal hDC As Long, _
    ByVal pszPath As String, _
    ByVal dx As Long) As Long

Private Const MAX_PATH = 260

Private Const WM_USER = &H400

Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Private Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_STATUSTEXT As Long = &H4

Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

' Zeigt den BrowseForFolder-Dialog an.
Public Function BrowseForFolder(DialogText As String, _
        DefaultPath As String, _
        OwnerhWnd As Long, _
        Optional ShowCurrentPath As Boolean = True, _
        Optional RootPath As Variant, _
        Optional NewDialogStyle As Boolean = False, _
        Optional IncludeFiles As Boolean = False) As String

    ' Parameter:
    ' o DialogText Dialogtext, der oben im Dialog angezeigt wird.
    ' o DefaultPath Standardmäßig ausgewähltes Verzeichnis.
    ' o OwnerhWnd hWnd des übergeordneten Fensters (in den meisten
    ' Fällen Me.hWnd).
    ' o ShowCurrentPath Legt fest, ob die aktuelle Verzeichnisauswahl
    ' angezeigt werden soll. Verfügbar ab
    ' Internet Explorer 4.0 (-> PathCompactPath).
    ' o RootPath Root-Verzeichnis. Wird es angegeben, werden nur die
    ' Ordner unterhalb dieses Verzeichnisses angezeigt.
    ' o NewDialogStyle Legt fest, ob der Dialog in der neuen Darstellung
    ' angezeigt werden soll (Dialog kann vergrößert/
    ' verkleinert werden, es ist eine Schaltfläche zum
    ' Anlegen eines neuen Ordners vorhanden, es können
    ' Dateioperationen wie löschen etc. ausgeführt
    ' werden, ...). Ist dieser Parameter True, hat der
    ' Parameter ShowCurrentPath keine Wirkung. Verfügbar
    ' unter WinME und Betriebsystemen ab Win2000.
    ' o IncludeFiles Legt fest, ob auch Dateien im Dialog angezeigt und
    ' ausgewählt werden können.
    ' Verfügbar ab Win98 und Internet Explorer 4.0 (bei
    ' frühreren Windowsversionen muss IE4 inkl. der
    ' Integrated Shell installiert sein).

    Dim biBrowseInfo As BROWSEINFO
    Dim lPIDL As Long
    Dim sBuffer As String
    Dim lBufferPointer As Long

    With biBrowseInfo
        ' Handle des übergeordneten Fensters
        .hOwner = OwnerhWnd

        ' PIDL des Rootordners zuweisen
        If Not IsMissing(RootPath) Then .pidlRoot = PathToPIDL(RootPath)

        ' Dialogtext zuweisen
        If ShowCurrentPath And DialogText = "$" Then DialogText = "" ' Wird intern nicht zugelassen
        .lpszTitle = DialogText

        ' Stringbuffer für aktuell selektierten Pfad zuweisen
        If ShowCurrentPath Then .pszDisplayName = sBuffer

        ' Dialogeinstellungen zuweisen
        .ulFlags = BIF_RETURNONLYFSDIRS + _
            IIf(ShowCurrentPath, BIF_STATUSTEXT, 0) + _
            IIf(NewDialogStyle, BIF_NEWDIALOGSTYLE, 0) + _
            IIf(IncludeFiles, BIF_BROWSEINCLUDEFILES, 0)

        ' Callbackfunktion-Adresse zuweisen
        .lpfnCallback = FARPROC(AddressOf CallbackString)

        ' PIDL des vorselektierten Ordnerpfades zuweisen (wird im
        ' lpData-Parameter an die Callback-Funktion weitergeleitet)
        .lParam = PathToPIDL(DefaultPath)
    End With

    ' BrowseForFolder-Dialog anzeigen
    lPIDL = SHBrowseForFolder(biBrowseInfo)

    If lPIDL Then
        ' Stringspeicher reservieren
        sBuffer = Space$(MAX_PATH)

        ' Selektierten Pfad aus der zurückgegebenen PIDL ermitteln
        SHGetPathFromIDList lPIDL, sBuffer

        ' Nullterminierungszeichen des Strings entfernen
        sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)

        ' Selektierten Pfad zurückgeben
        BrowseForFolder = sBuffer

        ' Reservierten Task-Speicher wieder freigeben
        Call CoTaskMemFree(lPIDL)
    End If

    ' Stringspeicher wieder freigeben
    If ShowCurrentPath Then Call LocalFree(lBufferPointer)
End Function

Private Function CallbackString(ByVal hwnd As Long, ByVal uMsg As Long, _
        ByVal lParam As Long, ByVal lpData As Long) As Long

    ' Callback-Funktion des BrowseForFolder-Dialogs. Wird bei
    ' eintretenden Ereignissen des Dialogs aufgerufen.

    Dim sBuffer As String
    Dim lStaticWnd As Long
    Dim lStaticDC As Long
    Dim sPath As String
    Dim rctStatic As RECT
    Dim szTextSize As Size

    ' Meldungen herausfiltern
    Select Case uMsg
        Case BFFM_INITIALIZED
            ' Dialog wurde initialisiert

            ' Standardmäßig markierten Pfad (dessen PIDL wurde in lpData
            ' übergeben) im Dialog selektieren
            Call SendMessage(hwnd, BFFM_SETSELECTIONA, False, ByVal lpData)
        Case BFFM_SELCHANGED
            ' Selektion hat sich geändert

            ' Stringspeicher reservieren
            sBuffer = Space$(MAX_PATH)

            ' Aktuell selektierten Pfad ermitteln und anzeigen, wenn möglich
            If SHGetPathFromIDList(lParam, sBuffer) Then
                ' Temporäre Zeichenfolge an das Anzeigelabel senden, um
                ' dessen Handle anhand dieser Zeichenfolge ermitteln zu können
                SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal "$"

                ' Handle und DeviceContext des Anzeigelabels ermitteln
                lStaticWnd = FindWindowEx(hwnd, ByVal 0&, ByVal "Static", ByVal "$")
                lStaticDC = GetWindowDC(lStaticWnd)

                ' Abmessungen des Anzeigelabels ermitteln
                GetWindowRect lStaticWnd, rctStatic

                ' Textabmessungen der Zeichenfolge "Auswahl: " im Anzeigelabel
                ' ermitteln
                GetTextExtentPoint lStaticDC, ByVal DIALOG_CURRENT_SELECTION_TEXT, _
                    ByVal Len(DIALOG_CURRENT_SELECTION_TEXT), szTextSize

                ' Anzuzeigenden Pfad auf die Abmessungen des Anzeigelabels
                ' kürzen; falls dies nicht möglich ist, gesamten Pfad anzeigen
                sPath = sBuffer
                If PathCompactPath(ByVal lStaticDC, sPath, ByVal (rctStatic.Right - _
                    rctStatic.Left - szTextSize.cx + 80)) = 0 Then sPath = sBuffer

                ' Nullterminierung entfernen
                sPath = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)

                ' Pfad im Dialog anzeigen
                Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0&, _
                    ByVal DIALOG_CURRENT_SELECTION_TEXT & sPath)
            Else
                ' Pfadanzeige leeren
                SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal ""
            End If
    End Select
End Function

Private Function FARPROC(FunctionPointer As Long) As Long
    ' Funktion wird benötigt, um Funktions-Adresse ermitteln
    ' zu können, dessen Adresse mit AddressOf übergeben und
    ' anschließend wieder zurückgegeben wird.

    FARPROC = FunctionPointer
End Function

' Gibt die lPIDL zum übergebenen Pfad zurück.
Private Function PathToPIDL(ByVal sPath As String) As Long
    Dim lRet As Long

    lRet = ILCreateFromPath(sPath)
    If lRet = 0 Then
        sPath = StrConv(sPath, VbStrConv.vbUnicode)
        lRet = ILCreateFromPath(sPath)
    End If

    PathToPIDL = lRet
End Function

Sub speichern_ohne_makro()
    Dim i As Integer, y As Integer, totFiles As Integer
    Dim Sind As Long
    Dim wks As Worksheet
    Dim gefFile As String
    Dim Suchbegriff As String, Suchpfad As String
    Dim oldStatus As Variant


    Suchpfad = BrowseForFolder("Bitte wählen Sie ein Verzeichnis aus", Environ(25) & "\Eigene Dateien\", 0, , , True, False)

    If Suchpfad = "" Then
        MsgBox "Sie haben keine Auswahl getroffen", vbInformation
        Exit Sub
    End If

    oldStatus = Application.DisplayStatusBar
    Application.DisplayStatusBar = True

    'Hier gibt es ein Dialog der kurz zeigt was zutun ist'

    ModulAnweisung.AW0002


    ActiveSheet.Copy
    Call DelModule
    Call DelUForms
    Call DelEvent
    ActiveWorkbook.SaveAs Suchpfad & "\" & Worksheets("Coordinates").Cells(1, 7) & "_" & Worksheets("Coordinates").Cells(1, 1) & ".xls", xlNormal
End Sub

Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Hallo k.rola!
Du hast mich erwischt;-))
So sollte es aber jetzt auch für xl97 funzen.
'BrowseForFolder mit Extra-Funktionen
'VB -Versionen: VB5 , VB6
'Betriebssystem: Win9x , WinNT, Win2000, WinME, WinXP
'Autor: Marco Wünschmann Homepage: ohne
'Datum: 23.08.2004

Option Explicit

' == Dialog-Einstellungen ================================

' String, der vor dem aktuell ausgewählen Verzeichnis angezeigt wird,
' falls der ShowCurrentPath-Paramter True ist.
Private Const DIALOG_CURRENT_SELECTION_TEXT As String = "Auswahl: "

' == API-Deklarationen ===================================

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

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

Private Type Size
    cx As Long
    cy As Long
End Type

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" ( _
    ByVal lPIDL As Long, _
    ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
    ByVal pv As Long)

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)

Private Declare Function ILCreateFromPath Lib "shell32" _
    Alias "#157" ( _
    ByVal sPath As String) As Long

Private Declare Function LocalAlloc Lib "kernel32" ( _
    ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long

Private Declare Function LocalFree Lib "kernel32" ( _
    ByVal hmem As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" ( _
    lpString1 As Any, _
    lpString2 As Any) As Long

Private Declare Function lstrlenA Lib "kernel32" ( _
    lpString As Any) As Long

Private Declare Function FindWindowEx Lib "user32.dll" _
    Alias "FindWindowExA" ( _
    ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Long

Private Declare Function GetWindowDC Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long

Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long

Private Declare Function GetTextExtentPoint Lib "gdi32.dll" _
    Alias "GetTextExtentPointA" ( _
    ByVal hDC As Long, _
    ByVal lpszString As String, _
    ByVal cbString As Long, _
    ByRef lpSize As Size) As Long

Private Declare Function PathCompactPath Lib "shlwapi.dll" _
    Alias "PathCompactPathA" ( _
    ByVal hDC As Long, _
    ByVal pszPath As String, _
    ByVal dx As Long) As Long

Private Const MAX_PATH = 260

Private Const WM_USER = &H400

Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Private Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_STATUSTEXT As Long = &H4

Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

' Zeigt den BrowseForFolder-Dialog an.
Public Function BrowseForFolder(DialogText As String, _
    DefaultPath As String, _
    OwnerhWnd As Long, _
    Optional ShowCurrentPath As Boolean = True, _
    Optional RootPath As Variant, _
    Optional NewDialogStyle As Boolean = False, _
    Optional IncludeFiles As Boolean = False) As String

' Parameter:
' o DialogText Dialogtext, der oben im Dialog angezeigt wird.
' o DefaultPath Standardmäßig ausgewähltes Verzeichnis.
' o OwnerhWnd hWnd des übergeordneten Fensters (in den meisten
' Fällen Me.hWnd).
' o ShowCurrentPath Legt fest, ob die aktuelle Verzeichnisauswahl
' angezeigt werden soll. Verfügbar ab
' Internet Explorer 4.0 (-> PathCompactPath).
' o RootPath Root-Verzeichnis. Wird es angegeben, werden nur die
' Ordner unterhalb dieses Verzeichnisses angezeigt.
' o NewDialogStyle Legt fest, ob der Dialog in der neuen Darstellung
' angezeigt werden soll (Dialog kann vergrößert/
' verkleinert werden, es ist eine Schaltfläche zum
' Anlegen eines neuen Ordners vorhanden, es können
' Dateioperationen wie löschen etc. ausgeführt
' werden, ...). Ist dieser Parameter True, hat der
' Parameter ShowCurrentPath keine Wirkung. Verfügbar
' unter WinME und Betriebsystemen ab Win2000.
' o IncludeFiles Legt fest, ob auch Dateien im Dialog angezeigt und
' ausgewählt werden können.
' Verfügbar ab Win98 und Internet Explorer 4.0 (bei
' frühreren Windowsversionen muss IE4 inkl. der
' Integrated Shell installiert sein).

Dim biBrowseInfo As BROWSEINFO
Dim lPIDL As Long
Dim sBuffer As String
Dim lBufferPointer As Long

With biBrowseInfo
    ' Handle des übergeordneten Fensters
    .hOwner = OwnerhWnd

    ' PIDL des Rootordners zuweisen
    If Not IsMissing(RootPath) Then .pidlRoot = PathToPIDL(RootPath)

    ' Dialogtext zuweisen
    If ShowCurrentPath And DialogText = "$" Then DialogText = "" ' Wird intern nicht zugelassen
    .lpszTitle = DialogText

    ' Stringbuffer für aktuell selektierten Pfad zuweisen
    If ShowCurrentPath Then .pszDisplayName = sBuffer

    ' Dialogeinstellungen zuweisen
    .ulFlags = BIF_RETURNONLYFSDIRS + _
        IIf(ShowCurrentPath, BIF_STATUSTEXT, 0) + _
        IIf(NewDialogStyle, BIF_NEWDIALOGSTYLE, 0) + _
        IIf(IncludeFiles, BIF_BROWSEINCLUDEFILES, 0)

    ' Callbackfunktion-Adresse zuweisen

    #If VBA6 Then ' ab VBA6/Office 2000
        .lpfnCallback = FARPROC(AddressOf CallbackString)
        #Else ' für VBA5/Office 97
        .lpfnCallback = FARPROC(GetFuncAdress("CallbackString"))
        #End If

        ' PIDL des vorselektierten Ordnerpfades zuweisen (wird im
        ' lpData-Parameter an die Callback-Funktion weitergeleitet)
        .lParam = PathToPIDL(DefaultPath)
    End With

    ' BrowseForFolder-Dialog anzeigen
    lPIDL = SHBrowseForFolder(biBrowseInfo)

    If lPIDL Then
        ' Stringspeicher reservieren
        sBuffer = Space$(MAX_PATH)

        ' Selektierten Pfad aus der zurückgegebenen PIDL ermitteln
        SHGetPathFromIDList lPIDL, sBuffer

        ' Nullterminierungszeichen des Strings entfernen
        sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)

        ' Selektierten Pfad zurückgeben
        BrowseForFolder = sBuffer

        ' Reservierten Task-Speicher wieder freigeben
        Call CoTaskMemFree(lPIDL)
    End If

    ' Stringspeicher wieder freigeben
    If ShowCurrentPath Then Call LocalFree(lBufferPointer)
End Function

Private Function CallbackString(ByVal hwnd As Long, ByVal uMsg As Long, _
        ByVal lParam As Long, ByVal lpData As Long) As Long

    ' Callback-Funktion des BrowseForFolder-Dialogs. Wird bei
    ' eintretenden Ereignissen des Dialogs aufgerufen.

    Dim sBuffer As String
    Dim lStaticWnd As Long
    Dim lStaticDC As Long
    Dim sPath As String
    Dim rctStatic As RECT
    Dim szTextSize As Size

    ' Meldungen herausfiltern
    Select Case uMsg
        Case BFFM_INITIALIZED
            ' Dialog wurde initialisiert

            ' Standardmäßig markierten Pfad (dessen PIDL wurde in lpData
            ' übergeben) im Dialog selektieren
            Call SendMessage(hwnd, BFFM_SETSELECTIONA, False, ByVal lpData)
        Case BFFM_SELCHANGED
            ' Selektion hat sich geändert

            ' Stringspeicher reservieren
            sBuffer = Space$(MAX_PATH)

            ' Aktuell selektierten Pfad ermitteln und anzeigen, wenn möglich
            If SHGetPathFromIDList(lParam, sBuffer) Then
                ' Temporäre Zeichenfolge an das Anzeigelabel senden, um
                ' dessen Handle anhand dieser Zeichenfolge ermitteln zu können
                SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal "$"

                ' Handle und DeviceContext des Anzeigelabels ermitteln
                lStaticWnd = FindWindowEx(hwnd, ByVal 0&, ByVal "Static", ByVal "$")
                lStaticDC = GetWindowDC(lStaticWnd)

                ' Abmessungen des Anzeigelabels ermitteln
                GetWindowRect lStaticWnd, rctStatic

                ' Textabmessungen der Zeichenfolge "Auswahl: " im Anzeigelabel
                ' ermitteln
                GetTextExtentPoint lStaticDC, ByVal DIALOG_CURRENT_SELECTION_TEXT, _
                    ByVal Len(DIALOG_CURRENT_SELECTION_TEXT), szTextSize

                ' Anzuzeigenden Pfad auf die Abmessungen des Anzeigelabels
                ' kürzen; falls dies nicht möglich ist, gesamten Pfad anzeigen
                sPath = sBuffer
                If PathCompactPath(ByVal lStaticDC, sPath, ByVal (rctStatic.Right - _
                    rctStatic.Left - szTextSize.cx + 80)) = 0 Then sPath = sBuffer

                ' Nullterminierung entfernen
                sPath = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)

                ' Pfad im Dialog anzeigen
                Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0&, _
                    ByVal DIALOG_CURRENT_SELECTION_TEXT & sPath)
            Else
                ' Pfadanzeige leeren
                SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal ""
            End If
    End Select
End Function

Private Function FARPROC(FunctionPointer As Long) As Long
    ' Funktion wird benötigt, um Funktions-Adresse ermitteln
    ' zu können, dessen Adresse mit AddressOf übergeben und
    ' anschließend wieder zurückgegeben wird.

    FARPROC = FunctionPointer
End Function

' Gibt die lPIDL zum übergebenen Pfad zurück.
Private Function PathToPIDL(ByVal sPath As String) As Long
    Dim lRet As Long

    lRet = ILCreateFromPath(sPath)
    If lRet = 0 Then
        sPath = StrConv(sPath, VbStrConv.vbUnicode)
        lRet = ILCreateFromPath(sPath)
    End If

    PathToPIDL = lRet
End Function

Sub speichern_ohne_makro()
    Dim i As Integer, y As Integer, totFiles As Integer
    Dim Sind As Long
    Dim wks As Worksheet
    Dim gefFile As String
    Dim Suchbegriff As String, Suchpfad As String
    Dim oldStatus As Variant


    Suchpfad = BrowseForFolder("Bitte wählen Sie ein Verzeichnis aus", Environ(25) & "\Eigene Dateien\", 0, , , True, False)

    If Suchpfad = "" Then
        MsgBox "Sie haben keine Auswahl getroffen", vbInformation
        Exit Sub
    End If

    oldStatus = Application.DisplayStatusBar
    Application.DisplayStatusBar = True

    'Hier gibt es ein Dialog der kurz zeigt was zutun ist'
    '
    ' ModulAnweisung.AW0002
    '
    '
    ' ActiveSheet.Copy
    ' Call DelModule
    ' Call DelUForms
    ' Call DelEvent
    ' ActiveWorkbook.SaveAs Suchpfad & "\" & Worksheets("Coordinates").Cells(1, 7) & "_" & Worksheets("Coordinates").Cells(1, 1) & ".xls", xlNormal
End Sub

Und in ein separates Modul!
Option Explicit

'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************
Private Declare Function GetVbaProjekt _
    Lib "vba332.dll" Alias "EbGetExecutingProj" _
    (hVBA As Long) As Long
Private Declare Function GetFunktionsnummerString _
    Lib "vba332.dll" Alias "TipGetFunctionId" _
    (ByVal hVBA As Long, ByVal strFuncNameUnicode _
    As String, _
    strFunktionsnummer As String) As Long
Private Declare Function GetFunktionsnummerLong _
    Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
    (ByVal hVBA As Long, ByVal strFunktionsnummer _
    As String, hlngFunction As Long) As Long

Public Function GetFuncAdress&(strFunktion$)
    Dim hVBA&, lngRück&, strFunktionsnummer$
    Dim hlngFunction&, strFuncNameUnicode$
    strFuncNameUnicode = StrConv(strFunktion, vbUnicode)
    GetVbaProjekt hVBA
    If hVBA <> 0 Then
        lngRück = GetFunktionsnummerString(hVBA, _
            strFuncNameUnicode, strFunktionsnummer)
        If lngRück = 0 Then
            lngRück = GetFunktionsnummerLong(hVBA, _
                strFunktionsnummer, hlngFunction)
            If lngRück = 0 Then GetFuncAdress = _
                hlngFunction
        End If
    End If
End Function

Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Beliebteste Forumthreads (12 Monate)

Probelem beim speichern mit 97 version

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Probelem beim speichern mit 97 version

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread