Hallo hier das Makro:
23.08.2006 14:12:18
Walter
Hallo Emi,
hier das kompl.Makro, ich möchte ja nur beim Öffnen der Mappe die Meldung haben,
da das Speichern ins Laufwerk etwas dauert.
Private Sub Workbook_Open()
UFWarten.Show
Dim jdate
Dim Verzeichnis As String
Dim myFSO As Object, myDrv As Object, strFS As String
Dim zuhr
jdate = Format(Now, "dd.mm.yyyy hh:mm")
zuhr = Format(Now, "hh:mm")
Sheets("Nutzer").Select
'--------- Wer hatte Datei geöffnet --------------------------------------------
Dim n As Byte, zzeit, zei As Long, Satz As String
jdate = Format(Now, "dd.mm.yyyy")
zzeit = Format(Now, "hh:mm:ss ")
jdate = Format(Now, "dd.mm.yyyy hh:mm:ss ")
Satz = Application.UserName & " am: " & jdate & " um: " & zzeit & " Uhr"
If Cells(19, 2) = "" Then
If Cells(10, 2) = "" Then
Sheets("Nutzer").Cells(10, 2).Value = Satz
Else
zei = Cells(65536, 2).End(xlUp).Row
Sheets("Nutzer").Cells(zei + 1, 2).Value = Satz
End If
Else
If Cells(10, 3) = "" Then
Sheets("Nutzer").Cells(10, 3).Value = Satz
Else
zei = Cells(65536, 3).End(xlUp).Row
Sheets("Nutzer").Cells(zei + 1, 3).Value = Satz
End If
End If
Sheets("Eingang").Select
Range("A1").Select
'----------------------- Lauwerk Speicherung ändern... ----------------------------
Dim OrdNam As String
Dim DateiNam As String
DateiNam = ActiveWorkbook.Name
OrdNam = "C:\Werkstatt"
If Dir(OrdNam, 16) <> "" Then
Application.DisplayAlerts = False ' Sicherheitsabfrage unterdrücken
ActiveWorkbook.SaveAs Filename:=(OrdNam & "\" & DateiNam), FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
Else
MsgBox "Ordner '" & OrdNam & "' ist noch nicht vorhanden ! " & Chr(13) _
& vbCr & "Ordner wird jetzt neu erstellt !" & Chr(13), vbCritical
MkDir OrdNam ' hier wird Verzeichnis erstellt
Application.DisplayAlerts = False ' Sicherheitsabfrage unterdrücken
ActiveWorkbook.SaveAs Filename:=(OrdNam & "\" & DateiNam), FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
End If
'Unload UFWarten
Unload Me
End Sub
mfg Walter