Datei Speichern.....
02.02.2006 13:41:40
Joachim
ich habe eine Datei bei der ich verhindere, dass diese unter einem anderen Namen gespeichert werden kann. Also nicht speichern unter im Menü Datei.
Um EIN Tabellenbaltt zu speichern habe ich einen Code bekommen der bewirkt, dass das erste Tabellenblatt mit dem Namen Ergebnis und dem Zusatz des Inhaltes aus Feld E1 als neue Arbeitsmappe gespeichert werden kann.
Diese Mappe enthält eben nur dieses eine Blatt mit Werten jedoch ohne Formel und Makros.
Soweit so gut... funktioniert.
Nun habe ich noch 2 probleme:
1.) Wenn ich das Blatt als neue Mappe Speichern will schlägt mit Excel als Speicherort C:\Dokumente und Einstellungen\(benutzer)\Eigene Dateien vor.
Nun möchte ich verhindern, dass man immer wieder sich durch die verschiedenen Ordner hanglen muss um ggf. 7-8 Ebenen tiefer endlich an dem Ordner angekommen ist, in dem gespeichert weden soll.
Für das erste mal ist das auch OK.
Doch ich möchte, dass sich die Tabelle den letzten gewählten Ornder merkt und diesen als Vorgabe bei der nächsten Speicheraktion vorschlägt.
Das funktioniert auch so lange ich Excel nicht wieder schließe.
Wenn aber Excel geschlossen wurde und ich die Tabelle neu starte wird mir wieder
C:\Dokumente und Einstellungen\(benutzer)\Eigene Dateien vorgeschlagen.
Kann man es einricten, dass der letzte Speicherort als erstes Verzeichnis vorgeschlagen wird?
2.) Das Problem in diesem Code ist auch noch, dass nicht ALLE Makros gelöscht werden. Hierzu habe ich auch schon in einem anderen Thread einiges diskutiert jedoch ohne Erfolg.
-------------------------
Hier der Code in Tabelle 1 ,der sich um das Speichern kümmert....
Option Explicit
Option Private Module
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" ( _
ByVal pszPath As String) As Long
Private Sub Speichern_BeiKlick()
Dim objWb As Workbook, objMe As Worksheet
Dim objVBComp As Object
Dim objShape As Shape
Dim objName As Name
Dim strFileName As String, strPath As String
Dim rng As Range
Dim lngResult As Long
Set objMe = Sheets("ANALYSE")
strFileName = Range("E1")
If strFileName = "" Then
MsgBox "Bitte geben sie dieser Auswertung einen Namen!" & Space(20) & vbLf & _
"Unter diesem Namen wird die Auswertung gespeichert." & Space(20) & vbLf & _
" " & Space(20) & vbLf & _
"Der Vorgang wird abgebrochen!", 64, "Hinweis"
Application.Goto objMe.Range("E1")
Exit Sub
End If
strFileName = strFileName & ".xls"
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
objMe.Copy
Set objWb = ActiveWorkbook
With objWb
.Sheets(1).Name = "Auswertung"
.Sheets(1).Unprotect
On Error Resume Next
For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeFormulas, 23) 'Formel in Werte
rng = rng.Value
Next
For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeAllFormatConditions) 'Bedingte Formatierung entfernen
rng.FormatConditions(1).Delete
rng.FormatConditions(2).Delete
rng.FormatConditions(3).Delete
Next
.Sheets(1).Cells.SpecialCells(xlCellTypeAllValidation).Validation.Delete 'Gültigkeiten entfernen
Err.Clear
On Error GoTo ErrExit
.Sheets(1).Range("P1:IV65536").Delete
.Sheets(1).Range("A102:IV65536").Delete
.Sheets(1).Range("A1:O101").Interior.ColorIndex = xlNone
For Each objName In .Names 'Definierte Namen entfernen
objName.Delete
Next
On Error Resume Next
For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
With objVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Next
Err.Clear
For Each objShape In .Sheets(1).Shapes 'Schaltflächen/Shapes entfernen
objShape.Delete
Next
lngResult = Application.Dialogs(xlDialogSaveAs).Show(strPath & "Ergebnis " & strFileName)
If lngResult = 0 Then
.Close False
MsgBox "Vorgang abgebrochen!", 64, "Abbruch"
Else
strFileName = .FullName
objMe.Parent.Names("Pfad").Value = "=" & .Path & "\"
.Close True
End If
End With
If lngResult <> 0 Then
Set objWb = Workbooks.Open(strFileName)
With objWb
On Error Resume Next
For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
With objVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Next
Err.Clear
.Save
.Close True
End With
End If
ErrExit:
Set objWb = Nothing
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
--------------------
Gruß
Joachim