Option Explicit
' zunächst die benötigten API-Deklarationen
' wegen der Nachrichten-Länge weggelassen  (siehe ShowOpenDlg, ShowSaveDlg)
 
Global lngOpenFileName As OPENFILENAME
 
'Öffnen-Dialog
Public Function ShowOpenDlg(F As Form, strFilter As String, _
  strTitel As String, strInitDir As String) As String
  ' Dim lngOpenFileName As OPENFILENAME
  Dim lngAnt As Long
 
  With lngOpenFileName
    .lStructSize = Len(lngOpenFileName)
    .hwndOwner = F.hWnd
    .hInstance = App.hInstance
    If Right$(strFilter, 1) <> "|" Then strFilter = strFilter + "|"
 
    For lngAnt = 1 To Len(strFilter)
      If Mid$(strFilter, lngAnt, 1) = "|" Then
       Mid$(strFilter, lngAnt, 1) = Chr$(0)
      End If
    Next
 
    .lpstrFilter = strFilter
    .lpstrFile = Space$(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space$(254)
    .nMaxFileTitle = 255
    .lpstrInitialDir = strInitDir
    .lpstrTitle = strTitel
    .flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
 
    ' Hier meine Änderung, die Do...Loop-Anweisung
    Do
      lngAnt = GetOpenFileName(lngOpenFileName)
      If (lngAnt) Then
        ' Hier wird der Dateiname an die Funktion übergeben (das könnte auch 
        ' später passieren,
        ' wenn es sich um die korrekte Dateiendung handelt)
        ShowOpenDlg = Trim$(.lpstrFile)
      Else
        ' Hier wird der Abbrechen-Button zugelassen
        Exit Do
      End If
    Loop Until (lngAnt) And Right$(Trim$(.lpstrFile), 4) = "pst" & Chr$(0)
  End With
End Function
 
'Speichern-Dialog
Public Function ShowSaveDlg(F As Form, strFilter As String, strTitel As String, _
  strInitDir As String) As String
 
  Dim lngAnt As Long
  Dim DatLen As Integer
  Dim sDateiendung As String
  Dim sExtension As Boolean
  Dim Dateiname As String
 
  With lngOpenFileName
    .lStructSize = Len(lngOpenFileName)
    .hwndOwner = F.hWnd
    .hInstance = App.hInstance
    If Right$(strFilter, 1) <> "|" Then strFilter = strFilter + "|"
 
    For lngAnt = 1 To Len(strFilter)
      If Mid$(strFilter, lngAnt, 1) = "|" Then Mid$(strFilter, lngAnt, 1) = _
        Chr$(0)
    Next
 
    If .lpstrFileTitle <> "" Then
      .lpstrFile = .lpstrFileTitle
    Else
      .lpstrFilter = strFilter
      .nMaxFile = 255
      .lpstrFileTitle = Space$(254)
      .nMaxFileTitle = 255
      .lpstrInitialDir = strInitDir
    End If
    .lpstrTitle = strTitel
    .flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT
 
    lngAnt = GetSaveFileName(lngOpenFileName)
    If (lngAnt) Then
      ' gewünschte Dateiendung
      sDateiendung = "pst"
      ' Prüfung des eingegebenen Dateinamens
      ' Dateiname wurde nur mit Punkt angegeben
      If InStr(1, .lpstrFileTitle, ".") > 0 Then
        ' Dateiname wurde mit korrekter Dateiendung angegeben
        If InStr(1, .lpstrFileTitle, "pst") Then
        Else
          DatLen = Len(Trim$(.lpstrFileTitle))
          ' Dateiname wurde mit unzulässiger Dateiendung angegeben
          If DatLen > InStr(1, .lpstrFileTitle, ".") + 1 Then
            ' Statt der MsgBox kann auch die Endung ab [InStr(1, 
            ' .lpstrFileTitle, ".")] abgeschnitten werden
            MsgBox "Unzulässige Dateiendung - Datei wird nicht gespeichert!"
          Else
            ' Dateiname hat bereits einen Punkt und braucht nur noch die 
            ' richtige Dateiendung
            Dateiname = Mid$(.lpstrFileTitle, 1, (DatLen - 1))
            .lpstrFileTitle = Dateiname & sDateiendung
          End If
        End If
      Else
        DatLen = Len(Trim$(.lpstrFileTitle))
        Dateiname = Mid$(.lpstrFileTitle, 1, (DatLen - 1))
        ' Dateiname hat noch keinen Punkt und braucht noch die richtige 
        ' Dateiendung
        .lpstrFileTitle = Dateiname & "." & sDateiendung
      End If
      ShowSaveDlg = .lpstrFileTitle
    End If
  End With
End Function