Makro mit Pfad auswählen Dialog
06.06.2007 19:05:53
Ryu_Hoshi
Ich möchte ein Makro ausführen (sub Test) und dabei den Speicherpfad vom User auswählen lassen. Ich habe hier was zusammengebastelt, aber es funzt nicht. Der Speicherpfad soll per Variable Wahl2 übergeben werden, aber diese hat dem Wert "Test" und nicht dem Pfad des Ordners welches zuvor bestimmt wurde. Wer kennt Rat?
Gruss+Danke
Private Declare Function GetActiveWindow Lib "user32" () As Long
Global Wahl2 As String
Public Sub OrdnerAuswaehlenAufruf()
Dim Modal As Boolean 'Die Deklaration ist hier zwingend
Hinweis = "Wählen Sie einen Ordner aus:" 'Erscheint im oberen Teil des Dialogs
Steuerung = 65 'Aussehen/Verhalten des Dialogs (1 = "Standard"; 65 = "new look")
'explizite Basisverzeichnisvorgabe...
'Basis = "C:\Dokumente und Einstellungen\eku\Eigene Dateien\WordFAQ"
'...oder alternativ implizit über so genannte *Special Folder* Konstanten
Basis = 0 'Arbeitsplatz (Siehe Liste der *Special Folders*)
Modal = True 'True oder False
Retcode = OrdnerAuswaehlen(Modal, Hinweis, Steuerung, Basis, Wahl2)
If Retcode = 0 Then MsgBox Wahl2 ', vbInformation
If Retcode = 4 Then MsgBox "Der Benutzer hat abgebrochen.", vbExclamation
If Retcode = 16 Then MsgBox "Interner Fehler!", vbExclamation
End Sub
Private Function OrdnerAuswaehlen(ByVal Modal As Boolean, _
ByVal Hinweis As String, _
ByVal Steuerung As Long, _
ByVal Basis As Variant, Wahl As String) As Long
Dim Owner As Long, oFolder As Object
If Modal Then Owner = GetActiveWindow
On Error Resume Next
Set oShell = CreateObject("Shell.Application")
rc = Err.Number: sysmsg = Err.Description: Err.Clear
If rc = 0 Then
Set oFolder = oShell.BrowseForFolder(Owner, Hinweis, Steuerung, Basis)
rc = Err.Number: sysmsg = Err.Description
End If
On Error GoTo 0
If oFolder Is Nothing Then
OrdnerAuswaehlen = 4
Else
Wahl = oFolder.Self.Path
If Right(Wahl, 1) = "\" Then Wahl = Left(Wahl, Len(Wahl) - 1) 'Normalisieren
End If
If Not rc = 0 Then
MsgBox "Laufzeitfehler: " & rc & vbLf & sysmsg, vbExclamation
OrdnerAuswaehlen = 16
End If
Set oFolder = Nothing
Set oShell = Nothing
End Function
Public Sub Test()
Dim wkb As Workbook, wkbNeu As Workbook
Dim i As Integer
Dim x1 As Integer
Set wkb = Workbooks("Delivery Performance IC.xls")
x1 = wkb.Worksheets.Count
OrdnerAuswaehlenAufruf
For i = 2 To x1
wkb.Worksheets("Important").Copy
Set wkbNeu = ActiveWorkbook
wkb.Worksheets(i).Copy After:=wkbNeu.Sheets("Important")
wkbNeu.SaveAs Filename:="" & Wahl2 & wkb.Worksheets(i).Name & ".xls"
wkbNeu.Close
Next
End Sub