ein Versuch ....
22.02.2006 14:37:33
RolfK
Hallo Martin,
ich habe die Prozedur etwas übersichtlicher strukturiert und soweit es geht mit Kommentaren versehen. Ich hoffe es hilft.
Private Sub CommandButton1_Click()
Dim s_pfad(20) 'Dimensionierung einer eindimensionalen
'Feldvariablen, kann max 20 Werte aufnehmen
SPfad = "D:\Save" 'Zuweisung von festem Laufwerk und Verzeichnis
OPfad = ActiveWorkbook.Path 'einlesen des Pfades (Laufwerk und ges. Verzeichniskette)
'der aktiven Arbeitsmappe
On Error Resume Next 'wenn Fehler im weiteren Ablauf auftreten,
'weiter mit der nächsten Anweisung
opfad2 = Right(OPfad, Len(OPfad) - 3) 'ermittelt die Zeichen einer Zeichenkette
'von rechts. Die Gesamtlänge wird um drei
'Zeichen gekürzt z.B. aus C:\Test\Fritz
'wird Test\Fritz
spfad2 = SPfad & "\" & opfad2 'Verketten der Variablen aus in dem Beispiel
'wird daraus D:\Save\Test\Fritz
n = 0 'ermittelt über den Rückschräger
For s = 1 To Len(spfad2) 'und die Länge des ges. Verzeichnispfades
If Mid(spfad2, s, 1) = "\" Then 'die einzelnen Teilverzeichnisse zu den Variablen
s_pfad(n) = Left(spfad2, s - 1) 's_pfad(0) = D:
Debug.Print n, s_pfad(n) 's_pfad(1) = D:\Save
n = n + 1 's_pfad(2) = D:\Save\Test
End If 's_pfad(3) = D:\Save\Test\Fritz
Next s 'und druckt diese im Direktbereich
s_pfad(n) = spfad2
oname = ActiveWorkbook.Name 'Zuordnen des Namens der aktiven Arbeitsmappe
On Error GoTo erstellen 'wenn Fehler, Sprung zu Sprungmarke "erstellen"
For t = 1 To n
ChDir (s_pfad(t)) 'wechseln zum Verzeichnis, wenn nicht vorhanden
Next t 'Sprung zu Sprungmarke
ActiveWorkbook.SaveCopyAs Filename:=spfad2 & "\" & oname 'Speichern Kopie im neuen Verzeichnis
ActiveWorkbook.Save 'speichern der Mappe im alten Verzeichnis
Exit Sub
erstellen: 'Sprungmarke "erstellen"
MkDir (s_pfad(t)) 'Einrichten Verzeichnis
Resume Next 'zurück zum Aufruf
End Sub
Sub sf_ein()
Set SM = CommandBars.FindControl(ID:=3) 'Zuweisen einer Befehlsschaltfläche,
'wahrscheinlich ist es "Speichern"
SM.OnAction = "Test" 'Zuordnen einer Prozedur, die aufgerufen wird
End Sub
'wenn die Schaltfläche geklickt wird
Sub sf_aus()
Set SM = CommandBars.FindControl(ID:=3)
SM.OnAction = "" 'Zurücksetzen der Zuordnung
End Sub
Eine Anmerkung noch dazu. Der Autor hat ohne 'Option Explicit' (siehe entsprechende Hilfe dazu) gearbeitet, daher besteht die Gefahr, dass Fehler möglicherweise nur schwer nachzuvollziehen sind.
mfg Rolf