[API]
GetSaveFileNameA
GetSaveFileNameW
OFNOTIFY
MessageBoxW
LocalAlloc
LocalFree
RtlMoveMemory
GetParent

[INCLUDE]
FormatMessage
SetWindowLong
LocalAllocFromString_Wide
LocalAllocFromString
GetAddressOf
OPENFILENAME
PeekS
PeekS_Wide
PokeS
GetFileAttributes
GetDlgItemText
SendMessage_String

[DEFINE]
Private Type GetSaveFilename_CustomParams
  LenFilters As Long
  ErrExistsTitle As Long
  ErrExistsText As Long
  ErrROTitle As Long
  ErrROText As Long
  RealResult As Long
  End Type
Private Const GetSaveFilename_CustomParamsLen As Long = 24&

[CODE]
Public Function GetSaveFileName(ByRef xType1 As OPENFILENAME) As String
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xType2 As OPENFILENAME_Real
  Dim xType3 As GetSaveFilename_CustomParams
  
  xLong1 = LocalAlloc(0&, GetSaveFilename_CustomParamsLen)
  If Not xLong1 = 0& Then
'    Stop
    With xType3
      If Not Len(xType1.ErrExistsTitle) = 0& Then
        .ErrExistsTitle = LocalAllocFromString_Wide(xType1.ErrExistsTitle)
        End If
      If Len(xType1.ErrExistsText) = 0& Then
        .ErrExistsText = LocalAllocFromString_Wide(FormatMessage(&H1200&, 0&, 80&))
        Else
        .ErrExistsText = LocalAllocFromString_Wide(xType1.ErrExistsText)
        End If
      If Not Len(xType1.ErrROTitle) = 0& Then
        .ErrROTitle = LocalAllocFromString_Wide(xType1.ErrROTitle)
        End If
      If Len(xType1.ErrROText) = 0& Then
        .ErrROText = LocalAllocFromString_Wide(FormatMessage(&H1200&, 0&, 82&))
        Else
        .ErrROText = LocalAllocFromString_Wide(xType1.ErrROText)
        End If
      End With
    
    Call OPENFILENAME_Patch(xType1, xType2)
    xType3.LenFilters = xType2.lCustData
    xType2.lCustData = xLong1
    Call RtlMoveMemory(ByVal xLong1, xType3, GetSaveFilename_CustomParamsLen)
    With xType2
      If Not Len(xType2.Ext_SaveName) = 0& Then
        xLong1 = InStrRev(xType2.Ext_SaveName, ".")
        If Not xLong1 = 0& Then
          xLong2 = GetSaveFileName_FindFilterIndex(xType2.lpstrFilter, xType3.LenFilters, Mid(xType2.Ext_SaveName, xLong1 + 1&))
          If Not xLong2 = 0& Then
            '.lpstrDefExt = LocalAllocFromString(Mid(xChar1, xLong1 + 1&))
            .nFilterIndex = xLong2
            xType2.Ext_SaveName = Left(xType2.Ext_SaveName, xLong1 - 1&)
            End If
          End If
        If Not .lpstrFile = 0& Then
          Call PokeS(.lpstrFile, xType2.Ext_SaveName, 256&)
          End If
        End If
  
      'FileMode = FileMode Or &H80020
      'If (FileMode And &H2&) = &H2& Then FileMode = FileMode - &H2&
      .lpfnHook = GetAddressOf(AddressOf GetSaveFileName_Hook)
      .Flags = &H80024
  
      End With
    If IsUnicode Then
      xLong1 = GetSaveFileNameW(xType2)
      Else
      xLong1 = GetSaveFileNameA(xType2)
      End If
    Call RtlMoveMemory(xType3, ByVal xType2.lCustData, GetSaveFilename_CustomParamsLen)
    If Not xLong1 = 0& Then
      If Not xType3.RealResult = 0& Then
        GetSaveFileName = PeekS(xType3.RealResult)
        End If
      End If
    xType1.FilterIndex = xType2.nFilterIndex
    Call OPENFILENAME_Free(xType2)
    With xType3
      If Not .ErrExistsTitle = 0& Then Call LocalFree(.ErrExistsTitle)
      If Not .ErrExistsText = 0& Then Call LocalFree(.ErrExistsText)
      If Not .ErrROTitle = 0& Then Call LocalFree(.ErrROTitle)
      If Not .ErrROText = 0& Then Call LocalFree(.ErrROText)
      If Not .RealResult = 0& Then Call LocalFree(.RealResult)
      End With
    Call LocalFree(xType2.lCustData)
    End If
  End Function

