AW: VBA Speichern Unter
09.10.2011 15:43:30
Tino
Hallo,
kannst mal diesen Code testen.
kommt als Code in DieseArbeitsmappe
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim strPfad$, strFileName$
Dim sFile As String
'Pfad Vorgabe
strPfad = "D:\Bilder\"
'Dateiname (hier aus A1 evtl. Tabelle anpassen)
strFileName = Sheets("Tabelle1").Range("A1")
sFile = Speichern_Unter(strFileName, strPfad)
If sFile <> "" Then
MsgBox "Datei wurde gespeichert unter" & vbCr & sFile, vbInformation
Else
MsgBox "Datei wurde nicht gespeichert unter neuen Namen/Pfad gespeichert", vbExclamation
End If
End Sub
kommt als Code in Modul
Option Explicit
'Function Dialog Speichern unter **********************************************************************
Function Speichern_Unter(Optional ByRef sFile_Name As String, Optional ByVal sPath As String) As String
Dim ArrFileFormat, varIndex, sExtension$, iFileFormat%
Dim SaveR
'Extension der Datei
sExtension$ = Right$(sFile_Name, Len(sFile_Name) - InStrRev(sFile_Name, "."))
ArrFileFormat = Array("xlsx", "xlsm", "xlsb", "xls") 'Datei Versionen
varIndex = Application.Match(sExtension, ArrFileFormat, 0) 'Index für Dialog und Angabe
'ist Angabe eine Excel Datei?
If IsError(varIndex) Then
MsgBox "kein Excel- Datei vbCr & sFile_Name, vbExclamation"
Exit Function
End If
'Ordner da?
If sPath = "" Then sPath = ThisWorkbook.Path
If sPath = "" Then sPath = Application.DefaultFilePath
If Dir(sPath, vbDirectory) = "" Then
MsgBox "Ordner exestiert nicht", vbCritical
Exit Function
End If
'Wechselt das aktuelle Laufwerk.
ChDrive Left$(sPath, 2)
'Wechselt das aktuelle Verzeichnis oder den aktuellen Ordner
ChDir sPath
'Dialog aufrufen
If Val(Application.Version) > 11 Then
sFile_Name = Application.GetSaveAsFilename(sFile_Name, _
"Excel Arbeitsmappe ohne VBA (*.xlsx),*.xlsx," & _
"Excel Arbeitsmappe mit Makros (*.xlsm),*.xlsm," & _
"Excel Binärarbeitsmappe (*.xlsb),*.xlsb," & _
"Excel 97-2003 Arbeitsmappe (*.xls),*.xls", varIndex, "Speichern unter")
ElseIf sExtension$ = "xls" Then
sFile_Name = Application.GetSaveAsFilename(sFile_Name, _
"Excel Arbeitsmappe (*.xls),*.xls", 1, "Speichern unter")
Else
MsgBox "Extension kann mit dieser Excel- Version nicht gespeichert werden!", vbCritical
Exit Function
End If
'Dialog abgebrochen!
If sFile_Name = CStr(False) Then Exit Function
'nochmal Abfragen fals im Dialog geändert
sExtension$ = Right$(sFile_Name, Len(sFile_Name) - InStrRev(sFile_Name, "."))
'Formatabfrage
iFileFormat = File_Format(sExtension$)
If iFileFormat = 0 Then
MsgBox "Auswahl ist kein Excel File!", vbCritical
Exit Function
End If
'welche Excelversion
On Error GoTo Error_Handler:
If Val(Application.Version) > 11 Then
'Datei im richtigen Format speichern
ActiveWorkbook.SaveAs sFile_Name, iFileFormat
ElseIf iFileFormat = 56 Then
'bis Version 11, speichern als *.xls
ActiveWorkbook.SaveAs sFile_Name
Else
MsgBox "Extension kann mit dieser Excel- Version nicht gespeichert werden!", vbCritical
Exit Function
End If
Error_Handler:
If Err.Number <> 0 Then
Speichern_Unter = sFile_Name
Else
MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, _
Err.HelpFile, _
Err.HelpContext
End If
End Function
'Funktion zum ermitteln des Dateiformats ab xl2007
Private Function File_Format(sExtension$)
Select Case LCase(sExtension$)
Case "xlsx": File_Format = 51
Case "xlsm": File_Format = 52
Case "xlsb": File_Format = 50
Case "xls": File_Format = 56
End Select
End Function
Gruß Tino