keine Extension --> keine Excel- Datei ...
27.07.2010 22:35:32
Tino
Hallo,
ja ohne richtige Extension ist es auch keine Excel- Datei.
Sub Speichern_Unter()
Dim ArrIndex, varIndex, sExtension$, iFileFormat%, strFileName$
'Dateinamen aus aktuller Zelle
strFileName = ActiveCell.Value
If strFileName <> "" Then
If InStr(LCase(strFileName), ".xls") = 0 Then
strFileName = strFileName & ".xls"
End If
End If
'Extension der Datei
sExtension$ = Right$(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
ArrIndex = Array("xlsx", "xlsm", "xlsb", "xls") 'Datei Versionen
varIndex = Application.Match(sExtension, ArrIndex, 0) 'Index für Dialog und Angabe
'ist Angabe eine Excel Datei?
If Not IsNumeric(varIndex) Then
MsgBox "kein Excel- Datei- Name in " & ActiveCell.Address(0, 0) & vbCr & strFileName, vbExclamation
Exit Sub
End If
'Ordner da?
If Dir("D:\temp", vbDirectory) = "" Then
MsgBox "Ordner exestiert nicht", vbCritical
Exit Sub
End If
'Wechselt das aktuelle Laufwerk.
ChDrive "D:"
'Wechselt das aktuelle Verzeichnis oder den aktuellen Ordner
ChDir "D:\temp"
'Dialog aufrufen
If Val(Application.Version) > 11 Then
strFileName = Application.GetSaveAsFilename(strFileName, _
"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
strFileName = Application.GetSaveAsFilename(strFileName, _
"Excel Arbeitsmappe (*.xls),*.xls", 1, "Speichern unter")
Else
MsgBox "Extension kann mit dieser Excel- Version nicht gespeichert werden!", vbCritical
Exit Sub
End If
'nochmal Abfragen fals im Dialog geändert
sExtension$ = Right$(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
'Formatabfrage
iFileFormat = File_Format(sExtension$)
If iFileFormat = 0 Then
MsgBox "Auswahl ist kein Excel File!", vbCritical
Exit Sub
End If
'welche Excelversion
If Val(Application.Version) > 11 Then
'Datei im richtigen Format speichern
ActiveWorkbook.SaveAs strFileName, iFileFormat
ElseIf iFileFormat = 4 Then
'bis Version 11, speichern als *.xls
ActiveWorkbook.SaveAs strFileName
Else
MsgBox "Extension kann mit dieser Excel- Version nicht gespeichert werden!", vbCritical
Exit Sub
End If
'Datei schleßen ohne speichern
ActiveWorkbook.Close False
End Sub
'Funktion zum ermitteln des Dateiformats ab xl2007
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