Private Function GetSaveFileName_GetFilterString(ByVal ptrFilter As Long, ByVal LenFilters As Long, ByRef xChar1 As String) As Boolean
  If Not (ptrFilter = 0& Or LenFilters = 0&) Then
    xChar1 = String(LenFilters, vbNullChar)
    If IsUnicode Then
      Call RtlMoveMemory(ByVal StrPtr(xChar1), ByVal ptrFilter, LenFilters * 2&)
      Else
      Call RtlMoveMemory(ByVal xChar1, ByVal ptrFilter, LenFilters)
      End If
    GetSaveFileName_GetFilterString = True
    End If
  End Function

Private Function GetSaveFileName_FindFilterIndex(ByVal ptrFilter As Long, ByVal LenFilters As Long, ByVal Extension As String) As Long
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xChar1 As String
  Dim xChar2 As String
  
  If GetSaveFileName_GetFilterString(ptrFilter, LenFilters, xChar1) Then
    Do
      xLong1 = InStr(xLong2 + 1&, xChar1, vbNullChar)
      If xLong1 = 0& Then Exit Do
      xLong2 = InStr(xLong1 + 1&, xChar1, vbNullChar)
      If xLong2 = 0& Then Exit Do
      GetSaveFileName_FindFilterIndex = GetSaveFileName_FindFilterIndex + 1&
      xChar2 = Mid(xChar1, xLong1 + 1&, xLong2 - xLong1 - 1&) + ";"
      If Not InStr(xChar2, "*." + Extension + ";") = 0& Then
        Exit Function
        End If
      Loop
    End If
  GetSaveFileName_FindFilterIndex = 0&
  End Function

Private Function GetSaveFileName_ExtensionByIndex(ByVal ptrFilter As Long, ByVal LenFilters As Long, ByVal Index As Long) As String
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xChar1 As String
  
  If Index > 0& Then
    If GetSaveFileName_GetFilterString(ptrFilter, LenFilters, xChar1) Then
      Do
        xLong1 = InStr(xLong2 + 1&, xChar1, vbNullChar)
        If xLong1 = 0& Then Exit Do
        xLong2 = InStr(xLong1 + 1&, xChar1, vbNullChar)
        If xLong2 = 0& Then Exit Do
        Index = Index - 1&
        If Index = 0& Then
          GetSaveFileName_ExtensionByIndex = Mid(xChar1, xLong1 + 1&, xLong2 - xLong1 - 1&) + ";"
          GetSaveFileName_ExtensionByIndex = Left(GetSaveFileName_ExtensionByIndex, InStr(GetSaveFileName_ExtensionByIndex, ";") - 1&)
          If Left(GetSaveFileName_ExtensionByIndex, 2&) = "*." Then
            GetSaveFileName_ExtensionByIndex = Mid(GetSaveFileName_ExtensionByIndex, 3&)
            Exit Function
            End If
          Exit Do
          End If
        Loop
      GetSaveFileName_ExtensionByIndex = ""
      End If
    End If
  End Function

Private Function GetSaveFileName_HookHandle(ByVal hDlgChild As Long, ByVal ptrNMHDR As Long) As Long
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xType1 As OFNOTIFY
  Dim xType2 As OPENFILENAME_Real
  Dim xType3 As GetSaveFilename_CustomParams
  Dim xChar1 As String
  Dim xChar2 As String
  
