├── Files ├── frmInfo.frx ├── frmExample.frx ├── ExcelFormatCell.bas ├── tblInput.vb ├── ConstantsAndPublic.bas ├── ExcelDates.bas ├── frmInfo.frm ├── formExample.bas ├── frmExample.frm ├── formSummaryPresenter.cls ├── tddSpecSuite.cls ├── ExcelPrintToNotepad.bas ├── xl_main.vb ├── tddSpecDefinition.cls ├── tddMain.bas ├── VersionsAbout.bas ├── ExcelLastThings.bas ├── tddSpecInlineRunner.bas ├── ExcelAdditional.bas ├── ExcelVBE.bas ├── ExcelStructure.bas └── tddSpecExpectation.cls ├── Boilerplate_v8.0.3.xlsb ├── NewFilesToAdd ├── Folders.vb └── CopyWorksheet.vb ├── LICENSE └── readme.md /Files/frmInfo.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VBoilerplate/Boiler/HEAD/Files/frmInfo.frx -------------------------------------------------------------------------------- /Files/frmExample.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VBoilerplate/Boiler/HEAD/Files/frmExample.frx -------------------------------------------------------------------------------- /Boilerplate_v8.0.3.xlsb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VBoilerplate/Boiler/HEAD/Boilerplate_v8.0.3.xlsb -------------------------------------------------------------------------------- /Files/ExcelFormatCell.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VBoilerplate/Boiler/HEAD/Files/ExcelFormatCell.bas -------------------------------------------------------------------------------- /NewFilesToAdd/Folders.vb: -------------------------------------------------------------------------------- 1 | Public Function FolderIsEmpty(myPath As String) As Boolean 2 | 'Checks whether folder is empty 3 | FolderIsEmpty = CBool(Dir(myPath & "*.*") = "") 4 | 5 | End Function 6 | -------------------------------------------------------------------------------- /Files/tblInput.vb: -------------------------------------------------------------------------------- 1 | Private Sub Worksheet_SelectionChange(ByVal Target As Range) 2 | 3 | If ActiveWindow.Zoom > 100 Or ActiveWindow.Zoom < 70 Then 4 | ActiveWindow.Zoom = 100 5 | End If 6 | 7 | End Sub 8 | -------------------------------------------------------------------------------- /Files/ConstantsAndPublic.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ConstantsAndPublic" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Const SET_IN_PRODUCTION = True 6 | Public Const WORKSHEET_UNPROTECT_PASSWORD = "shouldistayorshouldigo" 'I am never using this password anywhere, do not bother ;) 7 | Public Const ADMINS = "vitosh:vitos" 8 | Public Const CON_STR_APP_NAME = "Boilerplate VitoshAcademy" 9 | Public Const CON_STR_INSTANCES_LOG = "More then one Workbook is opened in this Excel instance." 10 | Public Const CON_STR_1904 = "You are using 1904 date system. This is probably* not what you need." 11 | 12 | 'Public variables are a bad practice and should be avoided in general... 13 | Public PUB_STR_ERROR_REPORT As String 14 | -------------------------------------------------------------------------------- /Files/ExcelDates.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelDates" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Function GetLastDayOfMonth(ByVal myDate As Date) As Date 6 | GetLastDayOfMonth = DateSerial(Year(myDate), Month(myDate) + 1, 0) 7 | End Function 8 | 9 | Public Function GetFirstDayOfMonth(ByVal myDate As Date) As Date 10 | GetFirstDayOfMonth = DateSerial(Year(myDate), Month(myDate), 1) 11 | End Function 12 | 13 | Public Function AddMonths(ByVal myDate As Date, ByVal lngMonth As Long) As Date 14 | AddMonths = GetLastDayOfMonth(DateAdd("m", lngMonth, myDate)) 15 | End Function 16 | 17 | Public Function AddMonthsAndGetFirstDate(ByVal my_date As Date, ByVal lngMonth As Long) As Date 18 | AddMonthsAndGetFirstDate = GetFirstDayOfMonth(DateAdd("m", lngMonth, my_date)) 19 | End Function 20 | 21 | Public Function DateDiffInMonths(a As Date, b As Date) As Long 22 | DateDiffInMonths = DateDiff("m", a, b) 23 | End Function 24 | -------------------------------------------------------------------------------- /Files/frmInfo.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmInfo 3 | ClientHeight = 1440 4 | ClientLeft = -156 5 | ClientTop = -564 6 | ClientWidth = 2772 7 | OleObjectBlob = "frmInfo.frx":0000 8 | StartUpPosition = 1 'Fenstermitte 9 | End 10 | Attribute VB_Name = "frmInfo" 11 | Attribute VB_GlobalNameSpace = False 12 | Attribute VB_Creatable = False 13 | Attribute VB_PredeclaredId = True 14 | Attribute VB_Exposed = False 15 | Option Explicit 16 | 17 | Private Sub UserForm_Initialize() 18 | 19 | If PUB_STR_ERROR_REPORT Then 20 | Me.lblInformation = CON_STR_INSTANCES_LOG 21 | End If 22 | 23 | With Me 24 | .StartUpPosition = 0 25 | .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width) 26 | .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height) 27 | .caption = CON_STR_APP_NAME 28 | End With 29 | 30 | End Sub 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 VBoilerplate 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Files/formExample.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "formExample" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Private presenter As formSummaryPresenter 6 | 7 | Public Sub FormExampleMain() 8 | 9 | presenter.ChangeLabelAndCaption "Starting and running...", "Running..." 10 | GenerateNumbers 11 | 12 | End Sub 13 | 14 | Public Sub GenerateNumbers(Optional outerLoopLimit As Long = 2, Optional innerLoopLimit As Long = 4) 15 | 16 | Dim a As Long 17 | Dim b As Long 18 | 19 | For a = 1 To outerLoopLimit 20 | For b = 1 To innerLoopLimit 21 | Debug.Print a * b 22 | Next 23 | Next 24 | Debug.Print "-------END-------" & vbCrLf & Now 25 | 26 | End Sub 27 | 28 | Public Sub ShowMainForm() 29 | 30 | If (presenter Is Nothing) Then 31 | Set presenter = New formSummaryPresenter 32 | End If 33 | 34 | presenter.Show 35 | 36 | End Sub 37 | 38 | Public Sub CheckHowManyWbAreOpened() 39 | 40 | On Error GoTo CheckHowManyWbAreOpened_Error 41 | 42 | If Workbooks.Count > 1 Then 43 | PUB_STR_ERROR_REPORT = True 44 | frmInfo.Show (vbModeless) 45 | Application.Wait (Now + TimeValue("00:00:02")) 46 | Unload frmInfo 47 | End If 48 | 49 | PUB_STR_ERROR_REPORT = False 50 | 51 | On Error GoTo 0 52 | Exit Sub 53 | 54 | CheckHowManyWbAreOpened_Error: 55 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckHowManyWbAreOpened of Sub DieseArbeitsmappe" 56 | 57 | End Sub 58 | 59 | -------------------------------------------------------------------------------- /Files/frmExample.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmExample 3 | Caption = "UserForm1" 4 | ClientHeight = 4404 5 | ClientLeft = -12 6 | ClientTop = 120 7 | ClientWidth = 5388 8 | OleObjectBlob = "frmExample.frx":0000 9 | StartUpPosition = 1 'Fenstermitte 10 | End 11 | Attribute VB_Name = "frmExample" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Option Explicit 17 | 18 | Public Event OnRunReport() 19 | Public Event OnExit() 20 | 21 | Public Property Get InformationText() As String 22 | 23 | InformationText = lblInfo.caption 24 | 25 | End Property 26 | 27 | Public Property Let InformationText(ByVal value As String) 28 | 29 | lblInfo.caption = value 30 | 31 | End Property 32 | 33 | Public Property Get InformationCaption() As String 34 | 35 | InformationCaption = caption 36 | 37 | End Property 38 | 39 | Public Property Let InformationCaption(ByVal value As String) 40 | 41 | caption = value 42 | 43 | End Property 44 | 45 | Private Sub btnRun_Click() 46 | 47 | RaiseEvent OnRunReport 48 | 49 | End Sub 50 | 51 | Private Sub btnExit_Click() 52 | 53 | RaiseEvent OnExit 54 | 55 | End Sub 56 | 57 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 58 | 59 | If CloseMode = vbFormControlMenu Then 60 | Cancel = True 61 | Hide 62 | End If 63 | 64 | End Sub 65 | -------------------------------------------------------------------------------- /Files/formSummaryPresenter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "formSummaryPresenter" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | Private WithEvents summaryForm As frmExample 13 | Attribute summaryForm.VB_VarHelpID = -1 14 | 15 | Private Sub Class_Initialize() 16 | 17 | Set summaryForm = New frmExample 18 | 19 | End Sub 20 | 21 | Private Sub Class_Terminate() 22 | 23 | Set summaryForm = Nothing 24 | 25 | End Sub 26 | 27 | Public Sub Show() 28 | 29 | If Not summaryForm.Visible Then 30 | summaryForm.Show vbModeless 31 | ChangeLabelAndCaption "Press Run to Start", "Starting" 32 | End If 33 | 34 | With summaryForm 35 | .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2) 36 | .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2) 37 | .caption = CON_STR_APP_NAME 38 | End With 39 | 40 | End Sub 41 | 42 | Private Sub Hide() 43 | 44 | If summaryForm.Visible Then summaryForm.Hide 45 | 46 | End Sub 47 | 48 | Public Sub ChangeLabelAndCaption(labelInfo As String, caption As String) 49 | 50 | summaryForm.InformationText = labelInfo 51 | summaryForm.InformationCaption = caption 52 | summaryForm.Repaint 53 | 54 | End Sub 55 | 56 | Private Sub summaryForm_OnRunReport() 57 | 58 | FormExampleMain 59 | Refresh 60 | 61 | End Sub 62 | 63 | Private Sub summaryForm_OnExit() 64 | 65 | Hide 66 | 67 | End Sub 68 | 69 | Public Sub Refresh() 70 | 71 | With summaryForm 72 | .lblInfo = "Ready" 73 | .caption = "Task performed" 74 | End With 75 | 76 | End Sub 77 | -------------------------------------------------------------------------------- /NewFilesToAdd/CopyWorksheet.vb: -------------------------------------------------------------------------------- 1 | Public Sub CopyWorksheet(wksName As String) 2 | 3 | Dim newName As String 4 | newName = wksName & "_w" 5 | 6 | If WorksheetNameIsPresent(newName) Then 7 | Application.DisplayAlerts = False 8 | Worksheets(newName).Delete 9 | Application.DisplayAlerts = True 10 | End If 11 | 12 | Dim wks As Worksheet 13 | Dim newWks As Worksheet 14 | 15 | Set wks = Worksheets(wksName) 16 | wks.Copy after:=Worksheets(Worksheets.Count) 17 | Set newWks = Worksheets.Item(Worksheets.Count) 18 | 19 | With newWks 20 | .Name = newName 21 | .Tab.Color = vbBlue 22 | End With 23 | 24 | End Sub 25 | 26 | Public Function WorksheetNameIsPresent(newName As String) As Boolean 27 | 28 | Dim wks As Worksheet 29 | For Each wks In ThisWorkbook.Worksheets 30 | If wks.Name = newName Then 31 | WorksheetNameIsPresent = True 32 | Exit Function 33 | End If 34 | Next wks 35 | WorksheetNameIsPresent = False 36 | 37 | End Function 38 | 39 | Public Sub CopyWorksheets() 40 | 41 | Dim wksCollection As New Collection 42 | 43 | wksCollection.Add ThisWorkbook.Worksheets("VitoshAcademy") 44 | wksCollection.Add ThisWorkbook.Worksheets("Academy") 45 | wksCollection.Add ThisWorkbook.Worksheets("Vitosh") 46 | 47 | Dim wks As Worksheet 48 | Dim newWks As Worksheet 49 | 50 | For Each wks In wksCollection 51 | Dim newName As String 52 | newName = wks.Name & "_w" 53 | 54 | If WorksheetNameIsPresent(newName) Then 55 | Application.DisplayAlerts = False 56 | Worksheets(newName).Delete 57 | Application.DisplayAlerts = True 58 | End If 59 | 60 | wks.Copy after:=Worksheets(Worksheets.Count) 61 | Set newWks = Worksheets.Item(Worksheets.Count) 62 | 63 | With newWks 64 | .Name = newName 65 | .Tab.Color = vbRed 66 | End With 67 | Next wks 68 | 69 | End Sub 70 | -------------------------------------------------------------------------------- /Files/tddSpecSuite.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tddSpecSuite" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Private pSpecsCol As Collection 13 | 14 | Public Description As String 15 | Public BeforeEachCallback As String 16 | Public BeforeEachCallbackArgs As Variant 17 | Private pCounter As Long 18 | 19 | Public Property Get SpecsCol() As Collection 20 | 21 | If pSpecsCol Is Nothing Then: Set pSpecsCol = New Collection 22 | Set SpecsCol = pSpecsCol 23 | 24 | End Property 25 | 26 | Public Property Let SpecsCol(value As Collection) 27 | 28 | Set pSpecsCol = value 29 | 30 | End Property 31 | 32 | Public Function It(Description As String, Optional SpecId As String = "") As tddSpecDefinition 33 | 34 | Dim Spec As New tddSpecDefinition 35 | 36 | pCounter = pCounter + 1 37 | ExecuteBeforeEach 38 | Spec.Description = Description 39 | Spec.Id = SpecId 40 | Me.SpecsCol.Add Spec 41 | Set It = Spec 42 | 43 | End Function 44 | 45 | Public Sub TotalTests() 46 | 47 | Debug.Print "Total tests:" & pCounter 48 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "Total tests:" & pCounter & vbCrLf 49 | 50 | End Sub 51 | 52 | Public Sub BeforeEach(Callback As String, ParamArray CallbackArgs() As Variant) 53 | Me.BeforeEachCallback = Callback 54 | Me.BeforeEachCallbackArgs = CallbackArgs 55 | End Sub 56 | 57 | Private Sub ExecuteBeforeEach() 58 | 59 | If Me.BeforeEachCallback <> "" Then 60 | Dim HasArguments As Boolean 61 | If VarType(Me.BeforeEachCallbackArgs) = vbObject Then 62 | If Not Me.BeforeEachCallbackArgs Is Nothing Then 63 | HasArguments = True 64 | End If 65 | ElseIf IsArray(Me.BeforeEachCallbackArgs) Then 66 | If UBound(Me.BeforeEachCallbackArgs) >= 0 Then 67 | HasArguments = True 68 | End If 69 | End If 70 | 71 | If HasArguments Then 72 | Application.Run Me.BeforeEachCallback, Me.BeforeEachCallbackArgs 73 | Else 74 | Application.Run Me.BeforeEachCallback 75 | End If 76 | End If 77 | 78 | End Sub 79 | 80 | -------------------------------------------------------------------------------- /Files/ExcelPrintToNotepad.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelPrintToNotepad" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Sub PrintToNotepad(Optional dataToPrint As String = "") 6 | 7 | If SET_IN_PRODUCTION Then On Error GoTo CreateLogFile_Error 8 | 9 | Dim fileSystem As Object 10 | Dim textObject As Object 11 | Dim fileName As String 12 | Dim newFile As String 13 | Dim shellPath As String 14 | 15 | newFile = "\Info" 16 | 17 | fileName = ThisWorkbook.path & newFile & CodifyTime(True) 18 | If Dir(ThisWorkbook.path & newFile, vbDirectory) = vbNullString Then MkDir ThisWorkbook.path & newFile 19 | 20 | Set fileSystem = CreateObject("Scripting.FileSystemObject") 21 | Set textObject = fileSystem.CreateTextFile(fileName, True) 22 | 23 | If dataToPrint <> "" Then 24 | textObject.WriteLine dataToPrint 25 | Else 26 | textObject.WriteLine PUB_STR_ERROR_REPORT 27 | End If 28 | 29 | textObject.Close 30 | 31 | shellPath = "C:\WINDOWS\notepad.exe " 32 | shellPath = shellPath & fileName 33 | shell shellPath 34 | 35 | On Error GoTo 0 36 | Exit Sub 37 | 38 | CreateLogFile_Error: 39 | 40 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" 41 | 42 | End Sub 43 | 44 | Public Function CodifyTime(Optional makeString As Boolean = False) As String 45 | 46 | If SET_IN_PRODUCTION Then On Error GoTo codify_Error 47 | 48 | Dim leftPart As Variant 49 | Dim rightPart As Variant 50 | Dim initialTime As Double 51 | 52 | initialTime = Round(Now(), 8) 53 | 54 | leftPart = Split(CStr(initialTime), ".")(0) 55 | rightPart = Split(CStr(initialTime), ".")(1) 56 | 57 | CodifyTime = Hex(leftPart) & "_" & Hex(rightPart) 58 | 59 | If makeString Then CodifyTime = "\" & CodifyTime & ".txt" 60 | 61 | On Error GoTo 0 62 | Exit Function 63 | 64 | codify_Error: 65 | 66 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" 67 | 68 | End Function 69 | 70 | Public Function DecodifyTime(hexTime As String) As String 71 | 72 | Dim leftPart As Variant 73 | Dim rightPart As Variant 74 | 75 | leftPart = Split(hexTime, "_")(0) 76 | rightPart = Split(hexTime, "_")(1) 77 | 78 | DecodifyTime = CLng("&H" & leftPart) & "." & CLng("&H" & rightPart) 79 | 80 | End Function 81 | -------------------------------------------------------------------------------- /Files/xl_main.vb: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | 3 | Private Sub Workbook_BeforeClose(Cancel As Boolean) 4 | 5 | On Error GoTo Workbook_BeforeClose_Error 6 | 7 | If Not SET_IN_PRODUCTION Then 8 | MsgBox "SET_IN_PRODUCTION" 9 | On Error GoTo 0 10 | Cancel = True 11 | End If 12 | 13 | Cancel = False 14 | 15 | ThisWorkbook.Save 16 | 17 | Application.DisplayAlerts = False 18 | HideNeededWorksheets 19 | Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" 20 | Application.DisplayAlerts = True 21 | ActiveWindow.DisplayHeadings = True 22 | Application.DisplayFormulaBar = True 23 | 'ActiveSheet.PageSetup.BlackAndWhite = True 24 | Me.Save 25 | 26 | EnableMySaves 27 | 28 | On Error GoTo 0 29 | Exit Sub 30 | 31 | Workbook_BeforeClose_Error: 32 | 33 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_BeforeClose" 34 | 35 | End Sub 36 | 37 | Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 38 | 39 | If Not SET_IN_PRODUCTION Then 40 | MsgBox "SET_IN_PRODUCTION", vbInformation, CON_STR_APP_NAME 41 | Cancel = True 42 | End If 43 | 44 | End Sub 45 | 46 | Private Sub Workbook_NewSheet(ByVal Sh As Object) 47 | 48 | If Not tblSettings.Visible Then 49 | With Application 50 | Application.ScreenUpdating = False 51 | Application.DisplayAlerts = False 52 | Sh.Delete 53 | Application.DisplayAlerts = True 54 | Application.ScreenUpdating = True 55 | End With 56 | 57 | MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, ThisWorkbook.Name 58 | End If 59 | 60 | End Sub 61 | 62 | Private Sub Workbook_Open() 63 | 64 | On Error GoTo Workbook_Open_Error 65 | 66 | HideNeededWorksheets 67 | 'Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" 68 | 'Application.DisplayFormulaBar = False 69 | 70 | If Not IsValueInArray(Environ("username"), ADMINS, True) Then 71 | Application.OnKey "%{F11}", "DisabledCombination" 72 | End If 73 | 74 | DisableShortcutsAndSaves 75 | 76 | If ThisWorkbook.Date1904 Then 77 | MsgBox CON_STR_1904, vbInformation, CON_STR_APP_NAME 78 | End If 79 | 80 | Application.WindowState = xlMaximized 81 | 82 | CheckHowManyWbAreOpened 83 | 84 | On Error GoTo 0 85 | Exit Sub 86 | 87 | Workbook_Open_Error: 88 | 89 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open" 90 | Me.Save 91 | ThisWorkbook.Close 92 | 93 | End Sub 94 | -------------------------------------------------------------------------------- /Files/tddSpecDefinition.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tddSpecDefinition" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Private pExpectations As Collection 13 | Private pFailedExpectations As Collection 14 | Public Description As String 15 | Public Id As String 16 | 17 | Public Enum SpecResult 18 | Pass 19 | Fail 20 | Pending 21 | End Enum 22 | 23 | Public Property Get Expectations() As Collection 24 | 25 | If pExpectations Is Nothing Then 26 | Set pExpectations = New Collection 27 | End If 28 | Set Expectations = pExpectations 29 | 30 | End Property 31 | 32 | Private Property Let Expectations(value As Collection) 33 | 34 | Set pExpectations = value 35 | 36 | End Property 37 | 38 | Public Property Get FailedExpectations() As Collection 39 | 40 | If pFailedExpectations Is Nothing Then 41 | Set pFailedExpectations = New Collection 42 | End If 43 | Set FailedExpectations = pFailedExpectations 44 | 45 | End Property 46 | 47 | Private Property Let FailedExpectations(value As Collection) 48 | Set pFailedExpectations = value 49 | End Property 50 | 51 | Public Function Expect(Optional value As Variant) As tddSpecExpectation 52 | 53 | Dim Exp As New tddSpecExpectation 54 | 55 | If VarType(value) = vbObject Then 56 | Set Exp.Actual = value 57 | Else 58 | Exp.Actual = value 59 | End If 60 | Me.Expectations.Add Exp 61 | 62 | Set Expect = Exp 63 | 64 | End Function 65 | 66 | Public Function Result() As SpecResult 67 | 68 | Dim Exp As tddSpecExpectation 69 | 70 | FailedExpectations = New Collection 71 | If Me.Expectations.Count < 1 Then 72 | Result = Pending 73 | Else 74 | For Each Exp In Me.Expectations 75 | If Exp.Result = Fail Then 76 | FailedExpectations.Add Exp 77 | End If 78 | Next Exp 79 | 80 | If Me.FailedExpectations.Count > 0 Then 81 | Result = Fail 82 | Else 83 | Result = Pass 84 | End If 85 | End If 86 | 87 | End Function 88 | 89 | Public Function ResultName() As String 90 | 91 | Select Case Me.Result 92 | Case Pass: 93 | ResultName = "Pass" 94 | Case Fail: 95 | ResultName = "Fail" 96 | Case Pending: 97 | ResultName = "Pending" 98 | End Select 99 | 100 | End Function 101 | 102 | -------------------------------------------------------------------------------- /Files/tddMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "tddMain" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Sub Tdd(Optional export As Boolean = False) 6 | 7 | On Error Resume Next 8 | 9 | Dim specs As New tddSpecSuite 10 | 11 | Debug.Print "Test report from " & Environ("Username") & vbCrLf & "START: " & Now() & vbCrLf 12 | PUB_STR_ERROR_REPORT = "Test report from " & Environ("Username") & vbCrLf & "START: " & Now() & vbCrLf 13 | '--------------------- 14 | 'Tests start here ---v 15 | 'Test Scenario #1 16 | TestMeSample 17 | Dim myarr(16) As Variant 18 | Dim arrCounter As Long 19 | Dim myCell As Range 20 | 21 | myarr(1) = 1.81859485365136 22 | myarr(2) = -4.79462137331569 23 | myarr(3) = -0.713935644387188 24 | myarr(4) = -8.38308001079428 25 | myarr(5) = 24.9643391023361 26 | myarr(6) = -27.4617351821139 27 | myarr(7) = 64.2321735505502 28 | myarr(8) = -88.9405995522673 29 | myarr(9) = -127.858501929498 30 | myarr(10) = 101.737867039937 31 | myarr(11) = 146.707455130634 32 | myarr(12) = -120.333197895024 33 | myarr(13) = 772.275323251858 34 | myarr(14) = 1129.5172126244 35 | myarr(15) = 1312.97247658607 36 | myarr(16) = -349.11864840751 37 | 38 | For Each myCell In tblInput.Range("A1:B8") 39 | Increment arrCounter 40 | specs.It("Scenario 1." & CStr(arrCounter)).Expect(myarr(arrCounter)).ToEqual myCell.value 41 | Next myCell 42 | 43 | 'Test Scenario #2 44 | specs.It("Scenario 2.1").Expect(SumArray(Array(1, 2, 3))).ToEqual 6 45 | specs.It("Scenario 2.2").Expect(SumArray(Array(3, 3, 3))).ToEqual 9 46 | specs.It("Scenario 2.3").Expect(SumArray(Array(3, 4, 3))).ToNotEqual 9 47 | specs.It("Scenario 2.4").Expect(SumArray(Array(3, 3, 100), 1)).ToEqual 6 48 | specs.It("Scenario 2.5").Expect(SumArray(Array(3, 3, 100))).ToEqual 106 49 | specs.It("Scenario 2.6").Expect(SumArray(Array(-3, -3))).ToEqual -6 50 | 51 | 'Tests Scenario #3 52 | specs.It("Scenario 3.1").Expect(ColumnNumberToLetter(26)).ToEqual "Z" 53 | specs.It("Scenario 3.2").Expect(ColumnNumberToLetter(1)).ToEqual "A" 54 | 55 | '--------------------- 56 | 'Tests end here -----^ 57 | tddSpecInlineRunner.RunSuite specs 58 | specs.TotalTests 59 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "END: " & Now() & vbCrLf 60 | Debug.Print "END: " & Now() & vbCrLf 61 | If export Then PrintToNotepad 62 | On Error GoTo 0 63 | 64 | End Sub 65 | 66 | Public Sub MakeAllValues() 67 | 68 | Dim myCell As Range 69 | Dim i As Long 70 | Dim str As String 71 | 72 | For Each myCell In Selection 73 | Increment i 74 | str = vbTab & "myArr(" & i & ")= " 75 | 76 | If Len(myCell) > 0 Then 77 | If IsDate(myCell) Then 78 | str = str & "CDate(""" & myCell & """)" 79 | Else 80 | If Not IsNumeric(myCell) Then 81 | str = str & """" & myCell & """" 82 | Else 83 | str = str & ChangeCommas(myCell.value) 84 | End If 85 | End If 86 | Else 87 | If myCell.HasFormula Then 88 | str = str & """""" 89 | Else 90 | str = str & 0 91 | End If 92 | End If 93 | 94 | Debug.Print str 95 | Next myCell 96 | 97 | End Sub 98 | 99 | Sub TestMeSample() 100 | 101 | Dim myCell As Range 102 | Dim myVal As Variant 103 | 104 | For Each myCell In tblInput.Range("A1:B8") 105 | myVal = myVal * 1.5 + 2 106 | myCell = myVal * Sin(myVal) 107 | Next 108 | 109 | End Sub 110 | 111 | -------------------------------------------------------------------------------- /Files/VersionsAbout.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VersionsAbout" 2 | Option Explicit 3 | Option Private Module 4 | 5 | '================================================================================================================== 6 | '=======================================CREDITS==================================================================== 7 | '================================================================================================================== 8 | 'TDD classes are taken with some changes from: 9 | ' https://github.com/VBA-tools/vba-test 10 | 'Form ideas are from: 11 | ' https://www.vitoshacademy.com/vba-the-perfect-userform-in-vba/ 12 | ' https://codereview.stackexchange.com/questions/154401/handling-dialog-closure-in-a-vba-user-form 13 | 'Most of the code is present also at: 14 | ' https://github.com/Vitosh/VBA_personal 15 | 'The offisial site and GitHub repo of the Boilerplate: 16 | ' https://www.vitoshacademy.com/boilerplate 17 | ' https://github.com/Vitosh/VBA_personal/tree/master/Boilerplate 18 | '================================================================================================================== 19 | '=======================================VERSIONS=================================================================== 20 | '================================================================================================================== 21 | 'Boiler Plate Version 8.0.3: 22 | ' Vitosh - 23.12.2019 23 | ' 24 | ' Minor fixes: 25 | ' - Fix RangeIsZeroOrEmpty 26 | ' - Fix the credits with the correct url 27 | ' - Fix spaces, remove some lines, fix variables 28 | ' - Adding "DecodifyTime" to return "CodifyTime" back 29 | '------------------------------------------------------------------------------------------------------------------- 30 | '------------------------------------------------------------------------------------------------------------------- 31 | '------------------------------------------------------------------------------------------------------------------- 32 | 'Boiler Plate Version 8.0.: 33 | ' Vitosh - 19.12.2019 34 | ' 35 | ' Openning the project, removing the password 36 | ' Trying to remove words like "Call" and fix variables names 37 | ' Structuring the code (that's a lot!) 38 | '------------------------------------------------------------------------------------------------------------------- 39 | '------------------------------------------------------------------------------------------------------------------- 40 | '------------------------------------------------------------------------------------------------------------------- 41 | 'Boiler Plate Version 7.0.: 42 | ' Vitosh - 16.03.2017 43 | ' 44 | ' Add CON_STR_APP_NAME = "Boilerplate Project Name" 45 | ' A new form, with a new class is implemented 46 | ' Change to xlsb 47 | ' Move all named ranges from Settings as Constants 48 | '------------------------------------------------------------------------------------------------------------------- 49 | '------------------------------------------------------------------------------------------------------------------- 50 | '------------------------------------------------------------------------------------------------------------------- 51 | 'Boiler Plate Version 6.0.: 52 | ' Vitosh - 01.2017 53 | ' 54 | ' Check for more opened instances 55 | ' TDD implemented 56 | ' Standard Functions and subs 57 | ' On openning: 58 | ' fixing outlook 59 | ' hiding whatever possible 60 | ' checking for another instance opened 61 | ' frmInfo with lblInfo is present 62 | ' adding new sheet is disabled 63 | ' beforeclose sheet function is present 64 | '================================================================================================================== 65 | '=======================================THANK YOU (YES, YOU!)====================================================== 66 | '================================================================================================================== 67 | 'As far as you are looking into these credits, most probably you are a VBA developer! 68 | ' 69 | 'As a VBA developer, you have probably heard hundres of times that you are not a real developer or anything 70 | 'like this from random people - from high end clean code gurus to java guys, who learned about programming 71 | 'some 2 weeks ago. Anyway, it does not matter. You are a developer! (and don't listen to these guys, most of them 72 | 'are deeply confused in general) 73 | ' 74 | ' Thank you for all the awesome #VBA code you have written! 75 | ' It matters! You matter! 76 | ' Stay awesome! 77 | -------------------------------------------------------------------------------- /Files/ExcelLastThings.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelLastThings" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Function LastColumn(wsName As String, Optional rowToCheck As Long = 1) As Long 6 | 7 | Dim ws As Worksheet 8 | Set ws = ThisWorkbook.Worksheets(wsName) 9 | LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column 10 | 11 | End Function 12 | 13 | Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long 14 | 15 | Dim ws As Worksheet 16 | Set ws = ThisWorkbook.Worksheets(wsName) 17 | LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row 18 | 19 | End Function 20 | 21 | Public Function LastUsedColumn(wsName As String) As Long 22 | 23 | Dim ws As Worksheet 24 | Set ws = ThisWorkbook.Worksheets(wsName) 25 | Dim lastCell As Range 26 | 27 | Set lastCell = ActiveSheet.Cells.Find(What:="*", _ 28 | After:=ActiveSheet.Cells(1, 1), _ 29 | LookIn:=xlFormulas, _ 30 | LookAt:=xlPart, _ 31 | SearchOrder:=xlByColumns, _ 32 | SearchDirection:=xlPrevious, _ 33 | MatchCase:=False) 34 | 35 | LastUsedColumn = lastCell.Column 36 | 37 | End Function 38 | 39 | Public Function LastUsedRow(wsName As String) As Long 40 | 41 | Dim ws As Worksheet 42 | Set ws = ThisWorkbook.Worksheets(wsName) 43 | Dim lastCell As Range 44 | 45 | Set lastCell = ActiveSheet.Cells.Find(What:="*", _ 46 | After:=ActiveSheet.Cells(1, 1), _ 47 | LookIn:=xlFormulas, _ 48 | LookAt:=xlPart, _ 49 | SearchOrder:=xlByRows, _ 50 | SearchDirection:=xlPrevious, _ 51 | MatchCase:=False) 52 | 53 | LastUsedRow = lastCell.Row 54 | 55 | End Function 56 | 57 | Public Function LocateValueRow(ByVal textTarget As String, _ 58 | ByRef wksTarget As Worksheet, _ 59 | Optional col As Long = 1, _ 60 | Optional moreValuesFound As Long = 1, _ 61 | Optional lookForPart = False, _ 62 | Optional lookUpToBottom = True) As Long 63 | 64 | Dim valuesFound As Long 65 | Dim localRange As Range 66 | Dim myCell As Range 67 | Dim lastRowOnColumn1 As Long 68 | 69 | LocateValueRow = -999 70 | 71 | valuesFound = moreValuesFound 72 | lastRowOnColumn1 = LastRow(wksTarget.Name) 73 | 74 | 75 | Set localRange = wksTarget.Range(wksTarget.Cells(1, col), wksTarget.Cells(lastRowOnColumn1, col)) 76 | 77 | For Each myCell In localRange 78 | If lookForPart Then 79 | If UCase(textTarget) = UCase(Left(myCell, Len(textTarget))) Then 80 | If valuesFound = 1 Then 81 | LocateValueRow = myCell.Row 82 | If lookUpToBottom Then Exit Function 83 | Else 84 | Decrement valuesFound 85 | End If 86 | End If 87 | Else 88 | If UCase(textTarget) = UCase(Trim(myCell)) Then 89 | If valuesFound = 1 Then 90 | LocateValueRow = myCell.Row 91 | If lookUpToBottom Then Exit Function 92 | Else 93 | Decrement valuesFound 94 | End If 95 | End If 96 | End If 97 | Next myCell 98 | 99 | End Function 100 | 101 | Public Function LocateValueCol(ByVal textTarget As String, _ 102 | ByRef wksTarget As Worksheet, _ 103 | Optional rowNeeded As Long = 1, _ 104 | Optional moreValuesFound As Long = 1, _ 105 | Optional lookForPart = False, _ 106 | Optional lookUpToBottom = True) As Long 107 | 108 | Dim valuesFound As Long 109 | Dim localRange As Range 110 | Dim myCell As Range 111 | 112 | LocateValueCol = -999 113 | valuesFound = moreValuesFound 114 | Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count)) 115 | 116 | For Each myCell In localRange 117 | If lookForPart Then 118 | If textTarget = Left(myCell, Len(textTarget)) Then 119 | If valuesFound = 1 Then 120 | LocateValueCol = myCell.Column 121 | If lookUpToBottom Then Exit Function 122 | Else 123 | Decrement valuesFound 124 | End If 125 | End If 126 | Else 127 | If textTarget = Trim(myCell) Then 128 | If valuesFound = 1 Then 129 | LocateValueCol = myCell.Column 130 | If lookUpToBottom Then Exit Function 131 | Else 132 | Decrement valuesFound 133 | End If 134 | End If 135 | End If 136 | Next myCell 137 | 138 | End Function 139 | 140 | Public Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1) 141 | valueToIncrement = valueToIncrement + incrementWith 142 | End Sub 143 | 144 | Public Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1) 145 | valueToDecrement = valueToDecrement - decrementWith 146 | End Sub 147 | -------------------------------------------------------------------------------- /Files/tddSpecInlineRunner.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "tddSpecInlineRunner" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Sub RunSuite(specs As tddSpecSuite, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = False) 6 | 7 | Dim SuiteCol As New Collection 8 | 9 | SuiteCol.Add specs 10 | RunSuites SuiteCol, ShowFailureDetails, ShowPassed, ShowSuiteDetails 11 | 12 | End Sub 13 | 14 | Public Sub RunSuites(SuiteCol As Collection, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = True) 15 | 16 | Dim Suite As tddSpecSuite 17 | Dim Spec As tddSpecDefinition 18 | Dim TotalCount As Long 19 | Dim FailedSpecs As Long 20 | Dim PendingSpecs As Long 21 | Dim ShowingResults As Boolean 22 | Dim Indentation As String 23 | 24 | For Each Suite In SuiteCol 25 | If Not Suite Is Nothing Then 26 | TotalCount = TotalCount + Suite.SpecsCol.Count 27 | 28 | For Each Spec In Suite.SpecsCol 29 | If Spec.Result = SpecResult.Fail Then 30 | FailedSpecs = FailedSpecs + 1 31 | ElseIf Spec.Result = SpecResult.Pending Then 32 | PendingSpecs = PendingSpecs + 1 33 | End If 34 | Next Spec 35 | End If 36 | Next Suite 37 | 38 | Debug.Print "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & Now & " =========================" 39 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & Now & " =========================" & vbCrLf 40 | 41 | For Each Suite In SuiteCol 42 | If Not Suite Is Nothing Then 43 | If ShowSuiteDetails Then 44 | Debug.Print SuiteMessage(Suite) 45 | Indentation = " " 46 | ShowingResults = True 47 | Else 48 | Indentation = "" 49 | End If 50 | 51 | For Each Spec In Suite.SpecsCol 52 | If Spec.Result = SpecResult.Fail Then 53 | Debug.Print Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) 54 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) & vbCrLf 55 | ShowingResults = True 56 | ElseIf Spec.Result = SpecResult.Pending Then 57 | Debug.Print Indentation & PendingMessage(Spec) 58 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PendingMessage(Spec) & vbCrLf 59 | ShowingResults = True 60 | ElseIf ShowPassed Then 61 | Debug.Print Indentation & PassingMessage(Spec) 62 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PassingMessage(Spec) & vbCrLf 63 | ShowingResults = True 64 | End If 65 | Next Spec 66 | End If 67 | Next Suite 68 | 69 | If ShowingResults Then 70 | Debug.Print "===" 71 | PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "===" & vbCrLf 72 | End If 73 | 74 | End Sub 75 | 76 | Private Function SummaryMessage(TotalCount As Long, FailedSpecs As Long, PendingSpecs As Long) As String 77 | 78 | If FailedSpecs = 0 Then 79 | SummaryMessage = "PASS (" & TotalCount - PendingSpecs & " of " & TotalCount & " passed" 80 | Else 81 | SummaryMessage = "FAIL (" & FailedSpecs & " of " & TotalCount & " failed" 82 | End If 83 | 84 | If PendingSpecs = 0 Then 85 | SummaryMessage = SummaryMessage & ")" 86 | Else 87 | SummaryMessage = SummaryMessage & ", " & PendingSpecs & " pending)" 88 | End If 89 | 90 | End Function 91 | 92 | Private Function FailureMessage(Spec As tddSpecDefinition, ShowFailureDetails As Boolean, Indentation As String) As String 93 | 94 | Dim FailedExpectation As tddSpecExpectation 95 | Dim i As Long 96 | 97 | FailureMessage = ResultMessage(Spec, "X") 98 | 99 | If ShowFailureDetails Then 100 | FailureMessage = FailureMessage & vbNewLine 101 | 102 | For Each FailedExpectation In Spec.FailedExpectations 103 | FailureMessage = FailureMessage & Indentation & " " & FailedExpectation.FailureMessage 104 | 105 | If i + 1 <> Spec.FailedExpectations.Count Then: FailureMessage = FailureMessage & vbNewLine 106 | i = i + 1 107 | Next FailedExpectation 108 | End If 109 | 110 | End Function 111 | 112 | Private Function PendingMessage(Spec As tddSpecDefinition) As String 113 | PendingMessage = ResultMessage(Spec, ".") 114 | End Function 115 | 116 | Private Function PassingMessage(Spec As tddSpecDefinition) As String 117 | PassingMessage = ResultMessage(Spec, "+") 118 | End Function 119 | 120 | Private Function ResultMessage(Spec As tddSpecDefinition, Symbol As String) As String 121 | ResultMessage = Symbol & " " 122 | 123 | If Spec.Id <> "" Then 124 | ResultMessage = ResultMessage & Spec.Id & ": " 125 | End If 126 | 127 | ResultMessage = ResultMessage & Spec.Description 128 | End Function 129 | 130 | Private Function SuiteMessage(Suite As tddSpecSuite) As String 131 | Dim HasFailures As Boolean 132 | Dim Spec As tddSpecDefinition 133 | 134 | For Each Spec In Suite.SpecsCol 135 | If Spec.Result = SpecResult.Fail Then 136 | HasFailures = True 137 | Exit For 138 | End If 139 | Next Spec 140 | 141 | If HasFailures Then 142 | SuiteMessage = "X " 143 | Else 144 | SuiteMessage = "+ " 145 | End If 146 | 147 | If Suite.Description <> "" Then 148 | SuiteMessage = SuiteMessage & Suite.Description 149 | Else 150 | SuiteMessage = SuiteMessage & Suite.SpecsCol.Count & " specs" 151 | End If 152 | End Function 153 | 154 | -------------------------------------------------------------------------------- /Files/ExcelAdditional.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelAdditional" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Sub FreezeRow(Optional wsName As String = "Input", Optional cellAddress As String = "B5") 6 | 7 | Dim ws As Worksheet 8 | Set ws = Worksheets(wsName) 9 | 10 | ActiveWindow.FreezePanes = False 11 | Application.Goto ws.Range(cellAddress) 12 | ActiveWindow.FreezePanes = True 13 | 14 | End Sub 15 | 16 | Public Sub UnfreezeRows(Optional wsName As String = "Input") 17 | 18 | Dim ws As Worksheet 19 | Set ws = Worksheets(wsName) 20 | ActiveWindow.FreezePanes = False 21 | 22 | End Sub 23 | 24 | Public Function SumArray(myArray As Variant, Optional lastValuesNotToCalculate As Long = 0) As Double 25 | 26 | Dim i As Long 27 | For i = LBound(myArray) To UBound(myArray) - lastValuesNotToCalculate 28 | SumArray = SumArray + myArray(i) 29 | Next 30 | 31 | End Function 32 | 33 | Public Function ChangeCommas(ByVal myValue As Variant) As String 34 | 35 | Dim temp As String 36 | 37 | temp = CStr(myValue) 38 | ChangeCommas = Replace(temp, ",", ".") 39 | 40 | End Function 41 | 42 | Public Function BubbleSort(ByRef myArray As Variant) As Variant 43 | 44 | Dim temp As Variant 45 | Dim i As Long 46 | Dim noExchanges As Boolean 47 | 48 | Do 49 | noExchanges = True 50 | 51 | For i = LBound(myArray) To UBound(myArray) - 1 52 | If CDbl(myArray(i)) > CDbl(myArray(i + 1)) Then 53 | noExchanges = False 54 | temp = myArray(i) 55 | myArray(i) = myArray(i + 1) 56 | myArray(i + 1) = temp 57 | End If 58 | Next i 59 | 60 | Loop While Not (noExchanges) 61 | 62 | BubbleSort = myArray 63 | 64 | On Error GoTo 0 65 | Exit Function 66 | 67 | End Function 68 | 69 | Public Function IsArrayAllocated(varArr As Variant) As Boolean 70 | 71 | On Error Resume Next 72 | IsArrayAllocated = IsArray(varArr) And Not IsError(LBound(varArr, 1)) And LBound(varArr, 1) <= UBound(varArr, 1) 73 | On Error GoTo 0 74 | 75 | End Function 76 | 77 | Public Function RangeIsZeroOrEmpty(myRange As Range) As Boolean 78 | 79 | Dim myCell As Range 80 | 81 | If myRange.Cells.Count > 1 Then 82 | 83 | For Each myCell In myRange 84 | If (isEmpty(myCell) Or myCell.value = 0) Then 85 | RangeIsZeroOrEmpty = True 86 | Else 87 | RangeIsZeroOrEmpty = False 88 | Exit Function 89 | End If 90 | Next myCell 91 | Else 92 | If (isEmpty(myRange) Or myRange.value = 0) Then 93 | RangeIsZeroOrEmpty = True 94 | Else 95 | RangeIsZeroOrEmpty = False 96 | End If 97 | End If 98 | 99 | End Function 100 | 101 | Public Function MakeRandom(lowest As Long, highest As Long) As Long 102 | 'WorksheetFunction.randbetween for outside Excel 103 | MakeRandom = CLng((highest - lowest) * Rnd + lowest) 104 | 105 | End Function 106 | 107 | Public Function IsRangeHidden(myRange As Range) As Boolean 108 | 109 | If myRange.EntireRow.Hidden Or myRange.EntireColumn.Hidden Then 110 | IsRangeHidden = True 111 | End If 112 | 113 | End Function 114 | 115 | Public Function ColumnNumberToLetter(col As Long) As String 116 | ColumnNumberToLetter = Split(Cells(1, col).Address, "$")(1) 117 | End Function 118 | 119 | Public Function IsValueInArray(varMyValue As Variant, myArray As Variant, _ 120 | Optional isValueString As Boolean = False) As Boolean 121 | 122 | Dim i As Long 123 | 124 | If isValueString Then 125 | myArray = Split(myArray, ":") 126 | End If 127 | 128 | For i = LBound(myArray) To UBound(myArray) 129 | myArray(i) = CStr(myArray(i)) 130 | Next i 131 | 132 | IsValueInArray = Not IsError(Application.Match(CStr(varMyValue), myArray, 0)) 133 | 134 | End Function 135 | 136 | Public Function Rgb2HtmlColor(r As Byte, g As Byte, b As Byte) As String 137 | 138 | 'INPUT: Numeric (Base 10) Values for R, G, and B) 139 | 'RETURNS: 140 | 'A string that can be used as an HTML Color 141 | '(i.e., "#" + the Hexadecimal equivalent) 142 | 'For VBA the RGB is reversed. R and B are revered... 143 | 144 | Dim varHexR As Variant 145 | Dim varHexB As Variant 146 | Dim varHexG As Variant 147 | 148 | 'R 149 | varHexR = Hex(r) 150 | If Len(varHexR) < 2 Then varHexR = "0" & varHexR 151 | 152 | 'Get Green Hex 153 | varHexG = Hex(g) 154 | If Len(varHexG) < 2 Then varHexG = "0" & varHexG 155 | 156 | varHexB = Hex(b) 157 | If Len(varHexB) < 2 Then varHexB = "0" & varHexB 158 | 159 | 160 | Rgb2HtmlColor = "#" & varHexR & varHexG & varHexB 161 | 162 | End Function 163 | 164 | Function NamedRangeExists(rangeName As String) As Boolean 165 | 166 | On Error Resume Next 167 | 168 | Dim myRange As Range 169 | Set myRange = Range(rangeName) 170 | If Not myRange Is Nothing Then NamedRangeExists = True 171 | 172 | On Error GoTo 0 173 | 174 | End Function 175 | 176 | Function GetRgb(lngLong) As String 177 | 178 | Dim r As Long 179 | Dim g As Long 180 | Dim b As Long 181 | 182 | r = lngLong Mod 256 183 | g = lngLong \ 256 Mod 256 184 | b = lngLong \ 65536 Mod 256 185 | GetRgb = "R=" & r & ", G=" & g & ", B=" & b 186 | 187 | End Function 188 | 189 | Public Sub CopyValues(mySource As Range, myTarget As Range) 190 | myTarget.Resize(mySource.Rows.Count, mySource.Columns.Count).value = mySource.value 191 | End Sub 192 | 193 | Public Sub OnEnd() 194 | 195 | Application.ScreenUpdating = True 196 | Application.EnableEvents = True 197 | Application.AskToUpdateLinks = True 198 | Application.DisplayAlerts = True 199 | 200 | ActiveWindow.View = xlNormalView 201 | Application.StatusBar = False 202 | Application.Calculation = xlAutomatic 203 | ThisWorkbook.Date1904 = False 204 | 205 | End Sub 206 | 207 | Public Sub OnStart() 208 | 209 | Application.ScreenUpdating = False 210 | Application.EnableEvents = False 211 | Application.AskToUpdateLinks = False 212 | Application.DisplayAlerts = False 213 | 214 | ActiveWindow.View = xlNormalView 215 | Application.StatusBar = False 216 | Application.Calculation = xlAutomatic 217 | ThisWorkbook.Date1904 = False 218 | 219 | End Sub 220 | -------------------------------------------------------------------------------- /Files/ExcelVBE.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelVBE" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Sub PrintAllCode() 6 | 7 | Dim item As Variant 8 | Dim textToPrint As String 9 | Dim lineToPrint As String 10 | 11 | For Each item In ThisWorkbook.vbProject.VBComponents 12 | lineToPrint = item.codeModule.lines(1, item.codeModule.CountOfLines) 13 | Debug.Print lineToPrint 14 | textToPrint = textToPrint & vbCrLf & lineToPrint 15 | Next item 16 | 17 | PrintToNotepad textToPrint 18 | 19 | End Sub 20 | 21 | Sub PrintAllContainers() 22 | 23 | Dim item As Variant 24 | Dim textToPrint As String 25 | Dim lineToPrint As String 26 | 27 | For Each item In ThisWorkbook.vbProject.VBComponents 28 | lineToPrint = item.Name 29 | Debug.Print lineToPrint 30 | textToPrint = textToPrint & vbCrLf & lineToPrint 31 | Next item 32 | 33 | PrintToNotepad textToPrint 34 | 35 | End Sub 36 | 37 | Sub ListProcedures(Optional modName As String = "ExcelAdditional", Optional withParentInfo As Boolean = False) 38 | 39 | Dim project As VBIDE.vbProject 40 | Dim component As VBIDE.VBComponent 41 | Dim codeModule As VBIDE.codeModule 42 | Dim lineNum As Long 43 | Dim procName As String 44 | Dim procKind As VBIDE.vbext_ProcKind 45 | Dim subsInfo As String 46 | 47 | Set project = ThisWorkbook.vbProject 48 | Set component = project.VBComponents(modName) 49 | Set codeModule = component.codeModule 50 | 51 | With codeModule 52 | lineNum = .CountOfDeclarationLines + 1 53 | 54 | Do Until lineNum >= .CountOfLines 55 | procName = .ProcOfLine(lineNum, procKind) 56 | 57 | If withParentInfo Then 58 | subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & modName & "." & procName 59 | Else 60 | subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & procName 61 | End If 62 | 63 | lineNum = .ProcStartLine(procName, procKind) + .ProcCountLines(procName, procKind) + 1 64 | Loop 65 | 66 | End With 67 | 68 | Debug.Print subsInfo 69 | PrintToNotepad subsInfo 70 | 71 | End Sub 72 | 73 | Sub ExportModules() 74 | 75 | CreateFolderOnDesktop GetFolderOnDesktopPath 76 | 77 | On Error Resume Next 78 | Kill GetFolderOnDesktopPath & "\*.*" 79 | On Error GoTo 0 80 | 81 | Dim wkb As Workbook: Set wkb = Excel.Workbooks(ThisWorkbook.Name) 82 | 83 | If wkb.vbProject.Protection = vbext_pp_locked Then 84 | Debug.Print "The VBA in this workbook is locked." 85 | Exit Sub 86 | End If 87 | 88 | Dim unitsCount As Long 89 | Dim filePath As String 90 | Dim component As VBIDE.VBComponent 91 | Dim tryExport As Boolean 92 | 93 | For Each component In wkb.vbProject.VBComponents 94 | tryExport = True 95 | filePath = component.Name 96 | 97 | 98 | Select Case component.Type 99 | Case vbext_ct_ClassModule 100 | filePath = filePath & ".cls" 101 | Case vbext_ct_MSForm 102 | filePath = filePath & ".frm" 103 | Case vbext_ct_StdModule 104 | filePath = filePath & ".bas" 105 | Case vbext_ct_Document 106 | tryExport = False 107 | End Select 108 | 109 | If tryExport Then 110 | Increment unitsCount 111 | Debug.Print unitsCount & " exporting " & filePath 112 | component.export GetFolderOnDesktopPath & filePath 113 | End If 114 | 115 | Next 116 | 117 | Debug.Print "Exported at " & GetFolderOnDesktopPath 118 | 119 | End Sub 120 | 121 | Function GetFolderOnDesktopPath() As String 122 | 123 | Dim shell As Object 124 | Dim fso As Object 125 | Dim specialFolderPath As String 126 | 127 | Set shell = CreateObject("WScript.Shell") 128 | Set fso = CreateObject("scripting.filesystemobject") 129 | 130 | specialFolderPath = shell.SpecialFolders("Desktop") 131 | If Right(specialFolderPath, 1) <> "\" Then specialFolderPath = specialFolderPath & "\" 132 | 133 | GetFolderOnDesktopPath = specialFolderPath & CON_STR_APP_NAME & "\" 134 | 135 | End Function 136 | 137 | Sub CreateFolderOnDesktop(specialFolderPath As String) 138 | 139 | On Error Resume Next 140 | 141 | MkDir specialFolderPath 142 | If Err.Number <> 0 Then 143 | If Err.Number = 75 Then 144 | Debug.Print "Folder exists - " & specialFolderPath 145 | Else 146 | Err.Raise Err.Number, Err.source, Err.Description 147 | End If 148 | Else 149 | Debug.Print "Folder has been created - " & specialFolderPath 150 | End If 151 | 152 | On Error GoTo 0 153 | 154 | End Sub 155 | 156 | Public Sub ImportModules() 157 | 158 | '1. The target workbook should be opened in the same Excel instance as the ThisWorkbook 159 | '2. The target workbook should be in the same directory as ThisWorkbook 160 | '3. The code to be added should be present in GetFolderOnDesktopPath 161 | 162 | Dim targetName As String: targetName = "empty.xlsm" 163 | Dim targetPath As String: targetPath = ThisWorkbook.path & "\" & targetName 164 | 165 | Dim wkbTarget As Workbook 166 | Dim fso As Scripting.FileSystemObject 167 | Dim file As Scripting.file 168 | Dim codePath As String: codePath = GetFolderOnDesktopPath 169 | 170 | Set wkbTarget = Workbooks(targetName) 171 | 172 | If wkbTarget.vbProject.Protection = 1 Then 173 | Debug.Print "VBProject is protected!" 174 | End If 175 | 176 | Set fso = New Scripting.FileSystemObject 177 | If fso.GetFolder(codePath).Files.Count = 0 Then 178 | Debug.Print "Zero vba files in source workbook!" 179 | Exit Sub 180 | End If 181 | 182 | DeleteAllVba wkbTarget 183 | 184 | Dim unitsCount As Long 185 | For Each file In fso.GetFolder(codePath).Files 186 | Select Case fso.GetExtensionName(file.Name) 187 | Case "cls", "frm", "bas": 188 | Increment unitsCount 189 | Debug.Print unitsCount & " -> in " & wkbTarget.Name & " adding " & file.Name 190 | wkbTarget.vbProject.VBComponents.Import file.path 191 | Case Else: 192 | Debug.Print file.Name & " cannot be processed." 193 | End Select 194 | Next 195 | 196 | Debug.Print vbCrLf & unitsCount & " units were just added to:" & vbCrLf & targetPath 197 | 198 | End Sub 199 | 200 | Function DeleteAllVba(wkbTarget As Workbook) 201 | 202 | Dim project As VBIDE.vbProject 203 | Dim component As VBIDE.VBComponent 204 | Dim unitsCount As Long 205 | 206 | Set project = wkbTarget.vbProject 207 | 208 | For Each component In project.VBComponents 209 | If component.Type <> vbext_ct_Document Then 210 | Increment unitsCount 211 | Debug.Print unitsCount & " from " & wkbTarget.Name & " deleting " & component.Name 212 | project.VBComponents.Remove component 213 | End If 214 | Next 215 | 216 | Debug.Print 'Empty line is good :) 217 | 218 | End Function 219 | 220 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # VBA Boilerplate 2 | 3 | ## Migrating the repository to: 4 | - ## https://github.com/Vitosh/VBA_personal 5 | ## This repository is no longer maintained. 6 | 7 | :cat: 8 | 9 | ## The idea 10 | Boilerplate is an Excel binary file with VBA code in it, which can be used for every new VBA project as a boilerplate. 11 | Building a boilerplate, which is to be used by as a start point for every VBA project was long in my mind. Somewhere in 2016 I have decided to put all the useful VBA code that I am using in a single repository. 12 | 13 | The repository is  https://github.com/Vitosh/VBA_personal, and up to now it has more than 60+ :star: in GitHub and just 1 contributor except me. The reason for this is that it probably looks a bit unstructured and I am the only one who can somehow find his way among all these files. Anyway, this week I am having some free time, thus I have decided to restart the project again -  create an Excel binary file with VBA code in it, which can be used for every new VBA project as a boilerplate. 14 | 15 | ## The structure 16 | On February 2020 I have decided to change the repository to the current one: 17 | https://github.com/VBoilerplate/Boiler 18 | 19 | ## How can I use the boilerplate: 20 | Simply download it and use it! Or go through the files in and check them. If you find something interesting, copy it to your project. 21 | 22 | ## Video tutorials: 23 | [YouTube VBA Boilerplate Tutorials](https://www.youtube.com/playlist?list=PLHvb-qAb0DaE2WXKfOXXNNRkoW990S5lP) 24 | 25 | ## Where is the official documentation? 26 | On the current document and here - [vitoshacademy.com/boilerplate](https://www.vitoshacademy.com/boilerplate/) 27 | 28 | ## What is inside the boilerplate: 29 | 30 | 203 | 204 | :cactus::cat::dog::monkey: 205 | -------------------------------------------------------------------------------- /Files/ExcelStructure.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ExcelStructure" 2 | Option Explicit 3 | Option Private Module 4 | 5 | Public Sub LockScroll(lockArea As Range) 6 | 7 | Dim wks As Worksheet 8 | For Each wks In ThisWorkbook.Worksheets 9 | wks.ScrollArea = lockArea.Address 10 | Next wks 11 | 12 | End Sub 13 | 14 | Public Sub UnlockScroll() 15 | 16 | Dim wks As Worksheet 17 | For Each wks In ThisWorkbook.Worksheets 18 | wks.ScrollArea = "" 19 | Next wks 20 | 21 | End Sub 22 | 23 | Sub StyleKiller() 24 | 25 | Dim myStyle As Style 26 | 27 | For Each myStyle In ThisWorkbook.Styles 28 | If Not myStyle.BuiltIn Then 29 | Debug.Print myStyle.Name 30 | myStyle.Delete 31 | End If 32 | Next 33 | 34 | End Sub 35 | 36 | Public Sub DeleteName(myName As String) 37 | 38 | On Error GoTo DeleteName_Error 39 | 40 | ThisWorkbook.Names(myName).Delete 41 | Debug.Print myName & " is deleted!" 42 | 43 | On Error GoTo 0 44 | Exit Sub 45 | 46 | DeleteName_Error: 47 | 48 | Debug.Print myName & " not present or some error" 49 | On Error GoTo 0 50 | 51 | End Sub 52 | 53 | Sub CoverRange(myRange As Range, wks As Worksheet) 54 | 55 | Dim myLeft As Long 56 | Dim myTop As Long 57 | Dim myWidth As Long 58 | Dim myHeight As Long 59 | 60 | If wks.Name <> ActiveSheet.Name Then 61 | MsgBox "You better select the sheet you are working on..." 62 | Exit Sub 63 | End If 64 | 65 | myLeft = myRange.Left 66 | myTop = myRange.Top 67 | myWidth = myRange.Width 68 | myHeight = myRange.Height 69 | 70 | With wks.Shapes 71 | .AddTextbox(msoTextOrientationVertical, myLeft, myTop, myWidth, myHeight).Select 72 | Selection.ShapeRange.Line.Visible = msoFalse 73 | End With 74 | 75 | End Sub 76 | 77 | Public Sub PrintSheetPDF(inputPrintArea As Range, _ 78 | printedFileName As String, _ 79 | Optional isBlack As Boolean = False) 80 | 81 | If SET_IN_PRODUCTION Then On Error GoTo PrintPDF_Error 82 | 83 | Dim wks As Worksheet 84 | Set wks = Worksheets(inputPrintArea.Parent.Name) 85 | 86 | With wks 87 | .PageSetup.Zoom = False 88 | .PageSetup.BlackAndWhite = isBlack 89 | 90 | inputPrintArea.ExportAsFixedFormat _ 91 | Type:=xlTypePDF, _ 92 | fileName:=printedFileName, _ 93 | Quality:=xlQualityStandard, _ 94 | IncludeDocProperties:=True, _ 95 | IgnorePrintAreas:=False, _ 96 | OpenAfterPublish:=True 97 | End With 98 | 99 | On Error GoTo 0 100 | Exit Sub 101 | 102 | PrintPDF_Error: 103 | 104 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPDF of Modul mod_Drucken" 105 | 106 | End Sub 107 | 108 | Public Sub PrintPage(printRange As Range, Optional isBlack As Boolean = False) 109 | 110 | Dim wksSheet As Worksheet 111 | Dim reducePaperTitle As String 112 | 113 | On Error GoTo PrintPage_Error 114 | 115 | reducePaperTitle = "Reduce printing and save trees!" 116 | printRange.Parent.PageSetup.BlackAndWhite = isBlack 117 | 118 | Set wksSheet = printRange.Parent 119 | 120 | With wksSheet.PageSetup 121 | .Orientation = xlPortrait 122 | .Zoom = False 123 | .FitToPagesTall = 1 124 | .FitToPagesWide = 1 125 | End With 126 | 127 | Select Case MsgBox("Are you sure you would like to print the selected page?", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle) 128 | Case vbYes 129 | Select Case MsgBox("Really?", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle) 130 | Case vbYes 131 | printRange.PrintOut 132 | End Select 133 | End Select 134 | 135 | On Error GoTo 0 136 | Exit Sub 137 | 138 | PrintPage_Error: 139 | 140 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPage of Modul mod_Drucken" 141 | 142 | End Sub 143 | 144 | Sub DeleteDrawingObjects(wks As Worksheet) 145 | 146 | Dim i As Long 147 | 148 | For i = wks.DrawingObjects().Count To 1 Step -1 149 | wks.DrawingObjects(i).Delete 150 | Next i 151 | 152 | End Sub 153 | 154 | Public Sub UnhideAll() 155 | 156 | Dim wks As Worksheet 157 | 158 | For Each wks In ThisWorkbook.Worksheets 159 | wks.Visible = xlSheetVisible 160 | Next 161 | 162 | UnprotectAll 163 | 164 | End Sub 165 | 166 | Public Sub UnprotectAll() 167 | 168 | Dim i As Long 169 | For i = ThisWorkbook.Worksheets.Count To 1 Step -1 170 | ThisWorkbook.Worksheets(i).Unprotect Password:=WORKSHEET_UNPROTECT_PASSWORD 171 | Next i 172 | 173 | End Sub 174 | 175 | Public Sub HideNeededWorksheets() 176 | 177 | Dim varSheet As Variant 178 | Dim visibleSheets As Variant 179 | Dim hiddenSheets As Variant 180 | 181 | OnStart 182 | 183 | visibleSheets = Array(tblInput) 184 | hiddenSheets = Array(tblSettings) 185 | 186 | For Each varSheet In visibleSheets 187 | varSheet.Visible = xlSheetVisible 188 | Next varSheet 189 | 190 | For Each varSheet In hiddenSheets 191 | varSheet.Visible = xlSheetVeryHidden 192 | Next varSheet 193 | 194 | OnEnd 195 | 196 | End Sub 197 | 198 | Public Sub AddCommentToSelection(myComment As Range) 199 | 200 | Dim myCell As Range 201 | 202 | For Each myCell In Selection 203 | myCell.ClearComments 204 | myCell.AddComment myComment.Text 205 | myCell.Comment.Visible = False 206 | myCell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft 207 | myCell.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft 208 | 209 | Next myCell 210 | 211 | End Sub 212 | 213 | Public Sub PrintArray(myArray As Variant) 214 | 215 | Dim i As Long 216 | For i = LBound(myArray) To UBound(myArray) 217 | Debug.Print i & " --> " & myArray(i) 218 | Next i 219 | 220 | End Sub 221 | 222 | Sub PrintAllNames() 223 | 224 | Dim nm As Name 225 | 226 | For Each nm In ThisWorkbook.Names 227 | Debug.Print nm.Name 228 | Next nm 229 | 230 | End Sub 231 | 232 | Sub DeleteAllNames() 233 | 234 | Dim nm As Name 235 | 236 | For Each nm In ThisWorkbook.Names 237 | Debug.Print nm.Name & " is deleted!" 238 | nm.Delete 239 | Next nm 240 | 241 | End Sub 242 | 243 | Public Sub DeleteCommentInSelection() 244 | 245 | If SET_IN_PRODUCTION Then On Error GoTo DeleteCommentInSelection_Error 246 | 247 | Dim myCell As Range 248 | 249 | For Each myCell In Selection 250 | myCell.ClearComments 251 | Next myCell 252 | 253 | On Error GoTo 0 254 | Exit Sub 255 | 256 | DeleteCommentInSelection_Error: 257 | 258 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DeleteCommentInSelection of Sub mod_StandardSubs" 259 | 260 | End Sub 261 | 262 | Public Sub SelectMeA1RangeEverywhere() 263 | 264 | If SET_IN_PRODUCTION Then On Error GoTo SelectMeA1RangeEverywhere_Error 265 | 266 | Dim wks As Worksheet 267 | 268 | For Each wks In ThisWorkbook.Worksheets 269 | If wks.Visible = xlSheetVisible Then 270 | wks.Activate 271 | wks.Cells(1, 1).Select 272 | End If 273 | Next 274 | 275 | Worksheets(1).Select 276 | 277 | On Error GoTo 0 278 | Exit Sub 279 | 280 | SelectMeA1RangeEverywhere_Error: 281 | 282 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SelectMeA1RangeEverywhere of Sub mod_StandardSubs" 283 | 284 | End Sub 285 | 286 | Sub HideShowComments(Optional showComments As Boolean = False, _ 287 | Optional myRange As Range = Nothing) 288 | 289 | Dim myCell As Range 290 | 291 | If SET_IN_PRODUCTION Then On Error GoTo HideShowComments_Error 292 | If myRange Is Nothing Then Set myRange = Range("A1:AO1000") 293 | 294 | For Each myCell In myRange 295 | If Not myCell.Comment Is Nothing Then 296 | myCell.Comment.Visible = showComments 297 | End If 298 | Next myCell 299 | 300 | On Error GoTo 0 301 | Exit Sub 302 | 303 | HideShowComments_Error: 304 | 305 | MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure HideShowComments of Sub mod_StandardSubs" 306 | 307 | End Sub 308 | 309 | Public Sub ResetAndUnlock() 310 | 311 | If Not IsValueInArray(Environ("Username"), ADMINS, True) Then 312 | Debug.Print "no" 313 | Exit Sub 314 | End If 315 | 316 | UnhideAll 'UnprotectAll is included 317 | Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" 318 | ActiveWindow.DisplayHeadings = True 319 | Application.DisplayFormulaBar = True 320 | Debug.Print "Done." 321 | 322 | EnableMySaves 323 | 324 | End Sub 325 | 326 | Public Sub EnableMySaves() 327 | 328 | Application.OnKey "%{F11}" 329 | Application.OnKey "^c" 330 | Application.OnKey "^C" 331 | Application.OnKey "^v" 332 | Application.OnKey "^V" 333 | Application.OnKey "^x" 334 | Application.OnKey "^X" 335 | Application.OnKey "^w" 336 | Application.OnKey "^W" 337 | Application.OnKey "^e" 338 | Application.OnKey "^E" 339 | 340 | End Sub 341 | 342 | Public Sub DisabledCombination() 343 | 'This is the disabled combination for Application.OnKey 344 | End Sub 345 | 346 | Public Sub DisableShortcutsAndSaves() 347 | 348 | Application.OnKey "^c", "DisabledCombination" 349 | Application.OnKey "^C", "DisabledCombination" 350 | Application.OnKey "^v", "DisabledCombination" 351 | Application.OnKey "^V", "DisabledCombination" 352 | Application.OnKey "^x", "DisabledCombination" 353 | Application.OnKey "^X", "DisabledCombination" 354 | Application.OnKey "^w", "DisabledCombination" 355 | Application.OnKey "^W", "DisabledCombination" 356 | 357 | Application.OnKey "^e", "ShowMainForm" 358 | Application.OnKey "^E", "ShowMainForm" 359 | 360 | End Sub 361 | -------------------------------------------------------------------------------- /Files/tddSpecExpectation.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tddSpecExpectation" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | 12 | Public Actual As Variant 13 | Public Expected As Variant 14 | Public Result As ExpectResult 15 | Public FailureMessage As String 16 | 17 | Public Enum ExpectResult 18 | Pass 19 | Fail 20 | End Enum 21 | 22 | Public Sub ToEqual(Expected As Variant) 23 | Check IsEqual(Me.Actual, Expected), "to equal", Expected:=Expected 24 | End Sub 25 | 26 | Public Sub ToNotEqual(Expected As Variant) 27 | Check IsEqual(Me.Actual, Expected), "to not equal", Expected:=Expected, Inverse:=True 28 | End Sub 29 | 30 | Private Function IsEqual(Actual As Variant, Expected As Variant) As Variant 31 | 32 | Dim l_count As Long 33 | 34 | If IsArray(Expected) Then 35 | If UBound(Expected) <> UBound(Actual) Then IsEqual = False: Exit Function 36 | 37 | For l_count = LBound(Expected) To UBound(Expected) 38 | If Not Expected(l_count) = Actual(l_count) Then IsEqual = False: Exit Function 39 | Next l_count 40 | IsEqual = True 41 | End If 42 | 43 | If IsError(Actual) Or IsError(Expected) Then 44 | IsEqual = False 45 | ElseIf IsObject(Actual) Or IsObject(Expected) Then 46 | IsEqual = "Unsupported: Can't compare objects" 47 | ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then 48 | IsEqual = IsCloseTo(Actual, Expected, 15) 49 | Else 50 | IsEqual = Actual = Expected 51 | End If 52 | 53 | End Function 54 | 55 | Public Sub ToBeDefined() 56 | 57 | Debug.Print "Excel-TDD: DEPRECATED, ToBeDefined() has been deprecated in favor of ToNotBeUndefined and will be removed in Excel-TDD v2.0.0" 58 | Check IsUndefined(Me.Actual), "to be defined", Inverse:=True 59 | 60 | End Sub 61 | 62 | Public Sub ToBeUndefined() 63 | Check IsUndefined(Me.Actual), "to be undefined" 64 | End Sub 65 | 66 | Public Sub ToNotBeUndefined() 67 | Check IsUndefined(Me.Actual), "to not be undefined", Inverse:=True 68 | End Sub 69 | 70 | Private Function IsUndefined(Actual As Variant) As Variant 71 | IsUndefined = IsNothing(Actual) Or isEmpty(Actual) Or IsNull(Actual) Or IsMissing(Actual) 72 | End Function 73 | 74 | Public Sub ToBeNothing() 75 | Check IsNothing(Me.Actual), "to be nothing" 76 | End Sub 77 | 78 | Public Sub ToNotBeNothing() 79 | Check IsNothing(Me.Actual), "to not be nothing", Inverse:=True 80 | End Sub 81 | 82 | Private Function IsNothing(Actual As Variant) As Variant 83 | 84 | If IsObject(Actual) Then 85 | If Actual Is Nothing Then 86 | IsNothing = True 87 | Else 88 | IsNothing = False 89 | End If 90 | Else 91 | IsNothing = False 92 | End If 93 | 94 | End Function 95 | 96 | Public Sub ToBeEmpty() 97 | Check isEmpty(Me.Actual), "to be empty" 98 | End Sub 99 | 100 | Public Sub ToNotBeEmpty() 101 | Check isEmpty(Me.Actual), "to not be empty", Inverse:=True 102 | End Sub 103 | 104 | Public Sub ToBeNull() 105 | Check IsNull(Me.Actual), "to be null" 106 | End Sub 107 | 108 | Public Sub ToNotBeNull() 109 | Check IsNull(Me.Actual), "to not be null", Inverse:=True 110 | End Sub 111 | 112 | Public Sub ToBeMissing() 113 | Check IsMissing(Me.Actual), "to be missing" 114 | End Sub 115 | 116 | Public Sub ToNotBeMissing() 117 | Check IsMissing(Me.Actual), "to not be missing", Inverse:=True 118 | End Sub 119 | 120 | Public Sub ToBeLessThan(Expected As Variant) 121 | Check IsLT(Me.Actual, Expected), "to be less than", Expected:=Expected 122 | End Sub 123 | 124 | Public Sub ToBeLT(Expected As Variant) 125 | ToBeLessThan Expected 126 | End Sub 127 | 128 | Private Function IsLT(Actual As Variant, Expected As Variant) As Variant 129 | 130 | If IsError(Actual) Or IsError(Expected) Or Actual >= Expected Then 131 | IsLT = False 132 | Else 133 | IsLT = True 134 | End If 135 | 136 | End Function 137 | 138 | Public Sub ToBeLessThanOrEqualTo(Expected As Variant) 139 | Check IsLTE(Me.Actual, Expected), "to be less than or equal to", Expected:=Expected 140 | End Sub 141 | 142 | Public Sub ToBeLTE(Expected As Variant) 143 | ToBeLessThanOrEqualTo Expected 144 | End Sub 145 | 146 | Private Function IsLTE(Actual As Variant, Expected As Variant) As Variant 147 | 148 | If IsError(Actual) Or IsError(Expected) Or Actual > Expected Then 149 | IsLTE = False 150 | Else 151 | IsLTE = True 152 | End If 153 | 154 | End Function 155 | 156 | Public Sub ToBeGreaterThan(Expected As Variant) 157 | 158 | Check IsGT(Me.Actual, Expected), "to be greater than", Expected:=Expected 159 | 160 | End Sub 161 | Public Sub ToBeGT(Expected As Variant) 162 | ToBeGreaterThan Expected 163 | End Sub 164 | 165 | Private Function IsGT(Actual As Variant, Expected As Variant) As Variant 166 | 167 | If IsError(Actual) Or IsError(Expected) Or Actual <= Expected Then 168 | IsGT = False 169 | Else 170 | IsGT = True 171 | End If 172 | 173 | End Function 174 | 175 | Public Sub ToBeGreaterThanOrEqualTo(Expected As Variant) 176 | Check IsGTE(Me.Actual, Expected), "to be greater than or equal to", Expected:=Expected 177 | End Sub 178 | 179 | Public Sub ToBeGTE(Expected As Variant) 180 | ToBeGreaterThanOrEqualTo Expected 181 | End Sub 182 | 183 | Private Function IsGTE(Actual As Variant, Expected As Variant) As Variant 184 | 185 | If IsError(Actual) Or IsError(Expected) Or Actual < Expected Then 186 | IsGTE = False 187 | Else 188 | IsGTE = True 189 | End If 190 | 191 | End Function 192 | 193 | Public Sub ToBeCloseTo(Expected As Variant, SignificantFigures As Long) 194 | Check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected 195 | End Sub 196 | 197 | Public Sub ToNotBeCloseTo(Expected As Variant, SignificantFigures As Long) 198 | Check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected, Inverse:=True 199 | End Sub 200 | 201 | Private Function IsCloseTo(Actual As Variant, Expected As Variant, SignificantFigures As Long) As Variant 202 | 203 | Dim ActualAsString As String 204 | Dim ExpectedAsString As String 205 | 206 | If SignificantFigures < 1 Or SignificantFigures > 15 Then 207 | IsCloseTo = "ToBeCloseTo/ToNotBeClose to can only compare from 1 to 15 significant figures""" 208 | ElseIf Not IsError(Actual) And Not IsError(Expected) Then 209 | If Actual > 1 Then 210 | ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") 211 | Else 212 | ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") 213 | End If 214 | 215 | If Expected > 1 Then 216 | ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") 217 | Else 218 | ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") 219 | End If 220 | 221 | IsCloseTo = ActualAsString = ExpectedAsString 222 | End If 223 | 224 | End Function 225 | 226 | Public Sub ToContain(Expected As Variant, Optional MatchCase As Boolean = True) 227 | 228 | If VarType(Me.Actual) = vbString Then 229 | Debug.Print "Excel-TDD: DEPRECATED ToContain has been changed to ToMatch in Excel-TDD v2.0.0" 230 | If MatchCase Then 231 | Check Matches(Me.Actual, Expected), "to match", Expected:=Expected 232 | Else 233 | Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to match", Expected:=Expected 234 | End If 235 | Else 236 | Check Contains(Me.Actual, Expected), "to contain", Expected:=Expected 237 | End If 238 | 239 | End Sub 240 | 241 | Public Sub ToNotContain(Expected As Variant, Optional MatchCase As Boolean = True) 242 | 243 | If VarType(Me.Actual) = vbString Then 244 | Debug.Print "Excel-TDD: DEPRECATED ToNotContain has been changed to ToMatch in Excel-TDD v2.0.0" 245 | If MatchCase Then 246 | Check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True 247 | Else 248 | Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to not match", Expected:=Expected, Inverse:=True 249 | End If 250 | Else 251 | Check Contains(Me.Actual, Expected), "to not contain", Expected:=Expected, Inverse:=True 252 | End If 253 | 254 | End Sub 255 | 256 | Private Function Contains(Actual As Variant, Expected As Variant) As Variant 257 | 258 | If Not IsArray(Actual) Then 259 | Contains = "Error: Actual needs to be an Array or Collection for ToContain/ToNotContain" 260 | Else 261 | Dim i As Long 262 | 263 | If TypeOf Actual Is Collection Then 264 | For i = 1 To Actual.Count 265 | If Actual.item(i) = Expected Then 266 | Contains = True 267 | Exit Function 268 | End If 269 | Next i 270 | 271 | Else 272 | 273 | For i = LBound(Actual) To UBound(Actual) 274 | If Actual(i) = Expected Then 275 | Contains = True 276 | Exit Function 277 | End If 278 | Next i 279 | End If 280 | End If 281 | 282 | End Function 283 | 284 | Public Sub ToMatch(Expected As Variant) 285 | Check Matches(Me.Actual, Expected), "to match", Expected:=Expected 286 | End Sub 287 | 288 | Public Sub ToNotMatch(Expected As Variant) 289 | Check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True 290 | End Sub 291 | 292 | Private Function Matches(Actual As Variant, Expected As Variant) As Variant 293 | 294 | If InStr(Actual, Expected) > 0 Then 295 | Matches = True 296 | Else 297 | Matches = False 298 | End If 299 | 300 | End Function 301 | 302 | Public Sub RunMatcher(Name As String, Message As String, ParamArray Arguments()) 303 | 304 | Dim Expected As String 305 | Dim i As Long 306 | Dim HasArguments As Boolean 307 | 308 | HasArguments = UBound(Arguments) >= 0 309 | For i = LBound(Arguments) To UBound(Arguments) 310 | If Expected = "" Then 311 | Expected = GetStringForValue(Arguments(i)) 312 | ElseIf i = UBound(Arguments) Then 313 | If (UBound(Arguments) > 1) Then 314 | Expected = Expected & ", and " & GetStringForValue(Arguments(i)) 315 | Else 316 | Expected = Expected & " and " & GetStringForValue(Arguments(i)) 317 | End If 318 | Else 319 | Expected = Expected & ", " & GetStringForValue(Arguments(i)) 320 | End If 321 | Next i 322 | 323 | If HasArguments Then 324 | Check Application.Run(Name, Me.Actual, Arguments), Message, Expected:=Expected 325 | Else 326 | Check Application.Run(Name, Me.Actual), Message 327 | End If 328 | 329 | End Sub 330 | 331 | Private Sub Check(Result As Variant, Message As String, Optional Expected As Variant, Optional Inverse As Boolean = False) 332 | 333 | If Not IsMissing(Expected) Then 334 | If IsObject(Expected) Then 335 | Set Me.Expected = Expected 336 | Else 337 | Me.Expected = Expected 338 | End If 339 | End If 340 | 341 | If VarType(Result) = vbString Then 342 | Fails CStr(Result) 343 | Else 344 | If Inverse Then 345 | Result = Not Result 346 | End If 347 | 348 | If Result Then 349 | Passes 350 | Else 351 | Fails CreateFailureMessage(Message, Expected) 352 | End If 353 | End If 354 | 355 | End Sub 356 | 357 | Private Sub Passes() 358 | Me.Result = ExpectResult.Pass 359 | End Sub 360 | 361 | Private Sub Fails(Message As String) 362 | Me.Result = ExpectResult.Fail 363 | Me.FailureMessage = Message 364 | End Sub 365 | 366 | Private Function CreateFailureMessage(Message As String, Optional Expected As Variant) As String 367 | 368 | CreateFailureMessage = "Expected " & GetStringForValue(Me.Actual) & " " & Message 369 | If Not IsMissing(Expected) Then 370 | CreateFailureMessage = CreateFailureMessage & " " & GetStringForValue(Expected) 371 | End If 372 | 373 | End Function 374 | 375 | Private Function GetStringForValue(value As Variant) As String 376 | 377 | If IsObject(value) Then 378 | If value Is Nothing Then 379 | GetStringForValue = "(Nothing)" 380 | Else 381 | GetStringForValue = "(Object)" 382 | End If 383 | ElseIf IsArray(value) Then 384 | GetStringForValue = "(Array)" 385 | ElseIf isEmpty(value) Then 386 | GetStringForValue = "(Empty)" 387 | ElseIf IsNull(value) Then 388 | GetStringForValue = "(Null)" 389 | ElseIf IsMissing(value) Then 390 | GetStringForValue = "(Missing)" 391 | Else 392 | GetStringForValue = CStr(value) 393 | End If 394 | 395 | If GetStringForValue = "" Then 396 | GetStringForValue = "(Undefined)" 397 | End If 398 | 399 | End Function 400 | 401 | Private Function IsArray(value As Variant) As Boolean 402 | 403 | If Not isEmpty(value) Then 404 | If IsObject(value) Then 405 | If TypeOf value Is Collection Then 406 | IsArray = True 407 | End If 408 | ElseIf VarType(value) = vbArray Or VarType(value) = 8204 Then 409 | IsArray = True 410 | End If 411 | End If 412 | 413 | End Function 414 | 415 | 416 | --------------------------------------------------------------------------------