Deite speichern, Name vorgeben
23.08.2006 09:58:07
mtremer
ich habe hier für mich ein doch ziemlich grosses Problem.
Uwe (Nickname ingUR) hat mir dabei bereits sehr geholfen.
Nur leider habe ich es verpasst, ihm rechtzeitig zu Antworten; unsere Diskussion ist nun im Archiv :-(
Also: sorry an Uwe, und an alle die Bitte, mir zu helfen.
Folgendes Problem: Ich will eine Exceldatei speichern.
Dabei sind Dateiname und Speicherort durch bestimmte Zellen bzw. Kriterien vorgegeben. Diese beiden Probleme sind, wie ihr in dem nachfolgenden Code bestens behoben.
Jedoch ist die Ursprungsdatei schreibgeschützt, damit niemand die Datei überspeichern kann. Sobald Änderungen vorgenommen wurden, soll die Datei wie oben beschrieben gespeichert werden.
Allerdings soll der Schreibschutz nicht in die neue Datei übernommen werden, sodass an dieser jederzeit Änderungen vorgenommen werden können, ohne die Datei unter einem neuen Namen gespeichert werden muss.
Bitte helft mir, dieses Problem zu lösen. Ein weiteres Problem ist, dass ich kaum etwas von VBA verstehe. Daher bitte ich um eine "klare" Lösung...
Hier der Code, den Uwe erarbeitet hat (aber bei mir leider nicht funktioniert):
Option Explicit
Private Sub CommandButton1_Click()
Dim strFName As String, strRootPath As String, strPathName As String
strRootPath = "C:\TEMP\" ' TEMP ggf. durch gleichbleibenden Vorspann des Path
' ersetzen, unter denen sich die Unterverzeichnisse
' Verz1 und Verz2 befinden.
strFName = Worksheets("Tabelle1").Range("A1")
Select Case Left(UCase(strFName), 1)
Case "A": strPathName = "Verz1"
Case "B": strPathName = "Verz2"
Case "C": strPathName = "Verz3"
Case "D": strPathName = "Verz4"
Case "E": strPathName = "Verz5"
Case Else
MsgBox "Unzulässiger Kennbuchstabe, Datei wird nicht gesichert"
Exit Sub
End Select
strPathName = strRootPath + strPathName + "\"
Dim OldDir As String, OldDrive As String
Dim strReturnPathFName As String, strMsg As String, antw As VbMsgBoxStyle
Dim OldMode As Boolean, OldAttr As Integer
If Dir(strPathName, vbDirectory) = "" Then
strMsg = "Verzeichnis " & vbLf & _
strPathName & vbLf & _
"nicht vorhanden" & vbLf & _
"Soll es angelegt werden?"
antw = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Verzeichnisverwaltung")
If antw Then
MkDir (strPathName)
Else
Exit Sub
End If
End If
OldDir = CurDir
OldDrive = Left(OldDir, 1)
ChDrive (strPathName)
ChDir strPathName
strReturnPathFName = Application.GetSaveAsFilename(strFName, "Excel-File (*.xls), *.xls", , "MySave")
If Not (strReturnPathFName = "Falsch") Then
'merke Zustandeinstellung des Schreibschutzes der Datei strReturnPathName(!),
'sofern diese vorhanden ist, und der aktiven Arbeitsmappe
OldMode = ThisWorkbook.ReadOnly
On Error Resume Next
OldAttr = GetAttr(strReturnPathFName)
On Error Resume Next
SetAttr strReturnPathFName, GetAttr(strReturnPathFName) - vbReadOnly
ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite
On Error Resume Next
ActiveWorkbook.SaveAs (strReturnPathFName) 'strPathName & strFName)
If Err.Number <> 0 Then
strMsg = "Speichern von" & vbLf & _
strPathName & strFName & vbLf & _
"ist fehlgeschlagen oder wurde abgebrochen!"
MsgBox strMsg
Else
'Falle 1.1 und 2.1
'setzt Attr. der gespeicherten Datei und
'der Arbeitsmappe auf Stand vor dem Speichern zurück
'SetAttr strReturnPathFName, OldAttr
'ThisWorkbook.ChangeFileAccess Mode:=OldMode
'Fälle 2.1. und 2.2.
'setzt Attr. der gespeicherten Datei und
'der Arbeitsmappe auf [Schreibgeschützt]
On Error Resume Next
SetAttr strReturnPathFName, GetAttr(strReturnPathFName) + vbReadOnly
ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly
End If
End If
ChDrive (OldDrive)
ChDir (OldDir)
End Sub
Danke im Voraus und viele Grüße
Marco