Attribute VB_Name = "modFileDialog"
Option Explicit

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
'Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Const GWL_HINSTANCE = (-6)
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOACTIVATE = &H10
Const HCBT_ACTIVATE = 5
Const WH_CBT = 5

Dim hHook As Long

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

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


Public Const LF_FACESIZE = 32

'OFS_FILE_OPEN_FLAGS and OFS_FILE_SAVE_FLAGS below
'are mine to save long statements; they're not
'a standard Win32 type.
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_NODEREFERENCELINKS Or OFN_FILEMUSTEXIST
Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_HIDEREADONLY 'Or OFN_OVERWRITEPROMPT

Public Type OPENFILENAME
    nStructSize As Long
    hWndOwner As Long
    hInstance As Long
    sFilter As String
    sCustomFilter As String
    nCustFilterSize As Long
    nFilterIndex As Long
    sFile As String
    nFileSize As Long
    sFileTitle As String
    nTitleSize As Long
    sInitDir As String
    sDlgTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExt As Integer
    sDefFileExt As String
    nCustDataSize As Long
    fnHook As Long
    sTemplateName As String
End Type


Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type

Type OFNOTIFY
        hdr As NMHDR
        lpOFN As OPENFILENAME
        pszFile As String        '  May be NULL
End Type

Public Type SelectedFile
    nFilesSelected As Integer
    sFiles() As String
    sLastDirectory As String
    bCanceled As Boolean
    bOpenReadOnly As Boolean
    bFileReadOnly As Boolean
End Type

Public FileDialog As OPENFILENAME
Dim ParentHwnd As Long

Public Function ShowOpen(ByVal hwnd As Long, Optional ByVal centerForm As Boolean = True) As SelectedFile
On Error GoTo Err_:

Dim ret As Long
Dim Count As Integer
Dim fileNameHolder As String
Dim LastCharacter As Integer
Dim NewCharacter As Integer
Dim tempFiles(1 To 200) As String
Dim hInst As Long
Dim Thread As Long
    
