Option Explicit
' From X11Color.h : header file
Public Const colorAmptekBlue = &HFCCE7A
Public Const colorBlue = &HFF0000
Public Const colorGreen = &H8000&
Public Const colorLightGray = &HD3D3D3
Public Const colorLightSlateGray = &H998877
Public Const colorLightSteelBlue = &HDEC4B0
Public Const colorRed = &HFF&
Public Const colorWhite = &HFFFFFF
Public Const colorYellow = &HFFFF&
Public Const colorSilver = &HC0C0C0
'dialog box file filters for file extensions
Public Const dlgTXT_Filter As String = "Text File (*.txt)|*.txt|All Files (*.*)|*.*"
Public Const dlgCFG_Filter As String = "Amptek Config File (*.cfg)|*.cfg|All Files (*.*)|*.*"
Public Const dlgCSV_Filter As String = "Comma Separated Value (*.csv)|*.csv|All Files (*.*)|*.*"
Public Const dlgMCA_Filter As String = "Amptek Spectrum File (*.mca)|*.mca|All Files (*.*)|*.*"
Public Const dlgXL_Filter As String = "Excel Files (*.xls)|*.xls|All Files (*.*)|*.*"
Private Const cmdArrowWidth = 285
Private Const WS_EX_RIGHT = &H1000 ' Alignment use extended sytle
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Set Control Style
Public Sub SetStyle(ByVal lHWnd As Long, ByVal lStyleFlags As Long, ByVal bState As Boolean, Optional ByVal bExtended As Boolean = False)
Dim lGWLType As Long
Dim lStyle As Long
lGWLType = IIf(bExtended, GWL_EXSTYLE, GWL_STYLE)
lStyle = GetWindowLong(lHWnd, lGWLType)
If (bState) Then
lStyle = lStyle Or lStyleFlags
Else
lStyle = lStyle And Not lStyleFlags
End If
SetWindowLong lHWnd, lGWLType, lStyle
End Sub
'Set ComboBox text to right of drop arrow for all comboboxes
Public Sub SetComboRight(ByRef frm As Form)
Dim ctl As Control
For Each ctl In frm.Controls
If (TypeName(ctl) = "ComboBox") Then
SetStyle ctl.hwnd, WS_EX_RIGHT, True, True
End If
Next ctl
End Sub
'Aligns TextBox ComboBox Group Controls
Public Sub AlignTextBoxToComboBox(Combo1 As ComboBox, Text1 As TextBox)
Text1.Top = Combo1.Top
Text1.Left = Combo1.Left + cmdArrowWidth
Text1.Width = Combo1.Width - cmdArrowWidth
Text1.Height = Combo1.Height
End Sub
'Manages TextBox Display of TextBox ComboBox Control Group
Public Function ClickTxtComboGroup(Combo1 As ComboBox, Text1 As TextBox) As Boolean
If (InStr(Combo1.Text, "#") > 0) Then
Text1.Visible = True
Text1.ZOrder 0
Else
Text1.Visible = False
Text1.ZOrder 1
End If
ClickTxtComboGroup = Text1.Visible
End Function
'================================================================================
' Common Dialog Box Functions
'
' This module contains the common dialog box functions and filters
'================================================================================
'================================================================================
'==== Example Usage ====
'================================================================================
' If (dlgOpen(cmnDlg, dlgMCA_Filter)) Then
' FileToOpen = cmnDlg.Filename
' Else
' 'a file was not selected
' End If
'
' If (dlgSave(cmnDlg, dlgCSV_Filter)) Then
' FileToSave = cmnDlg.Filename
' Else
' 'a file was not selected
' End If
'================================================================================
'creates an open common dialog, returns true is a file was selected, false otherwise
Public Function dlgOpen(CmnDlgFIO As CommonDialog, strFileFilters As String) As Boolean
On Error GoTo ErrHandlerOpen
dlgOpen = False
CmnDlgFIO.CancelError = True 'create error on cancel
CmnDlgFIO.FilterIndex = 1
CmnDlgFIO.Filter = strFileFilters
'CmnDlgFIO.Flags = cdlOFNHideReadOnly 'cdlOFNFileMustExist + cdlOFNHideReadOnly
CmnDlgFIO.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNExplorer Or cdlOFNLongNames
CmnDlgFIO.filename = GetDefaultFileWildcard(strFileFilters)
CmnDlgFIO.ShowOpen
dlgOpen = True
Exit Function
ErrHandlerOpen:
If (Err.Number = cdlCancel) Then 'If (error = cdlCancel) user pressed Cancel button.
'------ message from dlgbox to exit ------
Else
MsgBox Err.Description & " (" & Err.Number & ")")
End If
Exit Function
End Function
'creates a save common dialog, returns true if the file was saved, false otherwise
Public Function dlgSave(CmnDlgFIO As Object, strFileFilters As String) As Boolean
On Error GoTo ErrHandlerSave
dlgSave = False
CmnDlgFIO.CancelError = True 'create error on cancel
CmnDlgFIO.FilterIndex = 1
CmnDlgFIO.Filter = strFileFilters
CmnDlgFIO.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt
CmnDlgFIO.filename = GetDefaultFileWildcard(strFileFilters)
CmnDlgFIO.ShowSave
dlgSave = True
Exit Function
ErrHandlerSave:
If (Err.Number = cdlCancel) Then 'If (error = cdlCancel) user pressed Cancel button.
'message from dlgbox to exit
Else
MsgBox Err.Description & " (" & Err.Number & ")")
End If
Exit Function
End Function
Private Function GetDefaultFileWildcard(strFilter As String) As String
Dim extBegin As Integer
Dim extEnd As Integer
Dim strExt As String
GetDefaultFileWildcard = ""
'find starting bar, read until next bar or end of string
extBegin = InStr(strFilter, "|")
If (extBegin < 1) Then Exit Function
extEnd = InStr(extBegin + 1, strFilter, "|")
If ((extEnd - 1) < extBegin) Then
extEnd = Len(strFilter)
Else
extEnd = extEnd - 1
End If
strExt = Trim(Mid(strFilter, extBegin + 1, extEnd - extBegin))
If (Len(strExt) < 1) Then Exit Function
GetDefaultFileWildcard = strExt
End Function
Public Sub SaveLastDir(CmnDlgFIO As CommonDialog)
CmnDlgFIO.InitDir = Left$(CmnDlgFIO.filename, Len(CmnDlgFIO.filename) - Len(CmnDlgFIO.FileTitle) - 1)
End Sub