Attribute VB_Name = "modControlUtility"
Option Explicit

Private Const GotFocus_color = &HC0FFFF
Private Const LostFocus_color = &H80000005

Private Type BrowseInfo
   hWndOwner As Long
   pIDLRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfnCallback As Long
   lParam As Long
   iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_EDITBOX = &H10
Public Const BIF_VALIDATE = &H20
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_UAHINT = &H100
Public Const BIF_NONEWFOLDERBUTTON = &H200
Public Const BIF_NOTRANSLATETARGETS = &H400
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_SHAREABLE = &H8000
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private mstrSTARTFOLDER As String
Public Function GetFolder(ByVal hWndModal As Long, Optional StartFolder As String = "", Optional Title As String = "Please select a folder:", _
   Optional IncludeFiles As Boolean = False, Optional IncludeNewFolderButton As Boolean = False) As String
    Dim bInf As BrowseInfo
    Dim RetVal As Long
    Dim PathID As Long
    Dim RetPath As String
    Dim Offset As Integer
    'Set the properties of the folder dialog
    bInf.hWndOwner = hWndModal
    bInf.pIDLRoot = 0
    bInf.lpszTitle = Title
    bInf.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT
    If IncludeFiles Then bInf.ulFlags = bInf.ulFlags Or BIF_BROWSEINCLUDEFILES
    If IncludeNewFolderButton Then bInf.ulFlags = bInf.ulFlags Or BIF_NEWDIALOGSTYLE
    If StartFolder <> "" Then
       mstrSTARTFOLDER = StartFolder & vbNullChar
       bInf.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
   End If
    'Show the Browse For Folder dialog
    PathID = SHBrowseForFolder(bInf)
    RetPath = Space$(512)
    RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
    If RetVal Then
         'Trim off the null chars ending the path
         'and display the returned folder
         Offset = InStr(RetPath, Chr$(0))
         GetFolder = Left$(RetPath, Offset - 1) + "\"
         'Free memory allocated for PIDL
         CoTaskMemFree PathID
    Else
         GetFolder = ""
    End If
End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
   On Error Resume Next
   Dim lpIDList As Long
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           Call SendMessage(hWnd, BFFM_SETSELECTION, 1, mstrSTARTFOLDER)
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lp, sBuffer)
           If ret = 1 Then
               Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
           End If
   End Select
   BrowseCallbackProc = 0
End Function

Private Function GetAddressofFunction(add As Long) As Long
 GetAddressofFunction = add
End Function

Public Sub TabEnter(KeyCode As Integer)
    If KeyCode = vbKeyReturn Then
        Sendkeys "{TAB}"
    End If
End Sub

Public Sub KeyPressAction(KeyAscii As Integer, Optional validationType As String = 0, Optional isUCase As Boolean = True)
    If KeyAscii = vbKeyReturn Then
        Sendkeys "{TAB}"
    Else
        Dim value As Integer
        value = KeyAscii
        ' input validate
        ' 0 = Default / Accept all characters ; 1 = Numeric Only ; 2 = Alphabet Only
        If value <> 8 Then
            If validationType = 1 Then
                If value <> 46 Then
                    If IsNumeric(UCase$(Chr$(value))) = False Then
                        value = 0
                    End If
                End If
            ElseIf validationType = 2 Then
                Select Case value
                    Case 33 To 44, 46 To 64, 91 To 96, 123 To 126
                        value = 0
                End Select
            End If
        End If
        KeyAscii = IIf(isUCase, Asc(UCase$(Chr$(value))), Asc(Chr$(value)))
    End If
End Sub

Private Sub Sendkeys(text As Variant, Optional wait As Boolean = False)
    Dim WshShell As Object
    Set WshShell = CreateObject("wscript.shell")
    WshShell.Sendkeys CStr(text), wait
    Set WshShell = Nothing
End Sub

' CONTROL GOTFOCUS/LOSTFOCUS
Public Sub Color_GotFocus(control As Object)
    Focus control
    control.BackColor = GotFocus_color
End Sub

Public Sub Color_LostFocus(control As Object)
     control.BackColor = LostFocus_color
End Sub

Private Sub Focus(control As Object)
    control.SelStart = 0
    control.SelLength = Len(control.text)
End Sub