Aufruf von Speichern unter

Speichern · 2005-10-03T12:28:34+00:00

Hallo, kann ich mit VBA programmieren, dass beim Start des Programmes automatisch das Dialogfeld von Datei - Speichern unter aufgerufen wird, dass ich also das Standarddialogfeld von Windows zum Speichern von Dateien unter einem anderen Namen und Verzeichnis bekomme? gruss volleybaerchen

Hi,
neuer Versuch:
Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
    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

Public Const OFN_SHAREWARN = 0
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREFALLTHROUGH = 2

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000

Private Const gcClassnameMSExcel = "XLMAIN"

Public Sub prcSaveAs()
    Const strInitialFilename = "Testdatei.xls"
    Dim udtOFN As OPENFILENAME
    Dim strFilename As String
    Do
        With udtOFN
            .lStructSize = Len(udtOFN)
            .hwndOwner = FindWindow(gcClassnameMSExcel, Application.Caption)
            .lpstrFilter = "Excelfiles (*.xls)" & Chr$(0) & "*.xls" & Chr$(0)
            .lpstrFile = strInitialFilename & Space$(254 - Len(strInitialFilename))
            .nMaxFile = 255
            .lpstrFileTitle = Space$(254)
            .nMaxFileTitle = 255
            .lpstrInitialDir = "C:\"
            .lpstrTitle = "Save As"
            .flags = OFN_SHAREWARN
        End With
        If GetSaveFileName(udtOFN) Then
            strFilename = Trim$(udtOFN.lpstrFile)
            strFilename = Left$(strFilename, Len(strFilename) - 1)
            If Right$(strFilename, 4) <> ".xls" Then strFilename = strFilename & ".xls"
            If LCase$(strFilename) <> LCase$(ThisWorkbook.FullName) Then
                On Error Resume Next
                ThisWorkbook.SaveAs strFilename
                If Err.Number = 0 Then Exit Do
                On Error GoTo 0
            Else
                MsgBox "Die Datei darf nicht überschieben werden.", 48, "Hinweis"
            End If
        Else
            Exit Do
        End If
    Loop
End Sub

Gruß
Nepumuk

Hi,
diesen Button kann ich nicht deaktivieren, aber der User kann gezwungen werden zu speichern:
Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
    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

Public Const OFN_SHAREWARN = 0
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREFALLTHROUGH = 2

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000

Private Const gcClassnameMSExcel = "XLMAIN"

Public Sub prcSaveAs()
    Const strInitialFilename = "Testdatei.xls"
    Dim udtOFN As OPENFILENAME
    Dim strFilename As String
    Do
        With udtOFN
            .lStructSize = Len(udtOFN)
            .hwndOwner = FindWindow(gcClassnameMSExcel, Application.Caption)
            .lpstrFilter = "Excelfiles (*.xls)" & Chr$(0) & "*.xls" & Chr$(0)
            .lpstrFile = strInitialFilename & Space$(254 - Len(strInitialFilename))
            .nMaxFile = 255
            .lpstrFileTitle = Space$(254)
            .nMaxFileTitle = 255
            .lpstrInitialDir = "C:\"
            .lpstrTitle = "Save As"
            .flags = OFN_SHAREWARN
        End With
        If GetSaveFileName(udtOFN) Then
            strFilename = Trim$(udtOFN.lpstrFile)
            strFilename = Left$(strFilename, Len(strFilename) - 1)
            If Right$(strFilename, 4) <> ".xls" Then strFilename = strFilename & ".xls"
            If LCase$(strFilename) <> LCase$(ThisWorkbook.FullName) Then
                On Error Resume Next
                ThisWorkbook.SaveAs strFilename
                If Err.Number = 0 Then Exit Do
                On Error GoTo 0
            Else
                MsgBox "Die Datei darf nicht überschieben werden.", 48, "Hinweis"
            End If
        Else
            MsgBox "Sie müssen speichern.", 48, "Hinweis"
        End If
    Loop
End Sub

Gruß
Nepumuk

Forumthread: Aufruf von Speichern unter

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Aufruf von Speichern unter

Forumthread: Aufruf von Speichern unter

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread