Speichern mit Pfad und Name

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Dim strDateiname As String Dim strAlterPfad As String Dim strAntwort As String strAlterPfad=CurDir 'Aktuellen Pfad speichern ChDir "C:\Irgend\Ein\anderer\Ordner" 'Ordner wechseln strDateiname = ActiveCell.Value Application.Dialogs(xlDialogSaveAs).Show strDateiname ActiveWorkbook.Close ChDir strAlterPfad 'Ordner wieder zurück wechseln

Sub speiChern() Dim strDateiname As String strDateiname = ActiveCell.Value strDateiname = Application.GetSaveAsFilename(strDateiname) If strDateiname False Then ActiveWorkbook.Close SaveChanges:=True, Filename:=strDateiname End If End Sub

Option Explicit Sub Speichern_Unter() Dim ArrIndex, iIndex%, sExtension$, iFileFormat%, strFileName$ 'Dateinamen aus aktuller Zelle strFileName = ActiveCell.Value 'Order da? If Dir("D:\temp", vbDirectory) = "" Then MsgBox "Ordner exestiert nicht", vbCritical Exit Sub End If 'Ist Angabe eine Excel Datei? If Not LCase(strFileName) Like "*.xls*" Then MsgBox "kein Excel- Datei- Name in " & ActiveCell.Address(0, 0) & vbCr & strFileName, vbExclamation Exit Sub End If 'Wechselt das aktuelle Laufwerk. ChDrive "D:" 'Wechselt das aktuelle Verzeichnis oder den aktuellen Ordner ChDir "D:\temp" 'Datei Version ArrIndex = Array("xlsx", "xlsm", "xls") 'Extention der Datei sExtension$ = Right$(strFileName, Len(strFileName) - InStrRev(strFileName, ".")) 'Dialog aufrufen strFileName = Application.GetSaveAsFilename(strFileName, _ "Excel Arbeitsmappe (*." & sExtension & "),*." & sExtension, 1, "Speichern unter") 'wurde Dialog abgebrochen? If strFileName <> CStr(False) Then 'welche Excelversion If Val(Application.Version) > 11 Then 'Formatabfrage iFileFormat = File_Format(sExtension$) 'Datei im richtigen Format speichern ActiveWorkbook.SaveAs strFileName, iFileFormat Else 'Unter V12, speichern als Normale *.xls ActiveWorkbook.SaveAs strFileName End If 'Datei schleßen ohne speichern ActiveWorkbook.Close False End If 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

Hallo,
na einfach so:

Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
    ByRef pOpenfilename As OPENFILENAME) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Const OFN_SHAREWARN = 0

Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Public Sub prcSaveAs()
    Const strInitialFilename = "Testdatei"
    Dim udtOFN As OPENFILENAME
    Dim strFilename As String
    With udtOFN
        .lStructSize = Len(udtOFN)
        .hwndOwner = FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
        .lpstrFilter = "Excelfiles (*.xls)" & Chr$(0) & "*.xls" + Chr$(0)
        .lpstrFile = strInitialFilename & Space$(254 - Len(strInitialFilename))
        .nMaxFile = 255
        .lpstrFileTitle = Space$(254)
        .nMaxFileTitle = 255
        .lpstrInitialDir = "\\SERVER\DOMAIN\FOLDER\SUBFOLDER\" '.....
        .lpstrTitle = "Save As"
        .flags = OFN_SHAREWARN
    End With
    If GetSaveFileName(udtOFN) Then
        strFilename = Trim$(udtOFN.lpstrFile)
        MsgBox strFilename 'nur zum testen
        ' ThisWorkbook.SaveAs strFilename
    Else
        MsgBox "Datei wurde nicht gespeichert!", 48, "Hinweis"
    End If
End Sub

Gruß
Nepumuk

Option Explicit Sub Speichern_Unter() Dim ArrIndex, varIndex, sExtension$, iFileFormat%, strFileName$ 'Dateinamen aus aktuller Zelle strFileName = ActiveCell.Value '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

Sub speiChern() Dim strDateiname As Variant strDateiname = ActiveCell.Value strDateiname = Application.GetSaveAsFilename(strDateiname) If VarType(strDateiname) vbBoolean Then ActiveWorkbook.Close SaveChanges:=True, Filename:=strDateiname End If End Sub

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

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread