AW: Makro zum speichern (ohne Makros)
20.08.2005 10:32:14
Wuntschi
Dieses ist der Code den ich aus dem Forum habe dieser Funktionoiert aber bei Excel 97 nicht!
Sub speichern_ohne_makro()
Dim i As Integer, y As Integer, totFiles As Integer, Qe As Integer
Dim Sind As Long
Dim wks As Worksheet
Dim gefFile As String
Dim Suchbegriff As String, Suchpfad As String
Dim oldStatus As Variant
'Neue Funktion erst ab Office XP verwendbar
'bzw. auch unter 2000 wenn ein Verweis auf die Office 10 Library
'gesetzt werden kann.
'Öffnet einen Dialog indem der Pfad elegant wie im normalen
'Datei-Dialog gewählt werden kann.
Dim Suchdialog As FileDialog
Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker)
If Application.Version < 10 Then
Qe = MsgBox("Diese Datei bzw. dieser Suchdialog ist erst ab EXCEL XP möglich!", vbCritical + vbOKOnly, "Tut mir leid...")
Exit Sub
End If
oldStatus = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'Hier gibt es ein Dialog der kurz zeigt was zutun ist'
ModulAnweisung.AW0002
'Hier wird der neue FolderPickerDialog aufgerufen
With Suchdialog
.Title = "Bitte wählen Sie ein Verzeichnis aus"
'Environ(25) ermittelt den Aktuellen Userpfad
.InitialFileName = Environ(25) & "\Eigene Dateien\"
.ButtonName = "Auswahl übernehmen"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Sie haben keine Auswahl getroffen", vbInformation
Set Suchdialog = Nothing
Exit Sub
Else
For Sind = 1 To .SelectedItems.Count
Suchpfad = Suchpfad & .SelectedItems(Sind)
Next Sind
End If
End With
ActiveSheet.Copy
Call DelModule
Call DelUForms
Call DelEvent
ActiveWorkbook.SaveAs Suchpfad & "\" & Worksheets("Coordinates").Cells(1, 7) & "_" & Worksheets("Coordinates").Cells(1, 1) & ".xls", xlNormal
End Sub
Sub DelModule()
'Löscht Module:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
If .VBProject.VBComponents(n).Type = 1 Then
.VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
End If
Next
End With
End Sub
Sub DelUForms()
'Löscht Userforms:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
If .VBProject.VBComponents(n).Type = 3 Then
.VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
End If
Next
End With
End Sub
Sub DelEvent()
'Löscht Ereignisprozeduren:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
For i = 1 To .VBProject.VBComponents(n).CodeModule.CountOfLines
If .VBProject.VBComponents(n).Type <> 1 And .VBProject.VBComponents(n).Type <> 3 Then _
.VBProject.VBComponents(n).CodeModule.DeleteLines 1
Next
Next
End With
End Sub
Gruß
Wuntschi