Verzeichnis aussuchen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Angela,
versuch es mal damit:

Option Explicit

Private Declare Function MoveWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    ByRef lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByRef wParam As Any, _
    ByRef lParam As Any) As Long

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

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

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

Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Private s_BrowseInitDir As String

Private Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hwnd = FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FuncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
        Call CenterDialog(hwnd)
    End If
    BrowseCallback = 0
End Function

Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function

Private Sub CenterDialog(hwnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hwnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Public Sub test3()
    Dim sName As String
    Dim sDatum As String
    Dim sFolder As String
    With ActiveSheet
        sName = Cells(7, 9)
        sDatum = Cells(9, 2)
        Range("A6:R56").Copy
        Workbooks.Add
        With ActiveSheet.Cells(1, 1)
            .PasteSpecial Paste:=xlPasteValues ' Werte
            .PasteSpecial Paste:=xlFormats ' Formate
            .PasteSpecial Paste:=xlPasteColumnWidths ' Spaltenbreite
            .Select
        End With
    End With
    sFolder = Trim$(fncGetFolder(, , "C:\"))
    If sFolder <> "" Then
        ActiveWorkbook.SaveAs sFolder & "\" & sName & "_" & sDatum & ".xls"
        ActiveWindow.Close
    End If
End Sub

Gruß
Nepumuk

Hallo Angela,
entschuldige, ich habe nicht daran gedacht, dass die Änderung einer Eigenschaft im Applicationobjekt, den Copymodus stört. So geht's:

Public Sub test3()
    Dim sName As String
    Dim sDatum As String
    Dim sFolder As String
    Dim lSheetsCount As Long
    lSheetsCount = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    With ActiveSheet
        sName = Cells(7, 9)
        sDatum = Cells(9, 2)
        Range("A6:R56").Copy
        Workbooks.Add
        With ActiveSheet.Cells(1, 1)
            .PasteSpecial Paste:=xlPasteValues ' Werte
            .PasteSpecial Paste:=xlFormats ' Formate
            .PasteSpecial Paste:=xlPasteColumnWidths ' Spaltenbreite
            .Select
        End With
    End With
    Application.SheetsInNewWorkbook = lSheetsCount
    sFolder = Trim$(fncGetFolder(, , "C:\"))
    If sFolder <> "" Then
        ActiveWorkbook.SaveAs sFolder & "\" & sName & "_" & sDatum & ".xls"
        ActiveWindow.Close
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread