Speicher-Makro aber als 1. Festplatte
03.04.2007 13:48:00
Kurt
ich habe das folgende Makro zum abspeichern, funktioniert.
Ich möchte jedoch als 1. eine Abfrage, der User sollte aus einer MSGBox oder ?
die Festplatten, die ER hat, aufgelistet bekommen und dann nur per Tastenk./Mausklick
aussuchen und das Speichern dann fortsetzen.
Habe das folgende Makro auch mit Unterstützung des Forums erhalten !
Private Sub CommandButton2_Click()
Dim Fs As Object, OrdNam As Variant, Ord As Byte, Pfad As String
Dim DateiNam As String
DateiNam = ActiveWorkbook.Name
On Error Resume Next
Pfad = OrdNam(0) & "\"
ChDrive Left(OrdNam(0), 1)
For Ord = 1 To UBound(OrdNam)
ChDir Pfad
Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs.folderexists(Pfad & OrdNam(Ord)) Then
MkDir OrdNam(Ord)
MsgBox "Der Ordner " & vbLf & vbLf & Pfad & OrdNam(Ord) & _
vbLf & vbLf & " wurde erstellt. "
Else
'' MsgBox "Der Ordner " & vbLf & vbLf & Pfad & _
'' OrdNam(Ord) & vbLf & vbLf & " existiert bereits. "
End If
Pfad = Pfad & OrdNam(Ord) & "\"
Next Ord
Set Fs = Nothing
' Application.DisplayAlerts = False 'Sicherheitsabfrage
ActiveWorkbook.SaveAs Filename:=Pfad & DateiNam, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
'---- ab hier ICON erstellt ------------------------------------------------
Dim wsh As Object
Dim tarLink As Object
Dim tarDeskTop As String
Set wsh = CreateObject("WScript.Shell")
tarDeskTop = wsh.SpecialFolders("Desktop")
Set tarLink = wsh.CreateShortcut(tarDeskTop & _
"\" & ThisWorkbook.Name & ".lnk")
With tarLink
.Targetpath = ThisWorkbook.FullName
.Save
End With
Set wsh = Nothing
End Sub
gruß Kurt