VBA Snippets
App_Alerts
Switches the Display Alerts either On or Off.Public Sub App_Alerts(ByVal bDisplayAlerts As Boolean)
On Error GoTo AnError
If bDisplayAlerts = True And Application.DisplayAlerts = False Then
Application.DisplayAlerts = True
ElseIf bDisplayAlerts = False And Application.DisplayAlerts = True Then
Application.DisplayAlerts = False
Else
End If
App_Alerts additonal textsttstsst
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("App_Alerts", msMODULENAME, 1, _
"switch the display alerts to """ & bDisplayAlerts & """")
End Sub
App_Screen
Switches the ScreenUpdating either On or Off.Public Sub App_Screen()
End Sub
Declarations_ModuleComments
The common declarations and important information to include at the top of every new VBA module.Declarations_ModuleComments()
'Module Name:
'Module Description:
'ProjectName:
'Date Created:
'File Name:
'Directory:
'Author: Russell Proctor
'Version: 1.0
'Client:
'----------------------------------------------------------------------------------------
'Change History:
'----------------------------------------------------------------------------------------
'Comments:
'****************************************************************************************
Private Const msMODULENAME As String = "modCode"
Public gbEND As Boolean
Public Const gbDEBUG As Boolean = False
Public Const gbDEBUG_ERRMSG As Boolean = False
Public Const gsVERSION As String = "1.1R"
Public Const gsSOLUTION_NAME As String = "Workbook SaveAs"
Public Const gsFORM_TITLE As String = "BET: Workbook SaveAs"
Public Const gsFORM_PREFIX As String = "BET: Workbook SaveAs - "
Declarations_MsgBoxFrms
The common declarations to include when using dynamic message boxes.Declarations_Frms
'Dynamic Message Boxes
'------------------------------------------- used for the dynamic changing userforms
Public Const lCOMMANDBUTTON_OKCOLOUR As Long = 8388608 'OK - button colour
Public Const lCOMMANDBUTTON_OKTEXTCOLOUR As Long = 16777215 'OK - text colour
Public Const lCOMMANDBUTTON_CANCELCOLOUR As Long = 16777215 'Cancel - button colour
Public Const lCOMMANDBUTTON_CANCELTEXTCOLOUR As Long = 8388608 'Cancel - text colour
Public Const iCOMMANDBUTTON_WIDTH As Integer = 66 'standard width of a command button
Public Const iCOMMANDBUTTON_HEIGHT As Integer = 24 'standard height of a command button
Public Const iCOMMANDBUTTON_TOP As Integer = 54 'standard height of a command button
Public Const iUSERFORM_FIRSTCONTROLTOP As Integer = 8
Public Const iUSERFORM_STANDHEIGHT As Integer = 102 'height of the messsage forms
Public Const iUSERFORM_STANDWIDTH As Integer = 220 'width of the message forms
Public Const iUSERFORM_TEXTHEIGHT As Integer = 10 'number of points = a line of text
Public Const iUSERFORM_TEXTLHSGAP As Integer = 42 'number of points on the LHS of text
Public Const iUSERFORM_TEXTRHSGAP As Integer = 28 'number of points on the RHS of text
Public Const iUSERFORM_TEXTBUTTONGAP As Integer = 10 'gap between the text box and cmb
Public Const iCHOICE_GAPBETWEENBUTTONS As Integer = 16 'gap between buttons on choice
Declarations_Solution
Option Explicit
'Module Description:
'Contains macros to
'Date Created: 01/08/2005
'File Name: Track Changes Consolidator
'Author: Better Solutions - Russell Proctor
'Version: 1_3
'Client: ClientName
'----------------------------------------------------------------------------------------
Private Const msMODULENAME As String = "modCode"
Public gbEND As Boolean
Public Const gbDEBUG As Boolean = False
Public Const gbDEBUG_ERRMSG As Boolean = False
Public Const gdtEXPIRES_DATE As Date = #4/30/2007#
Public Const gsVERSION As String = "1.21R"
Public Const gsSOLUTION_NAME As String = "Mail Merge Assistant"
Public Const gsFORM_TITLE As String = "BET: Mail Merge Assistant"
Public Const gsFORM_PREFIX As String = "BET: Mail Merge Assistant - "
Public Const gsTOOLBAR_NAME As String = "BET: Mail Merge Assistant"
Public Const gsBUTTON_TAG As String = "MailMergeAssistantButton1"
Public gfrmMERGEFIELDS As frmMergeFields
Public gfrmMERGEFIELDS_mbFormFieldsProtection As Boolean
Public gbCheck_MergePatientData As Boolean
Enumerations_Return_TriState
vba
General_clsProcessing
Used to create a progress dialog box.Public Sub ProcessingUpdate()
Dim frmProcessingForm As frmProcessing
Set frmProcessingForm = New frmProcessing
Call frmProcessing.Display(Me) 'passes this class of clsProcessing
End Sub
'****************************************************************************************
Public Sub ProgressCallBack(frmProcessingForm As frmProcessing)
Application.StatusBar = "Please wait ..."
Call UpdateProcessBar(frmProcessingForm, "Connecting to database ...", 0.1)
' DO WHATEVER !!!
Call UpdateProcessBar(frmProcessingForm, "Disconnecting from database ...", 1.0)
Unload frmProcessingForm
Application.StatusBar = ""
If gbDEBUG = False Then Exit Sub
AnError:
End Sub
General_FindTarget
Returns ??.Public Function General_FindTarget(dVariableNumber As Double, _
dCurrentNumber As Double, _
dTargetNumber As Double, _
dDeltaAmount As Double, _
dAccuracy As Double, _
sNumberCell As String, _
sTargetCell As String) As Double
Dim dNewCurrent_above As Double
Dim dNewCurrent_below As Double
Dim dVariableNumber_above As Double
Dim dVariableNumber_below As Double
On Error GoTo AnError
dVariableNumber_above = dVariableNumber + dDeltaAmount
Range(sNumberCell).Value = dVariableNumber_above
ActiveSheet.Calculate
dNewCurrent_above = Range(sTargetCell).Value
dVariableNumber_below = dVariableNumber - dDeltaAmount
Range(sNumberCell).Value = dVariableNumber_below
ActiveSheet.Calculate
dNewCurrent_below = Range(sTargetCell).Value
If Abs(dTargetNumber - dNewCurrent_above) < Abs(dTargetNumber - dNewCurrent_below) Then
' so we need to increase the variable value
If (Abs(((dTargetNumber - dCurrentNumber) / _
dCurrentNumber)) < dAccuracy) Then
FindTarget = dVariableNumber
ActiveSheet.Calculate
Else
dDeltaAmount = (Abs(dTargetNumber - dNewCurrent_above) / _
Abs(Abs(dCurrentNumber) - Abs(dNewCurrent_above))) * dDeltaAmount
FindTarget = FindTarget(dVariableNumber_above, dNewCurrent_above, _
dTargetNumber, dDeltaAmount, dAccuracy, sNumberCell, sTargetCell)
End If
Else
' so Abs(dTargetNumber - dNewCurrent_below) < Abs(dTargetNumber - dNewCurrent_above)
' then a number smaller than the current is nearer
If (Abs(((dTargetNumber - dCurrentNumber) / _
dCurrentNumber)) < dAccuracy) Then
FindTarget = dVariableNumber
ActiveSheet.Calculate
Else
dDeltaAmount = (Abs(dTargetNumber - dNewCurrent_below) / _
Abs(Abs(dCurrentNumber) - Abs(dNewCurrent_below))) * dDeltaAmount
FindTarget = FindTarget(dVariableNumber_below, dNewCurrent_below, _
dTargetNumber, dDeltaAmount, dAccuracy, sNumberCell, sTargetCell)
End If
End If
If gbDEBUG = False Then Exit Function
AnError:
FindTarget = 0
Call Error_Handle("General_FindTarget", msMODULENAME, 1, _
"??????? Check with print out ")
End Function
General_FolderAllFiles
Performs the wrapper to execute a common task on all files within a particulr folder.Public Function General_FolderAllFiles(sFolderPath As String, _
Optional sExtension As String = ".xls") As Boolean
Dim soriginalwbk As String
Dim snextfile As String
Dim lfilecount As Long
Dim bcontinue As Boolean
On Error GoTo AnError
bcontinue = True
lfilecount = 1
sFolderPath = Folder_AddLine(sFolderPath)
If Folder_Exists(sFolderPath, True) = True Then
snextfile = File_AddExt(File_GetFirst(sFolderPath, sExtension), sExtension)
' Call Macro_SettingsEnable
Do While (bcontinue = True) And (snextfile <> "")
'--------------------------
lfilecount = lfilecount + 1
'--------------------------
snextfile = File_AddExt(File_GetNext(snextfile, sFolderPath), sExtension)
Loop
Else: bcontinue = False
End If
Call Macro_SettingsReset
General_FolderAllFiles = bcontinue
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("General_FolderAllFiles", msMODULENAME, 1, _
"perform the general operation on all the files" & _
" with extension """ & sExtension & """" & _
" in the folder " & vbcrlf & sFolderPath)
End Function
General_ForAllLinesInDocument
Performs a common teask on all the lines in a document.Public Sub General_ForAllLinesInDocument()
Const sPROCNAME As String = General_ForAllLinesInDocument"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
General_ForAllTablesInDocument
Performs a common task on all the tables in a document.Public Sub General_ForAllTablesInDocument()
Const sPROCNAME As String = "General_ForAllTablesInDocument"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
General_MultiplePSFiles
Combines multiple Postscript files into a single PDF file./PathName (T:/Bin/lynn/ps files 2/*.ps) def % Edit this to point to the folder
% containing the PS files.
/RunDir { % Uses PathName variable on the operand stack
{ /mysave save def % Performs a save before running the PS file
dup = flush % Shows name of PS file being run
RunFile % Calls built in Distiller procedure
clear cleardictstack % Cleans up after PS file
mysave restore % Restores save level
}
255 string
filenameforall
} def
PathName RunDir
Macro_Pause
Public Sub Macro_Pause( _
ByVal iPauseSeconds As Integer, _
Optional ByVal bUseStatusBar As Boolean = False, _
Optional ByVal bChangeCursor As Boolean = False)
Dim Start 'what is the type ??
On Error GoTo AnError
If bUseStatusBar = True Then
Application.StatusBar = "Macro has been paused for " & iPauseSeconds & " seconds ..."
End If
If bChangeCursor = True Then
Application.Cursor = xlWait
End If
Start = Timer 'retrieves the current time
Do While Timer < Start + iPauseSeconds
DoEvents 'does other things
Loop
Application.StatusBar = False
Application.Cursor = xlDefault
If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
Call Error_Handle("Macro_Pause", msMODULENAME, _
"pause the macro for " & iPauseSeconds & " seconds.")
End Sub
Macro_RunHasIt
Runs a given macro (with arguments) and return whether it was successful.Public Function Macro_RunHasIt(sMacroName As String) As Boolean
On Error GoTo AnError
Application.Run sMacroName
???? Application.Run macro:= sMacroName
??? Also need to include a macro with parameters
Macro_RunHasIt = True
If gbDEBUG = False Then Exit Function
AnError:
Macro_RunHasIt = False
End Function
Macro_SettingsEnable
Enables all the standard application settings when running a macro.Public Sub Macro_SettingsEnable()
On Error GoTo AnError
Application.StatusBar = False
' Application.Caption = Empty 'the name in the title bar
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Application.EnableCancelKey = xlInterrupt
' Application.EnableEvents = True
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Macro_SettingsEnable", msMODULENAME, 1, _
"enable the standard application settings for a macro")
End Sub
Macro_SettingsReset
Resets all the macro settings.Public Sub Macro_SettingsReset()
Const sPROCNAME As String = "Macro_SettingsReset"
On Error GoTo AnError
Application.StatusBar = False
Application.Caption = ""
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
MacroButton_Add
Adds a macrobutton to the current location. A double click will take you to a specific bookmark.Public Sub MacroButton_Add( _
ByVal sBookmarkName As Variant, _
ByVal sDisplayText As String, _
Optional ByVal bBold As Boolean = False, _
Optional ByVal bUnder As Boolean = False)
Const sPROCNAME As String = "MacroButton_Add"
On Error GoTo AnError
With Selection
.Fields.Add Selection.Range, wdFieldEmpty, _
"MACROBUTTON " & sBookmarkName & " " & sDisplayText, False
Call Field_Trim(sDisplayText, wdFieldMacroButton)
.MoveLeft wdCharacter, 1, wdExtend
.Font.ColorIndex = wdBlue
.Font.Bold = bBold
.Font.Underline = bUnder
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"add the macro button")
End Sub
Registry_AppSetting_Exists
vba
Registry_CompanyNameGet
vba
Registry_Create
vba
Registry_Delete
Public Sub Registry_Delete( _
ByVal sAppName As String, _
ByVal sSection As String, _
Optional ByVal sKey As String = "")
On Error GoTo AnError
If Len(sKey) > 0 Then Call DeleteSetting(sAppName, sSection, sKey)
If Len(sKey) = 0 Then Call DeleteSetting(sAppName, sSection)
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Registry_Delete", msMODULENAME, 1, _
"delete the entry from the Registry for" & vbCrLf & _
"Application: " & sAppName & vbCrLf & _
"Section: " & sSection & vbCrLf & _
"Key: " & sKey)
End Sub
Registry_EntryExists
vba
Registry_InstalledCorrectly
vba
Registry_InstallTopKeys
vba
Registry_KeyExists
vba
Registry_ListKeysToArray
vba
Registry_ListKeysToString
Public Function Registry_ListKeysToString( _
ByVal sAppName As String, _
ByVal sSection As String, _
ByVal sReturnValuePrefix As String, _
ByVal sConditionPrefix As String, _
ByVal sConditionValue As String) _
As String
On Error GoTo AnError
Dim ilisttotal As Integer
Dim ilistcount As Integer
Dim svaluesconcat As String
Dim sreturnvalue As String
Dim stestvalue As String
svaluesconcat = ""
Do While Len(CStr(Registry_Read(sAppName, sSection, _
sReturnValuePrefix & " " & ilisttotal + 1, ""))) > 0
ilisttotal = ilisttotal + 1
Loop
For ilistcount = 0 To (ilisttotal - 1)
sreturnvalue = CStr(Registry_Read(sAppName, sSection, _
sReturnValuePrefix & " " & ilistcount + 1))
stestvalue = CStr(Registry_Read(sAppName, sSection, _
sConditionPrefix & " " & ilistcount + 1))
If stestvalue = sConditionValue Then
svaluesconcat = svaluesconcat & sreturnvalue & ";"
End If
Next ilistcount
If Len(svaluesconcat) > 0 Then
svaluesconcat = Right(svaluesconcat, Len(svaluesconcat) - 1)
End If
Registry_ListKeysToString = svaluesconcat
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Registry_ListKeysToString", msMODULENAME, 1, _
"")
End Function
Registry_ListMatchValue
vba
Registry_ListToCheckListBox
vba
Registry_ListToComboBox
vba
Registry_ListToListBox
vba
Registry_ListUpdate
vba
Registry_Read
Returns the entry from the Registry given an application name, section and key.Public Function Registry_Read(ByVal sAppName As String, _
ByVal sSection As String, _
ByVal sKey As String, _
Optional ByVal sDefault As String = "") _
As String
On Error GoTo AnError
Registry_Read = GetSetting(sAppName, sSection, sKey, sDefault)
If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
Call Error_Handle("Registry_Read", msMODULENAME, _
"return the entry from the Registry for" & vbCrLf & _
"Application: " & sAppName & vbCrLf & _
"Section: " & sSection & vbCrLf & _
"Key: " & sKey)
End Function
Registry_Save
Public Function Registry_Save(ByVal sAppName As String, _
ByVal sSection As String, _
ByVal sKey As String, _
ByVal sValue As String)
On Error GoTo AnError
Call SaveSetting(sAppName, sSection, sKey, sValue)
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "Registry_Save", Err, _
"save this entry to the Registry for" & vbCrLf & _
"Application: " & sAppName & vbCrLf & _
"Section: " & sSection & vbCrLf & _
"Key: " & sKey & vbCrLf & _
"Value: " & sValue)
End Function
Registry_SectionExists
Public Function Registry_SectionExists(sAppName As String, _
sSection As String) As Boolean
Dim sreturn As String
On Error GoTo AnError
'NOT POSSIBLE !!!!
Registry_SectionExists = False
'Setting(sAppName, sSection)
If sreturn <> "nothing" Then Registry_SectionExists = True
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Registry_Delete", msMODULENAME, 1, _
"determine if the followng entry exists in the Registry:" & vbCrLf & _
"Application: " & sAppName & vbCrLf & _
"Section: " & sSection & vbCrLf & _
"Key: " & sKey)
End Function
Registry_WriteSubKeyValue
vba
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top