VBA Snippets
Frm_CancelQueryClose
Disables the close button in the corner of a dialog box.Public Sub Frm_CancelQueryClose(iCancel As Integer, _
iCloseMode As Integer)
On Error GoTo AnError
If CloseMode = vbFormControlMenu Then
cmdCancel.SetFocus
' Call Frm_Inform("",
Call MsgBox( _
"Cannot close the userform !!")
Cancel = True
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_CancelQueryClose", msMODULENAME, 1, _
"disable the close button in the corner of the dialog box")
End Sub
Frm_Choice
Creates and displays a custom dialog box to display a choice to the user. This uses the API call "GetSystemMetrics" to determine the exact width of the label after the message has been added. This uses the global variable "gbChoice" to return the choice made, whether True or False.Public Sub Frm_Choice(sTitle As String, _
sMessage As String)
Dim ifrmwidth As Integer
Dim ifrmheight As Integer
Dim imsgboxtop As SInteger
Dim imsgboxheight As Integer
Dim imsgboxleft As Integer
Dim imsgboxwidth As Integer
Dim ibuttontop As Integer
Dim ibuttonyesleft As Integer
Dim ibuttonnoleft As integer
Dim sngwidesttextwidth As Single
Dim inoofcarriagereturns As Integer
On Error GoTo AnError
If bMSGBOX_USE = True Then
ifrmheight = iUSERFORM_STANDHEIGHT: ifrmwidth = iUSERFORM_STANDWIDTH
imsgboxheight = 30: imsgboxleft = 42: imsgboxtop = 12: imsgboxwidth = 150
ibuttontop = iCOMMANDBUTTON_TOP: ibuttonyesleft = 42: ibuttonnoleft = 114
inoofcarriagereturns = Str_NoOfCRs(sMessage)
If inoofcarriagereturns = 0 Then _
imsgboxtop = iUSERFORM_FIRSTCONTROLTOP + iUSERFORM_TEXTHEIGHT
If inoofcarriagereturns >= 3 Then
ifrmheight = iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns - 1)
ifrmheight = iUSERFORM_STANDHEIGHT + ifrmheight
imsgboxheight = (iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns + 1.5))
ibuttontop = imsgboxtop + imsgboxheight
ibuttontop = ibuttontop + iUSERFORM_TEXTBUTTONGAP
End If
Call VBE_FormLabelAdd("frmGeneral", sMessage, "lblMessage", _
imsgboxheight, imsgboxleft, imsgboxtop, imsgboxwidth, "")
sngwidesttextwidth = VBE_FormLabelWidth("frmGeneral", "lblMessage", sMessage)
If (iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + iUSERFORM_TEXTRHSGAP > _
iUSERFORM_STANDWIDTH) Then
ifrmwidth = iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + 25
imsgboxwidth = sngwidesttextwidth + 25
ibuttonyesleft = (ifrmwidth / 2) - iCOMMANDBUTTON_WIDTH - 5
ibuttonnoleft = (ifrmwidth / 2) + 5
End If
Call VBE_FormSize("frmGeneral", ifrmheight, ifrmwidth, sTitle)
Call VBE_FormLabelSize("frmGeneral", "lblMessage", _
imsgboxheight, imsgboxleft, imsgboxtop, imsgboxwidth)
Call VBE_FormGeneralPosition("frmGeneral", "ImageQuestion", imsgboxheight)
Call VBE_FormCommandButtonAdd("frmGeneral", "Yes", "cmbYes", _
24, ibuttonyesleft, ibuttontop, 66, _
lCOMMANDBUTTON_OKTEXTCOLOUR, _
lCOMMANDBUTTON_OKCOLOUR, _
"gbChoice = true" & vbCrLf & _
" unload Me")
Call VBE_FormCommandButtonAdd("frmGeneral", "No", "cmbNo", _
24, ibuttonnoleft, ibuttontop, 66, _
lCOMMANDBUTTON_CANCELTEXTCOLOUR, _
lCOMMANDBUTTON_CANCELCOLOUR, _
"gbChoice = False" & vbCrLf & _
" unload Me")
Call VBE_FormShow("frmGeneral")
Call VBE_FormGeneralDeleteExtraControls("frmGeneral")
Call VBE_FormGeneralResetControls("frmGeneral")
Call VBE_FormCodeDeleteAll("frmGeneral")
Else
Call MsgBox(sMessage, vbYesNo + vbQuestion, sTitle)
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_Choice", msMODULENAME, 1, _
"create and display the custom CHOICE dialog box from frmGeneral")
End Sub
Frm_GetInput
Creates and displays a custom dialog box to request an input from the user. This uses the API call "GetSystemMetrics" to determine the exact width of the label after the message has been added.Public Sub Frm_GetInput(sTitle As String, _
sMessage As String, _
sButtonCaption As String)
Dim ifrmwidth%, ifrmheight%
Dim imsgboxtop%, imsgboxheight%, imsgboxleft%, imsgboxwidth%
Dim ibuttontop%, ibuttonyesleft%, ibuttonnoleft%
Dim sngwidesttextwidth!, inoofcarriagereturns%
On Error GoTo AnError
If bMSGBOX_USE = True Then
ifrmheight = iUSERFORM_STANDHEIGHT: ifrmwidth = iUSERFORM_STANDWIDTH
imsgboxheight = 30: imsgboxleft = 42: imsgboxtop = 12: imsgboxwidth = 150
ibuttontop = iCOMMANDBUTTON_TOP: ibuttonyesleft = 42: ibuttonnoleft = 114
sngwidesttextwidth = Str_WidthWidest(sMessage, False)
inoofcarriagereturns = Str_CharsNoOf(sMessage, Chr(10))
If inoofcarriagereturns = 0 Then _
imsgboxtop = iUSERFORM_FIRSTCONTROLTOP + iUSERFORM_TEXTHEIGHT
If inoofcarriagereturns >= 3 Then
ifrmheight = iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns - 1)
ifrmheight = iUSERFORM_STANDHEIGHT + ifrmheight
imsgboxheight = (iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns + 1.5))
ibuttontop = imsgboxtop + ifrmheight
ibuttontop = ibuttontop + iUSERFORM_TEXTBUTTONGAP
End If
If (iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + iUSERFORM_TEXTRHSGAP > _
iUSERFORM_STANDWIDTH) Then
ifrmwidth = iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + 25
imsgboxwidth = sngwidesttextwidth + 25
ibuttonnoleft = (ifrmwidth / 2) - iCOMMANDBUTTON_WIDTH - 5
ibuttonyesleft = (ifrmwidth / 2) + 5
End If
Call VBE_FormSize("frmGeneral", ifrmheight, ifrmwidth - 65, sTitle)
Call VBE_FormGeneralPosition("frmGeneral", "None", imsgboxheight)
Call VBE_FormCommandButtonAdd("frmGeneral", sButtonCaption, "cmbOK", _
24, ibuttonyesleft - 35, ibuttontop, 66, _
lCOMMANDBUTTON_OKTEXTCOLOUR, lCOMMANDBUTTON_OKCOLOUR, _
"gbChoice = True" & vbCrLf & _
" gsResponse = txtInput.Value" & vbCrLf & _
" unload Me")
Call VBE_FormCommandButtonAdd("frmGeneral", "Cancel", "cmbCancel", _
24, ibuttonnoleft - 35, ibuttontop, 66, _
lCOMMANDBUTTON_CANCELTEXTCOLOUR, _
lCOMMANDBUTTON_CANCELCOLOUR, _
"gbChoice = False" & vbCrLf & _
" unload Me")
Call VBE_FormLabelAdd("frmGeneral", sMessage, "lblMessage", _
imsgboxheight - 17, imsgboxleft - 35, imsgboxtop - 10, imsgboxwidth, "")
Call VBE_FormTextBoxAdd("frmGeneral", "", "txtInput", _
imsgboxheight - 11, imsgboxleft - 35, imsgboxtop + 5, imsgboxwidth - 12, "")
Call VBE_FormShow("frmGeneral")
Call VBE_FormGeneralDeleteExtraControls("frmGeneral")
Call VBE_FormGeneralResetControls("frmGeneral")
Call VBE_FormCodeDeleteAll("frmGeneral")
Else
Call InputBox(sMessage, sTitle)
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_GetInput", msMODULENAME, 1, _
"create and display the custom GETINPUT dialog box from frmGeneral")
End Sub
Frm_Inform
Creates and displays a custom dialog box to display information. This uses the API call "GetSystemMetrics" to determine the exact width of the label after the message has been added.Public Sub Frm_Inform(sTitle As String, _
sMessage As String, _
Optional bIsError As Boolean = False)
Dim ifrmwidth%, ifrmheight%, imsgboxtop%, imsgboxheight%, imsgboxleft%, imsgboxwidth%
Dim ibuttontop%, ibuttonleft%, sngwidesttextwidth!, inoofcarriagereturns%
Dim simage$
On Error GoTo AnError
If bMSGBOX_USE = True Then
If bIsError = True Then simage = "ImageCritical"
If bIsError = False Then simage = "ImageInformation"
ifrmheight = iUSERFORM_STANDHEIGHT: ifrmwidth = iUSERFORM_STANDWIDTH
imsgboxheight = 30: imsgboxleft = 42: imsgboxtop = 12: imsgboxwidth = 150
ibuttontop = iCOMMANDBUTTON_TOP: ibuttonleft = 78
inoofcarriagereturns = Str_NoOfCRs(sMessage)
If inoofcarriagereturns = 0 Then _
imsgboxtop = iUSERFORM_FIRSTCONTROLTOP + iUSERFORM_TEXTHEIGHT
If inoofcarriagereturns >= 3 Then
ifrmheight = iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns - 1)
ifrmheight = iUSERFORM_STANDHEIGHT + ifrmheight
imsgboxheight = (iUSERFORM_TEXTHEIGHT * (inoofcarriagereturns + 1.5))
ibuttontop = imsgboxtop + imsgboxheight
ibuttontop = ibuttontop + iUSERFORM_TEXTBUTTONGAP
End If
Call VBE_FormLabelAdd("frmGeneral", sMessage, "lblMessage", _
imsgboxheight, imsgboxleft, imsgboxtop, imsgboxwidth, "")
sngwidesttextwidth = VBE_FormLabelWidth("frmGeneral", "lblMessage", sMessage)
If (iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + iUSERFORM_TEXTRHSGAP > _
iUSERFORM_STANDWIDTH) Then
ifrmwidth = iUSERFORM_TEXTLHSGAP + sngwidesttextwidth + 25
imsgboxwidth = sngwidesttextwidth + 25
ibuttonleft = (ifrmwidth - iCOMMANDBUTTON_WIDTH) / 2
End If
Call VBE_FormSize("frmGeneral", ifrmheight, ifrmwidth, sTitle)
Call VBE_FormLabelSize("frmGeneral", "lblMessage", _
imsgboxheight, imsgboxleft, imsgboxtop, imsgboxwidth)
Call VBE_FormGeneralPosition("frmGeneral", simage, imsgboxheight)
Call VBE_FormCommandButtonAdd("frmGeneral", "OK", "cmbOK", _
24, ibuttonleft, ibuttontop, 66, _
lCOMMANDBUTTON_OKTEXTCOLOUR, _
lCOMMANDBUTTON_OKCOLOUR, _
"unload Me")
Call VBE_FormShow("frmGeneral")
Call VBE_FormGeneralDeleteExtraControls("frmGeneral")
Call VBE_FormGeneralResetControls("frmGeneral")
Call VBE_FormCodeDeleteAll("frmGeneral")
Else
Call MsgBox(sMessage, vbOKOnly + vbInformation, sTitle)
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_Inform", msMODULENAME, 1, _
"create and display the custom INFORM dialog box from frmGeneral")
End Sub
Frm_Modal
Switches a userform between being modal or modeless 'API function to enable/disable the Excel Window.Public Sub Frm_Modal(sFormName As String, _
bModal As Boolean)
Dim serrortext As String
Dim mlHWnd As Long
On Error GoTo AnError
mlHWnd = FindWindowA("XLMAIN", Application.Caption)
If bModal = True Then Call EnableWindow(mlHWnd, 0)
If bModal = False Then Call EnableWindow(mlHWnd, 1)
If gbDEBUG = False Then Exit Sub
AnError:
If bModal = True Then serrortext = "MODAL"
If bModal = False Then serrortext = "MODELESS"
Call Error_Handle("Frm_Modal", msMODULENAME, 1, _
"adjust the mode of the userform """ & sFormName & """ to " & serrortext)
End Sub
'****************************************************************************************
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function EnableWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal bEnable As Long) As Long
Frm_Options
Creates and displays a custom dialog box to display various options. This uses the API call to determine the exact width of the label after the message has been added.Public Sub Frm_Options(sTitle As String, _
Optional sOKCodeToRun As String = "", _
Optional sButtonText1 As String = "", _
Optional sCodeToRun1 As String = "", _
Optional sButtonText2 As String = "", _
Optional sCodeToRun2 As String = "", _
Optional sButtonText3 As String = "", _
Optional sCodeToRun3 As String = "", _
Optional sButtonText4 As String = "", _
Optional sCodeToRun4 As String = "")
Dim inumberofoptions%
Dim ifrmwidth%, ifrmheight%, imsgboxtop%, imsgboxheight%, imsgboxleft%, imsgboxwidth%
Dim ibuttontop%, ibuttonyesleft%, ibuttonnoleft%
Dim sngwidesttextwidth!, inoofcarriagereturns%
On Error GoTo AnError
If bMSGBOX_USE = True Then
ifrmheight = iUSERFORM_STANDHEIGHT: ifrmwidth = iUSERFORM_STANDWIDTH
imsgboxheight = 30: imsgboxleft = 42: imsgboxtop = 12: imsgboxwidth = 150
ibuttontop = iCOMMANDBUTTON_TOP: ibuttonyesleft = 42: ibuttonnoleft = 114
inumberofoptions = 4
If sButtonText4 = "" Then inumberofoptions = 3
If sButtonText3 = "" Then inumberofoptions = 2
If inumberofoptions < 3 Then 'make the standard size for 2 options
ifrmheight = 98
ibuttontop = 48
Else 'make the correspondign length for the 3 or 4 options
ifrmheight = 98 + ((inumberofoptions - 2) * 20)
ibuttontop = 48 + ((inumberofoptions - 2) * 21)
End If
Call VBE_FormSize("frmGeneral", ifrmheight, ifrmwidth - 65, sTitle)
Call VBE_FormCommandButtonAdd("frmGeneral", "OK", "cmbOK", _
24, ibuttonyesleft - 35, ibuttontop, 66, _
lCOMMANDBUTTON_OKTEXTCOLOUR, lCOMMANDBUTTON_OKCOLOUR, _
sOKCodeToRun & vbCrLf & " unload me")
Call VBE_FormCommandButtonAdd("frmGeneral", "Cancel", "cmbCancel", _
24, ibuttonnoleft - 35, ibuttontop, 66, _
lCOMMANDBUTTON_CANCELTEXTCOLOUR, _
lCOMMANDBUTTON_CANCELCOLOUR, _
"gsResponse = """ & vbCrLf & " unload Me")
If sButtonText1 <> "" Then Call VBE_FormOptionButtonAdd("frmGeneral", sButtonText1, _
"optOne", 15, 42 - 35, 6, 145, _
sCodeToRun1 & _
"gsresponse = """ & sButtonText1)
If sButtonText2 <> "" Then Call VBE_FormOptionButtonAdd("frmGeneral", sButtonText2, _
"optTwo", 15, 42 - 35, 27, 145, _
sCodeToRun2 & _
"gsresponse = """ & sButtonText2)
If sButtonText3 <> "" Then Call VBE_FormOptionButtonAdd("frmGeneral", sButtonText3, _
"optThree", 15, 42 - 35, 48, 145, _
sCodeToRun3 & _
"gsresponse = """ & sButtonText3)
If sButtonText4 <> "" Then Call VBE_FormOptionButtonAdd("frmGeneral", sButtonText4, _
"optFour", 15, 42 - 35, 69, 145, _
sCodeToRun4 & _
"gsresponse = """ & sButtonText4)
Call VBE_FormGeneralPosition("frmGeneral", "None", imsgboxheight)
Call VBE_FormShow("frmGeneral")
Call VBE_FormGeneralDeleteExtraControls("frmGeneral")
Call VBE_FormGeneralResetControls("frmGeneral")
Call VBE_FormCodeDeleteAll("frmGeneral")
Else
Call MsgBox("Cannot display an options form !!", vbOKOnly, "ERROR")
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_Options", msMODULENAME, 1, _
"create and display the custom OPTIONS dialog box from frmGeneral")
End Sub
Frm_ProcessingUpdate
Creates a new instance of the callback method to allow processing updates.Public Sub Frm_ProcessingUpdate()
Dim classprocessing1 As clsProcessing
On Error Goto AnError
Set classprocessing1 = New clsProcessing
Call classprocessing1.ProcessingUpdate
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_ProcessingUpdate", msMODULENAME, 1, _
"create a new ""clsProcessing"" class for the userform call back")
End Sub
Frm_ProcessingUpdateProgessBar
Updates the progress bar and message on a progress bar when called as part of the callback method.Public Sub Frm_ProcessingUpdateProgessBar(frmInstance As frmProcessing, _
Optional sngPercent As Single = -1, _
Optional sMessage As String = "")
On Error GoTo AnError
If Len(sMessage) > 0 Then _
frmInstance.lblMessage = sMessage
If sngPercent > -1 Then _
frmInstance.lblProgressBar.Width = sngPercent * (frmInstance.fraProgress.Width - 4)
frmInstance.Repaint
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Frm_ProcessingUpdateProgessBar", msMODULENAME, 1, _
"update the progress bar to """ & sngPercent & """" & _
" and the message to """ & sMessage & """")
End Sub
Frm_Test
Determines if the customised dialog boxes will work on a PC and is used to set the global variable.Public Function Frm_Test() As Boolean
' to be used to set a global variable as to whether to use the msgbox or NOT
On Error GoTo AnError
'TRY AND ADJUST THE CONTROLS
Frm_Test = True
If gbDEBUG = False Then Exit Function
AnError:
Frm_Test = False
End Function
Message_UnableToClose
Public Sub Message_UserformCannotClose()
Dim sMessage As String
sMessage = "You must use the Cancel button to close this dialog box."
Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Close")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top