ParentHwnd = hwnd
With FileDialog
    .nStructSize = Len(FileDialog)
    .hWndOwner = hwnd
    .sFileTitle = Space$(512) '2048
    .nTitleSize = Len(.sFileTitle)
    .sFile = FileDialog.sFile & Space$(511) & vbNullChar '2047
    .nFileSize = Len(FileDialog.sFile)

    If .flags = 0 Then
        .flags = OFS_FILE_OPEN_FLAGS
    End If
    
    'Set up the CBT hook
    'hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
    hInst = App.hInstance
    'Thread = GetCurrentThreadId()
    Thread = App.ThreadID
    If centerForm = True Then
        hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
    Else
        hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
    End If
    
    ret = GetOpenFileName(FileDialog)

    If ret Then
        .sFileTitle = Trim(.sFileTitle)
        If .sFileTitle = vbNullString Then
            LastCharacter = 0
            Count = 0
            While ShowOpen.nFilesSelected = 0
                NewCharacter = InStr(LastCharacter + 1, .sFile, vbNullChar, vbTextCompare)
                If Count > 0 Then
                    tempFiles(Count) = Mid(.sFile, LastCharacter + 1, NewCharacter - LastCharacter - 1)
                Else
                    ShowOpen.sLastDirectory = Mid(.sFile, LastCharacter + 1, NewCharacter - LastCharacter - 1)
                End If
                Count = Count + 1
                If InStr(NewCharacter + 1, .sFile, vbNullChar, vbTextCompare) = InStr(NewCharacter + 1, .sFile, vbNullChar & vbNullChar, vbTextCompare) Then
                    tempFiles(Count) = Mid(.sFile, NewCharacter + 1, InStr(NewCharacter + 1, .sFile, vbNullChar & vbNullChar, vbTextCompare) - NewCharacter - 1)
                    ShowOpen.nFilesSelected = Count
                End If
                LastCharacter = NewCharacter
            Wend
            ReDim ShowOpen.sFiles(1 To ShowOpen.nFilesSelected)
            For Count = 1 To ShowOpen.nFilesSelected
                ShowOpen.sFiles(Count) = tempFiles(Count)
            Next
        Else
            ReDim ShowOpen.sFiles(1)
            '.sLastDirectory = left$(.sFile, .nFileOffset)
            ShowOpen.sLastDirectory = Left$(.sFile, InStrRev(.sFile, "\"))
            ShowOpen.nFilesSelected = 1
            ShowOpen.sFiles(1) = Mid(.sFile, .nFileOffset + 1, InStr(1, .sFile, vbNullChar, vbTextCompare) - .nFileOffset - 1)
            ShowOpen.bOpenReadOnly = (.flags And OFN_READONLY) > 0
            ShowOpen.bFileReadOnly = ((GetAttr(ShowOpen.sFiles(1)) And vbReadOnly) = vbReadOnly)  'Check system etc.
        End If
        ShowOpen.bCanceled = False
        Exit Function
    Else
        ShowOpen.sLastDirectory = ""
        ShowOpen.nFilesSelected = 0
        ShowOpen.bCanceled = True
        Erase ShowOpen.sFiles
        Exit Function
    End If
End With

Err_:
Resume Next

End Function

Public Function ShowSave(ByVal hwnd As Long, ByVal strOpenFile As String, Optional ByVal centerForm As Boolean = True) As SelectedFile
Dim ret As Long
Dim hInst As Long
Dim Thread As Long
Dim strFileExt As String
    
Dim strOpenFileDialog As String
Dim strOpenFilePath As String
Dim strOpenFileName As String

strOpenFileDialog = strOpenFile
    
Start_:
    
strOpenFilePath = fExtractPathDirectory(strOpenFileDialog)
strOpenFileName = fExtractPathFilename(strOpenFileDialog)
    
ParentHwnd = hwnd
With FileDialog
    .nStructSize = Len(FileDialog)
    .hWndOwner = hwnd
    .sFileTitle = Space$(512) '2048
    .nTitleSize = Len(FileDialog.sFileTitle)
    '.sFile = Space$(2047) & vbNullChar
    .sInitDir = strOpenFilePath
    .sFile = strOpenFileName & Space$(511 - Len(strOpenFileName)) & vbNullChar '2047
    .nFileSize = Len(FileDialog.sFile)
    
    If .flags = 0 Then
         .flags = OFS_FILE_SAVE_FLAGS
    End If
    
    'Set up the CBT hook
    'hInst = GetWindowLong(hwnd, GWL_HINSTANCE)
    hInst = App.hInstance
    'Thread = GetCurrentThreadId()
    Thread = App.ThreadID
    If centerForm = True Then
        hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterForm, hInst, Thread)
    Else
        hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProcCenterScreen, hInst, Thread)
    End If
    
    ret = GetSaveFileName(FileDialog)
    
    ReDim ShowSave.sFiles(1)

    If ret Then
        strFileExt = Split(.sFilter, vbNullChar)(1) '((.nFilterIndex * 2)-1)
        strFileExt = Right(strFileExt, Len(strFileExt) - 1)
        'ShowSave.sLastDirectory = left$(.sFile, .nFileOffset)
        ShowSave.sLastDirectory = Left$(.sFile, InStrRev(.sFile, "\"))
        ShowSave.nFilesSelected = 1
        ShowSave.sFiles(1) = Mid(.sFile, .nFileOffset + 1, InStr(1, .sFile, vbNullChar, vbTextCompare) - .nFileOffset - 1)
        ShowSave.bCanceled = False
        If Not Right(ShowSave.sFiles(1), 4) = strFileExt Then 'fix this shit
            ShowSave.sFiles(1) = ShowSave.sFiles(1) & strFileExt
        End If
        If fFileDIRExists(ShowSave.sFiles(1)) Then
            Select Case MsgBox(vbNewLine & "The file:" & vbNewLine & vbNewLine & """" & ShowSave.sFiles(1) & """" & vbTab & vbNewLine & vbNewLine & "already exists!  Continue with Save As and overwrite this file?" & vbTab, vbExclamation + vbYesNo, "Save As")
                Case vbYes:
                    If ((GetAttr(ShowSave.sFiles(1)) And vbReadOnly) = vbReadOnly) Then
                        MsgBox vbNewLine & "The file:" & vbNewLine & vbNewLine & """" & ShowSave.sFiles(1) & """" & vbTab & vbNewLine & vbNewLine & "is a read-only file and cannot be overwritten!" & vbTab, vbExclamation, "Save As"
                        GoTo Start_
                    End If
                Case vbNo:
                    strOpenFileDialog = ShowSave.sFiles(1)
                    GoTo Start_
                'Case vbCancel:
            End Select
        End If
    Else
        ShowSave.sLastDirectory = ""
        ShowSave.nFilesSelected = 0
        ShowSave.bCanceled = True
        Erase ShowSave.sFiles
    End If
    
End With

End Function

Private Function WinProcCenterScreen(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim rectForm As RECT, rectMsg As RECT
    Dim X As Long, Y As Long
    If lMsg = HCBT_ACTIVATE Then
        'Show the MsgBox at a fixed location (0,0)
        GetWindowRect wParam, rectMsg
        X = Screen.Width / Screen.TwipsPerPixelX / 2 - (rectMsg.Right - rectMsg.Left) / 2
        Y = Screen.Height / Screen.TwipsPerPixelY / 2 - (rectMsg.Bottom - rectMsg.Top) / 2
        'Debug.Print "Screen " & Screen.Height / 2
        'Debug.Print "MsgBox " & (rectMsg.Right - rectMsg.left) / 2
        SetWindowPos wParam, 0, X, Y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
        'Release the CBT hook
        UnhookWindowsHookEx hHook
    End If
    WinProcCenterScreen = False
End Function

Private Function WinProcCenterForm(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim rectForm As RECT, rectMsg As RECT
    Dim X As Long, Y As Long
    'On HCBT_ACTIVATE, show the MsgBox centered over Form1
    If lMsg = HCBT_ACTIVATE Then
        'Get the coordinates of the form and the message box so that
        'you can determine where the center of the form is located
        GetWindowRect ParentHwnd, rectForm
        GetWindowRect wParam, rectMsg
        X = (rectForm.Left + (rectForm.Right - rectForm.Left) / 2) - ((rectMsg.Right - rectMsg.Left) / 2)
        Y = (rectForm.Top + (rectForm.Bottom - rectForm.Top) / 2) - ((rectMsg.Bottom - rectMsg.Top) / 2)
        'Position the msgbox
        SetWindowPos wParam, 0, X, Y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
        'Release the CBT hook
        UnhookWindowsHookEx hHook
     End If
     WinProcCenterForm = False
End Function

Function fFileDIRExists(ByVal strPath As String, Optional ByVal lngType As Long) As Integer
On Error Resume Next

'To check for a file? fIsFileDIR("c:\winnt\win.ini")
'To check for a directory? fIsFileDir("c:\winnt",vbdirectory)

fFileDIRExists = Len(Dir(strPath, lngType)) > 0

End Function