'Public Const FILE_ATTRIBUTE_READONLY = &H1
'Public Const FILE_ATTRIBUTE_HIDDEN = &H2
'Public Const FILE_ATTRIBUTE_SYSTEM = &H4
'Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
  
  ' 4*4 = filters
  ' 7*4 = index
  Call RtlMoveMemory(xType1, ByVal ptrNMHDR, 16&)
  If xType1.code = -607& Then
    If Not xType1.lpOFN = 0& Then
      Call RtlMoveMemory(xType2, ByVal xType1.lpOFN, 17& * 4&)
      If Not (xType2.lpstrFilter = 0& Or xType2.lCustData = 0&) Then
        Call RtlMoveMemory(xType3, ByVal xType2.lCustData, GetSaveFilename_CustomParamsLen)
        hDlgChild = GetParent(hDlgChild)
        If Not hDlgChild = 0& Then
          xChar1 = GetDlgItemText(hDlgChild, &H480&)
          If Not Len(xChar1) = 0& Then
            xLong1 = InStrRev(xChar1, ".")
            If Not xLong1 = 0& Then
              xLong2 = GetSaveFileName_FindFilterIndex(xType2.lpstrFilter, xType3.LenFilters, Mid(xChar1, xLong1 + 1&))
              If Not (xLong2 = 0& Or xLong2 = xType2.nFilterIndex) Then
                xChar1 = Left(xChar1, xLong1 - 1&)
                Call SendMessage_String(hDlgChild, 1128&, &H480&, ByVal xChar1)
                End If
              End If
            End If
          End If
        End If
      End If
    ElseIf xType1.code = -606& Then
    If Not xType1.lpOFN = 0& Then
      Call RtlMoveMemory(xType2, ByVal xType1.lpOFN, 17& * 4&)
      If Not (xType2.lpstrFile = 0& Or xType2.lCustData = 0&) Then
        Call RtlMoveMemory(xType3, ByVal xType2.lCustData, GetSaveFilename_CustomParamsLen)
        xChar1 = PeekS(xType2.lpstrFile)
        If Not Len(xChar1) = 0& Then
          '' check attributes
          xLong1 = InStrRev(xChar1, ".")
          If Not xLong1 = 0& Then
            If Not GetSaveFileName_FindFilterIndex(xType2.lpstrFilter, xType3.LenFilters, Mid(xChar1, xLong1 + 1&)) = 0& Then
              GoTo FilenameComplete
              End If
            End If
          xChar1 = xChar1 + "." + GetSaveFileName_ExtensionByIndex(xType2.lpstrFilter, xType3.LenFilters, xType2.nFilterIndex)
FilenameComplete:
          xLong1 = GetFileAttributes(xChar1)
          If xLong1 = -1& Then GoTo Ok
          If (xLong1 And &H17&) = 0& Then
            xChar2 = Replace(PeekS_Wide(xType3.ErrExistsText), "$F", xChar1)
            If MessageBoxW(GetParent(hDlgChild), StrPtr(xChar2), xType3.ErrExistsTitle, vbOKCancel Or vbExclamation) = vbOK Then
Ok:
              'Call PokeS(xType2.lpstrFile, xChar1, 256&)
              If Not xType3.RealResult = 0& Then Call LocalFree(xType3.RealResult)
              xType3.RealResult = LocalAllocFromString(xChar1)
              Call RtlMoveMemory(ByVal xType2.lCustData, xType3, GetSaveFilename_CustomParamsLen)
              Exit Function
              End If
            Else
            xChar2 = Replace(PeekS_Wide(xType3.ErrROText), "$F", xChar1)
            Call MessageBoxW(GetParent(hDlgChild), StrPtr(xChar2), xType3.ErrROTitle, vbExclamation)
            End If
          End If
        End If
      'Debug.Print "Result:"; xChar1
      End If
    
    Call SetWindowLong(hDlgChild, 0&, 1&)
    GetSaveFileName_HookHandle = 1&
    End If
  End Function

Private Function GetSaveFileName_Hook(ByVal hDlgChild As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  'Debug.Print Msg
  Select Case Msg
    Case &H4E& ' WM_Notify
      GetSaveFileName_Hook = GetSaveFileName_HookHandle(hDlgChild, lParam)
    End Select
  End Function