[ { "path": ".gitattributes", "content": "*.vb linguist-language=vba\n" }, { "path": ".gitignore", "content": "# Compiled source #\n###################\n*.com\n*.class\n*.dll\n*.exe\n*.o\n*.so\n\n# Packages #\n############\n# it's better to unpack these files and commit the raw source\n# git has its own built in compression methods\n*.7z\n*.dmg\n*.gz\n*.iso\n*.jar\n*.rar\n*.tar\n*.zip\n\n# Logs and databases #\n######################\n*.log\n*.sql\n*.sqlite\n\n# OS generated files #\n######################\n.DS_Store\n.DS_Store?\n._*\n.Spotlight-V100\n.Trashes\nehthumbs.db\nThumbs.db\ndesktop.ini" }, { "path": "Algorithms/ActivitySelectionProblem.vb", "content": "Option Explicit\n\nPublic Sub TestMe()\n\n Dim objA As clsActivity\n Dim colObjs As New Collection\n Dim rngCell As Range\n Dim strResult As String\n Dim i As Long\n Dim lngNextStart As Long: lngNextStart = 0\n \n For Each rngCell In Range(Cells(1, 1), Cells(1, 11))\n Set objA = Nothing\n Set objA = New clsActivity\n objA.StartTime = rngCell\n objA.EndTime = rngCell.Offset(1, 0)\n objA.Name = rngCell.Offset(2, 0)\n colObjs.Add objA\n Next rngCell\n \n Set colObjs = SortedCollection(colObjs)\n \n For i = 1 To colObjs.Count\n If colObjs.Item(i).StartTime > lngNextStart Then\n strResult = strResult & colObjs.Item(i).Name & vbTab & _\n colObjs.Item(i).StartTime & vbTab & _\n colObjs.Item(i).EndTime & vbCrLf\n \n lngNextStart = colObjs.Item(i).EndTime\n End If\n Next i\n \n Debug.Print strResult\n \nEnd Sub\n\nPublic Function SortedCollection(myColl As Collection, Optional blnSortABC As Boolean = True) As Collection\n\n Dim i As Long\n Dim j As Long\n \n For i = myColl.Count To 2 Step -1\n For j = 1 To i - 1\n If blnSortABC Then\n If myColl(j).EndTime > myColl(j + 1).EndTime Then\n myColl.Add myColl(j), after:=j + 1\n myColl.Remove j\n End If\n Else\n If myColl(j).EndTime < myColl(j + 1).EndTime Then\n myColl.Add myColl(j), after:=j + 1\n myColl.Remove j\n End If\n End If\n Next j\n Next i\n \n Set SortedCollection = myColl\n \n\nEnd Function\n\n" }, { "path": "Algorithms/ActivitySelectionProblem_clsActivity.vb", "content": "Private pName As String\nPrivate pStartTime As Long\nPrivate pEndTime As Long\n\nPublic Property Get Name() As String\n Name = pName\nEnd Property\n\nPublic Property Let Name(value As String)\n pName = value\nEnd Property\n\nPublic Property Get StartTime() As Long\n StartTime = pStartTime\nEnd Property\n\nPublic Property Let StartTime(value As Long)\n pStartTime = value\nEnd Property\n\nPublic Property Get Endtime() As Long\n Endtime = pEndTime\nEnd Property\n\nPublic Property Let Endtime(value As Long)\n pEndTime = value\nEnd Property\n" }, { "path": "Algorithms/AlgorithmsTesting/Modul1.bas", "content": "Attribute VB_Name = \"Modul1\"\nOption Explicit\n\nPublic Sub Main()\n\n Dim totalTests As Long\n Dim pathInputTests As String\n Dim pathOutputTests As String\n\n Dim inputTests As Variant\n Dim outputTests As Variant\n\n Dim cntTests As Long\n Dim cnt As Long\n\n pathInputTests = \"C:\\Desktop\\Test002.txt\"\n pathOutputTests = \"C:\\Desktop\\Result002.txt\"\n\n inputTests = Split(ReadFileLineByLineToString(pathInputTests), vbCrLf)\n outputTests = Split(ReadFileLineByLineToString(pathOutputTests), vbCrLf)\n\n For cnt = LBound(inputTests) To UBound(inputTests)\n\n Dim expectedValue As Variant\n Dim receivedValue As Variant\n\n On Error Resume Next\n\n expectedValue = outputTests(cnt)\n receivedValue = MainTest(Trim(inputTests(cnt)))\n\n If Err.Number <> 0 Then\n Debug.Print runtimeError(cnt)\n Err.Clear\n Else\n If Trim(expectedValue) = Trim(receivedValue) Then\n Debug.Print positiveResult(cnt)\n Else\n Debug.Print negativeResult(cnt, expectedValue, receivedValue)\n End If\n End If\n\n Next cnt\n\nEnd Sub\n\nPublic Function runtimeError(ByVal cnt As Long) As String\n cnt = cnt + 1\n runtimeError = \"Runtime error on \" & cnt & \"!\"\nEnd Function\n\nPublic Function positiveResult(ByVal cnt As Long) As String\n cnt = cnt + 1\n positiveResult = \"Test \" & cnt & \"..................................... ok!\"\nEnd Function\n\nPublic Function negativeResult(ByVal cnt As Long, expected As Variant, _\n received As Variant) As String\n cnt = cnt + 1\n negativeResult = \"Error on test \" & cnt & \"!\" & _\n \" Expected -> \" & vbTab & expected & vbTab & _\n \" Received -> \" & vbTab & received\n\nEnd Function\n\n'---------------------------------------------------------------------------------------\n' Method : MainTest\n' Purpose: This is where the competitors paste their solution.\n'---------------------------------------------------------------------------------------\n\nPublic Function MainTest(ByVal consoleInput As String) As String\n\n Dim inputVar As Variant\n Dim cnt As Long\n Dim outputVar As Variant\n \n inputVar = Split(consoleInput)\n ReDim outputVar(UBound(inputVar))\n \n For cnt = LBound(inputVar) To UBound(inputVar)\n If Asc(inputVar(cnt)) = Asc(\"z\") Then\n MainTest = MainTest & \" a\"\n Else\n MainTest = MainTest & \" \" & Chr(Asc(inputVar(cnt)) + 1)\n End If\n \n Next cnt\n\n' Dim a As Double\n' Dim b As Double\n' Dim c As Double\n'\n' a = Split(consoleInput)(0)\n' b = Split(consoleInput)(1)\n' c = Split(consoleInput)(2)\n'\n' If c Mod 2 = 0 Then\n' MainTest = a + b + c\n' Else\n' MainTest = a + b - c\n' End If\n\nEnd Function\n\n\nPublic Function ReadFromFile(path As String) As String\n\n Dim fileNo As Long\n fileNo = FreeFile\n\n Open path For Input As #fileNo\n\n Do While Not EOF(fileNo)\n Dim textRowInput As String\n Line Input #fileNo, textRowInput\n ReadFromFile = ReadFromFile & textRowInput\n If Not EOF(fileNo) Then\n ReadFromFile = ReadFromFile & vbCrLf\n End If\n Loop\n\n Close #fileNo\n\nEnd Function\n\nSub WriteToFile(filePath As String, text As String)\n\n Dim fso As Object\n Set fso = CreateObject(\"Scripting.FileSystemObject\")\n Dim oFile As Object\n Set oFile = fso.CreateTextFile(filePath)\n oFile.Write text\n oFile.Close\n \nEnd Sub\n\nSub TestMe()\n\n Dim readTxt As String\n Dim filePath As String: filePath = \"C:\\text.txt\"\n\n readTxt = ReadFromFile(filePath)\n readTxt = Replace(readTxt, \"name=\", \"\")\n readTxt = Replace(readTxt, \"correo=\", \"\")\n\n WriteToFile filePath, readTxt\n\nEnd Sub\n\n\n\n" }, { "path": "Algorithms/AlgorithmsTesting/ReadMe.md", "content": "# Algorithm testing system, reading from text file with VBA\n\nFor the people, familiar with my blog, it is known that usually I am resolving problems from Codeforces.com. Codeforces supports plenty of languages, unfortunately VBA is not one of them. Thus, I have decided to build up a small algorithm testing system, which follows the following pattern – the input and the expected output are both provided via separate text files. Then, the person who writes the algorithm, should be able to write a function, reading from the first file and getting exactly the values from the other file.\nThus, let’s imagine that the task sounds like:\nTake an input of 3 numbers and sum them. However, if the third number is even, do sum only the first two and subtract the third. \nThis is easily achievable through this function (...)\n\nThe whole article is available @ [VitoshAcademy](http://www.vitoshacademy.com/algorithm-testing-system-reading-from-text-file-with-vba/)\n" }, { "path": "Algorithms/AlgorithmsTesting/Result001.txt", "content": "6\n1\n1\n58\n100\n121\n100\n" }, { "path": "Algorithms/AlgorithmsTesting/Result002.txt", "content": "b c d e f g\nc\na\nd d\na a b" }, { "path": "Algorithms/AlgorithmsTesting/Test001.txt", "content": "2 2 2\n2 2\n2 2 3\n4 54 1\n2 2\n54 23 6\n45 45 10\n" }, { "path": "Algorithms/AlgorithmsTesting/Test002.txt", "content": "a b c d e f\nb\nz\nc c\nz z a" }, { "path": "Algorithms/CryptographyHashing/Base64Sha1.bas", "content": "Public Function Base64Sha1(inputText As String, Optional secretKey = \"\") As String\n\n Dim asc As Object\n Dim enc As Object\n Dim textToHash() As Byte\n Dim SharedSecretKey() As Byte\n Dim bytes() As Byte\n \n If secretKey = \"\" Then secretKey = inputText\n \n Set asc = CreateObject(\"System.Text.UTF8Encoding\")\n Set enc = CreateObject(\"System.Security.Cryptography.HMACSHA1\")\n\n textToHash = asc.GetBytes_4(inputText)\n SharedSecretKey = asc.GetBytes_4(secretKey)\n enc.Key = SharedSecretKey\n\n bytes = enc.ComputeHash_2((textToHash))\n Base64Sha1 = EncodeBase64(bytes)\n\nEnd Function\n\nPrivate Function EncodeBase64(arrData() As Byte) As String\n\n Dim objXML As Object\n Dim objNode As Object\n\n Set objXML = CreateObject(\"MSXML2.DOMDocument\")\n Set objNode = objXML.createElement(\"b64\")\n\n objNode.DataType = \"bin.base64\"\n objNode.nodeTypedValue = arrData\n EncodeBase64 = objNode.text\n\nEnd Function\n\nSub TestMe()\n \n Debug.Print Base64Sha1(\"asdf\", \"ThisIsTheSecretKey\") = \"DSmGEC8dUW9xRs+YfAPji59dxCM=\"\n Debug.Print Base64Sha1(\"asdf\") = \"qIQmNGgreJRqJroWUUu0MxLq2oo=\"\n Debug.Print Base64Sha1(\"asdf\", \"asdf\") = \"qIQmNGgreJRqJroWUUu0MxLq2oo=\"\n \nEnd Sub\n" }, { "path": "Algorithms/CryptographyHashing/string_to_hash.py", "content": "import hmac\nimport hashlib\nimport base64\n\ndef string_to_hash(word):\n word = word.encode('utf-8')\n hash = hmac.new(word, word, hashlib.sha1).digest()\n return base64.b64encode(hash).decode(\"utf-8\")\n\nprint(string_to_hash('a')) #OQLthH/yiTC18UGr+otHFoElNnM=" }, { "path": "Algorithms/FillNumbersInGivenRange.vb", "content": "Option Explicit\n\nPrivate currentMove As Direction\nPrivate size As Long\n\nPublic Enum Direction\n Right\n Down\n Left\n Up\nEnd Enum\n\nSub Main()\n \n Cells.Clear\n size = 2\n SetMatrixStars\n MakeMatrix\n Cells.Columns.AutoFit\n\nEnd Sub\n\nSub SetMatrixStars()\n \n \n Dim i As Long\n For i = 1 To size\n Cells(size + 1, i) = \"*\"\n Cells(i, size + 1) = \"*\"\n Next i\n \n Cells(size + 1, size + 1) = \"*\"\n \nEnd Sub\n\nSub MakeMatrix()\n \n Dim currentCell As Range: Set currentCell = Cells(1, 1)\n \n currentMove = Right\n Dim i As Long\n\n Do While True\n i = i + 1\n currentCell = i\n If IsLast(currentCell) Then Exit Do\n Set currentCell = nextCell(currentCell)\n Loop\n \nEnd Sub\n\nFunction IsLast(currentCell As Range) As Boolean\n \n If size = 1 Then\n IsLast = True\n Exit Function\n End If\n \n If currentCell.Row = 1 Or currentCell.Column = 1 Then\n If size = 2 And currentCell = 4 Then\n IsLast = True\n Else\n IsLast = False\n End If\n Exit Function\n End If\n \n IsLast = Not IsEmpty(currentCell.Offset(1, 0)) _\n And Not IsEmpty(currentCell.Offset(-1, 0)) _\n And Not IsEmpty(currentCell.Offset(0, -1)) _\n And Not IsEmpty(currentCell.Offset(0, 1))\n \nEnd Function\n\n\nPublic Function nextCell(currentCell As Range) As Range\n \n Select Case currentMove\n \n Case Direction.Right\n If IsEmpty(currentCell.Offset(, 1)) Then\n Set nextCell = currentCell.Offset(, 1)\n Else\n Set nextCell = currentCell.Offset(1)\n currentMove = Direction.Down\n End If\n \n Case Direction.Down\n If IsEmpty(currentCell.Offset(1)) Then\n Set nextCell = currentCell.Offset(1)\n Else\n Set nextCell = currentCell.Offset(, -1)\n currentMove = Direction.Left\n End If\n \n Case Direction.Left\n If currentCell.Column = 1 Then\n Set nextCell = currentCell.Offset(-1)\n currentMove = Direction.Up\n Else\n If IsEmpty(currentCell.Offset(, -1)) Then\n Set nextCell = currentCell.Offset(, -1)\n Else\n Set nextCell = currentCell.Offset(-1)\n currentMove = Direction.Up\n End If\n End If\n \n Case Direction.Up\n If IsEmpty(currentCell.Offset(-1)) Then\n Set nextCell = currentCell.Offset(-1)\n Else\n Set nextCell = currentCell.Offset(0, 1)\n currentMove = Direction.Right\n End If\n End Select\n \nEnd Function\n" }, { "path": "Algorithms/Games/SnakeAttempt.vb", "content": "Option Explicit\n\n'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646299(v=vs.85).aspx\n'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646293(v=vs.85).aspx\n\nPrivate Declare PtrSafe Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nPublic Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Long\n\nPrivate Const SIZE_WIDTH As Long = 7\nPrivate Const SIZE_HEIGTH As Long = 5\nPrivate Const COL_WIDTH As Double = 2.3\nPrivate Const BORDER_COL As Long = 190\n\nPrivate wks As Worksheet\nPrivate pointX As Long\nPrivate pointY As Long\nPrivate leadPoint As Range\nPrivate pointField As Range\n\nPrivate movingDirection As Direction\nPublic Enum Direction\n\n GoUp = 1\n GoRight = 2\n GoDown = 3\n GoLeft = 4\n\nEnd Enum\n\nPrivate Sub Main()\n \n FixThePitch\n InitializePoint\n PrintInformation\n MoveAround\n \nEnd Sub\n\nPublic Sub PrintInformation()\n \n Debug.Print \"Press Home to exit.\"\n \nEnd Sub\n\nPrivate Sub ShowNewFood()\n \n Dim positionRow As Long\n Dim positionCol As Long\n \n positionRow = 1\n positionCol = 1\n \nEnd Sub\n\nPrivate Function MakeRandom(down As Long, up As Long) As Long\n\n MakeRandom = CLng((up - down) * Rnd + down)\n\nEnd Function\n\nPublic Sub ChangePoints(pointToChange As Long)\n\n pointField.value = pointField + pointToChange\n\nEnd Sub\n\nPublic Sub GoMove(moveDir As Direction)\n \n Debug.Print moveDir\n \nEnd Sub\n\nPublic Sub ColorSnake()\n \n With wks\n .Range(.Cells(1, 1), .Cells(SIZE_HEIGTH, SIZE_WIDTH)).Clear\n End With\n leadPoint.Interior.COLOR = vbWhite\n\nEnd Sub\n\nPrivate Sub MoveFurther()\n \n Select Case movingDirection\n \n Case GoUp:\n If leadPoint.row = 1 Then\n Set leadPoint = Cells(SIZE_HEIGTH, leadPoint.Column)\n Else\n Set leadPoint = Cells(leadPoint.row - 1, leadPoint.Column)\n End If\n \n Case GoRight:\n If leadPoint.Column = SIZE_WIDTH Then\n Set leadPoint = Cells(leadPoint.row, 1)\n Else\n Set leadPoint = Cells(leadPoint.row, leadPoint.Column + 1)\n End If\n \n Case GoDown:\n If leadPoint.row = SIZE_HEIGTH Then\n Set leadPoint = Cells(1, leadPoint.Column)\n Else\n Set leadPoint = Cells(leadPoint.row + 1, leadPoint.Column)\n End If\n \n Case GoLeft:\n If leadPoint.Column = 1 Then\n Set leadPoint = Cells(leadPoint.row, SIZE_WIDTH)\n Else\n Set leadPoint = Cells(leadPoint.row, leadPoint.Column - 1)\n End If\n End Select\n \nEnd Sub\n\nPrivate Sub ReadKey()\n\n Debug.Assert Not IsEmpty(GetAsyncKeyState(vbKeyUp))\n \n Select Case True\n Case GetAsyncKeyState(vbKeyHome)\n Debug.Print \"Exiting...\"\n End\n \n Case GetAsyncKeyState(vbKeyUp):\n movingDirection = GoUp\n \n Case GetAsyncKeyState(vbKeyRight):\n movingDirection = GoRight\n \n Case GetAsyncKeyState(vbKeyDown):\n movingDirection = GoDown\n \n Case GetAsyncKeyState(vbKeyLeft):\n movingDirection = GoLeft\n End Select\n \nEnd Sub\n\nPrivate Sub MoveAround()\n\n movingDirection = Direction.GoRight\n \n Do While True\n DoEvents\n ReadKey\n ColorSnake\n MoveFurther\n Sleep (200)\n Loop\n\nEnd Sub\n\nPrivate Sub InitializePoint()\n\n Set leadPoint = wks.Cells(2, 3)\n\nEnd Sub\n\nPrivate Sub FixThePitch()\n\n Set wks = tbl_Internal1\n\n wks.visible = xlSheetVisible\n wks.Activate\n \n With wks\n .Cells.Delete\n .Cells(1, 1).Select\n .Range(.Cells(1), .Cells(1 + SIZE_WIDTH)).ColumnWidth = COL_WIDTH\n .Range(.Cells(SIZE_HEIGTH + 1, 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL)\n .Range(.Cells(1, SIZE_WIDTH + 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH + 1)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL)\n End With\n\n Set pointField = wks.Cells(8, 1)\n ChangePoints (0)\n \nEnd Sub\n" }, { "path": "Algorithms/Games/SnakePrinting.vb", "content": "Option Explicit\n\nPublic Function SnakeMyNumbers(n As Long) As String\n\n Dim lngCol As Long\n Dim lngRow As Long\n Dim str As String\n \n For lngCol = 0 To n - 1\n \n str = \"\"\n \n For lngRow = 0 To n - 1\n If lngRow Mod 2 = 0 Then\n str = str & vbTab & n * lngRow + lngCol + 1\n Else\n str = str & vbTab & n * (lngRow + 1) - lngCol\n End If\n Next lngRow\n \n SnakeMyNumbers = SnakeMyNumbers & str & vbCrLf\n Next lngCol\n\nEnd Function\n" }, { "path": "Algorithms/GoRightAndDown.vb", "content": "Option Explicit\n\nSub GreedyAlgorithm()\n \n Dim rowsCount As Long\n Dim colCount As Long\n Dim l_row_counter As Long\n Dim l_col_counter As Long\n Dim l_min_value As Long\n Dim max_prev_cell As Long\n \n Dim arr_sum As Variant\n Dim arr_reverse As Variant\n\n Dim rng As Range\n Dim rng2 As Range\n \n Calculate\n Application.Calculation = xlCalculationManual\n \n Set rng = [matrix]\n Set rng2 = [matrix2]\n \n rowsCount = [matrix].Rows.Count\n colCount = [matrix].Columns.Count\n rng2.Clear\n \n l_min_value = Application.WorksheetFunction.Min([matrix]) - 1\n ReDim arr_sum(rowsCount, colCount)\n ReDim arr_reverse(rowsCount, colCount)\n For l_row_counter = 1 To rowsCount\n For l_col_counter = 1 To colCount\n \n max_prev_cell = l_min_value\n \n If l_row_counter > 1 Then\n If arr_sum(l_row_counter - 1, l_col_counter) > max_prev_cell Then\n max_prev_cell = arr_sum(l_row_counter - 1, l_col_counter)\n End If\n End If\n \n If l_col_counter > 1 Then\n If arr_sum(l_row_counter, l_col_counter - 1) > max_prev_cell Then\n max_prev_cell = arr_sum(l_row_counter, l_col_counter - 1)\n End If\n End If\n \n arr_sum(l_row_counter, l_col_counter) = rng.Item(l_row_counter, l_col_counter)\n rng2.Item(l_row_counter, l_col_counter) = rng.Item(l_row_counter, l_col_counter)\n \n If max_prev_cell <> l_min_value Then\n arr_sum(l_row_counter, l_col_counter) = arr_sum(l_row_counter, l_col_counter) + max_prev_cell\n rng2.Item(l_row_counter, l_col_counter) = arr_sum(l_row_counter, l_col_counter)\n End If\n \n Next l_col_counter\n Next l_row_counter\n \n l_col_counter = l_col_counter - 1\n l_row_counter = l_row_counter - 1\n \n While (l_row_counter > 0) And (l_col_counter > 0)\n arr_reverse(l_row_counter, l_col_counter) = True\n If arr_sum(l_row_counter - 1, l_col_counter) > arr_sum(l_row_counter, l_col_counter - 1) Then\n l_row_counter = l_row_counter - 1\n Else\n l_col_counter = l_col_counter - 1\n End If\n\n Wend\n \n For l_row_counter = 1 To rowsCount\n For l_col_counter = 1 To colCount\n If arr_reverse(l_row_counter, l_col_counter) Then\n rng2.Item(l_row_counter, l_col_counter).Font.Color = vbRed\n End If\n Next l_col_counter\n Next l_row_counter\n \n rng.Columns.EntireColumn.AutoFit\n rng2.Columns.EntireColumn.AutoFit\n \n 'Application.Calculation = xlAutomatic\n\nEnd Sub\n" }, { "path": "Algorithms/Knight.vb", "content": "Option Explicit\n\nPublic r_range As Range\nPublic r_used_range As Range\nPublic l_result As Long\n\nPublic Sub DeleteOthers()\n \n Dim r_cell As Range\n \n For Each r_cell In r_used_range\n If r_cell.Interior.Color <> vbGreen Then r_cell.ClearContents\n Next r_cell\n \nEnd Sub\n\nPublic Sub CalculatePriceWithItalic(r_cell As Range, l_size As Long, Optional b_once As Boolean = False)\n \n Dim r_row As Range\n Dim r_col As Range\n Dim my_cell As Range\n\n Dim l_row As Long\n Dim l_col As Long\n \n l_result = 0\n \n 'RIGHT\n l_row = r_cell.Row + 1\n l_col = r_cell.Column + 2\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n l_row = r_cell.Row - 1\n l_col = r_cell.Column + 2\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n 'DOWN\n l_row = r_cell.Row + 2\n l_col = r_cell.Column + 1\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n l_row = r_cell.Row + 2\n l_col = r_cell.Column - 1\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n 'LEFT\n l_row = r_cell.Row - 1\n l_col = r_cell.Column - 2\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n\n l_row = r_cell.Row + 1\n l_col = r_cell.Column - 2\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n 'UP\n l_row = r_cell.Row - 2\n l_col = r_cell.Column - 1\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n\n l_row = r_cell.Row - 2\n l_col = r_cell.Column + 1\n Call CheckRow(l_row, l_col, l_size, r_cell, b_once)\n \n r_cell = l_result\n Set my_cell = Nothing\n\nEnd Sub\n\nPublic Sub CheckRow(l_row As Long, l_col As Long, l_size As Long, r_cell As Range, b_once As Boolean)\n\n If l_row <= l_size And l_col <= l_size And l_row > 0 And l_col > 0 Then\n If Len(Cells(l_row, l_col)) < 1 And Cells(l_row, l_col).Address <> r_cell.Address Then\n l_result = l_result + 1\n If b_once Then Call CalculatePriceWithItalic(Cells(l_row, l_col), l_size)\n End If\n End If\n\nEnd Sub\n\nSub main()\n\n Dim my_array() As Variant\n Dim my_array_b() As Variant\n \n Dim l_counter As Long\n Dim l_counter_2 As Long\n Dim l_counter_moves As Long: l_counter_moves = 1\n Dim my_cell As Range\n Dim b_animate As Boolean\n Dim l_starting_row As Long\n Dim l_starting_col As Long\n \n b_animate = True\n l_counter = 8\n l_starting_row = 8\n l_starting_col = 8\n \n If l_starting_row > l_counter Or l_starting_row < 1 Then l_starting_row = l_counter\n If l_starting_col > l_counter Or l_starting_col < 1 Then l_starting_col = l_counter\n \n Call OnStart(b_animate)\n \n ReDim my_array(l_counter)\n \n Set r_used_range = Range(Cells(1, 1), Cells(100, 100))\n r_used_range.Clear\n \n Set r_used_range = Range(Cells(1, 1), Cells(l_counter, l_counter))\n r_used_range.Clear\n \n \n Call FormatRangeInitially(r_used_range)\n \n For l_counter_2 = 1 To l_counter\n ReDim my_array_b(l_counter)\n my_array(l_counter_2) = my_array_b\n Next l_counter_2\n \n Set my_cell = Cells(l_starting_row, l_starting_col)\n \n While l_counter_moves <= (l_counter ^ 2)\n Call CalculatePriceWithItalic(my_cell, l_counter, True)\n Call FormatMyCell(my_cell, l_counter_moves, 1)\n \n If b_animate Then Application.Wait (Now + TimeValue(\"00:00:01\"))\n \n Call FormatMyCell(my_cell, l_counter_moves, 2)\n \n l_counter_moves = l_counter_moves + 1\n Set my_cell = FindNextTarget\n \n Call DeleteOthers\n Wend\n \n Set r_used_range = Nothing\n Set r_range = Nothing\n Set my_cell = Nothing\n \n Call OnEnd\n \nEnd Sub\n\nFunction FindNextTarget() As Range\n \n Dim my_next As Range\n Dim lowest As Long: lowest = 9999\n \n For Each my_next In r_used_range\n If my_next.Value < lowest And my_next.Value > 0 And my_next.Interior.Color <> vbGreen Then\n lowest = my_next.Value\n Set FindNextTarget = my_next\n End If\n Next my_next\n \nEnd Function\n\nSub FormatMyCell(ByRef my_cell_range As Range, l_counter As Long, l_color As Long)\n \n If l_color = 2 Then my_cell_range.Interior.Color = vbGreen\n If l_color = 1 Then my_cell_range.Interior.Color = vbRed\n \n my_cell_range = l_counter\n\nEnd Sub\n\nPublic Sub FormatRangeInitially(r_range As Range)\n \n r_range.HorizontalAlignment = xlCenter\n r_range.Borders(xlDiagonalDown).LineStyle = xlNone\n r_range.Borders(xlDiagonalUp).LineStyle = xlNone\n With r_range.Borders(xlEdgeLeft)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n With r_range.Borders(xlEdgeTop)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n With r_range.Borders(xlEdgeBottom)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n With r_range.Borders(xlEdgeRight)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n With r_range.Borders(xlInsideVertical)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n With r_range.Borders(xlInsideHorizontal)\n .LineStyle = xlContinuous\n .ColorIndex = 0\n .TintAndShade = 0\n .Weight = xlThin\n End With\n \n r_range.ColumnWidth = 3.2\n\nEnd Sub\n\nPublic Sub OnStart(b_animate As Boolean)\n \n Application.DisplayAlerts = False\n If Not b_animate Then Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n \n 'Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\n\n" }, { "path": "Algorithms/LongestIncreasingSubsequence.vb", "content": "Option Explicit\n\nPublic Const NO_PREVIOUS = -1\n\nSub Main()\n\n Dim arrSeq As Variant\n Dim arrLen As Variant\n Dim arrPre As Variant\n \n Dim bestLength As Long\n \n arrSeq = Array(1, 2, -6, -5, -3, 23, 123, 3, 2, -23, -5, 54, 100, 200, 300, 1111, 23412, 3, 4, 5, 6, 7, 8, 9, 19, 65, 2)\n ReDim arrLen(UBound(arrSeq))\n ReDim arrPre(UBound(arrSeq))\n \n bestLength = CalculateLongestIncreasingSubsequence(arrSeq, arrLen, arrPre)\n PrintArray arrSeq\n PrintArray arrLen\n PrintArray arrPre\n \n PrintLongestIncreasingSubsequance arrSeq, arrPre, bestLength\n \nEnd Sub\n\nPublic Sub PrintLongestIncreasingSubsequance(ByRef arrSeq As Variant, _\n ByRef arrPre As Variant, _\n bestLength As Long)\n \n Dim arrResult As Variant\n Dim counter As Long: counter = 0\n \n ReDim arrResult(1)\n \n While (bestLength <> NO_PREVIOUS)\n ReDim Preserve arrResult(counter)\n counter = counter + 1\n arrResult(counter - 1) = arrSeq(bestLength)\n bestLength = arrPre(bestLength)\n Wend\n \n Debug.Print Join(ReverseArray(arrResult), \" \")\n \nEnd Sub\n\n\nPublic Function CalculateLongestIncreasingSubsequence(ByRef arrSeq As Variant, _\n ByRef arrLen As Variant, _\n ByRef arrPre As Variant) As Long\n\n Dim bestLengthLen As Long: bestLengthLen = 0\n Dim bestLengthIndex As Long: bestLengthIndex = 0\n Dim x As Long\n Dim i As Long\n \n For x = LBound(arrSeq) To (UBound(arrSeq))\n arrLen(x) = 1\n arrPre(x) = NO_PREVIOUS\n \n For i = 0 To x Step 1\n If (arrSeq(i) < arrSeq(x)) And (arrLen(i) + 1 > arrLen(x)) Then\n \n arrLen(x) = arrLen(i) + 1\n arrPre(x) = i\n \n If arrLen(x) > bestLengthLen Then\n bestLengthLen = arrLen(x)\n bestLengthIndex = x\n End If\n End If\n \n Next i\n Next x\n \n CalculateLongestIncreasingSubsequence = bestLengthIndex\n \nEnd Function\n\nPublic Sub PrintArray(ByRef myArray As Variant)\n Dim counter As Long\n \n For counter = LBound(myArray) To UBound(myArray)\n Debug.Print counter & \" --> \" & myArray(counter)\n Next counter\n Debug.Print \"------------------------------\"\nEnd Sub\n\nPublic Function ReverseArray(ByVal myArray As Variant) As Variant\n\n Dim counter As Long\n Dim counter2 As Long\n Dim arrNew As Variant\n \n ReDim arrNew(UBound(myArray) + 1)\n \n For counter = LBound(arrNew) To UBound(arrNew) - 1\n counter2 = UBound(arrNew) - counter - 1\n arrNew(counter) = myArray(counter2)\n Next counter\n\n ReverseArray = arrNew\n\nEnd Function\n\n" }, { "path": "Algorithms/NpComplete/NestedLoops.vb", "content": "Option Explicit\n\nSub TestMe()\n\n Dim myArr As Variant\n Dim myLoop As Variant\n Dim targetValue As Long\n Dim currentSum As Long\n\n myArr = Array(215, 275, 335, 355, 420, 580)\n targetValue = 1505\n\n Dim cnt0&, cnt1&, cnt2&, cnt3&, cnt4&, cnt5&, cnt6&\n Dim cnt As Long\n\n\n For cnt0 = 0 To 5\n For cnt1 = 0 To 5\n For cnt2 = 0 To 5\n For cnt3 = 0 To 5\n For cnt4 = 0 To 5\n For cnt5 = 0 To 5\n currentSum = 0\n\n Dim printableArray As Variant\n printableArray = Array(cnt0, cnt1, cnt2, cnt3, cnt4, cnt5)\n\n For cnt = LBound(myArr) To UBound(myArr)\n IncrementSum printableArray(cnt), myArr(cnt), currentSum\n Next cnt\n\n If currentSum = targetValue Then\n printValuesOfArray printableArray, myArr\n End If\n Next: Next: Next: Next: Next: Next\n\nEnd Sub\n\nPublic Sub printValuesOfArray(myArr As Variant, initialArr As Variant)\n\n Dim cnt As Long\n Dim printVal As String\n\n For cnt = LBound(myArr) To UBound(myArr)\n If myArr(cnt) Then\n printVal = printVal & myArr(cnt) & \" * \" & initialArr(cnt) & vbCrLf\n End If\n Next cnt\n\n Debug.Print printVal\n\nEnd Sub\n\nPublic Sub IncrementSum(ByVal multiplicator As Long, _\n ByVal arrVal As Long, ByRef currentSum As Long)\n\n currentSum = currentSum + arrVal * multiplicator\n\nEnd Sub\n" }, { "path": "Algorithms/NpComplete/RecursionLoops.vb", "content": "Option Explicit\n\nSub Main()\n\n Dim posArr As Variant\n Dim iniArr As Variant\n Dim tryArr As Variant\n Dim cnt As Long\n Dim targetVal As Long: targetVal = 1505\n\n iniArr = Array(215, 275, 335, 355, 420, 580)\n ReDim posArr(UBound(iniArr))\n ReDim tryArr(UBound(iniArr))\n\n For cnt = LBound(posArr) To UBound(posArr)\n posArr(cnt) = cnt\n Next cnt\n EmbeddedLoops 0, posArr, tryArr, iniArr, targetVal\n\nEnd Sub\n\nFunction EmbeddedLoops(index As Long, posArr As Variant, tryArr As Variant, _\n iniArr As Variant, targetVal As Long)\n\n Dim myUnit As Variant\n Dim cnt As Long\n\n If index >= UBound(posArr) + 1 Then\n If CheckSum(tryArr, iniArr, targetVal) Then\n For cnt = LBound(tryArr) To UBound(tryArr)\n If tryArr(cnt) Then Debug.Print tryArr(cnt) & \" x \" & iniArr(cnt)\n Next cnt\n End If\n Else\n For Each myUnit In posArr\n tryArr(index) = myUnit\n EmbeddedLoops index + 1, posArr, tryArr, iniArr, targetVal\n Next myUnit\n End If\n\nEnd Function\n\nPublic Function CheckSum(posArr, iniArr, targetVal) As Boolean\n\n Dim cnt As Long\n Dim compareVal As Long\n\n For cnt = LBound(posArr) To UBound(posArr)\n compareVal = posArr(cnt) * iniArr(cnt) + compareVal\n Next cnt\n CheckSum = CBool(compareVal = targetVal)\n\nEnd Function\n" }, { "path": "Algorithms/NpComplete/readme.md", "content": "Both VBA files are a solution of this joke:\n\n\n\n\n![alt text](https://imgs.xkcd.com/comics/np_complete.png)\n" }, { "path": "Algorithms/PwdHacks/CrackerJack.vb", "content": "'---------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------\n\nOption Explicit\n\nPublic Sub CJ()\n If CJ.Hook Then\n Debug.Print \"The deal is done!\"\n End If\nEnd Sub\n\n'---------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------\n\nOption Explicit\n\nOption Private Module\n\nPrivate Const PAGE_EXECUTE_READWRITE = &H40\n\nPrivate Declare Sub MoveMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" _\n (Destination As Long, Source As Long, ByVal Length As Long)\n\nPrivate Declare Function VirtualProtect Lib \"kernel32\" (lpAddress As Long, _\n ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long\n\nPrivate Declare Function GetModuleHandleA Lib \"kernel32\" (ByVal lpModuleName As String) As Long\n\nPrivate Declare Function GetProcAddress Lib \"kernel32\" (ByVal hModule As Long, _\n ByVal lpProcName As String) As Long\n\nPrivate Declare Function DialogBoxParam Lib \"user32\" Alias \"DialogBoxParamA\" (ByVal hInstance As Long, _\n ByVal pTemplateName As Long, ByVal hWndParent As Long, _\n ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer\n\nDim HookBytes(0 To 5) As Byte\nDim OriginBytes(0 To 5) As Byte\nDim pFunc As Long\nDim Flag As Boolean\n\nPrivate Function GetPtr(ByVal Value As Long) As Long\n GetPtr = Value\nEnd Function\n\nPublic Sub RecoverBytes()\n If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6\nEnd Sub\n\nPublic Function Hook() As Boolean\n Dim TmpBytes(0 To 5) As Byte\n Dim p As Long\n Dim OriginProtect As Long\n\n Hook = False\n\n pFunc = GetProcAddress(GetModuleHandleA(\"user32.dll\"), \"DialogBoxParamA\")\n\n\n If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then\n\n MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6\n If TmpBytes(0) <> &H68 Then\n\n MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6\n\n p = GetPtr(AddressOf MyDialogBoxParam)\n\n HookBytes(0) = &H68\n MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4\n HookBytes(5) = &HC3\n\n MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6\n Flag = True\n Hook = True\n End If\n End If\nEnd Function\n\nPrivate Function MyDialogBoxParam(ByVal hInstance As Long, _\n ByVal pTemplateName As Long, ByVal hWndParent As Long, _\n ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer\n If pTemplateName = 4070 Then\n MyDialogBoxParam = 1\n Else\n RecoverBytes\n MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _\n hWndParent, lpDialogFunc, dwInitParam)\n Hook\n End If\nEnd Function\n\n'---------------------\n'---------------------\n'---------------------\n'--------------64 bits\n \nOption Explicit\n\nPrivate Const PAGE_EXECUTE_READWRITE = &H40\n\nPrivate Declare PtrSafe Sub MoveMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" _\n(Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)\n\nPrivate Declare PtrSafe Function VirtualProtect Lib \"kernel32\" (lpAddress As LongPtr, _\nByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr\n\nPrivate Declare PtrSafe Function GetModuleHandleA Lib \"kernel32\" (ByVal lpModuleName As String) As LongPtr\n\nPrivate Declare PtrSafe Function GetProcAddress Lib \"kernel32\" (ByVal hModule As LongPtr, _\nByVal lpProcName As String) As LongPtr\n\nPrivate Declare PtrSafe Function DialogBoxParam Lib \"user32\" Alias \"DialogBoxParamA\" (ByVal hInstance As LongPtr, _\nByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _\nByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer\n\nDim HookBytes(0 To 5) As Byte\nDim OriginBytes(0 To 5) As Byte\nDim pFunc As LongPtr\nDim Flag As Boolean\n\nPrivate Function GetPtr(ByVal Value As LongPtr) As LongPtr\n GetPtr = Value\nEnd Function\n\nPublic Sub RecoverBytes()\n If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6\nEnd Sub\n\nPublic Function Hook() As Boolean\n Dim TmpBytes(0 To 5) As Byte\n Dim p As LongPtr\n Dim OriginProtect As LongPtr\n\n Hook = False\n\n pFunc = GetProcAddress(GetModuleHandleA(\"user32.dll\"), \"DialogBoxParamA\")\n\n\n If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then\n\n MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6\n If TmpBytes(0) <> &H68 Then\n\n MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6\n\n p = GetPtr(AddressOf MyDialogBoxParam)\n\n HookBytes(0) = &H68\n MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4\n HookBytes(5) = &HC3\n\n MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6\n Flag = True\n Hook = True\n End If\n End If\nEnd Function\n\nPrivate Function MyDialogBoxParam(ByVal hInstance As LongPtr, _\nByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _\nByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer\n\n If pTemplateName = 4070 Then\n MyDialogBoxParam = 1\n Else\n RecoverBytes\n MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _\n hWndParent, lpDialogFunc, dwInitParam)\n Hook\n End If\nEnd Function\n\n" }, { "path": "Algorithms/PwdHacks/GhostBreakInfo.vb", "content": "'http://stackoverflow.com/questions/2154699/excel-vba-app-stops-spontaneously-with-message-code-execution-has-been-halted\n'Ghost break unwanted break freezing\n\nPress \"Debug\" button in the popup.\nPress Ctrl+Pause|Break twice.\nHit the play button to continue.\nSave the file after completion.\n" }, { "path": "Algorithms/PwdHacks/Xlsb.PasswordRemover.vb", "content": "Change .xlsb to .zip\nOpen zip\nxl>vbaProject.bin\nSearch and replace \"DPB\" with \"DPx\", where there is a string after\nSave all\nChange back .zip to .xlsb\nOpen and click \"Yes\"\n" }, { "path": "Algorithms/QueenDrama.vb", "content": "Option Explicit\n\nPublic Const SIZE = 8\n\nPublic b_chessboard(7, 7) As Variant\nPublic l_solutions_found As Long\n\nPublic attackedRows As Object ' as New Scripting.Dictionary => for early binding with Microsoft Scripting Runtime\nPublic attackedColumns As Object\nPublic attackedLeftDiagonals As Object\nPublic attackedRightDiagonals As Object\n\nSub Main()\n \n Set attackedRows = CreateObject(\"Scripting.Dictionary\")\n Set attackedColumns = CreateObject(\"Scripting.Dictionary\")\n Set attackedLeftDiagonals = CreateObject(\"Scripting.Dictionary\")\n Set attackedRightDiagonals = CreateObject(\"Scripting.Dictionary\")\n \n tbl_show.Cells.Delete\n l_solutions_found = 0\n Call PutQueens(0)\n tbl_show.Columns.ColumnWidth = 3\n \n Set attackedRows = Nothing\n Set attackedColumns = Nothing\n Set attackedLeftDiagonals = Nothing\n Set attackedRightDiagonals = Nothing\n \n \nEnd Sub\n\nSub PutQueens(l_row As Long)\n \n Dim l_col As Long\n \n If l_row = SIZE Then\n \n Call PrintSolution\n l_solutions_found = l_solutions_found + 1\n \n Else\n For l_col = 0 To SIZE - 1 Step 1\n If CanPlaceQueen(l_row, l_col) Then\n \n Call MarkAllAttackedPositions(l_row, l_col)\n Call PutQueens(l_row + 1)\n Call UnmarkAllattackedPositions(l_row, l_col)\n \n End If\n Next l_col\n End If\nEnd Sub\n\nPublic Function CanPlaceQueen(l_row As Long, l_col As Long) As Boolean\n \n Dim b_result As Boolean\n \n b_result = dictionary_contains(attackedRows, l_row) Or _\n dictionary_contains(attackedColumns, l_col) Or _\n dictionary_contains(attackedLeftDiagonals, l_col - l_row) Or _\n dictionary_contains(attackedRightDiagonals, l_col + l_row)\n \n CanPlaceQueen = Not b_result\n \nEnd Function\n\nPublic Sub PrintSolution()\n \n Dim l_row As Long\n Dim l_col As Long\n \n Dim l_row_fixer As Long\n Dim l_col_fixer As Long\n \n Dim s_result As String\n \n l_row_fixer = (l_solutions_found \\ 9) * 9 + 1\n l_col_fixer = (l_solutions_found Mod 9) * 9 + 1\n \n For l_row = 0 To SIZE - 1 Step 1\n For l_col = 0 To SIZE - 1 Step 1\n \n If b_chessboard(l_row, l_col) Then\n s_result = s_result & \"*\"\n tbl_show.Cells(l_row + l_row_fixer, l_col + l_col_fixer).Interior.Color = vbRed\n Else\n s_result = s_result & \"-\"\n tbl_show.Cells(l_row + l_row_fixer, l_col + l_col_fixer).Interior.Color = vbBlue\n End If\n Next l_col\n s_result = s_result & vbCrLf\n Next l_row\n \n Debug.Print l_solutions_found & vbCrLf & s_result\n \nEnd Sub\n\nPublic Sub MarkAllAttackedPositions(l_row As Long, l_col As Long)\n \n attackedRows(l_row) = False\n attackedColumns(l_col) = False\n attackedLeftDiagonals(l_col - l_row) = False\n attackedRightDiagonals(l_col + l_row) = False\n \n b_chessboard(l_row, l_col) = True\n \nEnd Sub\n\nPublic Sub UnmarkAllattackedPositions(l_row As Long, l_col As Long)\n \n attackedRows.Remove (l_row)\n attackedColumns.Remove (l_col)\n attackedLeftDiagonals.Remove (l_col - l_row)\n attackedRightDiagonals.Remove (l_col + l_row)\n \n b_chessboard(l_row, l_col) = False\n\nEnd Sub\n\nPublic Function dictionary_contains(dict As Object, str_element As Variant) As Boolean\n \n Dim item As Variant\n Dim b_result As Boolean\n \n For Each item In dict\n If item = str_element Then b_result = True\n Next item\n \n dictionary_contains = b_result\n \nEnd Function\n\nPublic Sub TestDictionary()\n \n attackedRows(\"a\") = 1\n attackedRows(\"b\") = 2\n attackedRows(15) = 3\n \n Debug.Print dictionary_contains(attackedRows, \"b\")\n Debug.Print dictionary_contains(attackedRows, \"a\")\n Debug.Print dictionary_contains(attackedRows, \"d\")\n Debug.Print dictionary_contains(attackedRows, \"d\")\n Debug.Print dictionary_contains(attackedRows, 15)\n \n Debug.Print \"REMOVE\"\n attackedRows.Remove (\"a\")\n Debug.Print dictionary_contains(attackedRows, \"a\")\n Debug.Print dictionary_contains(attackedRows, \"a\")\n \nEnd Sub\n" }, { "path": "Algorithms/StringManipulations.vb", "content": "Function Insert(original As String, added As String, pos As Long) As String\n \n If pos < 1 Then pos = 1\n If Len(original) < pos Then pos = Len(original) + 1\n \n Insert = Mid(original, 1, pos - 1) _\n & added _\n & Mid(original, pos, Len(original) - pos + 1)\n \nEnd Function\n\nPublic Sub InsertTests()\n\n Debug.Print Insert(\"abcd\", \"ff\", 0) = \"ffabcd\"\n Debug.Print Insert(\"abcd\", \"ff\", 1) = \"ffabcd\"\n Debug.Print Insert(\"abcd\", \"ff\", 2) = \"affbcd\"\n Debug.Print Insert(\"abcd\", \"ff\", 3) = \"abffcd\"\n Debug.Print Insert(\"abcd\", \"ff\", 4) = \"abcffd\"\n Debug.Print Insert(\"abcd\", \"ff\", 100) = \"abcdff\"\n \nEnd Sub\n\nPublic Function StringRepeater(repeatString As String, count As Long) As String\n 'StringBuilder String Builder \n If count < 1 Or Len(repeatString) < 1 Then Exit Function\n \n Dim cnt As Long\n \n For cnt = 1 To count\n StringRepeater = StringRepeater & repeatString\n Next cnt\n\nEnd Function\n\nPublic Sub StringRepeaterTests()\n\n Debug.Print StringRepeater(\"ab\", 3) = \"ababab\"\n Debug.Print StringRepeater(\"a\", 2) = \"aa\"\n \nEnd Sub\n" }, { "path": "Algorithms/TaxiCabNumbers.vb", "content": "'https://en.wikipedia.org/wiki/Taxicab_number\n\nOption Explicit\n\nPublic Sub TaxiCabNumber()\n \n Dim a As Long\n Dim b As Long\n Dim lastNumber As Long\n Dim cnt As Long\n \n lastNumber = 200\n \n Dim arrList As Object\n Set arrList = CreateObject(\"System.Collections.ArrayList\")\n\n For a = 1 To lastNumber\n For b = a + 1 To lastNumber\n \n Dim current As String\n current = a ^ 3 + b ^ 3\n \n 'Debug.Assert (a <> 1 Or b <> 12) And (a <> 9 Or b <> 10)\n \n If arrList.contains(current) Then\n Debug.Print current\n Else\n arrList.Add (current)\n End If\n \n cnt = cnt + 1\n Next b\n Next a\n \nEnd Sub\n" }, { "path": "Algorithms/TraverseGraph.vb", "content": "'Exercises: graph Algorithms\n'This document defines the in-class exercises assignments for the \"Algorithms\" course @ Software University.\n'For the following exercises you are given a Visual Studio solution \"Graph-Algorithms-Lab\" holding portions of the source code + unit tests. You can download it from the course's page.\n'Part I - Traverse a Graph to Find Its Connected Components\n\nOption Explicit\n\nPublic visited As Variant\nPublic graph As Variant\n\nPublic Sub mains()\n\n Dim l_counter As Long\n Dim g1 As Variant\n Dim g2 As Variant\n Dim g3 As Variant\n Dim g4 As Variant\n Dim g5 As Variant\n Dim g6 As Variant\n Dim g7 As Variant\n Dim g8 As Variant\n Dim g9 As Variant\n \n g1 = Array(3, 6)\n g2 = Array(3, 4, 5, 6)\n g3 = Array(8)\n g4 = Array(0, 1, 5)\n g5 = Array(1, 6)\n g6 = Array(1, 3)\n g7 = Array(0, 1, 4)\n g8 = Array()\n g9 = Array(2)\n \n graph = Array(g1, g2, g3, g4, g5, g6, g7, g8, g9)\n \n ReDim visited(0)\n \n For l_counter = LBound(graph) To UBound(graph)\n \n If UBound(graph(l_counter)) >= 0 Then\n If Not b_value_in_array(graph(l_counter)(0), visited) Then\n Call DFS(graph(l_counter)(0))\n Debug.Print \"---------------------\"\n End If\n Else\n Debug.Print l_counter\n Debug.Print \"---------------------\"\n End If\n Next l_counter\nEnd Sub\n\nPublic Sub DFS(ByVal str_node As String)\n \n Dim nodes As Variant\n Dim cur_node As String\n Dim child_node As Variant\n Dim k As Variant\n \n nodes = Array(0, str_node)\n ReDim Preserve visited(UBound(visited) + 1)\n visited(UBound(visited)) = str_node\n \n While UBound(nodes) > 0\n cur_node = nodes(UBound(nodes))\n Debug.Print cur_node\n \n ReDim Preserve nodes(UBound(nodes) - 1)\n \n child_node = graph(cur_node)\n \n For Each k In child_node\n \n If Not b_value_in_array(k, visited) Then\n ReDim Preserve nodes(UBound(nodes) + 1)\n nodes(UBound(nodes)) = k\n \n ReDim Preserve visited(UBound(visited) + 1)\n visited(UBound(visited)) = k\n \n End If\n \n Next k\n Wend\n \nEnd Sub\n\nPublic Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean\n\n Dim l_counter As Long\n\n If b_is_string Then\n my_array = Split(my_array, \":\")\n End If\n\n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n" }, { "path": "Boilerplate/ApplicationOnKey.vb", "content": "'https://msdn.microsoft.com/en-us/library/office/ff197461.aspx\n \nPublic Sub EnableControls()\n\n Application.OnKey \"^{F8}\", \"F8_CtrlMacro\"\n Application.OnKey \"%{F8}\", \"F8_AltMacro\"\n Application.OnKey \"+{F8}\", \"F8_ShiftMacro\"\n Application.OnKey \"{F8}\", \"F8_OnlyMacro\"\n \nEnd Sub\n\nPublic Sub DisableControls()\n\n Application.OnKey \"^{F8}\", \"\"\n Application.OnKey \"%{F8}\", \"\"\n Application.OnKey \"+{F8}\", \"\"\n Application.OnKey \"{F8}\", \"\"\n \nEnd Sub\n\nPublic Sub F8_CtrlMacro()\n Debug.Print \"F8 with Ctrl\"\nEnd Sub\n\nPublic Sub F8_AltMacro()\n Debug.Print \"F8 with Alt\"\nEnd Sub\n\nPublic Sub F8_ShiftMacro()\n Debug.Print \"F8 with Shift\"\nEnd Sub\n\nPublic Sub F8_OnlyMacro()\n Debug.Print \"F8 Only\"\nEnd Sub\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ConstantsAndPublic.bas", "content": "Attribute VB_Name = \"ConstantsAndPublic\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Const SET_IN_PRODUCTION = True\r\nPublic Const WORKSHEET_UNPROTECT_PASSWORD = \"shouldistayorshouldigo\" 'I am never using this password anywhere, do not bother ;)\r\nPublic Const ADMINS = \"vitosh:vitos\"\r\nPublic Const CON_STR_APP_NAME = \"Boilerplate VitoshAcademy\"\r\nPublic Const CON_STR_INSTANCES_LOG = \"More then one Workbook is opened in this Excel instance.\"\r\nPublic Const CON_STR_1904 = \"You are using 1904 date system. This is probably* not what you need.\"\r\n\r\n'Public variables are a bad practice and should be avoided in general...\r\nPublic PUB_STR_ERROR_REPORT As String\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelAdditional.bas", "content": "Attribute VB_Name = \"ExcelAdditional\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Sub FreezeRow(Optional wsName As String = \"Input\", Optional cellAddress As String = \"B5\")\r\n\r\n Dim ws As Worksheet\r\n Set ws = Worksheets(wsName)\r\n\r\n ActiveWindow.FreezePanes = False\r\n Application.Goto ws.Range(cellAddress)\r\n ActiveWindow.FreezePanes = True\r\n\r\nEnd Sub\r\n\r\nPublic Sub UnfreezeRows(Optional wsName As String = \"Input\")\r\n \r\n Dim ws As Worksheet\r\n Set ws = Worksheets(wsName)\r\n ActiveWindow.FreezePanes = False\r\n \r\nEnd Sub\r\n\r\nPublic Function SumArray(myArray As Variant, Optional lastValuesNotToCalculate As Long = 0) As Double\r\n \r\n Dim i As Long\r\n For i = LBound(myArray) To UBound(myArray) - lastValuesNotToCalculate\r\n SumArray = SumArray + myArray(i)\r\n Next\r\n \r\nEnd Function\r\n\r\nPublic Function ChangeCommas(ByVal myValue As Variant) As String\r\n \r\n Dim temp As String\r\n \r\n temp = CStr(myValue)\r\n ChangeCommas = Replace(temp, \",\", \".\")\r\n \r\nEnd Function\r\n\r\nPublic Function BubbleSort(ByRef myArray As Variant) As Variant\r\n\r\n Dim temp As Variant\r\n Dim i As Long\r\n Dim noExchanges As Boolean\r\n\r\n Do\r\n noExchanges = True\r\n \r\n For i = LBound(myArray) To UBound(myArray) - 1\r\n If CDbl(myArray(i)) > CDbl(myArray(i + 1)) Then\r\n noExchanges = False\r\n temp = myArray(i)\r\n myArray(i) = myArray(i + 1)\r\n myArray(i + 1) = temp\r\n End If\r\n Next i\r\n \r\n Loop While Not (noExchanges)\r\n \r\n BubbleSort = myArray\r\n\r\n On Error GoTo 0\r\n Exit Function\r\n \r\nEnd Function\r\n\r\nPublic Function IsArrayAllocated(varArr As Variant) As Boolean\r\n\r\n On Error Resume Next\r\n IsArrayAllocated = IsArray(varArr) And Not IsError(LBound(varArr, 1)) And LBound(varArr, 1) <= UBound(varArr, 1)\r\n On Error GoTo 0\r\n\r\nEnd Function\r\n\r\nPublic Function RangeIsZeroOrEmpty(myRange As Range) As Boolean\r\n \r\n Dim myCell As Range\r\n \r\n If myRange.Cells.Count > 1 Then\r\n \r\n For Each myCell In myRange\r\n If (isEmpty(myCell) Or myCell.value = 0) Then\r\n RangeIsZeroOrEmpty = True\r\n Else\r\n RangeIsZeroOrEmpty = False\r\n Exit Function\r\n End If\r\n Next myCell\r\n Else\r\n If (isEmpty(myRange) Or myRange.value = 0) Then\r\n RangeIsZeroOrEmpty = True\r\n Else\r\n RangeIsZeroOrEmpty = False\r\n End If\r\n End If\r\n\r\nEnd Function\r\n\r\nPublic Function MakeRandom(lowest As Long, highest As Long) As Long\r\n 'WorksheetFunction.randbetween for outside Excel\r\n MakeRandom = CLng((highest - lowest) * Rnd + lowest)\r\n\r\nEnd Function\r\n\r\nPublic Function IsRangeHidden(myRange As Range) As Boolean\r\n \r\n If myRange.EntireRow.Hidden Or myRange.EntireColumn.Hidden Then\r\n IsRangeHidden = True\r\n End If\r\n\r\nEnd Function\r\n\r\nPublic Function ColumnNumberToLetter(col As Long) As String\r\n ColumnNumberToLetter = Split(Cells(1, col).Address, \"$\")(1)\r\nEnd Function\r\n\r\nPublic Function IsValueInArray(varMyValue As Variant, myArray As Variant, _\r\n Optional isValueString As Boolean = False) As Boolean\r\n \r\n Dim i As Long\r\n\r\n If isValueString Then\r\n myArray = Split(myArray, \":\")\r\n End If\r\n\r\n For i = LBound(myArray) To UBound(myArray)\r\n myArray(i) = CStr(myArray(i))\r\n Next i\r\n\r\n IsValueInArray = Not IsError(Application.Match(CStr(varMyValue), myArray, 0))\r\n \r\nEnd Function\r\n\r\nPublic Function Rgb2HtmlColor(r As Byte, g As Byte, b As Byte) As String\r\n\r\n 'INPUT: Numeric (Base 10) Values for R, G, and B)\r\n 'RETURNS:\r\n 'A string that can be used as an HTML Color\r\n '(i.e., \"#\" + the Hexadecimal equivalent)\r\n 'For VBA the RGB is reversed. R and B are revered...\r\n\r\n Dim varHexR As Variant\r\n Dim varHexB As Variant\r\n Dim varHexG As Variant\r\n\r\n 'R\r\n varHexR = Hex(r)\r\n If Len(varHexR) < 2 Then varHexR = \"0\" & varHexR\r\n\r\n 'Get Green Hex\r\n varHexG = Hex(g)\r\n If Len(varHexG) < 2 Then varHexG = \"0\" & varHexG\r\n\r\n varHexB = Hex(b)\r\n If Len(varHexB) < 2 Then varHexB = \"0\" & varHexB\r\n\r\n\r\n Rgb2HtmlColor = \"#\" & varHexR & varHexG & varHexB\r\n \r\nEnd Function\r\n\r\nFunction NamedRangeExists(rangeName As String) As Boolean\r\n\r\n On Error Resume Next\r\n \r\n Dim myRange As Range\r\n Set myRange = Range(rangeName)\r\n If Not myRange Is Nothing Then NamedRangeExists = True\r\n\r\n On Error GoTo 0\r\n\r\nEnd Function\r\n\r\nFunction GetRgb(lngLong) As String\r\n\r\n Dim r As Long\r\n Dim g As Long\r\n Dim b As Long\r\n\r\n r = lngLong Mod 256\r\n g = lngLong \\ 256 Mod 256\r\n b = lngLong \\ 65536 Mod 256\r\n GetRgb = \"R=\" & r & \", G=\" & g & \", B=\" & b\r\n \r\nEnd Function\r\n\r\nPublic Sub CopyValues(mySource As Range, myTarget As Range)\r\n myTarget.Resize(mySource.Rows.Count, mySource.Columns.Count).value = mySource.value\r\nEnd Sub\r\n\r\nPublic Sub OnEnd()\r\n\r\n Application.ScreenUpdating = True\r\n Application.EnableEvents = True\r\n Application.AskToUpdateLinks = True\r\n Application.DisplayAlerts = True\r\n\r\n ActiveWindow.View = xlNormalView\r\n Application.StatusBar = False\r\n Application.Calculation = xlAutomatic\r\n ThisWorkbook.Date1904 = False\r\n \r\nEnd Sub\r\n\r\nPublic Sub OnStart()\r\n \r\n Application.ScreenUpdating = False\r\n Application.EnableEvents = False\r\n Application.AskToUpdateLinks = False\r\n Application.DisplayAlerts = False\r\n \r\n ActiveWindow.View = xlNormalView\r\n Application.StatusBar = False\r\n Application.Calculation = xlAutomatic\r\n ThisWorkbook.Date1904 = False\r\n\r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelDates.bas", "content": "Attribute VB_Name = \"ExcelDates\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Function GetLastDayOfMonth(ByVal myDate As Date) As Date\r\n GetLastDayOfMonth = DateSerial(Year(myDate), Month(myDate) + 1, 0)\r\nEnd Function\r\n\r\nPublic Function GetFirstDayOfMonth(ByVal myDate As Date) As Date\r\n GetFirstDayOfMonth = DateSerial(Year(myDate), Month(myDate), 1)\r\nEnd Function\r\n\r\nPublic Function AddMonths(ByVal myDate As Date, ByVal lngMonth As Long) As Date\r\n AddMonths = GetLastDayOfMonth(DateAdd(\"m\", lngMonth, myDate))\r\nEnd Function\r\n\r\nPublic Function AddMonthsAndGetFirstDate(ByVal my_date As Date, ByVal lngMonth As Long) As Date\r\n AddMonthsAndGetFirstDate = GetFirstDayOfMonth(DateAdd(\"m\", lngMonth, my_date))\r\nEnd Function\r\n\r\nPublic Function DateDiffInMonths(a As Date, b As Date) As Long\r\n DateDiffInMonths = DateDiff(\"m\", a, b)\r\nEnd Function\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelFormatCell.bas", "content": "Attribute VB_Name = \"ExcelFormatCell\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Sub FormatAsDate(myCell As Range)\r\n myCell.NumberFormat = \"[$-407]mmm/ yy;@\"\r\nEnd Sub\r\n\r\nPublic Sub FormatAsPercent(myCell As Range, Optional afterComma = 2)\r\n\r\n If afterComma = 3 Then\r\n myCell.NumberFormat = \"0.000%\"\r\n Else\r\n myCell.NumberFormat = \"0.00%\"\r\n End If\r\n\r\nEnd Sub\r\n\r\nPublic Sub FormatAsCurrency(myCell As Range, _\r\n Optional changeZero = False, _\r\n Optional makeGray = True, _\r\n Optional makeRound = True)\r\n\r\n Dim isOneCell As Boolean\r\n\r\n isOneCell = IIf(myCell.Rows.Count + myCell.Columns.Count <> 2, False, True)\r\n\r\n If IsNumeric(myCell.value) And (Not myCell.HasFormula) Then\r\n myCell.value = Round(myCell.value, 2)\r\n End If\r\n\r\n If makeRound Then\r\n myCell.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00)\"\r\n Else\r\n myCell.NumberFormat = \"$#,##0.00_);($#,##0.00)\"\r\n End If\r\n\r\n If changeZero Then\r\n With myCell\r\n .FormatConditions.Delete\r\n .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=\"=0\"\r\n .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1\r\n .FormatConditions(1).Font.TintAndShade = -0.4\r\n End With\r\n End If\r\n\r\n If isOneCell Then\r\n If makeGray And myCell.value = 0 Then\r\n With myCell\r\n .Cells.Font.Color = RGB(191, 191, 191)\r\n End With\r\n End If\r\n End If\r\n\r\nEnd Sub\r\n\r\nPublic Sub FormatAsEurProM2(myCell As Range)\r\n myCell.NumberFormat = \"#,##0.00 \"\" / m\"\"\"\r\nEnd Sub\r\n\r\nPublic Sub FormatRedAndBold(myCell As Range, Optional isBold = True)\r\n\r\n myCell.Font.Color = -16777063\r\n myCell.Font.TintAndShade = 0\r\n If isBold Then myCell.Font.Bold = True\r\n \r\nEnd Sub\r\n\r\nPublic Sub WhiteRows(lines As Long, wks As Worksheet)\r\n \r\n Dim rowLines As String\r\n rowLines = lines & \":\" & lines\r\n \r\n With wks.Rows(rowLines).Font\r\n .ThemeColor = xlThemeColorDark1\r\n .TintAndShade = 0\r\n End With\r\n \r\nEnd Sub\r\n\r\nPublic Sub WhiteCell(myCell As Range)\r\n\r\n myCell.Font.ThemeColor = xlThemeColorDark1\r\n myCell.Font.TintAndShade = 0\r\n \r\nEnd Sub\r\n\r\nPublic Sub FormatFontColorToGrey(myCell As Range)\r\n\r\n myCell.Font.Color = RGB(128, 128, 128)\r\n \r\nEnd Sub\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelLastThings.bas", "content": "Attribute VB_Name = \"ExcelLastThings\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Function LastColumn(wsName As String, Optional rowToCheck As Long = 1) As Long\r\n\r\n Dim ws As Worksheet\r\n Set ws = ThisWorkbook.Worksheets(wsName)\r\n LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column\r\n \r\nEnd Function\r\n\r\nPublic Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long\r\n\r\n Dim ws As Worksheet\r\n Set ws = ThisWorkbook.Worksheets(wsName)\r\n LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row\r\n\r\nEnd Function\r\n \r\nPublic Function LastUsedColumn(wsName As String) As Long\r\n \r\n Dim ws As Worksheet\r\n Set ws = ThisWorkbook.Worksheets(wsName)\r\n Dim lastCell As Range\r\n \r\n Set lastCell = ActiveSheet.Cells.Find(What:=\"*\", _\r\n After:=ActiveSheet.Cells(1, 1), _\r\n LookIn:=xlFormulas, _\r\n LookAt:=xlPart, _\r\n SearchOrder:=xlByColumns, _\r\n SearchDirection:=xlPrevious, _\r\n MatchCase:=False)\r\n \r\n LastUsedColumn = lastCell.Column\r\n\r\nEnd Function\r\n\r\nPublic Function LastUsedRow(wsName As String) As Long\r\n \r\n Dim ws As Worksheet\r\n Set ws = ThisWorkbook.Worksheets(wsName)\r\n Dim lastCell As Range\r\n\r\n Set lastCell = ActiveSheet.Cells.Find(What:=\"*\", _\r\n After:=ActiveSheet.Cells(1, 1), _\r\n LookIn:=xlFormulas, _\r\n LookAt:=xlPart, _\r\n SearchOrder:=xlByRows, _\r\n SearchDirection:=xlPrevious, _\r\n MatchCase:=False)\r\n\r\n LastUsedRow = lastCell.Row\r\n\r\nEnd Function\r\n\r\nPublic Function LocateValueRow(ByVal textTarget As String, _\r\n ByRef wksTarget As Worksheet, _\r\n Optional col As Long = 1, _\r\n Optional moreValuesFound As Long = 1, _\r\n Optional lookForPart = False, _\r\n Optional lookUpToBottom = True) As Long\r\n\r\n Dim valuesFound As Long\r\n Dim localRange As Range\r\n Dim myCell As Range\r\n\r\n LocateValueRow = -999\r\n valuesFound = moreValuesFound\r\n Set localRange = wksTarget.Range(wksTarget.Cells(1, col), wksTarget.Cells(Rows.Count, col))\r\n\r\n For Each myCell In localRange\r\n If lookForPart Then\r\n If textTarget = Left(myCell, Len(textTarget)) Then\r\n If valuesFound = 1 Then\r\n LocateValueRow = myCell.Row\r\n If lookUpToBottom Then Exit Function\r\n Else\r\n Decrement valuesFound\r\n End If\r\n End If\r\n Else\r\n If textTarget = Trim(myCell) Then\r\n If valuesFound = 1 Then\r\n LocateValueRow = myCell.Row\r\n If lookUpToBottom Then Exit Function\r\n Else\r\n Decrement valuesFound\r\n End If\r\n End If\r\n End If\r\n Next myCell\r\n\r\nEnd Function\r\n\r\nPublic Function LocateValueCol(ByVal textTarget As String, _\r\n ByRef wksTarget As Worksheet, _\r\n Optional rowNeeded As Long = 1, _\r\n Optional moreValuesFound As Long = 1, _\r\n Optional lookForPart = False, _\r\n Optional lookUpToBottom = True) As Long\r\n\r\n Dim valuesFound As Long\r\n Dim localRange As Range\r\n Dim myCell As Range\r\n \r\n LocateValueCol = -999\r\n valuesFound = moreValuesFound\r\n Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))\r\n\r\n For Each myCell In localRange\r\n If lookForPart Then\r\n If textTarget = Left(myCell, Len(textTarget)) Then\r\n If valuesFound = 1 Then\r\n LocateValueCol = myCell.Column\r\n If lookUpToBottom Then Exit Function\r\n Else\r\n Decrement valuesFound\r\n End If\r\n End If\r\n Else\r\n If textTarget = Trim(myCell) Then\r\n If valuesFound = 1 Then\r\n LocateValueCol = myCell.Column\r\n If lookUpToBottom Then Exit Function\r\n Else\r\n Decrement valuesFound\r\n End If\r\n End If\r\n End If\r\n Next myCell\r\n\r\nEnd Function\r\n \r\nPublic Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)\r\n valueToIncrement = valueToIncrement + incrementWith\r\nEnd Sub\r\n\r\nPublic Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)\r\n valueToDecrement = valueToDecrement - decrementWith\r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelPrintToNotepad.bas", "content": "Attribute VB_Name = \"ExcelPrintToNotepad\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nSub PrintToNotepad(Optional dataToPrint As String = \"\")\r\n\r\n If SET_IN_PRODUCTION Then On Error GoTo CreateLogFile_Error\r\n \r\n Dim fileSystem As Object\r\n Dim textObject As Object\r\n Dim fileName As String\r\n Dim newFile As String\r\n Dim shellPath As String\r\n\r\n newFile = \"\\Info\"\r\n \r\n fileName = ThisWorkbook.path & newFile & CodifyTime(True)\r\n If Dir(ThisWorkbook.path & newFile, vbDirectory) = vbNullString Then MkDir ThisWorkbook.path & newFile\r\n \r\n Set fileSystem = CreateObject(\"Scripting.FileSystemObject\")\r\n Set textObject = fileSystem.CreateTextFile(fileName, True)\r\n \r\n If dataToPrint <> \"\" Then\r\n textObject.WriteLine dataToPrint\r\n Else\r\n textObject.WriteLine PUB_STR_ERROR_REPORT\r\n End If\r\n \r\n textObject.Close\r\n \r\n shellPath = \"C:\\WINDOWS\\notepad.exe \"\r\n shellPath = shellPath & fileName\r\n shell shellPath\r\n \r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nCreateLogFile_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CreateLogFile of Sub mod_TDD_Export\"\r\n\r\nEnd Sub\r\n\r\nPublic Function CodifyTime(Optional makeString As Boolean = False) As String\r\n\r\n If SET_IN_PRODUCTION Then On Error GoTo codify_Error\r\n \r\n Dim leftPart As Variant\r\n Dim rightPart As Variant\r\n Dim initialTime As Double\r\n \r\n initialTime = Round(Now(), 8)\r\n \r\n leftPart = Split(CStr(initialTime), \".\")(0)\r\n rightPart = Split(CStr(initialTime), \".\")(1)\r\n \r\n CodifyTime = Hex(leftPart) & \"_\" & Hex(rightPart)\r\n \r\n If makeString Then CodifyTime = \"\\\" & CodifyTime & \".txt\"\r\n \r\n On Error GoTo 0\r\n Exit Function\r\n\r\ncodify_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\r\n\r\nEnd Function\r\n\r\nPublic Function DecodifyTime(hexTime As String) As String\r\n \r\n Dim leftPart As Variant\r\n Dim rightPart As Variant\r\n \r\n leftPart = Split(hexTime, \"_\")(0)\r\n rightPart = Split(hexTime, \"_\")(1)\r\n \r\n DecodifyTime = CLng(\"&H\" & leftPart) & \".\" & CLng(\"&H\" & rightPart)\r\n \r\nEnd Function\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelStructure.bas", "content": "Attribute VB_Name = \"ExcelStructure\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Sub LockScroll(lockArea As Range)\r\n \r\n Dim wks As Worksheet\r\n For Each wks In ThisWorkbook.Worksheets\r\n wks.ScrollArea = lockArea.Address\r\n Next wks\r\n \r\nEnd Sub\r\n\r\nPublic Sub UnlockScroll()\r\n \r\n Dim wks As Worksheet\r\n For Each wks In ThisWorkbook.Worksheets\r\n wks.ScrollArea = \"\"\r\n Next wks\r\n \r\nEnd Sub\r\n\r\nSub StyleKiller()\r\n\r\n Dim myStyle As Style\r\n \r\n For Each myStyle In ThisWorkbook.Styles\r\n If Not myStyle.BuiltIn Then\r\n Debug.Print myStyle.Name\r\n myStyle.Delete\r\n End If\r\n Next\r\n\r\nEnd Sub\r\n\r\nPublic Sub DeleteName(myName As String)\r\n\r\n On Error GoTo DeleteName_Error\r\n\r\n ThisWorkbook.Names(myName).Delete\r\n Debug.Print myName & \" is deleted!\"\r\n \r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nDeleteName_Error:\r\n\r\n Debug.Print myName & \" not present or some error\"\r\n On Error GoTo 0\r\n \r\nEnd Sub\r\n\r\nSub CoverRange(myRange As Range, wks As Worksheet)\r\n \r\n Dim myLeft As Long\r\n Dim myTop As Long\r\n Dim myWidth As Long\r\n Dim myHeight As Long\r\n \r\n If wks.Name <> ActiveSheet.Name Then\r\n MsgBox \"You better select the sheet you are working on...\"\r\n Exit Sub\r\n End If\r\n \r\n myLeft = myRange.Left\r\n myTop = myRange.Top\r\n myWidth = myRange.Width\r\n myHeight = myRange.Height\r\n \r\n With wks.Shapes\r\n .AddTextbox(msoTextOrientationVertical, myLeft, myTop, myWidth, myHeight).Select\r\n Selection.ShapeRange.Line.Visible = msoFalse\r\n End With\r\n\r\nEnd Sub\r\n\r\nPublic Sub PrintSheetPDF(inputPrintArea As Range, _\r\n printedFileName As String, _\r\n Optional isBlack As Boolean = False)\r\n\r\n If SET_IN_PRODUCTION Then On Error GoTo PrintPDF_Error\r\n \r\n Dim wks As Worksheet\r\n Set wks = Worksheets(inputPrintArea.Parent.Name)\r\n \r\n With wks\r\n .PageSetup.Zoom = False\r\n .PageSetup.BlackAndWhite = isBlack\r\n\r\n inputPrintArea.ExportAsFixedFormat _\r\n Type:=xlTypePDF, _\r\n fileName:=printedFileName, _\r\n Quality:=xlQualityStandard, _\r\n IncludeDocProperties:=True, _\r\n IgnorePrintAreas:=False, _\r\n OpenAfterPublish:=True\r\n End With\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nPrintPDF_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure PrintPDF of Modul mod_Drucken\"\r\n\r\nEnd Sub\r\n\r\nPublic Sub PrintPage(printRange As Range, Optional isBlack As Boolean = False)\r\n\r\n Dim wksSheet As Worksheet\r\n Dim reducePaperTitle As String\r\n\r\n On Error GoTo PrintPage_Error\r\n\r\n reducePaperTitle = \"Reduce printing and save trees!\"\r\n printRange.Parent.PageSetup.BlackAndWhite = isBlack\r\n\r\n Set wksSheet = printRange.Parent\r\n\r\n With wksSheet.PageSetup\r\n .Orientation = xlPortrait\r\n .Zoom = False\r\n .FitToPagesTall = 1\r\n .FitToPagesWide = 1\r\n End With\r\n\r\n Select Case MsgBox(\"Are you sure you would like to print the selected page?\", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle)\r\n Case vbYes\r\n Select Case MsgBox(\"Really?\", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle)\r\n Case vbYes\r\n printRange.PrintOut\r\n End Select\r\n End Select\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nPrintPage_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure PrintPage of Modul mod_Drucken\"\r\n\r\nEnd Sub\r\n\r\nSub DeleteDrawingObjects(wks As Worksheet)\r\n\r\n Dim i As Long\r\n \r\n For i = wks.DrawingObjects().Count To 1 Step -1\r\n wks.DrawingObjects(i).Delete\r\n Next i\r\n\r\nEnd Sub\r\n\r\nPublic Sub UnhideAll()\r\n\r\n Dim wks As Worksheet\r\n\r\n For Each wks In ThisWorkbook.Worksheets\r\n wks.Visible = xlSheetVisible\r\n Next\r\n\r\n UnprotectAll\r\n\r\nEnd Sub\r\n\r\nPublic Sub UnprotectAll()\r\n\r\n Dim i As Long\r\n For i = ThisWorkbook.Worksheets.Count To 1 Step -1\r\n ThisWorkbook.Worksheets(i).Unprotect Password:=WORKSHEET_UNPROTECT_PASSWORD\r\n Next i\r\n \r\nEnd Sub\r\n\r\nPublic Sub HideNeededWorksheets()\r\n\r\n Dim varSheet As Variant\r\n Dim visibleSheets As Variant\r\n Dim hiddenSheets As Variant\r\n\r\n OnStart\r\n\r\n visibleSheets = Array(tblInput)\r\n hiddenSheets = Array(tblSettings)\r\n\r\n For Each varSheet In visibleSheets\r\n varSheet.Visible = xlSheetVisible\r\n Next varSheet\r\n\r\n For Each varSheet In hiddenSheets\r\n varSheet.Visible = xlSheetVeryHidden\r\n Next varSheet\r\n\r\n OnEnd\r\n\r\nEnd Sub\r\n\r\nPublic Sub AddCommentToSelection(myComment As Range)\r\n \r\n Dim myCell As Range\r\n\r\n For Each myCell In Selection\r\n myCell.ClearComments\r\n myCell.AddComment myComment.Text\r\n myCell.Comment.Visible = False\r\n myCell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft\r\n myCell.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft\r\n\r\n Next myCell\r\n\r\nEnd Sub\r\n\r\nSub PrintAllNames()\r\n \r\n Dim nm As Name\r\n \r\n For Each nm In ThisWorkbook.Names\r\n Debug.Print nm.Name\r\n Next nm\r\n \r\nEnd Sub\r\n\r\nSub DeleteAllNames()\r\n\r\n Dim nm As Name\r\n \r\n For Each nm In ThisWorkbook.Names\r\n Debug.Print nm.Name & \" is deleted!\"\r\n nm.Delete\r\n Next nm\r\n \r\nEnd Sub\r\n\r\nPublic Sub DeleteCommentInSelection()\r\n \r\n If SET_IN_PRODUCTION Then On Error GoTo DeleteCommentInSelection_Error\r\n\r\n Dim myCell As Range\r\n \r\n For Each myCell In Selection\r\n myCell.ClearComments\r\n Next myCell\r\n \r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nDeleteCommentInSelection_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure DeleteCommentInSelection of Sub mod_StandardSubs\"\r\n\r\nEnd Sub\r\n\r\nPublic Sub SelectMeA1RangeEverywhere()\r\n\r\n If SET_IN_PRODUCTION Then On Error GoTo SelectMeA1RangeEverywhere_Error\r\n\r\n Dim wks As Worksheet\r\n\r\n For Each wks In ThisWorkbook.Worksheets\r\n If wks.Visible = xlSheetVisible Then\r\n wks.Activate\r\n wks.Cells(1, 1).Select\r\n End If\r\n Next\r\n \r\n Worksheets(1).Select\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nSelectMeA1RangeEverywhere_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure SelectMeA1RangeEverywhere of Sub mod_StandardSubs\"\r\n\r\nEnd Sub\r\n\r\nSub HideShowComments(Optional showComments As Boolean = False, _\r\n Optional myRange As Range = Nothing)\r\n \r\n Dim myCell As Range\r\n \r\n If SET_IN_PRODUCTION Then On Error GoTo HideShowComments_Error\r\n If myRange Is Nothing Then Set myRange = Range(\"A1:AO1000\")\r\n \r\n For Each myCell In myRange\r\n If Not myCell.Comment Is Nothing Then\r\n myCell.Comment.Visible = showComments\r\n End If\r\n Next myCell\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nHideShowComments_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure HideShowComments of Sub mod_StandardSubs\"\r\n\r\nEnd Sub\r\n\r\nPublic Sub ResetAndUnlock()\r\n \r\n If Not IsValueInArray(Environ(\"Username\"), ADMINS, True) Then\r\n Debug.Print \"no\"\r\n Exit Sub\r\n End If\r\n\r\n UnhideAll 'UnprotectAll is included\r\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\r\n ActiveWindow.DisplayHeadings = True\r\n Application.DisplayFormulaBar = True\r\n Debug.Print \"Done.\"\r\n\r\n EnableMySaves\r\n\r\nEnd Sub\r\n\r\nPublic Sub EnableMySaves()\r\n\r\n Application.OnKey \"%{F11}\"\r\n Application.OnKey \"^c\"\r\n Application.OnKey \"^C\"\r\n Application.OnKey \"^v\"\r\n Application.OnKey \"^V\"\r\n Application.OnKey \"^x\"\r\n Application.OnKey \"^X\"\r\n Application.OnKey \"^w\"\r\n Application.OnKey \"^W\"\r\n Application.OnKey \"^e\"\r\n Application.OnKey \"^E\"\r\n\r\nEnd Sub\r\n\r\nPublic Sub DisabledCombination()\r\n 'This is the disabled combination for Application.OnKey\r\nEnd Sub\r\n\r\nPublic Sub DisableShortcutsAndSaves()\r\n\r\n Application.OnKey \"^c\", \"DisabledCombination\"\r\n Application.OnKey \"^C\", \"DisabledCombination\"\r\n Application.OnKey \"^v\", \"DisabledCombination\"\r\n Application.OnKey \"^V\", \"DisabledCombination\"\r\n Application.OnKey \"^x\", \"DisabledCombination\"\r\n Application.OnKey \"^X\", \"DisabledCombination\"\r\n Application.OnKey \"^w\", \"DisabledCombination\"\r\n Application.OnKey \"^W\", \"DisabledCombination\"\r\n \r\n Application.OnKey \"^e\", \"ShowMainForm\"\r\n Application.OnKey \"^E\", \"ShowMainForm\"\r\n \r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/ExcelVBE.bas", "content": "Attribute VB_Name = \"ExcelVBE\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nSub PrintAllCode()\r\n \r\n Dim item As Variant\r\n Dim textToPrint As String\r\n Dim lineToPrint As String\r\n \r\n For Each item In ThisWorkbook.vbProject.VBComponents\r\n lineToPrint = item.codeModule.lines(1, item.codeModule.CountOfLines)\r\n Debug.Print lineToPrint\r\n textToPrint = textToPrint & vbCrLf & lineToPrint\r\n Next item\r\n \r\n PrintToNotepad textToPrint\r\n \r\nEnd Sub\r\n\r\nSub PrintAllContainers()\r\n \r\n Dim item As Variant\r\n Dim textToPrint As String\r\n Dim lineToPrint As String\r\n \r\n For Each item In ThisWorkbook.vbProject.VBComponents\r\n lineToPrint = item.Name\r\n Debug.Print lineToPrint\r\n textToPrint = textToPrint & vbCrLf & lineToPrint\r\n Next item\r\n \r\n PrintToNotepad textToPrint\r\n \r\nEnd Sub\r\n\r\nSub ListProcedures(Optional modName As String = \"ExcelAdditional\", Optional withParentInfo As Boolean = False)\r\n \r\n Dim project As VBIDE.vbProject\r\n Dim component As VBIDE.VBComponent\r\n Dim codeModule As VBIDE.codeModule\r\n Dim lineNum As Long\r\n Dim procName As String\r\n Dim procKind As VBIDE.vbext_ProcKind\r\n Dim subsInfo As String\r\n \r\n Set project = ThisWorkbook.vbProject\r\n Set component = project.VBComponents(modName)\r\n Set codeModule = component.codeModule\r\n\r\n With codeModule\r\n lineNum = .CountOfDeclarationLines + 1\r\n \r\n Do Until lineNum >= .CountOfLines\r\n procName = .ProcOfLine(lineNum, procKind)\r\n\r\n If withParentInfo Then\r\n subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & modName & \".\" & procName\r\n Else\r\n subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & procName\r\n End If\r\n\r\n lineNum = .ProcStartLine(procName, procKind) + .ProcCountLines(procName, procKind) + 1\r\n Loop\r\n \r\n End With\r\n \r\n Debug.Print subsInfo\r\n PrintToNotepad subsInfo\r\n \r\nEnd Sub\r\n\r\nSub ExportModules()\r\n \r\n CreateFolderOnDesktop GetFolderOnDesktopPath\r\n \r\n On Error Resume Next\r\n Kill GetFolderOnDesktopPath & \"\\*.*\"\r\n On Error GoTo 0\r\n \r\n Dim wkb As Workbook: Set wkb = Excel.Workbooks(ThisWorkbook.Name)\r\n \r\n If wkb.vbProject.Protection = vbext_pp_locked Then\r\n Debug.Print \"The VBA in this workbook is locked.\"\r\n Exit Sub\r\n End If\r\n \r\n Dim unitsCount As Long\r\n Dim filePath As String\r\n Dim component As VBIDE.VBComponent\r\n Dim tryExport As Boolean\r\n\r\n For Each component In wkb.vbProject.VBComponents\r\n tryExport = True\r\n filePath = component.Name\r\n \r\n \r\n Select Case component.Type\r\n Case vbext_ct_ClassModule\r\n filePath = filePath & \".cls\"\r\n Case vbext_ct_MSForm\r\n filePath = filePath & \".frm\"\r\n Case vbext_ct_StdModule\r\n filePath = filePath & \".bas\"\r\n Case vbext_ct_Document\r\n tryExport = False\r\n End Select\r\n \r\n If tryExport Then\r\n Increment unitsCount\r\n Debug.Print unitsCount & \" exporting \" & filePath\r\n component.export GetFolderOnDesktopPath & filePath\r\n End If\r\n \r\n Next\r\n\r\n Debug.Print \"Exported at \" & GetFolderOnDesktopPath\r\n \r\nEnd Sub\r\n\r\nFunction GetFolderOnDesktopPath() As String\r\n\r\n Dim shell As Object\r\n Dim fso As Object\r\n Dim specialFolderPath As String\r\n\r\n Set shell = CreateObject(\"WScript.Shell\")\r\n Set fso = CreateObject(\"scripting.filesystemobject\")\r\n\r\n specialFolderPath = shell.SpecialFolders(\"Desktop\")\r\n If Right(specialFolderPath, 1) <> \"\\\" Then specialFolderPath = specialFolderPath & \"\\\"\r\n \r\n GetFolderOnDesktopPath = specialFolderPath & CON_STR_APP_NAME & \"\\\"\r\n \r\nEnd Function\r\n\r\nSub CreateFolderOnDesktop(specialFolderPath As String)\r\n \r\n On Error Resume Next\r\n \r\n MkDir specialFolderPath\r\n If Err.Number <> 0 Then\r\n If Err.Number = 75 Then\r\n Debug.Print \"Folder exists - \" & specialFolderPath\r\n Else\r\n Err.Raise Err.Number, Err.source, Err.Description\r\n End If\r\n Else\r\n Debug.Print \"Folder has been created - \" & specialFolderPath\r\n End If\r\n \r\n On Error GoTo 0\r\n \r\nEnd Sub\r\n\r\nPublic Sub ImportModules()\r\n \r\n '1. The target workbook should be opened in the same Excel instance as the ThisWorkbook\r\n '2. The target workbook should be in the same directory as ThisWorkbook\r\n '3. The code to be added should be present in GetFolderOnDesktopPath\r\n \r\n Dim targetName As String: targetName = \"empty.xlsm\"\r\n Dim targetPath As String: targetPath = ThisWorkbook.path & \"\\\" & targetName\r\n \r\n Dim wkbTarget As Workbook\r\n Dim fso As Scripting.FileSystemObject\r\n Dim file As Scripting.file\r\n Dim codePath As String: codePath = GetFolderOnDesktopPath\r\n \r\n Set wkbTarget = Workbooks(targetName)\r\n \r\n If wkbTarget.vbProject.Protection = 1 Then\r\n Debug.Print \"VBProject is protected!\"\r\n End If\r\n \r\n Set fso = New Scripting.FileSystemObject\r\n If fso.GetFolder(codePath).Files.Count = 0 Then\r\n Debug.Print \"Zero vba files in source workbook!\"\r\n Exit Sub\r\n End If\r\n \r\n DeleteAllVba wkbTarget\r\n\r\n Dim unitsCount As Long\r\n For Each file In fso.GetFolder(codePath).Files\r\n Select Case fso.GetExtensionName(file.Name)\r\n Case \"cls\", \"frm\", \"bas\":\r\n Increment unitsCount\r\n Debug.Print unitsCount & \" -> in \" & wkbTarget.Name & \" adding \" & file.Name\r\n wkbTarget.vbProject.VBComponents.Import file.path\r\n Case Else:\r\n Debug.Print file.Name & \" cannot be processed.\"\r\n End Select\r\n Next\r\n \r\n Debug.Print vbCrLf & unitsCount & \" units were just added to:\" & vbCrLf & targetPath\r\n \r\nEnd Sub\r\n\r\nFunction DeleteAllVba(wkbTarget As Workbook)\r\n\r\n Dim project As VBIDE.vbProject\r\n Dim component As VBIDE.VBComponent\r\n Dim unitsCount As Long\r\n \r\n Set project = wkbTarget.vbProject\r\n \r\n For Each component In project.VBComponents\r\n If component.Type <> vbext_ct_Document Then\r\n Increment unitsCount\r\n Debug.Print unitsCount & \" from \" & wkbTarget.Name & \" deleting \" & component.Name\r\n project.VBComponents.Remove component\r\n End If\r\n Next\r\n \r\n Debug.Print 'Empty line is good :)\r\n \r\nEnd Function\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/VersionsAbout.bas", "content": "Attribute VB_Name = \"VersionsAbout\"\r\nOption Explicit\r\nOption Private Module\r\n\r\n'==================================================================================================================\r\n'=======================================CREDITS====================================================================\r\n'==================================================================================================================\r\n'TDD classes are taken with some changes from:\r\n' https://github.com/VBA-tools/vba-test\r\n'Form ideas are from:\r\n' https://www.vitoshacademy.com/vba-the-perfect-userform-in-vba/\r\n' https://codereview.stackexchange.com/questions/154401/handling-dialog-closure-in-a-vba-user-form\r\n'Most of the code is present also at:\r\n' https://github.com/Vitosh/VBA_personal\r\n'The offisial site and GitHub repo of the Boilerplate:\r\n' https://www.vitoshacademy.com/boilerplate\r\n' https://github.com/Vitosh/VBA_personal/tree/master/Boilerplate\r\n'==================================================================================================================\r\n'=======================================VERSIONS===================================================================\r\n'==================================================================================================================\r\n'Boiler Plate Version 8.0.3:\r\n' Vitosh - 23.12.2019\r\n'\r\n' Minor fixes:\r\n' - Fix RangeIsZeroOrEmpty\r\n' - Fix the credits with the correct url\r\n' - Fix spaces, remove some lines, fix variables\r\n' - Adding \"DecodifyTime\" to return \"CodifyTime\" back\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'Boiler Plate Version 8.0.:\r\n' Vitosh - 19.12.2019\r\n'\r\n' Openning the project, removing the password\r\n' Trying to remove words like \"Call\" and fix variables names\r\n' Structuring the code (that's a lot!)\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'Boiler Plate Version 7.0.:\r\n' Vitosh - 16.03.2017\r\n'\r\n' Add CON_STR_APP_NAME = \"Boilerplate Project Name\"\r\n' A new form, with a new class is implemented\r\n' Change to xlsb\r\n' Move all named ranges from Settings as Constants\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'-------------------------------------------------------------------------------------------------------------------\r\n'Boiler Plate Version 6.0.:\r\n' Vitosh - 01.2017\r\n'\r\n' Check for more opened instances\r\n' TDD implemented\r\n' Standard Functions and subs\r\n' On openning:\r\n' fixing outlook\r\n' hiding whatever possible\r\n' checking for another instance opened\r\n' frmInfo with lblInfo is present\r\n' adding new sheet is disabled\r\n' beforeclose sheet function is present\r\n'==================================================================================================================\r\n'=======================================THANK YOU (YES, YOU!)======================================================\r\n'==================================================================================================================\r\n'As far as you are looking into these credits, most probably you are a VBA developer!\r\n'\r\n'As a VBA developer, you have probably heard hundres of times that you are not a real developer or anything\r\n'like this from random people - from high end clean code gurus to java guys, who learned about programming\r\n'some 2 weeks ago. Anyway, it does not matter. You are a developer! (and don't listen to these guys, most of them\r\n'are deeply confused in general)\r\n'\r\n' Thank you for all the awesome #VBA code you have written!\r\n' It matters! You matter!\r\n' Stay awesome!\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/formExample.bas", "content": "Attribute VB_Name = \"formExample\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPrivate presenter As formSummaryPresenter\r\n\r\nPublic Sub FormExampleMain()\r\n \r\n presenter.ChangeLabelAndCaption \"Starting and running...\", \"Running...\"\r\n GenerateNumbers\r\n\r\nEnd Sub\r\n\r\nPublic Sub GenerateNumbers(Optional outerLoopLimit As Long = 2, Optional innerLoopLimit As Long = 4)\r\n \r\n Dim a As Long\r\n Dim b As Long\r\n \r\n For a = 1 To outerLoopLimit\r\n For b = 1 To innerLoopLimit\r\n Debug.Print a * b\r\n Next\r\n Next\r\n Debug.Print \"-------END-------\" & vbCrLf & Now\r\n \r\nEnd Sub\r\n\r\nPublic Sub ShowMainForm()\r\n\r\n If (presenter Is Nothing) Then\r\n Set presenter = New formSummaryPresenter\r\n End If\r\n\r\n presenter.Show\r\n\r\nEnd Sub\r\n\r\nPublic Sub CheckHowManyWbAreOpened()\r\n\r\n On Error GoTo CheckHowManyWbAreOpened_Error\r\n\r\n If Workbooks.Count > 1 Then\r\n PUB_STR_ERROR_REPORT = True\r\n frmInfo.Show (vbModeless)\r\n Application.Wait (Now + TimeValue(\"00:00:02\"))\r\n Unload frmInfo\r\n End If\r\n \r\n PUB_STR_ERROR_REPORT = False\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nCheckHowManyWbAreOpened_Error:\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CheckHowManyWbAreOpened of Sub DieseArbeitsmappe\"\r\n\r\nEnd Sub\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/formSummaryPresenter.cls", "content": "VERSION 1.0 CLASS\r\nBEGIN\r\n MultiUse = -1 'True\r\nEND\r\nAttribute VB_Name = \"formSummaryPresenter\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = False\r\nAttribute VB_Exposed = False\r\nOption Explicit\r\n\r\nPrivate WithEvents summaryForm As frmExample\r\nAttribute summaryForm.VB_VarHelpID = -1\r\n\r\nPrivate Sub Class_Initialize()\r\n\r\n Set summaryForm = New frmExample\r\n\r\nEnd Sub\r\n\r\nPrivate Sub Class_Terminate()\r\n\r\n Set summaryForm = Nothing\r\n\r\nEnd Sub\r\n\r\nPublic Sub Show()\r\n\r\n If Not summaryForm.Visible Then\r\n summaryForm.Show vbModeless\r\n ChangeLabelAndCaption \"Press Run to Start\", \"Starting\"\r\n End If\r\n\r\n With summaryForm\r\n .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2)\r\n .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2)\r\n .caption = CON_STR_APP_NAME\r\n End With\r\n\r\nEnd Sub\r\n\r\nPrivate Sub Hide()\r\n\r\n If summaryForm.Visible Then summaryForm.Hide\r\n\r\nEnd Sub\r\n\r\nPublic Sub ChangeLabelAndCaption(labelInfo As String, caption As String)\r\n\r\n summaryForm.InformationText = labelInfo\r\n summaryForm.InformationCaption = caption\r\n summaryForm.Repaint\r\n\r\nEnd Sub\r\n\r\nPrivate Sub summaryForm_OnRunReport()\r\n \r\n FormExampleMain\r\n Refresh\r\n\r\nEnd Sub\r\n\r\nPrivate Sub summaryForm_OnExit()\r\n\r\n Hide\r\n\r\nEnd Sub\r\n\r\nPublic Sub Refresh()\r\n \r\n With summaryForm\r\n .lblInfo = \"Ready\"\r\n .caption = \"Task performed\"\r\n End With\r\n\r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/frmExample.frm", "content": "VERSION 5.00\r\nBegin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmExample \r\n Caption = \"UserForm1\"\r\n ClientHeight = 4404\r\n ClientLeft = -12\r\n ClientTop = 120\r\n ClientWidth = 5388\r\n OleObjectBlob = \"frmExample.frx\":0000\r\n StartUpPosition = 1 'Fenstermitte\r\nEnd\r\nAttribute VB_Name = \"frmExample\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = True\r\nAttribute VB_Exposed = False\r\nOption Explicit\r\n\r\nPublic Event OnRunReport()\r\nPublic Event OnExit()\r\n\r\nPublic Property Get InformationText() As String\r\n\r\n InformationText = lblInfo.caption\r\n\r\nEnd Property\r\n\r\nPublic Property Let InformationText(ByVal value As String)\r\n\r\n lblInfo.caption = value\r\n\r\nEnd Property\r\n\r\nPublic Property Get InformationCaption() As String\r\n\r\n InformationCaption = caption\r\n\r\nEnd Property\r\n\r\nPublic Property Let InformationCaption(ByVal value As String)\r\n\r\n caption = value\r\n\r\nEnd Property\r\n\r\nPrivate Sub btnRun_Click()\r\n\r\n RaiseEvent OnRunReport\r\n\r\nEnd Sub\r\n\r\nPrivate Sub btnExit_Click()\r\n\r\n RaiseEvent OnExit\r\n\r\nEnd Sub\r\n\r\nPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)\r\n\r\n If CloseMode = vbFormControlMenu Then\r\n Cancel = True\r\n Hide\r\n End If\r\n\r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/frmInfo.frm", "content": "VERSION 5.00\r\nBegin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmInfo \r\n ClientHeight = 1440\r\n ClientLeft = -156\r\n ClientTop = -564\r\n ClientWidth = 2772\r\n OleObjectBlob = \"frmInfo.frx\":0000\r\n StartUpPosition = 1 'Fenstermitte\r\nEnd\r\nAttribute VB_Name = \"frmInfo\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = True\r\nAttribute VB_Exposed = False\r\nOption Explicit\r\n\r\nPrivate Sub UserForm_Initialize()\r\n \r\n If PUB_STR_ERROR_REPORT Then\r\n Me.lblInformation = CON_STR_INSTANCES_LOG\r\n End If\r\n \r\n With Me\r\n .StartUpPosition = 0\r\n .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)\r\n .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)\r\n .caption = CON_STR_APP_NAME\r\n End With\r\n \r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tblInput.vb", "content": "Private Sub Worksheet_SelectionChange(ByVal Target As Range)\r\n\r\n If ActiveWindow.Zoom > 100 Or ActiveWindow.Zoom < 70 Then\r\n ActiveWindow.Zoom = 100\r\n End If\r\n \r\nEnd Sub\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tddMain.bas", "content": "Attribute VB_Name = \"tddMain\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nSub Tdd(Optional export As Boolean = False)\r\n \r\n On Error Resume Next\r\n\r\n Dim specs As New tddSpecSuite\r\n \r\n Debug.Print \"Test report from \" & Environ(\"Username\") & vbCrLf & \"START: \" & Now() & vbCrLf\r\n PUB_STR_ERROR_REPORT = \"Test report from \" & Environ(\"Username\") & vbCrLf & \"START: \" & Now() & vbCrLf\r\n '---------------------\r\n 'Tests start here ---v\r\n 'Test Scenario #1\r\n TestMeSample\r\n Dim myarr(16) As Variant\r\n Dim arrCounter As Long\r\n Dim myCell As Range\r\n \r\n myarr(1) = 1.81859485365136\r\n myarr(2) = -4.79462137331569\r\n myarr(3) = -0.713935644387188\r\n myarr(4) = -8.38308001079428\r\n myarr(5) = 24.9643391023361\r\n myarr(6) = -27.4617351821139\r\n myarr(7) = 64.2321735505502\r\n myarr(8) = -88.9405995522673\r\n myarr(9) = -127.858501929498\r\n myarr(10) = 101.737867039937\r\n myarr(11) = 146.707455130634\r\n myarr(12) = -120.333197895024\r\n myarr(13) = 772.275323251858\r\n myarr(14) = 1129.5172126244\r\n myarr(15) = 1312.97247658607\r\n myarr(16) = -349.11864840751\r\n\r\n For Each myCell In tblInput.Range(\"A1:B8\")\r\n Increment arrCounter\r\n specs.It(\"Scenario 1.\" & CStr(arrCounter)).Expect(myarr(arrCounter)).ToEqual myCell.value\r\n Next myCell\r\n \r\n 'Test Scenario #2\r\n specs.It(\"Scenario 2.1\").Expect(SumArray(Array(1, 2, 3))).ToEqual 6\r\n specs.It(\"Scenario 2.2\").Expect(SumArray(Array(3, 3, 3))).ToEqual 9\r\n specs.It(\"Scenario 2.3\").Expect(SumArray(Array(3, 4, 3))).ToNotEqual 9\r\n specs.It(\"Scenario 2.4\").Expect(SumArray(Array(3, 3, 100), 1)).ToEqual 6\r\n specs.It(\"Scenario 2.5\").Expect(SumArray(Array(3, 3, 100))).ToEqual 106\r\n specs.It(\"Scenario 2.6\").Expect(SumArray(Array(-3, -3))).ToEqual -6\r\n \r\n 'Tests Scenario #3\r\n specs.It(\"Scenario 3.1\").Expect(ColumnNumberToLetter(26)).ToEqual \"Z\"\r\n specs.It(\"Scenario 3.2\").Expect(ColumnNumberToLetter(1)).ToEqual \"A\"\r\n \r\n '---------------------\r\n 'Tests end here -----^\r\n tddSpecInlineRunner.RunSuite specs\r\n specs.TotalTests\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & \"END: \" & Now() & vbCrLf\r\n Debug.Print \"END: \" & Now() & vbCrLf\r\n If export Then PrintToNotepad\r\n On Error GoTo 0\r\n \r\nEnd Sub\r\n\r\nPublic Sub MakeAllValues()\r\n \r\n Dim myCell As Range\r\n Dim i As Long\r\n Dim str As String\r\n \r\n For Each myCell In Selection\r\n Increment i\r\n str = vbTab & \"myArr(\" & i & \")= \"\r\n \r\n If Len(myCell) > 0 Then\r\n If IsDate(myCell) Then\r\n str = str & \"CDate(\"\"\" & myCell & \"\"\")\"\r\n Else\r\n If Not IsNumeric(myCell) Then\r\n str = str & \"\"\"\" & myCell & \"\"\"\"\r\n Else\r\n str = str & ChangeCommas(myCell.value)\r\n End If\r\n End If\r\n Else\r\n If myCell.HasFormula Then\r\n str = str & \"\"\"\"\"\"\r\n Else\r\n str = str & 0\r\n End If\r\n End If\r\n \r\n Debug.Print str\r\n Next myCell\r\n \r\nEnd Sub\r\n\r\nSub TestMeSample()\r\n \r\n Dim myCell As Range\r\n Dim myVal As Variant\r\n \r\n For Each myCell In tblInput.Range(\"A1:B8\")\r\n myVal = myVal * 1.5 + 2\r\n myCell = myVal * Sin(myVal)\r\n Next\r\n \r\nEnd Sub\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tddSpecDefinition.cls", "content": "VERSION 1.0 CLASS\r\nBEGIN\r\n MultiUse = -1 'True\r\nEND\r\nAttribute VB_Name = \"tddSpecDefinition\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = False\r\nAttribute VB_Exposed = True\r\nOption Explicit\r\n\r\nPrivate pExpectations As Collection\r\nPrivate pFailedExpectations As Collection\r\nPublic Description As String\r\nPublic Id As String\r\n\r\nPublic Enum SpecResult\r\n Pass\r\n Fail\r\n Pending\r\nEnd Enum\r\n\r\nPublic Property Get Expectations() As Collection\r\n\r\n If pExpectations Is Nothing Then\r\n Set pExpectations = New Collection\r\n End If\r\n Set Expectations = pExpectations\r\n \r\nEnd Property\r\n\r\nPrivate Property Let Expectations(value As Collection)\r\n\r\n Set pExpectations = value\r\n \r\nEnd Property\r\n\r\nPublic Property Get FailedExpectations() As Collection\r\n\r\n If pFailedExpectations Is Nothing Then\r\n Set pFailedExpectations = New Collection\r\n End If\r\n Set FailedExpectations = pFailedExpectations\r\n \r\nEnd Property\r\n\r\nPrivate Property Let FailedExpectations(value As Collection)\r\n Set pFailedExpectations = value\r\nEnd Property\r\n\r\nPublic Function Expect(Optional value As Variant) As tddSpecExpectation\r\n\r\n Dim Exp As New tddSpecExpectation\r\n \r\n If VarType(value) = vbObject Then\r\n Set Exp.Actual = value\r\n Else\r\n Exp.Actual = value\r\n End If\r\n Me.Expectations.Add Exp\r\n \r\n Set Expect = Exp\r\n \r\nEnd Function\r\n\r\nPublic Function Result() As SpecResult\r\n\r\n Dim Exp As tddSpecExpectation\r\n \r\n FailedExpectations = New Collection\r\n If Me.Expectations.Count < 1 Then\r\n Result = Pending\r\n Else\r\n For Each Exp In Me.Expectations\r\n If Exp.Result = Fail Then\r\n FailedExpectations.Add Exp\r\n End If\r\n Next Exp\r\n \r\n If Me.FailedExpectations.Count > 0 Then\r\n Result = Fail\r\n Else\r\n Result = Pass\r\n End If\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Function ResultName() As String\r\n \r\n Select Case Me.Result\r\n Case Pass:\r\n ResultName = \"Pass\"\r\n Case Fail:\r\n ResultName = \"Fail\"\r\n Case Pending:\r\n ResultName = \"Pending\"\r\n End Select\r\n \r\nEnd Function\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tddSpecExpectation.cls", "content": "VERSION 1.0 CLASS\r\nBEGIN\r\n MultiUse = -1 'True\r\nEND\r\nAttribute VB_Name = \"tddSpecExpectation\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = False\r\nAttribute VB_Exposed = True\r\nOption Explicit\r\n\r\nPublic Actual As Variant\r\nPublic Expected As Variant\r\nPublic Result As ExpectResult\r\nPublic FailureMessage As String\r\n\r\nPublic Enum ExpectResult\r\n Pass\r\n Fail\r\nEnd Enum\r\n\r\nPublic Sub ToEqual(Expected As Variant)\r\n Check IsEqual(Me.Actual, Expected), \"to equal\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToNotEqual(Expected As Variant)\r\n Check IsEqual(Me.Actual, Expected), \"to not equal\", Expected:=Expected, Inverse:=True\r\nEnd Sub\r\n\r\nPrivate Function IsEqual(Actual As Variant, Expected As Variant) As Variant\r\n \r\n Dim l_count As Long\r\n\r\n If IsArray(Expected) Then\r\n If UBound(Expected) <> UBound(Actual) Then IsEqual = False: Exit Function\r\n \r\n For l_count = LBound(Expected) To UBound(Expected)\r\n If Not Expected(l_count) = Actual(l_count) Then IsEqual = False: Exit Function\r\n Next l_count\r\n IsEqual = True\r\n End If\r\n\r\n If IsError(Actual) Or IsError(Expected) Then\r\n IsEqual = False\r\n ElseIf IsObject(Actual) Or IsObject(Expected) Then\r\n IsEqual = \"Unsupported: Can't compare objects\"\r\n ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then\r\n IsEqual = IsCloseTo(Actual, Expected, 15)\r\n Else\r\n IsEqual = Actual = Expected\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeDefined()\r\n\r\n Debug.Print \"Excel-TDD: DEPRECATED, ToBeDefined() has been deprecated in favor of ToNotBeUndefined and will be removed in Excel-TDD v2.0.0\"\r\n Check IsUndefined(Me.Actual), \"to be defined\", Inverse:=True\r\n \r\nEnd Sub\r\n\r\nPublic Sub ToBeUndefined()\r\n Check IsUndefined(Me.Actual), \"to be undefined\"\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeUndefined()\r\n Check IsUndefined(Me.Actual), \"to not be undefined\", Inverse:=True\r\nEnd Sub\r\n\r\nPrivate Function IsUndefined(Actual As Variant) As Variant\r\n IsUndefined = IsNothing(Actual) Or isEmpty(Actual) Or IsNull(Actual) Or IsMissing(Actual)\r\nEnd Function\r\n\r\nPublic Sub ToBeNothing()\r\n Check IsNothing(Me.Actual), \"to be nothing\"\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeNothing()\r\n Check IsNothing(Me.Actual), \"to not be nothing\", Inverse:=True\r\nEnd Sub\r\n\r\nPrivate Function IsNothing(Actual As Variant) As Variant\r\n\r\n If IsObject(Actual) Then\r\n If Actual Is Nothing Then\r\n IsNothing = True\r\n Else\r\n IsNothing = False\r\n End If\r\n Else\r\n IsNothing = False\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeEmpty()\r\n Check isEmpty(Me.Actual), \"to be empty\"\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeEmpty()\r\n Check isEmpty(Me.Actual), \"to not be empty\", Inverse:=True\r\nEnd Sub\r\n\r\nPublic Sub ToBeNull()\r\n Check IsNull(Me.Actual), \"to be null\"\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeNull()\r\n Check IsNull(Me.Actual), \"to not be null\", Inverse:=True\r\nEnd Sub\r\n\r\nPublic Sub ToBeMissing()\r\n Check IsMissing(Me.Actual), \"to be missing\"\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeMissing()\r\n Check IsMissing(Me.Actual), \"to not be missing\", Inverse:=True\r\nEnd Sub\r\n\r\nPublic Sub ToBeLessThan(Expected As Variant)\r\n Check IsLT(Me.Actual, Expected), \"to be less than\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToBeLT(Expected As Variant)\r\n ToBeLessThan Expected\r\nEnd Sub\r\n\r\nPrivate Function IsLT(Actual As Variant, Expected As Variant) As Variant\r\n \r\n If IsError(Actual) Or IsError(Expected) Or Actual >= Expected Then\r\n IsLT = False\r\n Else\r\n IsLT = True\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeLessThanOrEqualTo(Expected As Variant)\r\n Check IsLTE(Me.Actual, Expected), \"to be less than or equal to\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToBeLTE(Expected As Variant)\r\n ToBeLessThanOrEqualTo Expected\r\nEnd Sub\r\n\r\nPrivate Function IsLTE(Actual As Variant, Expected As Variant) As Variant\r\n\r\n If IsError(Actual) Or IsError(Expected) Or Actual > Expected Then\r\n IsLTE = False\r\n Else\r\n IsLTE = True\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeGreaterThan(Expected As Variant)\r\n\r\n Check IsGT(Me.Actual, Expected), \"to be greater than\", Expected:=Expected\r\n \r\nEnd Sub\r\nPublic Sub ToBeGT(Expected As Variant)\r\n ToBeGreaterThan Expected\r\nEnd Sub\r\n\r\nPrivate Function IsGT(Actual As Variant, Expected As Variant) As Variant\r\n\r\n If IsError(Actual) Or IsError(Expected) Or Actual <= Expected Then\r\n IsGT = False\r\n Else\r\n IsGT = True\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeGreaterThanOrEqualTo(Expected As Variant)\r\n Check IsGTE(Me.Actual, Expected), \"to be greater than or equal to\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToBeGTE(Expected As Variant)\r\n ToBeGreaterThanOrEqualTo Expected\r\nEnd Sub\r\n\r\nPrivate Function IsGTE(Actual As Variant, Expected As Variant) As Variant\r\n\r\n If IsError(Actual) Or IsError(Expected) Or Actual < Expected Then\r\n IsGTE = False\r\n Else\r\n IsGTE = True\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToBeCloseTo(Expected As Variant, SignificantFigures As Long)\r\n Check IsCloseTo(Me.Actual, Expected, SignificantFigures), \"to be close to\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToNotBeCloseTo(Expected As Variant, SignificantFigures As Long)\r\n Check IsCloseTo(Me.Actual, Expected, SignificantFigures), \"to be close to\", Expected:=Expected, Inverse:=True\r\nEnd Sub\r\n\r\nPrivate Function IsCloseTo(Actual As Variant, Expected As Variant, SignificantFigures As Long) As Variant\r\n\r\n Dim ActualAsString As String\r\n Dim ExpectedAsString As String\r\n \r\n If SignificantFigures < 1 Or SignificantFigures > 15 Then\r\n IsCloseTo = \"ToBeCloseTo/ToNotBeClose to can only compare from 1 to 15 significant figures\"\"\"\r\n ElseIf Not IsError(Actual) And Not IsError(Expected) Then\r\n If Actual > 1 Then\r\n ActualAsString = VBA.Format$(Actual, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e+0\")\r\n Else\r\n ActualAsString = VBA.Format$(Actual, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e-0\")\r\n End If\r\n \r\n If Expected > 1 Then\r\n ExpectedAsString = VBA.Format$(Expected, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e+0\")\r\n Else\r\n ExpectedAsString = VBA.Format$(Expected, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e-0\")\r\n End If\r\n \r\n IsCloseTo = ActualAsString = ExpectedAsString\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToContain(Expected As Variant, Optional MatchCase As Boolean = True)\r\n\r\n If VarType(Me.Actual) = vbString Then\r\n Debug.Print \"Excel-TDD: DEPRECATED ToContain has been changed to ToMatch in Excel-TDD v2.0.0\"\r\n If MatchCase Then\r\n Check Matches(Me.Actual, Expected), \"to match\", Expected:=Expected\r\n Else\r\n Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), \"to match\", Expected:=Expected\r\n End If\r\n Else\r\n Check Contains(Me.Actual, Expected), \"to contain\", Expected:=Expected\r\n End If\r\n \r\nEnd Sub\r\n\r\nPublic Sub ToNotContain(Expected As Variant, Optional MatchCase As Boolean = True)\r\n\r\n If VarType(Me.Actual) = vbString Then\r\n Debug.Print \"Excel-TDD: DEPRECATED ToNotContain has been changed to ToMatch in Excel-TDD v2.0.0\"\r\n If MatchCase Then\r\n Check Matches(Me.Actual, Expected), \"to not match\", Expected:=Expected, Inverse:=True\r\n Else\r\n Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), \"to not match\", Expected:=Expected, Inverse:=True\r\n End If\r\n Else\r\n Check Contains(Me.Actual, Expected), \"to not contain\", Expected:=Expected, Inverse:=True\r\n End If\r\n \r\nEnd Sub\r\n\r\nPrivate Function Contains(Actual As Variant, Expected As Variant) As Variant\r\n\r\n If Not IsArray(Actual) Then\r\n Contains = \"Error: Actual needs to be an Array or Collection for ToContain/ToNotContain\"\r\n Else\r\n Dim i As Long\r\n \r\n If TypeOf Actual Is Collection Then\r\n For i = 1 To Actual.Count\r\n If Actual.item(i) = Expected Then\r\n Contains = True\r\n Exit Function\r\n End If\r\n Next i\r\n \r\n Else\r\n \r\n For i = LBound(Actual) To UBound(Actual)\r\n If Actual(i) = Expected Then\r\n Contains = True\r\n Exit Function\r\n End If\r\n Next i\r\n End If\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub ToMatch(Expected As Variant)\r\n Check Matches(Me.Actual, Expected), \"to match\", Expected:=Expected\r\nEnd Sub\r\n\r\nPublic Sub ToNotMatch(Expected As Variant)\r\n Check Matches(Me.Actual, Expected), \"to not match\", Expected:=Expected, Inverse:=True\r\nEnd Sub\r\n\r\nPrivate Function Matches(Actual As Variant, Expected As Variant) As Variant\r\n\r\n If InStr(Actual, Expected) > 0 Then\r\n Matches = True\r\n Else\r\n Matches = False\r\n End If\r\n \r\nEnd Function\r\n\r\nPublic Sub RunMatcher(Name As String, Message As String, ParamArray Arguments())\r\n\r\n Dim Expected As String\r\n Dim i As Long\r\n Dim HasArguments As Boolean\r\n \r\n HasArguments = UBound(Arguments) >= 0\r\n For i = LBound(Arguments) To UBound(Arguments)\r\n If Expected = \"\" Then\r\n Expected = GetStringForValue(Arguments(i))\r\n ElseIf i = UBound(Arguments) Then\r\n If (UBound(Arguments) > 1) Then\r\n Expected = Expected & \", and \" & GetStringForValue(Arguments(i))\r\n Else\r\n Expected = Expected & \" and \" & GetStringForValue(Arguments(i))\r\n End If\r\n Else\r\n Expected = Expected & \", \" & GetStringForValue(Arguments(i))\r\n End If\r\n Next i\r\n \r\n If HasArguments Then\r\n Check Application.Run(Name, Me.Actual, Arguments), Message, Expected:=Expected\r\n Else\r\n Check Application.Run(Name, Me.Actual), Message\r\n End If\r\n \r\nEnd Sub\r\n\r\nPrivate Sub Check(Result As Variant, Message As String, Optional Expected As Variant, Optional Inverse As Boolean = False)\r\n \r\n If Not IsMissing(Expected) Then\r\n If IsObject(Expected) Then\r\n Set Me.Expected = Expected\r\n Else\r\n Me.Expected = Expected\r\n End If\r\n End If\r\n \r\n If VarType(Result) = vbString Then\r\n Fails CStr(Result)\r\n Else\r\n If Inverse Then\r\n Result = Not Result\r\n End If\r\n \r\n If Result Then\r\n Passes\r\n Else\r\n Fails CreateFailureMessage(Message, Expected)\r\n End If\r\n End If\r\n \r\nEnd Sub\r\n\r\nPrivate Sub Passes()\r\n Me.Result = ExpectResult.Pass\r\nEnd Sub\r\n\r\nPrivate Sub Fails(Message As String)\r\n Me.Result = ExpectResult.Fail\r\n Me.FailureMessage = Message\r\nEnd Sub\r\n\r\nPrivate Function CreateFailureMessage(Message As String, Optional Expected As Variant) As String\r\n \r\n CreateFailureMessage = \"Expected \" & GetStringForValue(Me.Actual) & \" \" & Message\r\n If Not IsMissing(Expected) Then\r\n CreateFailureMessage = CreateFailureMessage & \" \" & GetStringForValue(Expected)\r\n End If\r\n \r\nEnd Function\r\n\r\nPrivate Function GetStringForValue(value As Variant) As String\r\n\r\n If IsObject(value) Then\r\n If value Is Nothing Then\r\n GetStringForValue = \"(Nothing)\"\r\n Else\r\n GetStringForValue = \"(Object)\"\r\n End If\r\n ElseIf IsArray(value) Then\r\n GetStringForValue = \"(Array)\"\r\n ElseIf isEmpty(value) Then\r\n GetStringForValue = \"(Empty)\"\r\n ElseIf IsNull(value) Then\r\n GetStringForValue = \"(Null)\"\r\n ElseIf IsMissing(value) Then\r\n GetStringForValue = \"(Missing)\"\r\n Else\r\n GetStringForValue = CStr(value)\r\n End If\r\n \r\n If GetStringForValue = \"\" Then\r\n GetStringForValue = \"(Undefined)\"\r\n End If\r\n \r\nEnd Function\r\n\r\nPrivate Function IsArray(value As Variant) As Boolean\r\n\r\n If Not isEmpty(value) Then\r\n If IsObject(value) Then\r\n If TypeOf value Is Collection Then\r\n IsArray = True\r\n End If\r\n ElseIf VarType(value) = vbArray Or VarType(value) = 8204 Then\r\n IsArray = True\r\n End If\r\n End If\r\n \r\nEnd Function\r\n\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tddSpecInlineRunner.bas", "content": "Attribute VB_Name = \"tddSpecInlineRunner\"\r\nOption Explicit\r\nOption Private Module\r\n\r\nPublic Sub RunSuite(specs As tddSpecSuite, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = False)\r\n \r\n Dim SuiteCol As New Collection\r\n \r\n SuiteCol.Add specs\r\n RunSuites SuiteCol, ShowFailureDetails, ShowPassed, ShowSuiteDetails\r\n\r\nEnd Sub\r\n\r\nPublic Sub RunSuites(SuiteCol As Collection, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = True)\r\n \r\n Dim Suite As tddSpecSuite\r\n Dim Spec As tddSpecDefinition\r\n Dim TotalCount As Long\r\n Dim FailedSpecs As Long\r\n Dim PendingSpecs As Long\r\n Dim ShowingResults As Boolean\r\n Dim Indentation As String\r\n \r\n For Each Suite In SuiteCol\r\n If Not Suite Is Nothing Then\r\n TotalCount = TotalCount + Suite.SpecsCol.Count\r\n\r\n For Each Spec In Suite.SpecsCol\r\n If Spec.Result = SpecResult.Fail Then\r\n FailedSpecs = FailedSpecs + 1\r\n ElseIf Spec.Result = SpecResult.Pending Then\r\n PendingSpecs = PendingSpecs + 1\r\n End If\r\n Next Spec\r\n End If\r\n Next Suite\r\n \r\n Debug.Print \"= \" & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & \" = \" & Now & \" =========================\"\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & \"= \" & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & \" = \" & Now & \" =========================\" & vbCrLf\r\n \r\n For Each Suite In SuiteCol\r\n If Not Suite Is Nothing Then\r\n If ShowSuiteDetails Then\r\n Debug.Print SuiteMessage(Suite)\r\n Indentation = \" \"\r\n ShowingResults = True\r\n Else\r\n Indentation = \"\"\r\n End If\r\n \r\n For Each Spec In Suite.SpecsCol\r\n If Spec.Result = SpecResult.Fail Then\r\n Debug.Print Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation)\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) & vbCrLf\r\n ShowingResults = True\r\n ElseIf Spec.Result = SpecResult.Pending Then\r\n Debug.Print Indentation & PendingMessage(Spec)\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PendingMessage(Spec) & vbCrLf\r\n ShowingResults = True\r\n ElseIf ShowPassed Then\r\n Debug.Print Indentation & PassingMessage(Spec)\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PassingMessage(Spec) & vbCrLf\r\n ShowingResults = True\r\n End If\r\n Next Spec\r\n End If\r\n Next Suite\r\n \r\n If ShowingResults Then\r\n Debug.Print \"===\"\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & \"===\" & vbCrLf\r\n End If\r\n \r\nEnd Sub\r\n\r\nPrivate Function SummaryMessage(TotalCount As Long, FailedSpecs As Long, PendingSpecs As Long) As String\r\n \r\n If FailedSpecs = 0 Then\r\n SummaryMessage = \"PASS (\" & TotalCount - PendingSpecs & \" of \" & TotalCount & \" passed\"\r\n Else\r\n SummaryMessage = \"FAIL (\" & FailedSpecs & \" of \" & TotalCount & \" failed\"\r\n End If\r\n \r\n If PendingSpecs = 0 Then\r\n SummaryMessage = SummaryMessage & \")\"\r\n Else\r\n SummaryMessage = SummaryMessage & \", \" & PendingSpecs & \" pending)\"\r\n End If\r\n \r\nEnd Function\r\n\r\nPrivate Function FailureMessage(Spec As tddSpecDefinition, ShowFailureDetails As Boolean, Indentation As String) As String\r\n\r\n Dim FailedExpectation As tddSpecExpectation\r\n Dim i As Long\r\n \r\n FailureMessage = ResultMessage(Spec, \"X\")\r\n \r\n If ShowFailureDetails Then\r\n FailureMessage = FailureMessage & vbNewLine\r\n \r\n For Each FailedExpectation In Spec.FailedExpectations\r\n FailureMessage = FailureMessage & Indentation & \" \" & FailedExpectation.FailureMessage\r\n \r\n If i + 1 <> Spec.FailedExpectations.Count Then: FailureMessage = FailureMessage & vbNewLine\r\n i = i + 1\r\n Next FailedExpectation\r\n End If\r\n \r\nEnd Function\r\n\r\nPrivate Function PendingMessage(Spec As tddSpecDefinition) As String\r\n PendingMessage = ResultMessage(Spec, \".\")\r\nEnd Function\r\n\r\nPrivate Function PassingMessage(Spec As tddSpecDefinition) As String\r\n PassingMessage = ResultMessage(Spec, \"+\")\r\nEnd Function\r\n\r\nPrivate Function ResultMessage(Spec As tddSpecDefinition, Symbol As String) As String\r\n ResultMessage = Symbol & \" \"\r\n \r\n If Spec.Id <> \"\" Then\r\n ResultMessage = ResultMessage & Spec.Id & \": \"\r\n End If\r\n \r\n ResultMessage = ResultMessage & Spec.Description\r\nEnd Function\r\n\r\nPrivate Function SuiteMessage(Suite As tddSpecSuite) As String\r\n Dim HasFailures As Boolean\r\n Dim Spec As tddSpecDefinition\r\n \r\n For Each Spec In Suite.SpecsCol\r\n If Spec.Result = SpecResult.Fail Then\r\n HasFailures = True\r\n Exit For\r\n End If\r\n Next Spec\r\n \r\n If HasFailures Then\r\n SuiteMessage = \"X \"\r\n Else\r\n SuiteMessage = \"+ \"\r\n End If\r\n \r\n If Suite.Description <> \"\" Then\r\n SuiteMessage = SuiteMessage & Suite.Description\r\n Else\r\n SuiteMessage = SuiteMessage & Suite.SpecsCol.Count & \" specs\"\r\n End If\r\nEnd Function\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/tddSpecSuite.cls", "content": "VERSION 1.0 CLASS\r\nBEGIN\r\n MultiUse = -1 'True\r\nEND\r\nAttribute VB_Name = \"tddSpecSuite\"\r\nAttribute VB_GlobalNameSpace = False\r\nAttribute VB_Creatable = False\r\nAttribute VB_PredeclaredId = False\r\nAttribute VB_Exposed = True\r\nOption Explicit\r\n\r\nPrivate pSpecsCol As Collection\r\n\r\nPublic Description As String\r\nPublic BeforeEachCallback As String\r\nPublic BeforeEachCallbackArgs As Variant\r\nPrivate pCounter As Long\r\n\r\nPublic Property Get SpecsCol() As Collection\r\n\r\n If pSpecsCol Is Nothing Then: Set pSpecsCol = New Collection\r\n Set SpecsCol = pSpecsCol\r\n \r\nEnd Property\r\n\r\nPublic Property Let SpecsCol(value As Collection)\r\n \r\n Set pSpecsCol = value\r\n \r\nEnd Property\r\n\r\nPublic Function It(Description As String, Optional SpecId As String = \"\") As tddSpecDefinition\r\n \r\n Dim Spec As New tddSpecDefinition\r\n \r\n pCounter = pCounter + 1\r\n ExecuteBeforeEach\r\n Spec.Description = Description\r\n Spec.Id = SpecId\r\n Me.SpecsCol.Add Spec\r\n Set It = Spec\r\n \r\nEnd Function\r\n\r\nPublic Sub TotalTests()\r\n\r\n Debug.Print \"Total tests:\" & pCounter\r\n PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & \"Total tests:\" & pCounter & vbCrLf\r\n \r\nEnd Sub\r\n\r\nPublic Sub BeforeEach(Callback As String, ParamArray CallbackArgs() As Variant)\r\n Me.BeforeEachCallback = Callback\r\n Me.BeforeEachCallbackArgs = CallbackArgs\r\nEnd Sub\r\n\r\nPrivate Sub ExecuteBeforeEach()\r\n\r\n If Me.BeforeEachCallback <> \"\" Then\r\n Dim HasArguments As Boolean\r\n If VarType(Me.BeforeEachCallbackArgs) = vbObject Then\r\n If Not Me.BeforeEachCallbackArgs Is Nothing Then\r\n HasArguments = True\r\n End If\r\n ElseIf IsArray(Me.BeforeEachCallbackArgs) Then\r\n If UBound(Me.BeforeEachCallbackArgs) >= 0 Then\r\n HasArguments = True\r\n End If\r\n End If\r\n \r\n If HasArguments Then\r\n Application.Run Me.BeforeEachCallback, Me.BeforeEachCallbackArgs\r\n Else\r\n Application.Run Me.BeforeEachCallback\r\n End If\r\n End If\r\n \r\nEnd Sub\r\n\r\n" }, { "path": "Boilerplate/Boilerplate VitoshAcademy/xl_main.vb", "content": "Option Explicit\r\n\r\nPrivate Sub Workbook_BeforeClose(Cancel As Boolean)\r\n\r\n On Error GoTo Workbook_BeforeClose_Error\r\n \r\n If Not SET_IN_PRODUCTION Then\r\n MsgBox \"SET_IN_PRODUCTION\"\r\n On Error GoTo 0\r\n Cancel = True\r\n End If\r\n \r\n Cancel = False\r\n \r\n ThisWorkbook.Save\r\n\r\n Application.DisplayAlerts = False\r\n HideNeededWorksheets\r\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\r\n Application.DisplayAlerts = True\r\n ActiveWindow.DisplayHeadings = True\r\n Application.DisplayFormulaBar = True\r\n 'ActiveSheet.PageSetup.BlackAndWhite = True\r\n Me.Save\r\n\r\n EnableMySaves\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nWorkbook_BeforeClose_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_BeforeClose\"\r\n\r\nEnd Sub\r\n\r\nPrivate Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)\r\n \r\n If Not SET_IN_PRODUCTION Then\r\n MsgBox \"SET_IN_PRODUCTION\", vbInformation, CON_STR_APP_NAME\r\n Cancel = True\r\n End If\r\n \r\nEnd Sub\r\n\r\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\r\n\r\n If Not tblSettings.Visible Then\r\n With Application\r\n Application.ScreenUpdating = False\r\n Application.DisplayAlerts = False\r\n Sh.Delete\r\n Application.DisplayAlerts = True\r\n Application.ScreenUpdating = True\r\n End With\r\n\r\n MsgBox (Environ(\"UserName\") & \", Sie können Blätter nicht hinzufügen.\"), vbInformation, ThisWorkbook.Name\r\n End If\r\n\r\nEnd Sub\r\n\r\nPrivate Sub Workbook_Open()\r\n\r\n On Error GoTo Workbook_Open_Error\r\n\r\n HideNeededWorksheets\r\n 'Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\r\n 'Application.DisplayFormulaBar = False\r\n\r\n If Not IsValueInArray(Environ(\"username\"), ADMINS, True) Then\r\n Application.OnKey \"%{F11}\", \"DisabledCombination\"\r\n End If\r\n\r\n DisableShortcutsAndSaves\r\n\r\n If ThisWorkbook.Date1904 Then\r\n MsgBox CON_STR_1904, vbInformation, CON_STR_APP_NAME\r\n End If\r\n\r\n Application.WindowState = xlMaximized\r\n\r\n CheckHowManyWbAreOpened\r\n\r\n On Error GoTo 0\r\n Exit Sub\r\n\r\nWorkbook_Open_Error:\r\n\r\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_Open\"\r\n Me.Save\r\n ThisWorkbook.Close\r\n\r\nEnd Sub\r\n" }, { "path": "Boilerplate/CodifyDecodify.vb", "content": "'Encrypt, encript,\n'Decrypt, decript,\n'password, check hours\n\nOption Explicit\n\nPublic Const FIRST_ASCII = 97\nPublic Const LETTERS_NUMBER = 26\n\nPublic Function codify_time() As String\n\n If [set_in_production] Then On Error GoTo codify_Error\n \n Dim dbl_01 As Variant\n Dim dbl_02 As Variant\n Dim dbl_now As Double\n \n dbl_now = Round(Now(), 8)\n \n dbl_01 = Split(CStr(dbl_now), \",\")(0)\n dbl_02 = Split(CStr(dbl_now), \",\")(1)\n \n codify_time = Hex(dbl_01) & \"_\" & Hex(dbl_02)\n\n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\n\nEnd Function\n\n\nPublic Function codify(str_name) As String\n \n Dim l_counter As Long\n Dim l_number As Long\n \n Dim str_number As String\n \n Dim str_char As String\n Dim str_char_result As String\n \n Dim str_first As String\n Dim str_last As String\n \n 'making the time\n For l_counter = 1 To Len(str_name) - 3\n str_number = str_number & Mid(str_name, l_counter, 1)\n Next l_counter\n l_number = str_number\n \n 'making the name\n For l_counter = 3 To 1 Step -1\n \n str_char = Mid(str_name, Len(str_name) - l_counter + 1, 1)\n str_char = Chr((Asc(str_char) + l_number) Mod LETTERS_NUMBER)\n str_char = Chr(Asc(str_char) + FIRST_ASCII)\n str_char_result = str_char_result & str_char\n \n Next l_counter\n \n codify = Hex(l_number) & StrReverse(str_char_result)\n \n 'now reverse first and last positions\n str_first = get_in_position(codify, 1)\n str_last = get_in_position(codify, 1, True)\n \n codify = delete_in_position(codify, 1)\n codify = delete_in_position(codify, Len(codify))\n \n codify = insert_in_position(codify, str_first, Len(codify))\n codify = insert_in_position(codify, str_last, 0)\n \n codify = LCase(codify)\n \nEnd Function\n\nPublic Function decodify(str_name) As String\n \n Dim l_counter As Long\n Dim str_char As String\n Dim str_time As String\n \n Dim l_left As Long\n Dim str_right As String\n \n Dim str_first As String\n Dim str_last As String\n \n 'now reverse first and last positions\n str_first = get_in_position(str_name, 1)\n str_last = get_in_position(str_name, 1, True)\n \n str_name = delete_in_position(str_name, 1)\n str_name = delete_in_position(str_name, Len(str_name))\n \n str_name = insert_in_position(str_name, str_first, Len(str_name))\n str_name = insert_in_position(str_name, str_last, 0)\n \n 'making the time\n \n For l_counter = 1 To Len(str_name) - 3\n str_time = str_time & Mid(str_name, l_counter, 1)\n Next l_counter\n \n l_left = Val(\"&H\" & str_time)\n \n 'making the name\n \n For l_counter = 3 To 1 Step -1\n str_char = Mid(str_name, Len(str_name) - l_counter + 1, 1)\n str_char = Chr(Asc(str_char) - FIRST_ASCII)\n str_right = str_right & Chr(mod_where(str_char, l_left))\n \n Next l_counter\n \n decodify = l_left & StrReverse(str_right)\n\nEnd Function\n\nPublic Function format_decodify(str_input As String, Optional b_for_file_name As Boolean = False) As String\n \n Dim str_exchange1 As String: str_exchange1 = \":\"\n Dim str_exchange2 As String: str_exchange2 = \" \"\n \n If b_for_file_name Then\n If Len(str_input) = 9 Then\n format_decodify = insert_in_position(str_input, str_exchange2, 6)\n Else\n format_decodify = insert_in_position(str_input, str_exchange2, 5)\n End If\n \n Exit Function\n \n End If\n \n If Len(str_input) = 9 Then\n format_decodify = insert_in_position(str_input, str_exchange1, 2)\n format_decodify = insert_in_position(format_decodify, str_exchange1, 5)\n format_decodify = insert_in_position(format_decodify, str_exchange2, 8)\n Else\n format_decodify = insert_in_position(str_input, str_exchange1, 1)\n format_decodify = insert_in_position(format_decodify, str_exchange1, 4)\n format_decodify = insert_in_position(format_decodify, str_exchange2, 7)\n End If\n \nEnd Function\n\nPublic Function mod_where(str As String, l_left As Long) As Long\n \n Dim l_counter As Long\n \n For l_counter = 0 To LETTERS_NUMBER\n If ((l_left + l_counter + FIRST_ASCII) Mod LETTERS_NUMBER = Asc(str)) Then\n mod_where = l_counter + FIRST_ASCII\n Exit For\n End If\n Next l_counter\n\nEnd Function\n\nPublic Function get_extension() As String\n\n get_extension = Replace(Time, \":\", \"\") & Replace(Left(Environ(\"Username\"), 4), \".\", \"\")\n\nEnd Function\n\nFunction insert_in_position(ByVal source As String, str As String, l As Long) As String\n 'insert in position\n \n insert_in_position = Mid(source, 1, l) & str & Mid(source, l + 1, Len(source) - l)\n \nEnd Function\n\nFunction delete_in_position(ByVal source As String, l As Long) As String\n 'delete in position\n \n delete_in_position = Mid(source, 1, l - 1) & Mid(source, l + 1, Len(source) - l)\n \nEnd Function\n\nFunction get_in_position(ByVal str As String, l_position As Long, Optional b_is_last As Boolean = False) As String\n \n get_in_position = Mid(str, l_position, 1)\n \n If b_is_last Then get_in_position = Mid(str, Len(str), 1)\n \nEnd Function\n\n\n\n" }, { "path": "Boilerplate/ConvertNumberToLetter.vb", "content": "Public Function NumberToLetter(number As Long) As String\n\nOn Error GoTo NumberToLetterError\n\n Dim remainder As Long\n\n If number < 1 Or number > 2 ^ 14 Then\n Err.Raise 999, Description:=\"Error on \" & number\n End If\n\n Do While number > 0\n remainder = (number - 1) Mod 26\n NumberToLetter = Chr(65 + remainder) + NumberToLetter\n number = (number - remainder) \\ 26\n Loop\n \n Exit Function\n \nNumberToLetterError:\n NumberToLetter = Error\nEnd Function\n\nPublic Sub NumberToLetterTest()\n\n Debug.Print NumberToLetter(1) = \"A\"\n Debug.Print NumberToLetter(26) = \"Z\"\n Debug.Print NumberToLetter(27) = \"AA\"\n Debug.Print NumberToLetter(100) = \"CV\"\n Debug.Print NumberToLetter(200) = \"GR\"\n Debug.Print NumberToLetter(701) = \"ZY\"\n Debug.Print NumberToLetter(702) = \"ZZ\"\n\n Debug.Print NumberToLetter(703) = \"AAA\"\n Debug.Print NumberToLetter(715) = \"AAM\"\n Debug.Print NumberToLetter(1379) = \"BAA\"\n Debug.Print NumberToLetter(2055) = \"CAA\"\n Debug.Print NumberToLetter(2731) = \"DAA\"\n Debug.Print NumberToLetter(704) = \"AAB\"\n Debug.Print NumberToLetter(1380) = \"BAB\"\n Debug.Print NumberToLetter(2056) = \"CAB\"\n Debug.Print NumberToLetter(2732) = \"DAB\"\n Debug.Print NumberToLetter(2812) = \"DDD\"\n Debug.Print NumberToLetter(5434) = \"GZZ\"\n Debug.Print NumberToLetter(8138) = \"KZZ\"\n Debug.Print NumberToLetter(16000) = \"WQJ\"\n Debug.Print NumberToLetter(16251) = \"XAA\"\n Debug.Print NumberToLetter(16384) = \"XFD\"\n\n Debug.Print NumberToLetter(16386) = \"Error on 16386\"\n Debug.Print NumberToLetter(-3) = \"Error on -3\"\n\nEnd Sub\n\n\nPublic Function ConvertNumberToLetterExcel(number As Long) As String\n \n ConvertNumberToLetterExcel = Split(Cells(1, number).Address, \"$\")(1)\n\nEnd Function\n" }, { "path": "Boilerplate/ExcelGeneral.vb", "content": "Public Sub CloseAllExcelFilesExceptCurrent()\n\n Dim wb As Workbook\n \n Application.ScreenUpdating = False\n \n For Each wb In Workbooks\n\n If Not wb.ReadOnly Then wb.Save\n If wb.Name <> ThisWorkbook.Name Then\n wb.Close\n End If\n Next wb\n \nEnd Sub\n\n\nPublic Function ValueInArray(myValue As Variant, myArray As Variant) As Boolean\n\n Dim cnt As Long\n\n For cnt = LBound(myArray) To UBound(myArray)\n If LCase(CStr(myValue)) = LCase(CStr(myArray(cnt))) Then\n valueInArray = True\n Exit Function\n End If\n Next cnt\n\nEnd Function\n\nSub CheckUser()\n\n Dim userNames As Variant\n userNames = Array(\"User1\", \"User2\", \"User3\")\n\n If valueInArray(Environ(\"UserName\"), userNames) Then\n Debug.Print \"User Present\"\n Else\n Debug.Print \"User Not Present\"\n End If\n \nEnd Sub\n\n\nSub ChangeTheFont(lookFor As String, currentRange As Range, myColor As Long)\n\n Dim startPosition As Long: startPosition = InStr(1, currentRange.Value2, lookFor)\n Dim endPosition As Long: endPosition = startPosition + Len(currentRange.Value2)\n\n With currentRange.Characters(startPosition, Len(lookFor)).Font\n .Color = myColor\n .Bold = True\n End With\nEnd Sub\n\nPublic Function PositionInArray(myValue As Variant, myArray As Variant, Optional timesSeenBefore = 0) As Long\n \n Dim i As Long\n For i = LBound(myArray) To UBound(myArray)\n If Trim(myValue) = Trim(myArray(i)) Then\n If timesSeenBefore = 0 Then\n PositionInArray = i\n Exit Function\n Else\n timesSeenBefore = timesSeenBefore - 1\n End If\n End If\n Next\n \n PositionInArray = -1\n \nEnd Function\n\nPublic Sub WriteIfNotZero(myCell As Range, myValue As Variant)\n \n If IsError(myValue) Then\n Dim info As String\n info = \"ExcelError()->\" & CStr(myValue) & \"->\" & myCell.Address & \"->\" & myCell.Parent.Name & \"->\" & myCell.Parent.Parent.Name\n Debug.Print info\n LogDescription info\n ElseIf IsNumeric(myValue) Then\n If CDec(myValue) <> 0 Then\n myCell.Value2 = myValue\n End If\n End If\n \nEnd Sub\n" }, { "path": "Boilerplate/Files.vb", "content": "Public Function b_file_exists(ByVal str_file_path As String) As Boolean\n\n Dim str_test As String\n \n On Error Resume Next\n str_test = Dir(str_file_path)\n On Error GoTo 0\n b_file_exists = (str_test <> \"\")\n\nEnd Function\n\n'works in eshare\n'eshare file exists\n\nPublic Function EshareFileExists(filePath)\n \n filePath = Replace(filePath, \"https:\", \"\")\n filePath = Replace(filePath, \"%20\", \" \")\n filePath = Replace(filePath, \"/\", \"\\\")\n EshareFileExists = CreateObject(\"Scripting.FileSystemObject\").FileExists(filePath)\n \nEnd Function\n" }, { "path": "Boilerplate/Formula.vb", "content": "Public Sub PrintMeUsefulFormula()\n\n Dim selectedFormula As String\n Dim parenthesis As String\n\n parenthesis = \"\"\"\"\n\n selectedFormula = Selection.Formula\n selectedFormula = Replace(selectedFormula, \"\"\"\", \"\"\"\"\"\")\n\n selectedFormula = parenthesis & selectedFormula & parenthesis\n Debug.Print selectedFormula\n \nEnd Sub\n\n'A bit untested, use with caution --------v\nPublic Sub PrintMeUsefulFormat()\n\n Dim strFormula As String\n Dim strParenth As String\n\n strParenth = \"\"\"\"\n\n strFormula = Selection.NumberFormat\n strFormula = Replace(strFormula, \"\"\"\", \"\"\"\"\"\")\n\n strFormula = strParenth & strFormula & strParenth\n Debug.Print strFormula\n\nEnd Sub\n\n'Column to letter letter to column\n'lettertocolumn columntoletter\n\nFunction ColumnToLetter(columnNumber As Long) As String\n \n If columnNumber < 1 Then Exit Function\n ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc(\"A\")))\n\nEnd Function\n\nFunction LetterToColumn(letters As String) As Long\n \n Dim i As Long\n letters = UCase(letters)\n \n For i = Len(letters) To 1 Step -1\n LetterToColumn = LetterToColumn + (Asc(Mid(letters, i, 1)) - 64) * 26 ^ (Len(letters) - i)\n Next\n \nEnd Function\n\nSub Tests()\n\n Debug.Print LetterToColumn(\"a\") = 1\n Debug.Print LetterToColumn(\"A\") = 1\n Debug.Print LetterToColumn(\"Z\") = 26\n Debug.Print LetterToColumn(\"AA\") = 27\n Debug.Print LetterToColumn(\"AZ\") = 52\n Debug.Print LetterToColumn(\"BA\") = 53\n \n Debug.Print ColumnToLetter(1) = \"A\"\n Debug.Print ColumnToLetter(26) = \"Z\"\n Debug.Print ColumnToLetter(27) = \"AA\"\n Debug.Print ColumnToLetter(52) = \"AZ\"\n Debug.Print ColumnToLetter(53) = \"BA\"\n \nEnd Sub\n" }, { "path": "Boilerplate/GeneratePathToFolder.vb", "content": "Option Explicit\n\nSub myPathForFolder()\n Debug.Print GetFolder(Environ(\"USERPROFILE\"))\nEnd Sub\n\nFunction GetFolder(Optional InitialLocation As String) As String\n\n On Error GoTo GetFolder_Error\n\n Dim FolderDialog As FileDialog\n Dim SelectedFolder As String\n\n If Len(InitialLocation) = 0 Then InitialLocation = ThisWorkbook.Path\n\n Set FolderDialog = Excel.Application.FileDialog(msoFileDialogFolderPicker)\n\n With FolderDialog\n .Title = \"My Title For Dialog\"\n .AllowMultiSelect = False\n .InitialFileName = InitialLocation\n If .Show <> -1 Then GoTo GetFolder_Error\n SelectedFolder = .SelectedItems(1)\n End With\n\n GetFolder = SelectedFolder\n\n On Error GoTo 0\n Exit Function\n\nGetFolder_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \")\n\nEnd Function\n\n'---------------------------------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------------------------------\n'Taken from http://www.cpearson.com/excel/browsefolder.aspx\n\nPrivate Declare Function SHGetPathFromIDListA Lib \"shell32.dll\" (ByVal pidl As Long, ByVal pszBuffer As String) As Long\nPrivate Declare Function SHBrowseForFolderA Lib \"shell32.dll\" (lpBrowseInfo As BROWSEINFO) As Long\nPrivate Const MAX_PATH = 260\n\nFunction str_BrowseFolder(Optional ByVal DialogTitle As String) As String\n\n On Error GoTo str_BrowseFolder_Error\n\n '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n ' BrowseFolder\n ' This displays the standard Windows Browse Folder dialog. It returns\n ' the complete path name of the selected folder or vbNullString if the\n ' user cancelled.\n '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n Application.EnableCancelKey = xlDisabled\n\n If DialogTitle = vbNullString Then\n DialogTitle = \"Select A Folder\"\n End If\n\n Dim uBrowseInfo As BROWSEINFO\n Dim szBuffer As String\n Dim lID As Long\n Dim lRet As Long\n\n With uBrowseInfo\n .hOwner = 0\n .pidlRoot = 0\n .pszDisplayName = String$(MAX_PATH, vbNullChar)\n .lpszINSTRUCTIONS = DialogTitle\n .ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI\n .lpfn = 0\n End With\n \n szBuffer = String$(MAX_PATH, vbNullChar)\n lID = SHBrowseForFolderA(uBrowseInfo)\n\n If lID Then\n ''' Retrieve the path string.\n lRet = SHGetPathFromIDListA(lID, szBuffer)\n If lRet Then\n str_BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)\n End If\n End If\n \n Application.EnableCancelKey = xlInterrupt\n\n On Error GoTo 0\n Exit Function\n\nstr_BrowseFolder_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure str_BrowseFolder of Function mod_Browse\"\n\nEnd Function\n\n \nPublic Function FolderIsEmpty(myPath As String) As Boolean\n 'Checks whether folder is empty \n FolderIsEmpty = CBool(Dir(myPath & \"*.*\") = \"\")\n \nEnd Function\n\n \nPublic Function GetDesktopPath() As String\n GetDesktopPath = CreateObject(\"WScript.Shell\").specialfolders(\"Desktop\") & \"\\\"\nEnd Function\n" }, { "path": "Boilerplate/LastThings.vb", "content": "Option Explicit\nOption Private Module\n \n'locate last column \n'locate last row\n'last things count substrings, count strings, count stuff\n\nPublic Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long\n\n LastColumn = ws.Cells(rowToCheck, ws.Columns.count).End(xlToLeft).Column\n \nEnd Function\n\nPublic Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long\n \n LastRow = ws.Cells(ws.Rows.count, columnToCheck).End(xlUp).Row\n\nEnd Function\n \n \nPublic Function LastUsedColumn(wks As Worksheet) As Long\n \n Dim lastCell As Range\n \n With wks\n Set lastCell = .Cells.Find(What:=\"*\", _\n After:=.Cells(1, 1), _\n LookIn:=xlFormulas, _\n LookAt:=xlPart, _\n SearchOrder:=xlByColumns, _\n SearchDirection:=xlPrevious, _\n MatchCase:=False)\n End With \n LastUsedColumn = lastCell.Column\n\nEnd Function\n\n\nPublic Function LocateValueRow(ByVal textTarget As String, _\n ByRef wksTarget As Worksheet, _\n Optional col As Long = 1, _\n Optional moreValuesFound As Long = 1, _\n Optional lookForPart = False, _\n Optional lookUpToBottom = True) As Long\n\n Dim valuesFound As Long\n Dim localRange As Range\n Dim myCell As Range\n Dim lastRowOnColumn1 As Long\n \n LocateValueRow = GENERAL_NUMBERS.NF\n \n valuesFound = moreValuesFound\n lastRowOnColumn1 = LastRow(wksTarget, col)\n Set localRange = wksTarget.Range(wksTarget.Cells(1, col), wksTarget.Cells(lastRowOnColumn1, col))\n\n For Each myCell In localRange\n If lookForPart Then\n If UCase(textTarget) = UCase(Left(myCell, Len(textTarget))) Then\n If valuesFound = 1 Then\n LocateValueRow = myCell.Row\n If lookUpToBottom Then Exit Function\n Else\n Decrement valuesFound\n End If\n End If\n Else\n If UCase(textTarget) = UCase(Trim(myCell)) Then\n If valuesFound = 1 Then\n LocateValueRow = myCell.Row\n If lookUpToBottom Then Exit Function\n Else\n Decrement valuesFound\n End If\n End If\n End If\n Next myCell\n\nEnd Function\n\nPublic Function LocateValueCol(ByVal textTarget As String, _\n ByRef wksTarget As Worksheet, _\n Optional rowNeeded As Long = 1, _\n Optional moreValuesFound As Long = 1, _\n Optional lookForPart = False, _\n Optional lookUpToBottom = True) As Long\n\n Dim valuesFound As Long\n Dim localRange As Range\n Dim myCell As Range\n \n LocateValueCol = GENERAL_NUMBERS.NF\n valuesFound = moreValuesFound\n Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.count))\n\n For Each myCell In localRange\n If lookForPart Then\n If UCase(textTarget) = UCase(Left(myCell, Len(textTarget))) Then\n If valuesFound = 1 Then\n LocateValueCol = myCell.Column\n If lookUpToBottom Then Exit Function\n Else\n Decrement valuesFound\n End If\n End If\n Else\n If UCase(textTarget) = UCase(Trim(myCell)) Then\n If valuesFound = 1 Then\n LocateValueCol = myCell.Column\n If lookUpToBottom Then Exit Function\n Else\n Decrement valuesFound\n End If\n End If\n End If\n Next myCell\n\nEnd Function\n \n \nPublic Function GetColumnSequence(tbl As Worksheet, tableName As String, columnName As String) As Long\n \n Dim myCell As Range\n Dim result As Long\n result = 1\n \n For Each myCell In ThisWorkbook.Worksheets(tbl.Name).Range(tableName & \"[#Headers]\").Cells\n If UCase(Trim(myCell)) = UCase(Trim(columnName)) Then\n GetColumnSequence = result\n Exit Function\n Else\n result = result + 1\n End If\n Next\n \n GetColumnSequence = -1\n \nEnd Function\n \n \nPrivate Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)\n \n valueToIncrement = valueToIncrement + incrementWith\n\nEnd Sub\n\nPrivate Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)\n\n valueToDecrement = valueToDecrement - decrementWith\n\nEnd Sub\n \nPublic Function CountSubstringsInRow(wks As Worksheet, substring As String, Optional myRow As Long = 1)\n \n Dim myLastCol As Long\n myLastCol = LastColumn(wks, myRow)\n \n Dim result As Long\n Dim myCell As Range\n \n With wks\n For Each myCell In .Range(.Cells(myRow, 1), .Cells(myRow, myLastCol))\n If InStr(1, myCell.Text, substring, vbTextCompare) Then\n result = result + 1\n End If\n Next\n End With\n \n CountSubstringsInRow = result\n \nEnd Function\n\n \n'LastRow Last Row Formula\n=IFERROR(LOOKUP(2,1/(NOT(ISBLANK(A:A))),ROW(A:A)),0)\n\n'LastColumn Last Column Formula\n=IFERROR(LOOKUP(2,1/(NOT(ISBLANK(1:1))),COLUMN(1:1)),0)\n \n'Last Row Value of Column A\n=LOOKUP(2,1/(NOT(ISBLANK(A:A))),A:A)\n \n'Last Column Value of the first row\n=LOOKUP(2,1/(NOT(ISBLANK(1:1))),1:1)\n\n" }, { "path": "Boilerplate/Lock.vb", "content": "'lock cells, lock ranges, lock cells with formulas\nSub ProtectCellsWithFormulas()\n \n Dim wks As Worksheet\n Dim myCell As Range\n \n For Each wks In ThisWorkbook.Worksheets\n With wks\n If .Name = tblForwinCrest.Name Or .Name = tblForwinCrestPrefilled.Name Then\n .Unprotect \"v\"\n For Each myCell In wks.Range(\"A1:R102\").Cells\n If myCell.MergeArea.Cells.Count = 1 Then\n If myCell.HasFormula Then\n myCell.Locked = True\n Else\n myCell.Locked = False\n End If\n End If\n Next myCell\n .EnableOutlining = True\n .Protect \"v\", contents:=True, userinterfaceonly:=True\n End If\n End With\n Next wks\n \n\nEnd Sub\n" }, { "path": "Boilerplate/MinAndMax.vb", "content": "Function Min(ParamArray values() As Variant) As Variant\n \n Dim minValue As Variant, Value As Variant\n minValue = values(0)\n \n For Each Value In values\n If Value < minValue Then minValue = Value\n Next\n \n Min = minValue\n \nEnd Function\n\nFunction Max(ParamArray values() As Variant) As Variant\n \n Dim maxValue As Variant, Value As Variant\n maxValue = values(0)\n \n For Each Value In values\n If Value > minValue Then maxValue = Value\n Next\n \n Max = maxValue\n \nEnd Function\n" }, { "path": "Boilerplate/NamedRanges.vb", "content": "Option Explicit\n\n\n'Application.Run \"Personal.xlsb!DeleteName\", \"NAME_HERE\"\nPublic Sub DeleteName(sName As String)\n\n On Error GoTo DeleteName_Error\n\n ActiveWorkbook.Names(sName).Delete\n \n Debug.Print sName & \" is deleted!\"\n \n On Error GoTo 0\n Exit Sub\n\nDeleteName_Error:\n\n Debug.Print sName & \" not present or some error\"\n On Error GoTo 0\n \nEnd Sub\n\nPublic Sub RemoveNamedRanges()\n \n Dim nName As Name\n Dim strNameReserved As String\n \n On Error Resume Next\n \n strNameReserved = \"set_in_production\"\n \n For Each nName In Names\n If nName.Name <> strNameReserved And Left(nName.Name, 1) <> \"_\" Then\n Debug.Print nName.Name\n nName.Delete\n End If\n Next nName\n \n On Error GoTo 0\n \nEnd Sub\n\n\nSub get_names_of_cells()\n \n Dim cell As Range\n \n On Error Resume Next\n \n For Each cell In Selection\n cell = cell.Name.Name\n Next cell\n \n On Error GoTo 0\n \nEnd Sub\n\nSub set_names_of_cells()\n\n Dim sample_range As Range\n Dim cell As Range\n \n Set sample_range = Selection\n \n For Each cell In sample_range\n If Not IsEmpty(cell) Then\n cell.Name = cell.Text\n cell.Clear\n End If\n Next cell\n\nEnd Sub\n\nPublic Sub RemoveNamedRangesWithErrors()\n \n Dim nName As name\n Dim strNameReserved As String\n \n On Error Resume Next\n \n For Each nName In Names\n Debug.Print nName.RefersTo\n If Left(nName.RefersTo, 2) = \"=#\" Then\n Debug.Print nName.RefersTo\n 'nName.Delete\n End If\n Next nName\n \n On Error GoTo 0\n \nEnd Sub\n\nSub UnhideAllNames()\n\n Dim tempName As Name\n \n For Each tempName In Names\n 'Debug.Print tempname.Name\n tempName.Visible = False\n Next tempName\n\nEnd Sub\n" }, { "path": "Boilerplate/NotepadExport.vb", "content": "' export to notepad export txt export string string to txt string to notepad\n\nOption Explicit\n\nPublic STR_ERROR_REPORT As String\n\nSub CreateLogFile(Optional str_print As String)\n\n On Error GoTo CreateLogFile_Error\n\n Dim fs As Object\n Dim obj_text As Object\n Dim str_filename As String\n Dim str_new_file As String\n Dim str_shell As String\n\n str_new_file = \"\\tests_info\"\n\n str_filename = ThisWorkbook.Path & str_new_file & codify_time(True)\n If Dir(ThisWorkbook.Path & str_new_file, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & str_new_file\n\n Set fs = CreateObject(\"Scripting.FileSystemObject\")\n Set obj_text = fs.CreateTextFile(str_filename, True)\n\n If Len(STR_ERROR_REPORT) > 1 Then\n obj_text.writeline (STR_ERROR_REPORT)\n Else\n obj_text.writeline (str_print)\n End If\n \n obj_text.Close\n\n str_shell = \"C:\\WINDOWS\\notepad.exe \"\n str_shell = str_shell & str_filename\n Call Shell(str_shell)\n\n On Error GoTo 0\n Exit Sub\n\nCreateLogFile_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CreateLogFile of Sub mod_TDD_Export\"\n \nEnd Sub\n\nPublic Function codify_time(Optional b_make_str As Boolean = False) As String\n\n On Error GoTo codify_Error\n \n Dim dbl_01 As Variant\n Dim dbl_02 As Variant\n Dim dbl_now As Double\n \n dbl_now = Round(Now(), 8)\n \n dbl_01 = Split(CStr(dbl_now), \",\")(0)\n dbl_02 = Split(CStr(dbl_now), \",\")(1)\n \n codify_time = Hex(dbl_01) & \"_\" & Hex(dbl_02)\n \n If b_make_str Then codify_time = \"\\\" & codify_time & \".txt\"\n \n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\n\nEnd Function\n" }, { "path": "Boilerplate/OnStartOnEnd.vb", "content": "Public Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.AskToUpdateLinks = True\n Application.DisplayAlerts = True\n\n ActiveWindow.View = xlNormalView\n Application.StatusBar = False\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n \nEnd Sub\n\nPublic Sub OnStart()\n \n Application.ScreenUpdating = False\n Application.EnableEvents = False\n Application.AskToUpdateLinks = False\n Application.DisplayAlerts = False\n \n ActiveWindow.View = xlNormalView\n Application.StatusBar = False\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n\nEnd Sub\n" }, { "path": "Boilerplate/RegEx.vb", "content": "Option Explicit\n\nPublic Sub RegExExample()\n \n Dim strString As String\n Dim lngCounter As Long\n Dim objRegex As Object\n Dim arrWords As Variant\n \n 'RegEx with late binding\n Set objRegex = CreateObject(\"VBScript.RegExp\")\n\n strString = \"Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\"\n arrWords = Split(strString)\n objRegex.Pattern = \"or\"\n \n For lngCounter = LBound(arrWords) To UBound(arrWords)\n If objRegex.test(arrWords(lngCounter)) Then\n Debug.Print arrWords(lngCounter)\n End If\n Next lngCounter\n\nEnd Sub\n\n'===============================================================================\n'===============================================================================\n'removes anything that is not a digit or word from the string===================\n\nPublic Function removeInvisibleThings(s As String) As String\n\n Dim regEx As Object\n Dim inputMatches As Object\n Dim regExString As String\n\n Set regEx = CreateObject(\"VBScript.RegExp\")\n\n With regEx\n .pattern = \"[^a-zA-Z0-9]\"\n .IgnoreCase = True\n .Global = True\n\n Set inputMatches = .Execute(s)\n\n If regEx.test(s) Then\n removeInvisibleThings = .Replace(s, vbNullString)\n Else\n removeInvisibleThings = s\n End If\n\n End With\n\nEnd Function\n\nPublic Sub TestMe()\n\n Debug.Print removeInvisibleThings(\"aa1 Abc 67 ( *^ 45 \")\n Debug.Print removeInvisibleThings(\"aa1 ???!\")\n Debug.Print removeInvisibleThings(\" aa1 Abc 1267 ( *^ 45 \")\n\nEnd Sub\n\n'===============================================================================\n'===============================================================================\n'===============================================================================\n\nPublic Function findTheSubString(wholeString As String, subString As String) As String\n\n Dim regEx As Object\n Dim inputMatches As Object\n Dim regExString As String\n\n Set regEx = CreateObject(\"VBScript.RegExp\")\n\n With regEx\n .Pattern = Split(subString, \"*\")(0) & \"[\\s\\S]*\" & Split(subString, \"*\")(1)\n .IgnoreCase = True\n .Global = True\n\n Set inputMatches = .Execute(wholeString)\n If regEx.test(wholeString) Then\n findTheSubString = inputMatches(0)\n Else\n findTheSubString = \"Not Found!\"\n End If\n\n End With\n\nEnd Function\n\n'===============================================================================\n'===============================================================================\n'===============================================================================\n" }, { "path": "Boilerplate/StringsAlgorithms.vb", "content": "Public Function StringBetween2Strings(ByVal myText As String, _\r\n ByVal lookBefore As String, _\r\n ByVal repetition As Long, _\r\n Optional ByVal lookAfter As String = \" 1\r\n i = InStr(i, myText, lookBefore, vbTextCompare)\r\n myText = Right(myText, Len(myText) - i)\r\n repetition = repetition - 1\r\n Wend\r\n \r\n startPosition = InStr(1, myText, lookBefore) + Len(lookBefore)\r\n endPosition = InStr(startPosition, myText, lookAfter, vbTextCompare)\r\n StringBetween2Strings = Mid(myText, startPosition, endPosition - startPosition)\r\n \r\n Exit Function\r\n \r\nStringBetween2Strings_Error:\r\n StringBetween2Strings = -1\r\n\r\nEnd Function\r\n\r\nSub TestingLocateXmlData()\r\n \r\n Dim xmlA As String\r\n xmlA = \"1PeterThe KeeperPeshoPartan199412IvanMitovGoshoGoshan18892/FootballInfo>\"\r\n \r\n Debug.Print StringBetween2Strings(xmlA, \"\", 1) 'Peter\r\n Debug.Print StringBetween2Strings(xmlA, \"\", 1) 'The Keeper\r\n\r\n Debug.Print StringBetween2Strings(xmlA, \"\", 1) '1994\r\n Debug.Print StringBetween2Strings(xmlA, \"\", 2) '1889\r\n\r\nEnd Sub" }, { "path": "Boilerplate/Timer.vb", "content": "Sub StartingTimer(ByRef myTime As Double)\n\n Debug.Print \"Strating at:\"\n Debug.Print Time\n myTime = Timer\n \nEnd Sub\n\nSub EndingTimer(ByRef myTime As Double)\n\n Debug.Print \"Ending at:\"\n Debug.Print Time\n Debug.Print \"Total time:\"\n Debug.Print Format((Timer - myTime) / 86400, \"hh:mm:ss\")\n\nEnd Sub\n\nSub TestAll()\n \n Dim myTime As Double\n StartingTimer myTime\n \n Stop 'PUT THE STUFF HERE!\n \n EndingTimer myTime\n \nEnd Sub\n" }, { "path": "Boilerplate/VariousDatesFirstDay.vb", "content": "Option Explicit\n\nPublic Function GetLastDayOfMonth(ByVal myDate As Date) As Date\n GetLastDayOfMonth = DateSerial(Year(myDate), Month(myDate) + 1, 0)\nEnd Function\n\nPublic Function GetFirstDayOfMonth(ByVal myDate As Date) As Date\n GetFirstDayOfMonth = DateSerial(Year(myDate), Month(myDate), 1)\nEnd Function\n\nPublic Function AddMonths(ByVal myDate As Date, ByVal lngMonth As Long) As Date\n AddMonths = GetLastDayOfMonth(DateAdd(\"m\", lngMonth, myDate))\nEnd Function\n\nPublic Function AddMonthsAndGetFirstDate(ByVal my_date As Date, ByVal lngMonth As Long) As Date\n AddMonthsAndGetFirstDate = GetFirstDayOfMonth(DateAdd(\"m\", lngMonth, my_date))\nEnd Function\n\nPublic Function DateDiffInMonths(a As Date, b As Date) As Long\n DateDiffInMonths = DateDiff(\"m\", a, b)\nEnd Function\n\nSub TestMe()\n\n Debug.Print GetLastDayOfMonth(DateSerial(2020, 2, 22))\n Debug.Print GetLastDayOfMonth(DateSerial(2021, 2, 22))\n \n Debug.Print GetFirstDayOfMonth(DateSerial(2021, 2, 22))\n Debug.Print AddMonths(DateSerial(2020, 2, 23), 3)\n Debug.Print AddMonthsAndGetFirstDate(DateSerial(2020, 2, 23), 3)\n \n Debug.Print DateDiffInMonths(DateSerial(1988, 8, 18), DateSerial(1998, 10, 18))\n \nEnd Sub\n" }, { "path": "Boilerplate/WorksheetToCSV", "content": "Option Explicit\n\nPublic Const CSV_NAME As String = \"CSV_FILE\"\nPublic Const MY_STEP As Long = 5\nPublic Const WKS_TO_KEEP As String = \"Tabelle1\"\n\n'split worksheet\n'worksheet to csv\n'worksheets to csv\n'convert to csv\n'https://www.vitoshacademy.com/vba-split-worksheet-to-worksheets-save-excel-worksheets-to-csv/\n\nFunction WksToKeep() As Worksheet\n\n Set WksToKeep = ThisWorkbook.Worksheets(WKS_TO_KEEP)\n\nEnd Function\n\nSub SplitMe()\n \n OnStart\n \n Dim myLastRow As Long: myLastRow = LastRow(WksToKeep)\n Dim myCell As Range, i As Long\n \n For i = 1 To myLastRow Step MY_STEP\n \n With WksToKeep\n \n Dim newWks As Worksheet\n Set newWks = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))\n newWks.Name = i\n newWks.Rows(1).Value = .Rows(1).Value\n \n Dim ii As Long\n For ii = 2 To MY_STEP + 1\n \n With newWks\n newWks.Rows(ii).Value = WksToKeep.Rows(i + ii - 1).Value\n End With\n\n Next\n End With\n Next\n \n OnEnd\n \nEnd Sub\n\nPublic Sub DeleteAllButOne()\n \n Dim wks As Worksheet\n OnStart\n For Each wks In ThisWorkbook.Worksheets\n If wks.Name <> WKS_TO_KEEP Then\n wks.Delete\n End If\n Next wks\n OnEnd\n\nEnd Sub\n\nPublic Sub MakeMeACSV()\n \n Dim myNewWorkbook As Workbook\n OnStart\n \n Dim myWorksheet As Worksheet\n For Each myWorksheet In ThisWorkbook.Worksheets\n If myWorksheet.Name <> WKS_TO_KEEP Then\n \n Set myNewWorkbook = Workbooks.Add\n myWorksheet.Copy myNewWorkbook.Sheets(1)\n \n myNewWorkbook.Worksheets(WKS_TO_KEEP).Delete\n \n Dim myFileName As String\n myFileName = ThisWorkbook.Path & \"\\\"\n myFileName = myFileName & CSV_NAME & Format(Date, \"YYYYMMDD\") & \"_\" & Format(Now(), \"hhnnss\") & \".csv\"\n \n myNewWorkbook.Worksheets(1).Columns(1).Delete\n \n If myNewWorkbook.Worksheets(1).Cells(2, 1).Value = \"\" Then\n myNewWorkbook.Worksheets(1).Rows(1).Delete\n End If\n \n Debug.Print myNewWorkbook.Path\n myNewWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlCSV, local:=True\n myNewWorkbook.Close False\n \n End If\n Next\n \n OnEnd\nEnd Sub\n\nSub Main()\n\n SplitMe\n MakeMeACSV\n \nEnd Sub\n\nPublic Sub OnStart()\n \n Application.DisplayAlerts = False\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n \n Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long\n\n LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column\n \nEnd Function\n\nPublic Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long\n \n LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row\n\nEnd Function\n\n" }, { "path": "Boilerplate/readme.md", "content": "[The project migrated here.](https://github.com/vboilerplate)\n\n**But** it will return back to its place (here), as I am not updating it there \n🌞🥈🚛\n" }, { "path": "ExcelTdd/InlineRunner.vb", "content": "Option Explicit\nOption Private Module\n\nPublic Sub RunSuite(specs As SpecSuite, _\n Optional ShowFailureDetails As Boolean = True, _\n Optional ShowPassed As Boolean = False, _\n Optional ShowSuiteDetails As Boolean = False)\n\n Dim SuiteCol As New Collection\n\n SuiteCol.Add specs\n RunSuites SuiteCol, ShowFailureDetails, ShowPassed, ShowSuiteDetails\n\nEnd Sub\n\nPublic Sub RunSuites(SuiteCol As Collection, _\n Optional ShowFailureDetails As Boolean = True, _\n Optional ShowPassed As Boolean = False, _\n Optional ShowSuiteDetails As Boolean = True)\n\n Dim Suite As SpecSuite\n Dim Spec As SpecDefinition\n\n Dim TotalCount As Long\n Dim FailedSpecs As Long\n Dim PendingSpecs As Long\n\n Dim ShowingResults As Boolean\n Dim Indentation As String\n\n For Each Suite In SuiteCol\n If Not Suite Is Nothing Then\n TotalCount = TotalCount + Suite.SpecsCol.Count\n\n For Each Spec In Suite.SpecsCol\n If Spec.result = SpecResult.FAIL Then\n FailedSpecs = FailedSpecs + 1\n ElseIf Spec.result = SpecResult.Pending Then\n PendingSpecs = PendingSpecs + 1\n End If\n Next Spec\n End If\n Next Suite\n\n Debug.Print \"= \" & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & \" = \" & GetDateAndTime & \" =========================\" & vbCrLf\n str_error_report = str_error_report & \"= \" & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & \" = \" & GetDateAndTime & \" =========================\"\n \n For Each Suite In SuiteCol\n If Not Suite Is Nothing Then\n \n If ShowSuiteDetails Then\n Debug.Print SuiteMessage(Suite)\n Indentation = \" \"\n ShowingResults = True\n Else\n Indentation = \"\"\n End If\n \n For Each Spec In Suite.SpecsCol\n If Spec.result = SpecResult.FAIL Then\n Debug.Print Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation)\n str_error_report = str_error_report & vbCrLf & Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation)\n ShowingResults = True\n ElseIf Spec.result = SpecResult.Pending Then\n Debug.Print Indentation & PendingMessage(Spec)\n str_error_report = str_error_report & vbCrLf & Indentation & PendingMessage(Spec)\n ShowingResults = True\n ElseIf ShowPassed Then\n Debug.Print Indentation & PassingMessage(Spec)\n str_error_report = str_error_report & vbCrLf & Indentation & PassingMessage(Spec)\n ShowingResults = True\n End If\n Next Spec\n End If\n Next Suite\n\n If ShowingResults Then\n Debug.Print \"===\"\n str_error_report = str_error_report & vbCrLf & \"===\" & vbCrLf\n End If\n\nEnd Sub\n\nPrivate Function SummaryMessage(TotalCount As Long, FailedSpecs As Long, PendingSpecs As Long) As String\n\n If FailedSpecs = 0 Then\n SummaryMessage = \"PASS (\" & TotalCount - PendingSpecs & \" of \" & TotalCount & \" passed\"\n Else\n SummaryMessage = \"FAIL (\" & FailedSpecs & \" of \" & TotalCount & \" failed\"\n End If\n\n If PendingSpecs = 0 Then\n SummaryMessage = SummaryMessage & \")\"\n Else\n SummaryMessage = SummaryMessage & \", \" & PendingSpecs & \" pending)\"\n End If\n\nEnd Function\n\nPrivate Function FailureMessage(Spec As SpecDefinition, ShowFailureDetails As Boolean, Indentation As String) As String\n\n Dim FailedExpectation As SpecExpectation\n Dim i As Long\n \n FailureMessage = ResultMessage(Spec, \"X\")\n \n If ShowFailureDetails Then\n FailureMessage = FailureMessage & vbNewLine\n \n For Each FailedExpectation In Spec.FailedExpectations\n FailureMessage = FailureMessage & Indentation & \" \" & FailedExpectation.FailureMessage\n \n If i + 1 <> Spec.FailedExpectations.Count Then FailureMessage = FailureMessage & vbNewLine\n i = i + 1\n Next FailedExpectation\n End If\n \nEnd Function\n\nPrivate Function PendingMessage(Spec As SpecDefinition) As String\n \n PendingMessage = ResultMessage(Spec, \".\")\n \nEnd Function\n\nPrivate Function PassingMessage(Spec As SpecDefinition) As String\n\n PassingMessage = ResultMessage(Spec, \"+\")\n\nEnd Function\n\nPrivate Function ResultMessage(Spec As SpecDefinition, Symbol As String) As String\n\n ResultMessage = Symbol & \" \"\n\n If Spec.ID <> \"\" Then\n ResultMessage = ResultMessage & Spec.ID & \": \"\n End If\n\n ResultMessage = ResultMessage & Spec.Description\n\nEnd Function\n\nPrivate Function SuiteMessage(Suite As SpecSuite) As String\n\n Dim HasFailures As Boolean\n Dim Spec As SpecDefinition\n\n For Each Spec In Suite.SpecsCol\n If Spec.result = SpecResult.FAIL Then\n HasFailures = True\n Exit For\n End If\n Next Spec\n\n If HasFailures Then\n SuiteMessage = \"X \"\n Else\n SuiteMessage = \"+ \"\n End If\n\n If Suite.Description <> \"\" Then\n SuiteMessage = SuiteMessage & Suite.Description\n Else\n SuiteMessage = SuiteMessage & Suite.SpecsCol.Count & \" specs\"\n End If\n\nEnd Function\n" }, { "path": "ExcelTdd/MakeValuesSelection.vb", "content": "'---------------------------------------------------------------------------------------\n' Method : MakeAllValues\n' Author : v.doynov\n' Date : 07.11.2016\n' Purpose: Select the range, for which you want the TDD code.\n' Make sure that you can compile!!! (CreateLogFile and change_commas)\n'---------------------------------------------------------------------------------------\nPublic Sub MakeAllValues()\n\n Dim my_cell As Range\n Dim l_counter As Long\n Dim str As String\n Dim str_result As String\n \n STR_ERROR_REPORT = \"\"\n \n For Each my_cell In Selection\n Call Increment(l_counter)\n str = vbTab & \"my_arr(\" & l_counter & \")= \"\n \n If Len(my_cell) > 0 Then\n If IsDate(my_cell) Then\n str = str & \"CDate(\"\"\" & my_cell & \"\"\")\"\n Else\n If Not IsNumeric(my_cell) Then\n str = str & \"\"\"\" & my_cell & \"\"\"\"\n Else\n str = str & change_commas(my_cell.value)\n End If\n End If\n Else\n If my_cell.HasFormula Then\n str = str & \"\"\"\"\"\"\n Else\n str = str & 0\n End If\n End If\n \n If Len(str_result) = 0 Then\n str_result = str\n Else\n str_result = str_result & vbCrLf & str\n End If\n \n Next my_cell\n \n Debug.Print str_result\n Call CreateLogFile(str_result)\n\nEnd Sub\n" }, { "path": "ExcelTdd/README.md", "content": "Excel-TDD: Excel Testing Library\n================================\n\nIn general, the library is taken from here:\nhttps://github.com/VBA-tools/VBA-TDD\nI have decided not to fork, because its easier for me to do so.\n\nI have updated a few points, making it more suitable for my purposes:\n\n - adding a Notepad file with information for the failures. This information is concatenated in STR_ERROR_REPORT.\n - counter of the tests in real time\n - checker whether an array is assigned\n \nThis is what we get in the immediate window:\n\n**Test report from v.doynov\nSTART: 07-07-2017 22:14:38\n999 expected.**\n\n**= PASS (2 of 2 passed) = 07-07-2017 22:14:38 =========================**\n\n **Tests:2**\n\n**Tests expected: 999\nTotal Tests:\n2\nEND: 07-07-2017 22:14:38**\n\nThis is the original Readme from the source:\n=======\n\nBring the reliability of other programming realms to VBA with Test-Driven Development (TDD) for VBA on Windows and Mac.\n\nQuick example:\n\n```vb\nFunction Specs() As SpecSuite\n Set Specs = New SpecSuite\n Specs.Description = \"Add\"\n\n ' Report results to the Immediate Window\n ' (ctrl + g or View > Immediate Window)\n Dim Reporter As New ImmediateReporter\n Reporter.ListenTo Specs\n\n ' Describe the desired behavior\n With Specs.It(\"should add two numbers\")\n ' Test the desired behavior\n .Expect(Add(2, 2)).ToEqual 4\n .Expect(Add(3, -1)).ToEqual 2\n .Expect(Add(-1, -2)).ToEqual -3\n End With\n\n With Specs.It(\"should add any number of numbers\")\n .Expect(Add(1, 2, 3)).ToEqual 6\n .Expect(Add(1, 2, 3, 4)).ToEqual 10\n End With\nEnd Sub\n\nPublic Function Add(ParamArray Values() As Variant) As Double\n Dim i As Integer\n Add = 0\n \n For i = LBound(Values) To UBound(Values)\n Add = Add + Values(i)\n Next i\nEnd Function\n\n' Immediate Window:\n'\n' === Add ===\n' + should add two numbers\n' + should add any number of numbers\n' = PASS (2 of 2 passed) =\n```\n\nFor details of the process of reaching this example, see the [TDD Example](https://github.com/VBA-tools/VBA-TDD/wiki/TDD-Example)\n\n### Advanced Example\n\nFor an advanced example of what is possible with VBA-TDD, check out the [specs for VBA-Web](https://github.com/VBA-tools/VBA-Web/tree/master/specs)\n\n### Getting Started\n\n1. Download the [latest release (v2.0.0-beta)](https://github.com/VBA-tools/VBA-TDD/releases)\n2. Add `src/SpecSuite.cls`, `src/SpecDefinition.cls`, `src/SpecExpectation.cls`, add `src/ImmediateReporter.cls` to your project\n3. If you're starting from scratch with Excel, you can use `VBA-TDD - Blank.xlsm`\n\n### It and Expect\n\n`It` is how you describe desired behavior and once a collection of specs is written, it should read like a list of requirements.\n\n```vb\nWith Specs.It(\"should allow user to continue if they are authorized and up-to-date\")\n ' ...\nEnd With\n\nWith Specs.It(\"should show an X when the user rolls a strike\")\n ' ...\nEnd With\n```\n\n`Expect` is how you test desired behavior \n\n```vb\nWith Specs.It(\"should check values\")\n .Expect(2 + 2).ToEqual 4\n .Expect(2 + 2).ToNotEqual 5\n .Expect(2 + 2).ToBeLessThan 7\n .Expect(2 + 2).ToBeLT 6\n .Expect(2 + 2).ToBeLessThanOrEqualTo 5\n .Expect(2 + 2).ToBeLTE 4\n .Expect(2 + 2).ToBeGreaterThan 1\n .Expect(2 + 2).ToBeGT 2\n .Expect(2 + 2).ToBeGreaterThanOrEqualTo 3\n .Expect(2 + 2).ToBeGTE 4\n .Expect(2 + 2).ToBeCloseTo 3.9, 0\nEnd With\n\nWith Specs.It(\"should check Nothing, Empty, Missing, and Null\")\n .Expect(Nothing).ToBeNothing\n .Expect(Empty).ToBeEmpty\n .Expect().ToBeMissing\n .Expect(Null).ToBeNull\n \n ' `ToBeUndefined` checks if it's Nothing or Empty or Missing or Null\n\n .Expect(Nothing).ToBeUndefined\n .Expect(Empty).ToBeUndefined\n .Expect().ToBeUndefined\n .Expect(Null).ToBeUndefined\n \n ' Classes are undefined until they are instantiated\n Dim Sheet As Worksheet\n .Expect(Sheet).ToBeNothing\n \n .Expect(\"Howdy!\").ToNotBeUndefined\n .Expect(4).ToNotBeUndefined\n \n Set Sheet = ThisWorkbook.Sheets(1)\n .Expect(Sheet).ToNotBeUndefined\nEnd With\n\nWith Specs.It(\"should test complex things\")\n .Expect(ThisWorkbook.Sheets(\"Hidden\").Visible).ToNotEqual XlSheetVisibility.xlSheetVisible\n .Expect(ThisWorkbook.Sheets(\"Main\").Cells(1, 1).Interior.Color).ToEqual RGB(255, 0, 0)\nEnd With\n```\n\n### ImmediateReporter\n\nWith your specs defined, the easiest way to display the test results is with `ImmediateReporter`. This outputs results to the Immediate Window (`ctrl+g` or View > Immediate Window) and is useful for running your tests without leaving the VBA editor.\n\n```vb\nPublic Function Specs As SpecSuite\n Set Specs = New SpecSuite\n Specs.Description = \"...\"\n\n ' Create reporter and attach it to these specs\n Dim Reporter As New ImmediateReporter\n Reporter.ListenTo Specs\n\n ' -> Reporter will now output results as they are generated\nEnd Function\n```\n\n### RunMatcher\n\nFor VBA applications that support `Application.Run` (which is at least Windows Excel, Word, and Access), you can create custom expect functions with `RunMatcher`.\n\n```vb\nPublic Function Specs As SpecSuite\n Set Specs = New SpecSuite\n\n With Specs.It(\"should be within 1 and 100\")\n .Expect(50).RunMatcher \"ToBeWithin\", \"to be within\", 1, 100\n ' ^ Actual\n ' ^ Public Function to call\n ' ^ message for matcher\n ' ^ 0+ Args to pass to matcher\n End With\nEnd Function\n\nPublic Function ToBeWithin(Actual As Variant, Args As Variant) As Variant\n If UBound(Args) - LBound(Args) < 1 Then\n ' Return string for specific failure message\n ToBeWithin = \"Need to pass in upper-bound to ToBeWithin\"\n Else\n If Actual >= Args(0) And Actual <= Args(1) Then\n ' Return true for pass\n ToBeWithin = True\n Else\n ' Return false for fail or custom failure message\n ToBeWithin = False\n End If\n End If\nEnd Function\n```\n\nTo avoid compilation issues on unsupported applications, the compiler constant `EnableRunMatcher` in `SpecExpectation.cls` should be set to `False`.\n\nFor more details, check out the [Wiki](https://github.com/VBA-tools/VBA-TDD/wiki)\n\n- Design based heavily on the [Jasmine](https://jasmine.github.io/)\n- Author: Tim Hall\n- License: MIT\n" }, { "path": "ExcelTdd/SpecDefinition.vb", "content": "Private pExpectations As Collection\nPrivate pFailedExpectations As Collection\n\nPublic Enum SpecResult\n PASS\n FAIL\n Pending\nEnd Enum\n\nPublic Description As String\nPublic ID As String\n\nPublic Property Get Expectations() As Collection\n \n If pExpectations Is Nothing Then\n Set pExpectations = New Collection\n End If\n \n Set Expectations = pExpectations\n\nEnd Property\nPrivate Property Let Expectations(value As Collection)\n \n Set pExpectations = value\n\nEnd Property\n\nPublic Property Get FailedExpectations() As Collection\n\n If pFailedExpectations Is Nothing Then\n Set pFailedExpectations = New Collection\n End If\n \n Set FailedExpectations = pFailedExpectations\n \nEnd Property\nPrivate Property Let FailedExpectations(value As Collection)\n\n Set pFailedExpectations = value\n \nEnd Property\n\nPublic Function Expect(Optional value As Variant) As SpecExpectation\n\n Dim Exp As New SpecExpectation\n \n If VarType(value) = vbObject Then\n Set Exp.Actual = value\n Else\n Exp.Actual = value\n End If\n Me.Expectations.Add Exp\n \n Set Expect = Exp\n \nEnd Function\n\nPublic Function result() As SpecResult\n\n Dim Exp As SpecExpectation\n \n ' Reset failed expectations\n FailedExpectations = New Collection\n \n ' If no expectations have been defined, return pending\n If Me.Expectations.Count < 1 Then\n result = Pending\n Else\n ' Loop through all expectations\n For Each Exp In Me.Expectations\n ' If expectation fails, store it\n If Exp.result = FAIL Then\n FailedExpectations.Add Exp\n End If\n Next Exp\n \n ' If no expectations failed, spec passes\n If Me.FailedExpectations.Count > 0 Then\n result = FAIL\n Else\n result = PASS\n End If\n End If\n \nEnd Function\n\nPublic Function ResultName() As String\n\n Select Case Me.result\n Case PASS: ResultName = \"Pass\"\n Case FAIL: ResultName = \"Fail\"\n Case Pending: ResultName = \"Pending\"\n End Select\n \nEnd Function\n" }, { "path": "ExcelTdd/SpecExpectation.vb", "content": "Public Enum ExpectResult\n\n PASS\n FAIL\n\nEnd Enum\n\nPublic Actual As Variant\nPublic Expected As Variant\nPublic result As ExpectResult\nPublic FailureMessage As String\n\nPublic Sub ToEqual(Expected As Variant)\n \n check IsEqual(Me.Actual, Expected), \"to equal\", Expected:=Expected\n\nEnd Sub\nPublic Sub ToNotEqual(Expected As Variant)\n\n check IsEqual(Me.Actual, Expected), \"to not equal\", Expected:=Expected, Inverse:=True\n \nEnd Sub\n\nPrivate Function IsEqual(Actual As Variant, Expected As Variant) As Variant\n \n Dim l_count As Long\n \n 'here added additional value\n If IsArray(Expected) Then\n If UBound(Expected) <> UBound(Actual) Then IsEqual = False: Exit Function\n \n For l_count = LBound(Expected) To UBound(Expected)\n If Not Expected(l_count) = Actual(l_count) Then IsEqual = False: Exit Function\n Next l_count\n \n IsEqual = True\n \n End If\n 'end of additional value\n\n If IsError(Actual) Or IsError(Expected) Then\n IsEqual = False\n\n ElseIf IsObject(Actual) Or IsObject(Expected) Then\n IsEqual = \"Unsupported: Can't compare objects\"\n ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then\n IsEqual = IsCloseTo(Actual, Expected, 15)\n Else\n IsEqual = Actual = Expected\n End If\n \nEnd Function\n\nPublic Sub ToBeDefined()\n Debug.Print \"Excel-TDD: DEPRECATED, ToBeDefined() has been deprecated in favor of ToNotBeUndefined and will be removed in Excel-TDD v2.0.0\"\n check IsUndefined(Me.Actual), \"to be defined\", Inverse:=True\nEnd Sub\n\nPublic Sub ToBeUndefined()\n check IsUndefined(Me.Actual), \"to be undefined\"\nEnd Sub\n\nPublic Sub ToNotBeUndefined()\n check IsUndefined(Me.Actual), \"to not be undefined\", Inverse:=True\nEnd Sub\n\nPrivate Function IsUndefined(Actual As Variant) As Variant\n IsUndefined = IsNothing(Actual) Or IsEmpty(Actual) Or IsNull(Actual) Or IsMissing(Actual)\nEnd Function\n\nPublic Sub ToBeNothing()\n check IsNothing(Me.Actual), \"to be nothing\"\nEnd Sub\nPublic Sub ToNotBeNothing()\n check IsNothing(Me.Actual), \"to not be nothing\", Inverse:=True\nEnd Sub\n\nPrivate Function IsNothing(Actual As Variant) As Variant\n If IsObject(Actual) Then\n If Actual Is Nothing Then\n IsNothing = True\n Else\n IsNothing = False\n End If\n Else\n IsNothing = False\n End If\nEnd Function\n\nPublic Sub ToBeEmpty()\n check IsEmpty(Me.Actual), \"to be empty\"\nEnd Sub\n\nPublic Sub ToNotBeEmpty()\n check IsEmpty(Me.Actual), \"to not be empty\", Inverse:=True\nEnd Sub\n\nPublic Sub ToBeNull()\n check IsNull(Me.Actual), \"to be null\"\nEnd Sub\n\nPublic Sub ToNotBeNull()\n check IsNull(Me.Actual), \"to not be null\", Inverse:=True\nEnd Sub\n\nPublic Sub ToBeMissing()\n check IsMissing(Me.Actual), \"to be missing\"\nEnd Sub\n\nPublic Sub ToNotBeMissing()\n check IsMissing(Me.Actual), \"to not be missing\", Inverse:=True\nEnd Sub\n\nPublic Sub ToBeLessThan(Expected As Variant)\n check IsLT(Me.Actual, Expected), \"to be less than\", Expected:=Expected\nEnd Sub\n\nPublic Sub ToBeLT(Expected As Variant)\n ToBeLessThan Expected\nEnd Sub\n\nPrivate Function IsLT(Actual As Variant, Expected As Variant) As Variant\n If IsError(Actual) Or IsError(Expected) Or Actual >= Expected Then\n IsLT = False\n Else\n IsLT = True\n End If\nEnd Function\n\nPublic Sub ToBeLessThanOrEqualTo(Expected As Variant)\n check IsLTE(Me.Actual, Expected), \"to be less than or equal to\", Expected:=Expected\nEnd Sub\n\nPublic Sub ToBeLTE(Expected As Variant)\n ToBeLessThanOrEqualTo Expected\nEnd Sub\n\nPrivate Function IsLTE(Actual As Variant, Expected As Variant) As Variant\n If IsError(Actual) Or IsError(Expected) Or Actual > Expected Then\n IsLTE = False\n Else\n IsLTE = True\n End If\nEnd Function\n\nPublic Sub ToBeGreaterThan(Expected As Variant)\n check IsGT(Me.Actual, Expected), \"to be greater than\", Expected:=Expected\nEnd Sub\n\nPublic Sub ToBeGT(Expected As Variant)\n ToBeGreaterThan Expected\nEnd Sub\n\nPrivate Function IsGT(Actual As Variant, Expected As Variant) As Variant\n If IsError(Actual) Or IsError(Expected) Or Actual <= Expected Then\n IsGT = False\n Else\n IsGT = True\n End If\nEnd Function\n\nPublic Sub ToBeGreaterThanOrEqualTo(Expected As Variant)\n check IsGTE(Me.Actual, Expected), \"to be greater than or equal to\", Expected:=Expected\nEnd Sub\n\nPublic Sub ToBeGTE(Expected As Variant)\n ToBeGreaterThanOrEqualTo Expected\nEnd Sub\n\nPrivate Function IsGTE(Actual As Variant, Expected As Variant) As Variant\n If IsError(Actual) Or IsError(Expected) Or Actual < Expected Then\n IsGTE = False\n Else\n IsGTE = True\n End If\nEnd Function\n\nPublic Sub ToBeCloseTo(Expected As Variant, SignificantFigures As Long)\n check IsCloseTo(Me.Actual, Expected, SignificantFigures), \"to be close to\", Expected:=Expected\nEnd Sub\n\nPublic Sub ToNotBeCloseTo(Expected As Variant, SignificantFigures As Long)\n check IsCloseTo(Me.Actual, Expected, SignificantFigures), \"to be close to\", Expected:=Expected, Inverse:=True\nEnd Sub\n\nPrivate Function IsCloseTo(Actual As Variant, Expected As Variant, SignificantFigures As Long) As Variant\n Dim ActualAsString As String\n Dim ExpectedAsString As String\n \n If SignificantFigures < 1 Or SignificantFigures > 15 Then\n IsCloseTo = \"ToBeCloseTo/ToNotBeClose to can only compare from 1 to 15 significant figures\"\"\"\n ElseIf Not IsError(Actual) And Not IsError(Expected) Then\n ' Convert values to scientific notation strings and then compare strings\n If Actual > 1 Then\n ActualAsString = VBA.Format$(Actual, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e+0\")\n Else\n ActualAsString = VBA.Format$(Actual, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e-0\")\n End If\n\n If Expected > 1 Then\n ExpectedAsString = VBA.Format$(Expected, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e+0\")\n Else\n ExpectedAsString = VBA.Format$(Expected, VBA.Left$(\"0.00000000000000\", SignificantFigures + 1) & \"e-0\")\n End If\n \n IsCloseTo = ActualAsString = ExpectedAsString\n End If\nEnd Function\n\nPublic Sub ToContain(Expected As Variant, Optional MatchCase As Boolean = True)\n If VarType(Me.Actual) = vbString Then\n Debug.Print \"Excel-TDD: DEPRECATED ToContain has been changed to ToMatch in Excel-TDD v2.0.0\"\n If MatchCase Then\n check Matches(Me.Actual, Expected), \"to match\", Expected:=Expected\n Else\n check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), \"to match\", Expected:=Expected\n End If\n Else\n check Contains(Me.Actual, Expected), \"to contain\", Expected:=Expected\n End If\nEnd Sub\n\nPublic Sub ToNotContain(Expected As Variant, Optional MatchCase As Boolean = True)\n If VarType(Me.Actual) = vbString Then\n Debug.Print \"Excel-TDD: DEPRECATED ToNotContain has been changed to ToMatch in Excel-TDD v2.0.0\"\n If MatchCase Then\n check Matches(Me.Actual, Expected), \"to not match\", Expected:=Expected, Inverse:=True\n Else\n check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), \"to not match\", Expected:=Expected, Inverse:=True\n End If\n Else\n check Contains(Me.Actual, Expected), \"to not contain\", Expected:=Expected, Inverse:=True\n End If\nEnd Sub\n\nPrivate Function Contains(Actual As Variant, Expected As Variant) As Variant\n \n Dim i As Long\n \n If Not IsArray(Actual) Then\n Contains = \"Error: Actual needs to be an Array or Collection for ToContain/ToNotContain\"\n Else\n If TypeOf Actual Is Collection Then\n For i = 1 To Actual.Count\n If Actual.item(i) = Expected Then\n Contains = True\n Exit Function\n End If\n Next i\n Else\n For i = LBound(Actual) To UBound(Actual)\n If Actual(i) = Expected Then\n Contains = True\n Exit Function\n End If\n Next i\n End If\n End If\n \nEnd Function\n\nPublic Sub ToMatch(Expected As Variant)\n\n check Matches(Me.Actual, Expected), \"to match\", Expected:=Expected\n\nEnd Sub\n\nPublic Sub ToNotMatch(Expected As Variant)\n\n check Matches(Me.Actual, Expected), \"to not match\", Expected:=Expected, Inverse:=True\n\nEnd Sub\n\nPrivate Function Matches(Actual As Variant, Expected As Variant) As Variant\n If InStr(Actual, Expected) > 0 Then\n Matches = True\n Else\n Matches = False\n End If\nEnd Function\n\nPublic Sub RunMatcher(Name As String, Message As String, ParamArray Arguments())\n\n Dim Expected As String\n Dim i As Long\n Dim HasArguments As Boolean\n \n HasArguments = UBound(Arguments) >= 0\n For i = LBound(Arguments) To UBound(Arguments)\n If Expected = \"\" Then\n Expected = GetStringForValue(Arguments(i))\n ElseIf i = UBound(Arguments) Then\n If (UBound(Arguments) > 1) Then\n Expected = Expected & \", and \" & GetStringForValue(Arguments(i))\n Else\n Expected = Expected & \" and \" & GetStringForValue(Arguments(i))\n End If\n Else\n Expected = Expected & \", \" & GetStringForValue(Arguments(i))\n End If\n Next i\n \n If HasArguments Then\n check Application.Run(Name, Me.Actual, Arguments), Message, Expected:=Expected\n Else\n check Application.Run(Name, Me.Actual), Message\n End If\n\nEnd Sub\n\nPrivate Sub check(result As Variant, Message As String, Optional Expected As Variant, Optional Inverse As Boolean = False)\n\n If Not IsMissing(Expected) Then\n If IsObject(Expected) Then\n Set Me.Expected = Expected\n Else\n Me.Expected = Expected\n End If\n End If\n\n If VarType(result) = vbString Then\n Fails CStr(result)\n Else\n If Inverse Then\n result = Not result\n End If\n \n If result Then\n Passes\n Else\n Fails CreateFailureMessage(Message, Expected)\n End If\n End If\nEnd Sub\n\nPrivate Sub Passes()\n\n Me.result = ExpectResult.PASS\n\nEnd Sub\n\nPrivate Sub Fails(Message As String)\n\n Me.result = ExpectResult.FAIL\n Me.FailureMessage = Message\n\nEnd Sub\n\nPrivate Function CreateFailureMessage(Message As String, Optional Expected As Variant) As String\n CreateFailureMessage = \"Expected \" & GetStringForValue(Me.Actual) & \" \" & Message\n If Not IsMissing(Expected) Then\n CreateFailureMessage = CreateFailureMessage & \" \" & GetStringForValue(Expected)\n End If\nEnd Function\n\nPrivate Function GetStringForValue(value As Variant) As String\n\n If IsObject(value) Then\n \n If value Is Nothing Then\n GetStringForValue = \"(Nothing)\"\n Else\n GetStringForValue = \"(Object)\"\n End If\n \n ElseIf IsArray(value) Then\n GetStringForValue = \"(Array)\"\n \n ElseIf IsEmpty(value) Then\n GetStringForValue = \"(Empty)\"\n \n ElseIf IsNull(value) Then\n GetStringForValue = \"(Null)\"\n \n ElseIf IsMissing(value) Then\n GetStringForValue = \"(Missing)\"\n \n Else\n GetStringForValue = CStr(value)\n \n End If\n \n If GetStringForValue = \"\" Then\n GetStringForValue = \"(Undefined)\"\n End If\n \nEnd Function\n\nPrivate Function IsArray(value As Variant) As Boolean\n\n If Not IsEmpty(value) Then\n If IsObject(value) Then\n If TypeOf value Is Collection Then\n IsArray = True\n End If\n ElseIf VarType(value) = vbArray Or VarType(value) = 8204 Then\n IsArray = True\n End If\n End If\n\nEnd Function\n" }, { "path": "ExcelTdd/SpecSuite.vb", "content": "Option Explicit\nPrivate pSpecsCol As Collection\nPublic Description As String\nPublic BeforeEachCallback As String\nPublic BeforeEachCallbackArgs As Variant\nPrivate pCounter As Long\n\nPublic Property Get SpecsCol() As Collection\n\n If pSpecsCol Is Nothing Then Set pSpecsCol = New Collection\n Set SpecsCol = pSpecsCol\n \nEnd Property\n\nPublic Property Let SpecsCol(value As Collection)\n \n Set pSpecsCol = value\n \nEnd Property\n\nPublic Function It(Description As String, Optional SpecId As String = \"\") As SpecDefinition\n \n Dim Spec As New SpecDefinition\n \n pCounter = pCounter + 1\n ExecuteBeforeEach\n Spec.Description = Description\n Spec.ID = SpecId\n Me.SpecsCol.Add Spec\n Set It = Spec\n \nEnd Function\n\nPublic Function f_lng_number_tests() As Long\n f_lng_number_tests = pCounter\nEnd Function\n\nPublic Sub TotalTests()\n \n Call Increment(lng_total_tests, Me.f_lng_number_tests)\n Debug.Print \" Tests:\" & pCounter & vbCrLf\n str_error_report = str_error_report & vbCrLf & \" Tests:\" & pCounter & vbCrLf\n \nEnd Sub\n\nPublic Sub BeforeEach(Callback As String, ParamArray CallbackArgs() As Variant)\n Me.BeforeEachCallback = Callback\n Me.BeforeEachCallbackArgs = CallbackArgs\nEnd Sub\n\nPrivate Sub ExecuteBeforeEach()\n\n If Me.BeforeEachCallback <> vbNullString Then\n Dim HasArguments As Boolean\n If VarType(Me.BeforeEachCallbackArgs) = vbObject Then\n If Not Me.BeforeEachCallbackArgs Is Nothing Then\n HasArguments = True\n End If\n ElseIf IsArray(Me.BeforeEachCallbackArgs) Then\n If UBound(Me.BeforeEachCallbackArgs) >= 0 Then\n HasArguments = True\n End If\n End If\n \n If HasArguments Then\n Application.Run Me.BeforeEachCallback, Me.BeforeEachCallbackArgs\n Else\n Application.Run Me.BeforeEachCallback\n End If\n End If\n \nEnd Sub\n" }, { "path": "ExcelTdd/TDD_example.vb", "content": "Public Sub Tdd_CA2()\n \n On Error Resume Next\n \n Dim specs As New SpecSuite\n Dim myArr As Variant\n Dim lngSize As Long: lngSize = 46\n\n myArr = fnArr_CA0_002\n \n For lngCounter = 0 To UBound(myArr)\n \n lngRow = lngCounter \\ lngSize\n lngCol = lngCounter Mod lngSize\n\n specs.It(\"CA0_002_F86_Row\" & lngRow + 1 & \"_Col\" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value\n specs.It(\"MUST_FAIL_CA0_002_F86_Row\" & lngRow + 1 & \"_Col\" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToNotEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value & \"1\"\n specs.It(\"MUST_FAIL_CA0_002_F86_Row\" & lngRow + 1 & \"_Col\" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToNotEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value & \"2\"\n\n Next lngCounter\n \n InlineRunner.RunSuite specs\n Call specs.TotalTests\n \n On Error GoTo 0\n \nEnd Sub\n\nPublic Function fnArr_CA0_002()\n\n Dim my_arr As Variant\n\n ReDim my_arr(414)\n \n my_arr(1) = 1\n my_arr(2) = 2\n my_arr(413) = 8059.23\n my_arr(414) = 0\n \n fnArr_CA0_002 = my_arr\n \nEnd Function\n\nPublic Sub MakeAllValues()\n\n Dim my_cell As Range\n Dim l_counter As Long\n Dim str As String\n Dim str_result As String\n \n STR_ERROR_REPORT = \"\"\n\n For Each my_cell In Selection\n Call Increment(l_counter)\n str = vbTab & \"my_arr(\" & l_counter & \")= \"\n\n If Len(my_cell) > 0 Then\n If IsDate(my_cell) Then\n str = str & \"CDate(\"\"\" & my_cell & \"\"\")\"\n Else\n If Not IsNumeric(my_cell) Then\n str = str & \"\"\"\" & my_cell & \"\"\"\"\n Else\n str = str & change_commas(my_cell.value)\n End If\n End If\n Else\n If my_cell.HasFormula Then\n str = str & \"\"\"\"\"\"\n Else\n str = str & 0\n End If\n End If\n \n If Len(str_result) = 0 Then\n str_result = str\n Else\n str_result = str_result & vbCrLf & str\n End If\n Next my_cell\n \n Debug.Print str_result\n Call CreateLogFile(str_result)\n\nEnd Sub\n\nPublic Sub MakeColorsAllValues()\n \n Dim myCell As Range\n Dim lngCounter As Long\n Dim str As String\n Dim strResult As String\n \n STR_ERROR_REPORT = \"\"\n \n For Each myCell In Selection\n Call Increment(lngCounter)\n str = vbTab & \"my_arr(\" & lngCounter & \")= \"\n str = str & myCell.Interior.Color\n \n If Len(strResult) = 0 Then\n strResult = str\n Else\n strResult = strResult & vbCrLf & str\n End If\n \n Next myCell\n \n Debug.Print strResult\n Call CreateLogFile(strResult)\n \nEnd Sub\n\nPublic Function codify_time(Optional b_make_str As Boolean = False) As String\n\n If [set_in_production] Then On Error GoTo codify_Error\n \n Dim dbl_01 As Variant\n Dim dbl_02 As Variant\n Dim dbl_now As Double\n \n dbl_now = Round(Now(), 8)\n \n dbl_01 = Split(CStr(dbl_now), \",\")(0)\n dbl_02 = Split(CStr(dbl_now), \",\")(1)\n \n codify_time = Hex(dbl_01) & \"_\" & Hex(dbl_02)\n \n If b_make_str Then codify_time = \"\\\" & codify_time & \".txt\"\n \n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\n\nEnd Function\n" }, { "path": "ExcelTdd/mod_NeutralSubsAndRoutines.vb", "content": "Option Explicit\n\nPublic Sub Increment(ByRef value_to_increment, Optional l_plus As Double = 1) 'optional value type changed to_double\n \n value_to_increment = value_to_increment + l_plus\n \nEnd Sub\n\n\nPublic Function GetDateAndTime() As String\n\n GetDateAndTime = Format(DateValue(Date), \"dd-mm-yyyy\") & \" \" & Time\n\nEnd Function\n\nPublic Sub OnStart()\n \n Application.ScreenUpdating = False\n Application.EnableEvents = False\n Application.AskToUpdateLinks = False\n Application.DisplayAlerts = False\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n ActiveWindow.View = xlNormalView\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.AskToUpdateLinks = True\n Application.DisplayAlerts = True\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n Application.StatusBar = False\n\nEnd Sub\n\nPublic Function codify_time(Optional b_make_str As Boolean = False) As String\n\n If SET_IN_PRODUCTION Then On Error GoTo codify_Error\n \n Dim dbl_01 As Variant\n Dim dbl_02 As Variant\n Dim dbl_now As Double\n \n dbl_now = Round(Now(), 8)\n \n dbl_01 = Split(CStr(dbl_now), \",\")(0)\n dbl_02 = Split(CStr(dbl_now), \",\")(1)\n \n codify_time = Hex(dbl_01) & \"_\" & Hex(dbl_02)\n \n If b_make_str Then codify_time = \"\\\" & codify_time & \".txt\"\n \n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\n\nEnd Function\n" }, { "path": "ExcelTdd/mod_Notepad.vb", "content": "Option Explicit\n\nPublic Sub CreateLogFile(Optional report As String)\n\n On Error GoTo CreateLogFile_Error\n \n WaitASecond\n Dim newFilePath As String\n newFilePath = \"\\reports\"\n Dim fileName As String\n fileName = ThisWorkbook.Path & newFilePath & CodifyMyTime(True)\n If Dir(ThisWorkbook.Path & newFilePath, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFilePath\n \n Dim fs As Object\n Set fs = CreateObject(\"Scripting.FileSystemObject\")\n \n Dim notepad As Object\n Set notepad = fs.CreateTextFile(fileName, True)\n\n notepad.WriteLine report\n notepad.Close\n \n On Error GoTo 0\n Exit Sub\n\nCreateLogFile_Error:\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CreateLogFile of Sub mod_TDD_Export\"\nEnd Sub\n\nPublic Function CodifyMyTime(Optional makepath As Boolean = False) As String\n\n On Error GoTo codify_Error\n\n Dim timePart01 As Double\n Dim timePart02 As Double\n Dim timePartNow As Double\n\n timePartNow = Round(Now(), 8)\n timePart01 = Split(CStr(timePartNow), \".\")(0)\n timePart02 = Split(CStr(timePartNow), \".\")(1)\n CodifyMyTime = Format(Now, \"YYYYMMMDD_HHNNSS\") & \"_\" & Hex(timePart01) & \"_\" & Hex(timePart02)\n\n If makepath Then CodifyMyTime = \"\\\" & CodifyMyTime & \".xml\"\n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CodifyTime\"\nEnd Function \n \nPublic Sub WaitASecond()\n Application.Wait (Now + TimeValue(\"00:00:01\"))\nEnd Sub\n" }, { "path": "ExcelTdd/mod_PublicVariables.vb", "content": "Option Explicit\n\nPublic STR_ERROR_REPORT As String\nPublic LNG_TOTAL_TESTS As Long\nPublic SET_IN_PRODUCTION As Boolean\n" }, { "path": "ExcelTdd/mod_TddRoutines.vb", "content": "Option Explicit\nOption Private Module\n\nPublic Sub Tdd()\n\n Dim lngTestsTotalExpected As Long\n\n' Select Case MsgBox(\"The TDD is probably long.\", vbYesNo, \"Sure?\")\n' Case vbNo\n' Exit Sub\n' End Select\n \n SET_IN_PRODUCTION = False\n \n lngTestsTotalExpected = 999 'PLACEHOLDER_VALUE\n Debug.Print \"Test report from \" & Environ(\"Username\") & vbCrLf & \"START: \" & GetDateAndTime & vbCrLf & _\n lngTestsTotalExpected & \" expected.\" & vbCrLf\n Call OnStart\n Worksheets(1).Select\n \n STR_ERROR_REPORT = \"Test report from \" & Environ(\"Username\") & vbCrLf & \"START: \" & GetDateAndTime & vbCrLf & _\n lngTestsTotalExpected & \" expected.\" & vbCrLf & vbCrLf\n\n LNG_TOTAL_TESTS = 0\n\n Call Tdd_01\n\n\n STR_ERROR_REPORT = STR_ERROR_REPORT & vbCrLf & \"Tests expected: \" & lngTestsTotalExpected & vbCrLf & _\n \"Total Tests:\" & LNG_TOTAL_TESTS & vbCrLf & \"END: \" & GetDateAndTime\n\n [SET_IN_PRODUCTION] = True\n Debug.Print \"Tests expected: \" & lngTestsTotalExpected\n Debug.Print \"Total Tests:\" & vbCrLf & LNG_TOTAL_TESTS & vbCrLf & \"END: \" & GetDateAndTime\n\n Call CreateLogFile\n Call OnEnd\n\n STR_ERROR_REPORT = \"\"\n\nEnd Sub\n\n\n" }, { "path": "ExcelTdd/mod_TddRoutinesB.vb", "content": "Option Explicit\nOption Private Module\n\nPrivate lngCol As Long\nPrivate lngRow As Long\nPrivate lngCounter As Long\n\nPublic Sub Tdd_01()\n\n On Error Resume Next\n\n Dim specs As New SpecSuite\n\n Dim lngValue As Long\n Dim dtValue As Date\n Dim strInitial As String\n\n Call OnStart\n \n specs.It(\"001\", \"Just A Test\").Expect(2).ToEqual 1 + 1\n specs.It(\"002\", \"Just A Test\").Expect(2).ToNotEqual 1 + 1 + 2\n \n InlineRunner.RunSuite specs\n Call specs.TotalTests\n\n Call OnEnd\n \n On Error GoTo 0\n\nEnd Sub\n\n" }, { "path": "Financial/BenfordModule.vb", "content": "Option Explicit\n\nPublic Sub MainBenfordCheck(myRange As Range)\n \n Dim myCell As Range\n Dim benford As New BenfordModel\n \n For Each myCell In myRange\n If IsNumeric(myCell) Then\n benford.IncrementValue Abs(myCell.value)\n benford.IncrementCount\n End If\n Next myCell\n \n CreateLogFile benford.CreateBenfordLawReport\n \nEnd Sub\n\nPublic Sub CreateLogFile(Optional report As String)\n\n On Error GoTo CreateLogFile_Error\n \n Dim newFilePath As String\n newFilePath = \"\\tests_info\"\n \n Dim filename As String\n filename = ThisWorkbook.Path & newFilePath & CodifyTime(True)\n If Dir(ThisWorkbook.Path & newFilePath, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFilePath\n \n Dim fs As Object\n Set fs = CreateObject(\"Scripting.FileSystemObject\")\n \n Dim notepad As Object\n Set notepad = fs.CreateTextFile(filename, True)\n\n Dim header As String\n header = Now & vbCrLf & \"Created by: \" & Environ(\"USERNAME\")\n \n notepad.WriteLine header\n notepad.WriteLine report\n notepad.Close\n \n Dim shellCommand As String\n shellCommand = \"C:\\WINDOWS\\notepad.exe \"\n shellCommand = shellCommand & filename\n Shell shellCommand\n\n On Error GoTo 0\n Exit Sub\n\nCreateLogFile_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CreateLogFile of Sub mod_TDD_Export\"\n\nEnd Sub\n\nPublic Function CodifyTime(Optional makePath As Boolean = False) As String\n\n On Error GoTo codify_Error\n\n Dim timePart01 As Double\n Dim timePart02 As Double\n Dim timePartNow As Double\n\n timePartNow = Round(Now(), 8)\n timePart01 = Split(CStr(timePartNow), \",\")(0)\n timePart02 = Split(CStr(timePartNow), \",\")(1)\n CodifyTime = Hex(timePart01) & \"_\" & Hex(timePart02)\n\n If makePath Then CodifyTime = \"\\\" & CodifyTime & \".txt\"\n\n On Error GoTo 0\n Exit Function\n\ncodify_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure codify of Function TDD_Export\"\n\nEnd Function\n\n" }, { "path": "Financial/BenfordModuleClass.vb", "content": "Option Explicit\n\nPrivate benfordCheckValues As Variant\nPrivate benfordCount As Long\n\nSub Class_Initialize()\n\n Dim counter As Long\n ReDim benfordCheckValues(9)\n\n For counter = LBound(benfordCheckValues) To UBound(benfordCheckValues)\n benfordCheckValues(counter) = 0\n Next counter\n\nEnd Sub\n\nFunction InitialValuesBenford(val As Long) As Double\n \n '1 = \"30,1%\"\n '2 = \"17,6%\"\n '3 = \"12,5%\"\n '4 = \" 9,7%\"\n '5 = \" 7,9%\"\n '6 = \" 6,7%\"\n '7 = \" 5,8%\"\n '8 = \" 5,1%\"\n '9 = \" 4,6%\"\n \n InitialValuesBenford = Round(WorksheetFunction.Log10(1 + 1 / val), 3)\n \nEnd Function\n\nFunction PercentageFixer(valToReturn As Double) As String\n \n If valToReturn > 0.1 Then\n PercentageFixer = Trim(Format(valToReturn, \"##.0%\"))\n ElseIf valToReturn = 0 Then\n PercentageFixer = \" \" & Format(valToReturn, \"0.0%\")\n Else\n PercentageFixer = \" \" & Format(valToReturn, \"#.0%\")\n End If\n \nEnd Function\n\nFunction CreateBenfordLawReport() As String\n\n Dim line As String: line = \"---------------------------------\"\n On Error GoTo CreateBenfordLawReport_Error\n\n Dim counter As Long\n CreateBenfordLawReport = line & line & line & vbCrLf _\n & line & line & line & vbCrLf _\n & line & line & line & vbCrLf _\n & \"Benford's Law\" & vbCrLf & \"https://en.wikipedia.org/wiki/Benford%27s_law\" & vbCrLf\n\n For counter = LBound(CheckValues) To UBound(CheckValues)\n If counter = 0 Then\n Dim header As String\n header = CreateBenfordLawReport & vbCrLf & \"#\" & vbTab & _\n \"-> \" & \"Val.\" & vbTab & \"Real%\" & vbTab & \"Expected\"\n CreateBenfordLawReport = header\n Else\n CreateBenfordLawReport = CreateBenfordLawReport & vbCrLf & counter & vbTab & _\n \"-> \" & CheckValues(counter) & vbTab & _\n PercentageFixer(Round(CheckValues(counter) / Me.Count, 3)) & vbTab & _\n PercentageFixer(InitialValuesBenford(counter)) & vbTab & \"|\"\n End If\n \n If counter = 0 Or counter = 9 Then\n CreateBenfordLawReport = CreateBenfordLawReport & vbCrLf & line\n End If\n Next counter\n\n On Error GoTo 0\n Exit Function\n\nCreateBenfordLawReport_Error:\n\n CreateBenfordLawReport = \"Not enough data...\"\n\nEnd Function\n\nProperty Get CheckValues() As Variant\n CheckValues = benfordCheckValues\nEnd Property\n\nProperty Get Count() As Long\n Count = benfordCount\nEnd Property\n\nSub IncrementCount()\n benfordCount = benfordCount + 1\nEnd Sub\n\nSub IncrementValue(valToInput As Variant)\n\n Dim leftDigit As Variant\n leftDigit = Left(valToInput, 1)\n benfordCheckValues(leftDigit) = benfordCheckValues(leftDigit) + 1\n \nEnd Sub\n" }, { "path": "Financial/Binary.vb", "content": "Option Explicit\nOption Private Module\n\nPublic Sub TestMe()\n \n Dim arrProducts As Variant\n Dim lngCounter As Long\n Dim lngValue As Long\n Dim strBinary As String\n Dim lngNumber As Long\n \n arrProducts = Array(\"AAA\", \"BBB\", \"CCC\", \"DDD\", \"EEE\", \"FFF\", \"GGG\")\n '1, 2, 4, 8, 16, 32, 64\n lngNumber = 65 '1+2+8+16\n strBinary = StrReverse(LngToBinary(lngNumber))\n \n For lngCounter = 1 To Len(strBinary)\n lngValue = Mid(strBinary, lngCounter, 1)\n \n If lngValue Then\n Debug.Print arrProducts(lngCounter - 1)\n End If\n \n Next lngCounter\n \nEnd Sub\n\nFunction LngToBinary(ByVal n As Long) As String\n\n Dim k As Long\n\n LngToBinary = vbNullString\n \n If n < -2 ^ 15 Then\n LngToBinary = \"0\"\n n = n + 2 ^ 16\n k = 2 ^ 14\n \n ElseIf n < 0 Then\n \n LngToBinary = \"1\"\n n = n + 2 ^ 15\n k = 2 ^ 14\n \n Else\n \n k = 2 ^ 15\n \n End If\n\n Do While k >= 1\n LngToBinary = LngToBinary & Fix(n / k)\n n = n - k * Fix(n / k)\n k = k / 2\n Loop\n \nEnd Function\n" }, { "path": "Financial/ByReferenceByValue.vb", "content": "Option Explicit\n\nPublic Sub TestMe()\n\n Dim var1, var2\n Dim var3, var4\n Dim var5, var6\n \n var1 = Array(1, 1)\n var2 = Array(2, 1)\n var3 = Array(3, 1)\n var4 = Array(4, 1)\n var5 = Array(5, 1)\n var6 = Array(6, 1)\n \n increment1 (var1)\n increment2 (var2)\n increment1 var3\n increment2 var4\n var5 = increment1(var5)\n var6 = increment2(var6)\n \n Debug.Print var1(0)\n Debug.Print var2(0)\n Debug.Print var3(0)\n Debug.Print var4(0)\n Debug.Print var5(0)\n Debug.Print var6(0)\n \nEnd Sub\n\nPublic Function increment1(ByVal testValue As Variant) As Variant\n testValue(0) = testValue(0) + 100\n increment1 = testValue\nEnd Function\n\nPublic Function increment2(ByRef testValue As Variant) As Variant\n testValue(0) = testValue(0) + 100\n increment2 = testValue\nEnd Function\n\n'Immediate Window\n' 1 \n' 2 \n' 3 \n' 104 \n' 105 \n' 106 \n" }, { "path": "Financial/CalculateCostsWithInflation.vb", "content": "' If we use the optional argument, -> calculate_total_month_value_with_inflation(100,1.06,37,2),\n' this would return us the money for a month in the second period. -> 106 (100 + 1.06 inflation rate per year)\n\n\n\nPublic Function calculate_total_month_value_with_inflation(ByVal dbl_per_month As Double, ByVal dbl_inflation As Double, ByVal int_total_length, Optional ByVal int_period As Long = 0) As Double\n\n Dim months_left As Long\n Dim years As Long\n Dim i_counter As Long\n \n Dim dbl_result As Double\n\n Dim previous_period As Double\n \n \n On Error GoTo calculate_total_month_value_with_inflation_Error\n \n\n years = int_total_length \\ MONTHS_IN_YEAR\n months_left = int_total_length - MONTHS_IN_YEAR * years\n \n For i_counter = 0 To years - 1\n \n If i_counter > 0 Then\n previous_period = dbl_result\n End If\n \n dbl_result = dbl_result + dbl_per_month * MONTHS_IN_YEAR * dbl_inflation ^ i_counter\n \n If int_period = i_counter + 1 Then\n calculate_total_month_value_with_inflation = (dbl_result - previous_period) / MONTHS_IN_YEAR\n Exit Function\n End If\n \n Next i_counter\n \n previous_period = dbl_result\n 'adding values for months_left\n dbl_result = dbl_result + dbl_per_month * months_left * dbl_inflation ^ i_counter\n \n 'checking if we need the values for the not filled months:\n \n If int_period > 0 Then\n If months_left = 0 Then\n calculate_total_month_value_with_inflation = dbl_per_month * dbl_inflation ^ (i_counter - 1)\n Exit Function\n Else\n calculate_total_month_value_with_inflation = (dbl_result - previous_period) / months_left\n Exit Function\n End If\n End If\n \n calculate_total_month_value_with_inflation = dbl_result\n\n On Error GoTo 0\n Exit Function\n\ncalculate_total_month_value_with_inflation_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure calculate_total_month_value_with_inflation of Modul mod_GeneralFunctions\"\n \nEnd Function\n" }, { "path": "Financial/DoubleCalculation.vb", "content": "'double inaccuracy example example double inaccuracy floating point accuracy\n\nSub TestMe()\n \n Dim a As Double: a = 20\n Dim b As Double: b = 0.1\n \n Cells.Clear\n Range(\"A1\") = a - b\n Range(\"A2\") = a + b\n \n Range(\"A3\").Formula = \"=A1-A2\"\n Range(\"A4\") = b * 2 * -1\n Range(\"A5\").Formula = \"=A3=A4\"\n \nEnd Sub\n\nSub TestMe2()\n \n Dim a As Double: a = 20\n Dim b As Double: b = 0.1\n \n Cells.Clear\n Range(\"A1\").Formula = \"=\" & a & \"+0.1\"\n Range(\"A2\") = a\n \n Range(\"A3\").Formula = \"=A1-A2\"\n Range(\"A4\") = b\n Range(\"A5\").Formula = \"=A3=A4\"\n \nEnd Sub\n\n" }, { "path": "Financial/ExampleWithDoubles.vb", "content": "Option Explicit\n\n'---------------------------------------------------------------------------------------\n' Method : ErrorsNumber\n' Author : v.doynov\n' Date : 06.04.2017\n' Purpose: Model to see how excel calculates floating point numbers.\n'---------------------------------------------------------------------------------------\n' 0/2 + 0/4 + 0/8 + 1/16 + 1/32 +0/64 + 0/128 + 1/256 + 0/256 +1/512 +0/1024 + 0/2048\n' 0,099609375 \n'---------------------------------------------------------------------------------------\n\nPublic Sub ErrorsNumber()\n\n Const DIFF_DEFAULT = 0.1\n ThisWorkbook.PrecisionAsDisplayed = False\n Dim lngEndNumber As Long: lngEndNumber = 30\n\n Dim dblStarter As Double\n Dim dblEnder As Double\n Dim dblDiff As Double\n\n Dim lngCounter As Long\n Dim lngCounter2 As Long\n Dim lngRow As Long\n\n Dim dblResult As Double\n Dim lngCountErrors As Long\n Dim myCell As Range\n\n If lngEndNumber > 10000 Then Debug.Print lngEndNumber & \"is too big, it takes too much time!\": Exit Sub\n\n Call OnStart\n Cells.Clear\n\n For lngCounter = 0 To lngEndNumber\n dblDiff = DIFF_DEFAULT\n\n For lngCounter2 = 0 To 9\n dblDiff = DIFF_DEFAULT * lngCounter2\n\n lngRow = lngRow + 1\n Set myCell = Cells(lngRow, 1)\n\n dblStarter = lngCounter + dblDiff\n dblEnder = lngCounter + dblDiff + DIFF_DEFAULT\n dblResult = dblStarter - dblEnder\n\n myCell = dblStarter\n myCell.Offset(0, 1) = dblEnder\n myCell.Offset(0, 2).FormulaR1C1 = \"=RC[-1]-RC[-2]\"\n myCell.Offset(0, 2).NumberFormat = \"0.00000000000000000\"\n myCell.Offset(0, 3).FormulaR1C1 = \"=IF(RC[-1]=0.1,\"\"\"\",\"\"X\"\")\"\n \n Next lngCounter2\n \n If lngCounter Mod 100 = 0 Then Debug.Print lngCounter\n \n Next lngCounter\n\n With Range(\"E1\")\n .FormulaR1C1 = \"=COUNTIF(C[-1],\"\"X\"\")/\" & lngEndNumber * 10\n .NumberFormat = \"0.0000%\"\n End With\n\n Columns.AutoFit\n Debug.Print \"READY!\"\n\n Call OnEnd\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.AskToUpdateLinks = True\n Application.DisplayAlerts = True\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n \n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub OnStart()\n \n Application.ScreenUpdating = False\n Application.EnableEvents = False\n Application.AskToUpdateLinks = False\n Application.DisplayAlerts = False\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n \n ActiveWindow.View = xlNormalView\n\nEnd Sub\n\n" }, { "path": "Financial/MakeRedAndBlack.vb", "content": "'---------------------------------------------------------------------------------------\n' Module : mod_main\n' Author : v.doynov\n' Date : 27.01.2016\n' Purpose : To make the tool work, we need four lines of values. Rows 1,2 and Rows 4,5\n' We need to put values only on row 4, positive and negative.\n' Then run the \"main\" procedure.\n'---------------------------------------------------------------------------------------\n\nOption Explicit\n\nPublic Const STARTING_FROM_COLUMN = 1\nPublic Const COLUMNS_NOT_TOUCHED = 0\nPublic current_cell As Range\n'\n\nPublic Sub Main()\n \n Dim my_cell As Range\n Dim l_col_len As Long: l_col_len = last_column(row_to_check:=4)\n Dim l_counter As Long\n Dim d_result As Double\n Dim d_result_ini As Double\n \n On Error GoTo main_Error\n \n Call OnStart\n \n tbl_output.Unprotect \"toughpassword100\"\n \n tbl_output.Rows(1).Clear\n tbl_output.Rows(2).Clear\n tbl_output.Rows(3).Clear\n tbl_output.Rows(5).Clear\n tbl_output.Rows(6).Clear\n \n 'Copy\n Range(Cells(1, 1), Cells(1, l_col_len)).Value = Range(Cells(4, 1), Cells(4, l_col_len)).Value\n \n 'Format\n Call MakeRedAndBlack(tbl_output.Cells(2, 1))\n Call MakeRedAndBlack(tbl_output.Cells(5, 1))\n \n Set my_cell = tbl_output.Cells(2, 1)\n my_cell.FormulaR1C1 = \"=R[-1]C\"\n my_cell.Offset(1, 0).Interior.Color = 5296274\n Call MakeRedAndBlack(my_cell)\n Call MakeRedAndBlack(my_cell.Offset(-1, 0))\n \n Set my_cell = tbl_output.Cells(5, 1)\n my_cell.FormulaR1C1 = \"=R[-1]C\"\n my_cell.Offset(1, 0).Interior.Color = 5296274\n Call MakeRedAndBlack(my_cell)\n Call MakeRedAndBlack(my_cell.Offset(-1, 0))\n \n For l_counter = 2 To l_col_len\n \n Set my_cell = tbl_output.Cells(2, l_counter)\n \n my_cell.Formula = \"=R[-1]C+RC[-1]\"\n my_cell.Offset(3, 0).Formula = \"=R[-1]C+RC[-1]\"\n \n my_cell.Offset(1, 0).Interior.Color = 5296274\n my_cell.Offset(4, 0).Interior.Color = 5296274\n \n Call MakeRedAndBlack(my_cell)\n Call MakeRedAndBlack(my_cell.Offset(-1, 0))\n Call MakeRedAndBlack(my_cell.Offset(2, 0))\n Call MakeRedAndBlack(my_cell.Offset(3, 0))\n \n Next l_counter\n \n 'Action\n Call RedAndBlackRecalculation_main2(l_col_len, 2)\n \n 'Checks\n d_result = sum_range(tbl_output.Range(tbl_output.Cells(4, 1), tbl_output.Cells(4, l_col_len)))\n d_result_ini = sum_range(tbl_output.Range(tbl_output.Cells(1, 1), tbl_output.Cells(1, l_col_len)))\n \n If d_result > 0 Then\n [my_result] = d_result\n 'MsgBox \"Sie haben keinen Gewinn. Ihre finanziellen Verlust beträgt \" & d_result & \" Euro.\", vbInformation, \"RedAndBlack\"\n Else\n [my_result] = \"\"\n End If\n \n 'tbl_output.Protect \"toughpassword100\"\n \n If d_result <> d_result_ini Then\n MsgBox \"Überprüfen Sie die Eingabe.\", vbInformation, \"RedAndBlack\"\n End If\n \n tbl_output.Rows(2).EntireRow.Hidden = 1\n tbl_output.Rows(5).EntireRow.Hidden = 1\n \n Call OnEnd\n Set my_cell = Nothing\n\n On Error GoTo 0\n Exit Sub\n\nmain_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure main of Module mod_main\"\n Call OnEnd\n \nEnd Sub\n\nPublic Sub MakeRedAndBlack(ByRef my_range As Range)\n\n my_range.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00)\"\n my_range.Font.Name = \"Calibri\"\n my_range.Font.Size = 11\n \n \n 'if we try to do it with parenthesis, then the zero values are not showing...\n 'my_range.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00);\"\n \nEnd Sub\n\n'---------------------------------------------------------------------------------------\n' Procedure : RedAndBlackRecalculation\n' Author : v.doynov\n' Date : 07.08.2015\n' Purpose : Divides the row of \"CashFlow vor Steuern\" into red to the right and black\n' to the left. Change \"calendar_cols\" and \"current_row\" to make it work.\n' In order to call it use \"call RedAndBlackRecalculation(27,84)\".\n' 84 is the middle line of the original 3 in PAKU.\n'---------------------------------------------------------------------------------------\n'\nPublic Sub RedAndBlackRecalculation_main2(ByVal calendar_cols As Long, ByVal current_row As Long)\n \n Dim counter As Long\n \n Dim final_col_in_loop As Long\n \n Dim cell As Range\n Dim range_for_analysis As Range\n \n Dim holdback As Double\n Dim max_for_break_even As Double\n \n Dim cell_with_break_even As Range\n \n On Error GoTo RedAndBlackRecalculation_Error\n\n holdback = 0\n \n 'When used outside PAKU remove \"tbl_output.Range\" for the set\n With tbl_output\n Set range_for_analysis = .Range(.Cells(current_row, STARTING_FROM_COLUMN), .Cells(current_row, calendar_cols + COLUMNS_NOT_TOUCHED))\n End With\n \n max_for_break_even = Application.WorksheetFunction.Max(range_for_analysis)\n \n For Each cell In range_for_analysis\n If cell.Value = max_for_break_even Then\n Set cell_with_break_even = cell\n Exit For\n End If\n Next cell\n \n final_col_in_loop = cell_with_break_even.Column + 1\n current_row = current_row - 1\n \n If cell_with_break_even.Column = 1 And cell_with_break_even <= 0 Then\n For counter = COLUMNS_NOT_TOUCHED + calendar_cols To cell_with_break_even.Column Step -1\n \n With tbl_output\n Set current_cell = .Cells(current_row, counter)\n End With\n \n If current_cell > 0 Then\n holdback = holdback + current_cell\n current_cell = 0\n Else\n current_cell = current_cell + holdback\n holdback = 0\n End If\n \n 'we do it for a second time,\n 'in order to make it equal to zero, if\n 'it is not in the break even point\n \n If current_cell > 0 Then\n holdback = holdback + current_cell\n current_cell = 0\n End If\n Next counter\n Else\n \n For counter = COLUMNS_NOT_TOUCHED + calendar_cols To final_col_in_loop Step -1\n \n With tbl_output\n Set current_cell = .Cells(current_row, counter)\n End With\n \n If current_cell > 0 Then\n holdback = holdback + current_cell\n current_cell.Value = 0\n Else\n current_cell = current_cell + holdback\n holdback = 0\n End If\n \n 'we do it for a second time,\n 'in order to make it equal to zero, if\n 'it is not in the break even point\n \n If current_cell > 0 Then\n holdback = holdback + current_cell\n current_cell = 0\n End If\n \n ' current_cell.Activate\n Next counter\n \n For counter = STARTING_FROM_COLUMN To cell_with_break_even.Column Step 1\n With tbl_output\n Set current_cell = .Cells(current_row, counter)\n End With\n \n If current_cell < 0 Then\n holdback = holdback + current_cell\n current_cell = 0\n Else\n If holdback + current_cell < 0 Then\n holdback = holdback + current_cell\n current_cell = 0\n Else\n current_cell = current_cell + holdback\n holdback = 0\n End If\n End If\n Next counter\n End If\n \n Set range_for_analysis = Nothing\n Set cell_with_break_even = Nothing\n Set cell = Nothing\n Set current_cell = Nothing\n \n On Error GoTo 0\n Exit Sub\n\nRedAndBlackRecalculation_Error:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure RedAndBlackRecalculation of Modul mod_RedAndBlackRecalculation\"\nEnd Sub\n\nFunction lastColumn(Optional sheetName As String, Optional rowToCheck As Long = 1) As Long\n\n Dim ws As Worksheet\n \n If sheetName = vbNullString Then\n Set ws = ActiveSheet\n Else\n Set ws = Worksheets(sheetName)\n End If\n \n lastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column\n\nEnd Function\n\n\nPublic Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String\n\n Dim HexR As Variant, HexB As Variant, HexG As Variant\n Dim sTemp As String\n\n On Error GoTo ErrorHandler\n\n 'R\n HexR = Hex(R)\n If Len(HexR) < 2 Then HexR = \"0\" & HexR\n\n 'Get Green Hex\n HexG = Hex(G)\n If Len(HexG) < 2 Then HexG = \"0\" & HexG\n\n HexB = Hex(B)\n If Len(HexB) < 2 Then HexB = \"0\" & HexB\n\n RGB2HTMLColor = HexR & HexG & HexB\n Debug.Print \"Enter RGB, without caring for the real colors, the function knows what it is doing.\"\n Debug.Print \"IF 50D092 then &H0050D092&\"\n\n Exit Function\n \nErrorHandler:\n Debug.Print \"RGB2HTMLColor was not successful\"\nEnd Function\n\nPublic Sub OnStart()\n \n Application.DisplayAlerts = False\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n \n 'Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Function sum_range(my_range As Range) As Double\n \n Dim cell As Range\n \n sum_range = 0\n \n For Each cell In my_range\n sum_range = sum_range + cell.Value\n Next\n \nEnd Function\n" }, { "path": "Financial/Readme.md", "content": "## Financial\r\n
\r\n\r\nFor the *SUMPRODUCT* formula in SumProductCountAndSum.xlsx.
\r\nIt looks like this:
\r\n\r\n--------\r\n=SUMPRODUCT((B2:B6=C2)*1)
\r\n+SUMPRODUCT((B8:B13=C8)*1)
\r\n+SUMPRODUCT((B16:B20=C16)*1)
\r\n\r\n--------\r\n\r\n=SUMPRODUCT(((B2:B6=C2)*1)*(A2:A6=D2))
\r\n+SUMPRODUCT(((B8:B13=C8)*1)*(A8:A13=D8))
\r\n+SUMPRODUCT(((B16:B20=C16)*1)*(A16:A20=D16))
\r\n\r\n--------\r\n \r\n![Screenshot is here](https://image.ibb.co/nJ9WaF/Paint.png)\r\n\r\n
\r\nArray formula:\r\nWhich value in array is found in a range? \r\n\r\n=INDEX(C1:C6,MATCH(TRUE,COUNTIF(D:D,C1:C6)>0,0))\r\n\r\n\r\n![Screenshot is here](http://image.ibb.co/nhsuZv/vlookup.png)\r\n" }, { "path": "Financial/ScientificNotationExplanation.vb", "content": "Scientific Notation:\n----------------\n0,000025\n2,50E-05\n2,5*(10^-5)\n----------------\n0,00000000000025\n2,50E-13\n2,50(10^-13)\n----------------\n" }, { "path": "Financial/VLookUpWithMultipleCriteria.vb", "content": "'https://www.vitoshacademy.com/vba-vlookup-with-multiple-criteria-in-excel-without-excel-formula-but-with-vba/\n\nFunction GetLookupDataTriple(wks As Worksheet, tableName As String, lookIntoColumn As String, myArray As Variant) As Variant\n \n Dim lo As ListObject\n Set lo = wks.ListObjects(tableName)\n \n Dim i As Long\n For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count\n If lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1) Then\n If lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3) Then\n If lo.ListColumns(myArray(4)).Range.Cells(RowIndex:=i) = myArray(5) Then\n GetLookupDataTriple = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i)\n Exit Function\n End If\n End If\n End If\n Next i\n \n GetLookupDataTriple = -1\n \nEnd Function\n\nFunction GetLookupDataDouble(wks As Worksheet, tableName As String, lookIntoColumn As String, myArray As Variant) As Variant\n \n Dim lo As ListObject\n Set lo = wks.ListObjects(tableName)\n \n Dim i As Long\n For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count\n If lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1) Then\n If lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3) Then\n GetLookupDataDouble = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i)\n Exit Function\n End If\n End If\n Next i\n \n GetLookupDataDouble = -1\n \nEnd Function\n" }, { "path": "Formatting/Borders.vb", "content": "Option Explicit\n\nSub MakeSelectionWithCells(my_range As Range)\n\n Dim l_line_style As Long: l_line_style = 1\n Dim l_theme_color As Long: l_theme_color = 2\n Dim d_tint_shade As Double: d_tint_shade = 0.349986266670736\n Dim l_weight As Long: l_weight = 2\n Dim l_counter As Long\n \n For l_counter = 7 To 12\n Call MakeSelectionWithCells_Separated(l_line_style, l_theme_color, d_tint_shade, l_weight, l_counter, my_range)\n Next l_counter\n \nEnd Sub\n\nPublic Sub MakeSelectionWithCells_Separated(l_line_style As Long, _\n l_theme_color As Long, _\n d_tint_shade As Double, _\n l_weight As Long, _\n l_counter As Long, _\n my_range As Range)\n \n With my_range.Borders(l_counter)\n .LineStyle = l_line_style\n .ThemeColor = l_theme_color\n .TintAndShade = d_tint_shade\n .Weight = l_weight\n End With\n \nEnd Sub\n\nPublic Sub BorderMe(myRange As Range)\n\n Dim cnt As Long\n\n For cnt = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc\n With myRange.Borders(cnt)\n .LineStyle = xlContinuous\n .Weight = xlMedium\n End With\n Next\n\nEnd Sub\n\nPublic Sub FixTableWithLines(tbl As Worksheet, Optional myStep As Long = 4, Optional myStart As Long = 2)\n \n OnStart\n \n Dim i As Long\n Dim myLastRow As Long: myLastRow = LastRow(tbl.Name)\n Dim myLastColumn As Long: myLastColumn = LastColumn(tbl.Name)\n Dim myRange As Range\n \n For i = myStart + myStep To myLastRow + myStep Step myStep\n With tbl\n Set myRange = .Range(.Cells(i, 1), .Cells(i, myLastColumn))\n With myRange.Borders(xlEdgeTop)\n .LineStyle = xlContinuous\n .Weight = xlThin\n End With\n End With\n Next i\n \nEnd Sub\n\n" }, { "path": "Formatting/ColorSaturdayAndSunday.vb", "content": "Public Sub ColorSS()\n \n On Error GoTo ColorSS_Error\n \n 'Colors Saturdays and Sundays.\n \n Dim r_cell As Range\n Dim r_range As Range\n \n For Each r_cell In Selection\n If Weekday(r_cell.Value) = 1 Or Weekday(r_cell.Value) = 7 Then\n Set r_range = ActiveSheet.Range(Cells(4, r_cell.Column), Cells(340, r_cell.Column))\n r_range.Interior.Color = 13434828\n End If\n Next r_cell\n \n Set r_range = Nothing\n\n On Error GoTo 0\n Exit Sub\n\nColorSS_Error:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure ColorSS of Sub mod_play_with_me\"\nEnd Sub\n" }, { "path": "Formatting/Comments.vb", "content": "Public Sub AddCommentToSelection(myComment As String)\n \n Dim myCell As Range\n \n For Each myCell In Selection\n myCell.ClearComments\n myCell.AddComment myComment\n myCell.Comment.Visible = False\n myCell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft\n myCell.Comment.Shape.ScaleHeight 2.26, msoFalse, msoScaleFromTopLeft\n Next myCell\n \nEnd Sub\n\nPublic Sub DeleteCommentFromSelection()\n \n Dim myCell As Range\n \n For Each myCell In Selection\n myCell.ClearComments\n Next myCell\n \nEnd Sub\n\nPublic Sub BeautifyComments(myCell As Range, commentText As String, Optional commentVisible As Boolean = False)\n \n myCell.ClearComments\n myCell.AddComment.Visible = commentVisible\n myCell.Comment.Text commentText\n \n With myCell.Comment.Shape\n \n .AutoShapeType = msoShapeRoundedRectangle\n \n .ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft\n .ScaleWidth 2, msoFalse, msoScaleFromTopLeft\n \n .TextFrame.Characters.Font.Name = \"Tahoma\"\n .TextFrame.Characters.Font.Size = 12\n .TextFrame.Characters.Font.ColorIndex = 1\n\n .Line.ForeColor.RGB = RGB(0, 0, 0)\n .Line.BackColor.RGB = RGB(255, 255, 255)\n \n .Fill.Visible = msoTrue\n .Fill.ForeColor.RGB = RGB(255, 204, 153)\n .Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.25\n .Line.DashStyle = msoLineLongDash\n .Shadow.Visible = msoFalse\n .Placement = xlMoveAndSize\n \n End With\n \nEnd Sub\n\nPublic Sub MakeAllCommentsVisible()\n\n Dim myComment As Comment\n\n For Each myComment In Application.ActiveSheet.Comments\n myComment.Visible = False\n Next myComment\n\nEnd Sub\n" }, { "path": "Formatting/Conditional Compilation Arguments.vb", "content": "'Conditional Compilation Arguments in Access\n'To set them this is the code:\n\nApplication.SetOption \"Conditional Compilation Arguments\",\"A=4:B=10\"\n'To get them:\n\nApplication.GetOption(\"Conditional Compilation Arguments\")\n'They are printed like this: A = 4 : B = 10\n\n'That is how to test it:\n\nSub TestMe()\n\n #If A = 1 Then\n Debug.Print \"a is 1\"\n #Else\n Debug.Print \"a is not 1\"\n #End If\n\nEnd Sub\n" }, { "path": "Formatting/ConditionalFormat.vb", "content": "Sub ListAllConditionalFormat()\n\n Dim cf As FormatCondition\n Dim ws As Worksheet\n Dim l As Long\n Dim rngCell As Range\n\n On Error Resume Next\n\n Application.EnableEvents = False\n Application.ScreenUpdating = False\n tblReport.Cells.Clear\n\n For Each ws In ThisWorkbook.Worksheets\n Debug.Print ws.Name\n\n For Each cf In ws.Cells.FormatConditions\n l = 1 + l\n With tblReport\n Set rngCell = .Cells(l, 1)\n rngCell = cf.AppliesTo.Address\n rngCell.Offset(0, 1) = cf.Type\n rngCell.Offset(0, 2) = \"'\" & cf.Formula1\n rngCell.Offset(0, 3) = cf.Interior.Color\n rngCell.Offset(0, 4) = cf.Font.Name\n rngCell.Offset(0, 5) = ws.Name\n rngCell.Offset(0, 6) = \"'\" & cf.AppliesTo.AddressLocal\n rngCell.Offset(0, 7) = \"'\" & cf.Formula2\n End With\n Next cf\n Next ws\n Debug.Print \"END!\"\n\nEnd Sub\n" }, { "path": "Formatting/CreateSheetRemoveSheet.vb", "content": "'Create Make Sheet Worksheet\n'Remove Sheet Worksheet\n'Delete Sheet Worksheet\n\nSub CreateWorksheet(sheetName As String)\n\n ThisWorkbook.Worksheets.Add.Name = sheetName\n \nEnd Sub\n\nSub DeleteWorksheet(sheetName As String)\n\n Dim displayAlert As Boolean\n Dim mySheet As Worksheet\n \n displayAlert = Application.DisplayAlerts\n \n For Each mySheet In ThisWorkbook.Worksheets\n If mySheet.Name = sheetName Then\n Application.DisplayAlerts = False\n ThisWorkbook.Worksheets(sheetName).Delete\n Application.DisplayAlerts = displayAlert\n End If\n Next\n \nEnd Sub\n\nSub DeleteAllButLast()\n\n Dim wksToStay As Worksheet\n Dim wksToDelete As Worksheet\n Dim i As Long\n\n Set wksToStay = ThisWorkbook.Worksheets(Worksheets.Count)\n\n For i = Worksheets.Count To 1 Step -1\n Set wksToDelete = ThisWorkbook.Worksheets(i)\n If wksToDelete.Name <> wksToStay.Name Then\n Application.DisplayAlerts = False\n wksToDelete.Delete\n Application.DisplayAlerts = True\n End If\n Next\n\nEnd Sub\n\n" }, { "path": "Formatting/DataCleaning.vb", "content": "Sub AddEmptyValueIfMissingInColumn()\n\n Dim myCell As Range\n Dim str As String\n \n \n For Each myCell In Selection\n If Len(Trim(myCell)) = 0 Then\n myCell = str\n Else\n str = myCell\n End If\n Next myCell\n\nEnd Sub\n\nSub UnMergeSelection()\n\n Dim myCell As Range\n \n For Each myCell In Selection\n If myCell.MergeCells Then\n myCell.UnMerge\n End If\n Next\n\nEnd Sub\n" }, { "path": "Formatting/FileNameWithDialogBox.vb", "content": "Option Explicit\n\nPublic Sub MainBrowse(my_obj As Object)\n \n Dim str_file As String\n \n str_file = Application.GetOpenFilename(Title:=\"Please choose a file to open\", FileFilter:=\"Excel Files *.xls* (*.xls*),\")\n my_obj = str_file\n\nEnd Sub\n\nPrivate Sub btnBrowse_Click()\n \n Dim strInitial As String\n Dim objLabel As Object\n \n Set objLabel = ThisWorkbook.Worksheets(tbl_input.Name).lblDisplay\n \n strInitial = objLabel\n Call MainBrowse(objLabel)\n\n If Len(objLabel) >= 6 Then 'Falsch, False\n objLabel = strInitial\n End If\n\nEnd Sub\n" }, { "path": "Formatting/FixRangeError.vb", "content": "Sub ErrorInFormulas()\n\n 'Formatting condition, conditional formatting, external\n\n Dim ws As Worksheet, r As Range\n Dim cf As FormatCondition\n\n For Each ws In Worksheets\n \n For Each r In ws.UsedRange\n If IsError(r) Then\n Debug.Print r.Parent.Name, r.Address, r.Formula\n End If\n Next\n \n For Each cf In ws.Cells.FormatConditions\n Debug.Print cf.AppliesTo.Address, cf.Type, cf.Formula1, cf.Interior.COLOR, cf.Font.Name, ws.Name\n Next\n Next\n \nEnd Sub\n\nSub ListAllConditionalFormatting()\n\n Dim cf As FormatCondition\n Dim ws As Worksheet\n Set ws = ActiveSheet\n For Each cf In ws.Cells.FormatConditions\n Debug.Print cf.AppliesTo.Address, cf.Type, cf.Formula1, cf.Interior.COLOR, cf.Font.Name\n Next cf\n\nEnd Sub\n\n\nSub ErrorList()\n\n Dim ws As Worksheet\n Dim rng1 As Range\n Dim strOut As String\n \n For Each ws In ThisWorkbook.Worksheets\n Set rng1 = Nothing\n On Error Resume Next\n Set rng1 = ws.Cells.SpecialCells(xlFormulas, xlErrors)\n On Error GoTo 0\n If Not rng1 Is Nothing Then strOut = strOut & (ws.Name & \" has \" & rng1.Cells.count & \" errors\" & vbNewLine)\n Next ws\n \n If Len(strOut) > 0 Then\n Debug.Print \"Error List:\" & vbNewLine & strOut\n Else\n Debug.Print \"No Errors\"\n End If\n \nEnd Sub\n\n \nSub FixRangeError()\n \n On Error GoTo FixRangeError_Error\n\n Dim r_range As Range\n Dim str_text As String\n Dim l_counter As Long\n Dim str_result As String\n \n Dim arr_result As Variant\n Dim arr_range As Variant\n \n For Each r_range In ActiveSheet.UsedRange\n\t\t\tstr_text = \"\"\n If r_range.HasFormula Then\n ReDim arr_result(0)\n str_text = Replace(r_range.Formula, \"=\", \"\")\n \n arr_range = Split(str_text, \"+\")\n \n For l_counter = LBound(arr_range) To UBound(arr_range)\n If Not InStr(arr_range(l_counter), \"#\") > 0 Then\n ReDim Preserve arr_result(UBound(arr_result) + 1)\n arr_result(UBound(arr_result)) = arr_range(l_counter)\n End If\n Next l_counter\n \n For l_counter = LBound(arr_result) + 1 To UBound(arr_result)\n str_result = str_result & \"+\" & arr_result(l_counter)\n Next l_counter\n \n str_result = \"=\" & Right(str_result, Len(str_result) - 1)\n \n r_range.Formula = str_result\n End If\n Next r_range\n \n\n On Error GoTo 0\n Exit Sub\n\nFixRangeError_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure FixRangeError of Sub Modul1\"\n\nEnd Sub\n\n'---------------------------------------------------------------------------------------\n' Method : FindMeTheCellWithError\n' Author : v.doynov\n' Date : 01.09.2017\n' Purpose: Show the errors. Print the errors in a worksheet. Look for errors. Search errors.\n'---------------------------------------------------------------------------------------\nPublic Sub FindMeTheCellWithError()\n\n Dim rngCell As Range\n Dim wks As Worksheet\n\n For Each wks In ThisWorkbook.Worksheets\n For Each rngCell In wks.UsedRange\n If IsError(rngCell) Then\n Debug.Print rngCell.Address\n Debug.Print rngCell.Parent.name\n End If\n Next rngCell\n Next wks\n\nEnd Sub\n" }, { "path": "Formatting/GetWorkbook.vb", "content": "Public Function GetWorkbook(ByVal sFullName As String) As Workbook\n \n Dim sFile As String\n Dim wbReturn As Workbook\n \n sFile = Dir(sFullName)\n \n On Error Resume Next\n Workbooks(sFile).Close\n Set wbReturn = Workbooks(sFile)\n \n If wbReturn Is Nothing Then\n Set wbReturn = Workbooks.Open(sFullName)\n End If\n On Error GoTo 0\n \n Set GetWorkbook = wbReturn\n \nEnd Function\n\nPublic Function calculate_range(from_row As Long, to_row As Long, l_column As Long, _\n Optional s_sheet_name As String = \"calendar\") As Double\n\n Dim ws As Worksheet\n Dim l_counter As Long\n Dim d_result As Double\n \n Set ws = ThisWorkbook.Worksheets(s_sheet_name)\n \n For l_counter = from_row To to_row\n Call Increment(d_result, ws.Cells(l_counter, l_column))\n Next l_counter\n\n Set ws = Nothing\n \n calculate_range = Round(d_result, 2)\n \nEnd Function\n \nFunction IsWorkbookOpen(wbk As Workbook) As Boolean\n 'Opened Workbook, open workbook\n Dim checkWbk As Workbook\n \n On Error Resume Next\n Set checkWbk = Workbooks(wbk.Name)\n On Error GoTo 0\n \n If checkWbk Is Nothing Then\n IsWorkbookOpen = False\n Else\n IsWorkbookOpen = True\n End If\n \nEnd Function\n" }, { "path": "Formatting/IgnoreCellErrors.vb", "content": "Public Sub IgnoreCellErrors()\n \n Dim rngCell As Range\n Dim cnt As Long\n \n For Each rngCell In ActiveSheet.UsedRange\n For cnt = 1 To 8\n rngCell.Errors(cnt).Ignore = True\n Next cnt\n Next rngCell\n\nEnd Sub\n" }, { "path": "Formatting/InsertIntoString.vb", "content": "Function InsertIntoString(originalString As String, addedString As String, positionToAdd As Long) As String\n\n If positionToAdd < 1 Then positionToAdd = 1\n If Len(originalString) < positionToAdd Then positionToAdd = Len(originalString) + 1\n\n InsertIntoString = Mid(originalString, 1, positionToAdd - 1) _\n & addedString _\n & Mid(originalString, positionToAdd, Len(originalString) - positionToAdd + 1)\n\nEnd Function\n\nPublic Sub TestInsertIntoString()\n\n Debug.Print InsertIntoString(\"vitosh\", \"academy\", 1000) = \"vitoshacademy\"\n Debug.Print InsertIntoString(\"academy\", \"vit\", -6) = \"vitacademy\"\n Debug.Print InsertIntoString(\"vitacademy\", \"osh\", 4) = \"vitoshacademy\"\n Debug.Print InsertIntoString(\"abcd\", \"ff\", 3) = \"abffcd\"\n Debug.Print InsertIntoString(\"abcd\", \"ff\", 4) = \"abcffd\"\n Debug.Print InsertIntoString(\"abcd\", \"ff\", 100) = \"abcdff\"\n\nEnd Sub\n\n\n" }, { "path": "Formatting/OpenAndClose.vb", "content": "Private Sub Workbook_BeforeClose(Cancel As Boolean)\n Cancel = False\n \n ThisWorkbook.Save\n Application.DisplayAlerts = False\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n Application.DisplayAlerts = True\n ActiveWindow.DisplayHeadings = True\n Application.DisplayFormulaBar = True\n ActiveSheet.PageSetup.BlackAndWhite = False\n \nEnd Sub\n\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\n\n paku_message_title = tbl_settings.Range(\"AJ8\")\n \n If Not tbl_settings.Visible Then\n With Application\n Application.ScreenUpdating = False\n Application.DisplayAlerts = False\n Sh.Delete\n Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n End With\n \n MsgBox (Environ(\"UserName\") & \", Sie können Blätter nicht hinzufügen.\"), vbInformation, paku_message_title\n End If\n \nEnd Sub\n\nPrivate Sub Workbook_Open()\n\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\n Application.DisplayFormulaBar = False\n [set_root_user] = False\n Application.Caption = \"\"\n \nEnd Sub\n\nPublic Sub HideNeeded()\n \n Dim var_Sheet As Variant\n \n Dim arr_visible_sheets As Variant\n Dim arr_hidden_sheets As Variant\n \n Call OnStart\n \n arr_visible_sheets = Array(tbl_Input)\n arr_hidden_sheets = Array(tbl_1, tbl_2, tbl_3)\n \n For Each var_Sheet In arr_visible_sheets\n var_Sheet.Visible = xlSheetVisible\n Next var_Sheet\n \n For Each var_Sheet In arr_hidden_sheets\n var_Sheet.Visible = xlSheetVeryHidden\n Next var_Sheet\n \n Call OnEnd\n \nEnd Sub\n\n\nPublic Sub UnhideAll()\n \n Dim Sheet As Worksheet\n \n For Each Sheet In ThisWorkbook.Worksheets\n ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible\n Sheet.Visible = xlSheetVisible\n Next Sheet\n \n Call UnprotectAll\n \nEnd Sub\n" }, { "path": "Formatting/RangeConnector.vb", "content": "Sub FormatHalfOfTheSelectedCell()\n\n Dim myRange As Range\n Dim color As Long: color = RGB(0, 0, 0)\n Dim myShape As Shape\n \n With Worksheets(\"Sheet1\") 'With ActiveSheet\n \n Set myRange = .Range(\"E10\") 'Selection\n Dim left As Long: left = myRange.left\n Dim top As Long: top = myRange.top\n Dim width As Long: width = myRange.width\n Dim heigth As Long: heigth = myRange.Height\n\n 'Top line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left + width / 2, top)\n myShape.Line.ForeColor.RGB = color\n \n 'Left line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left, top + myRange.Height)\n myShape.Line.ForeColor.RGB = color\n \n 'Right line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + width / 2, top, left + width / 2, top + myRange.Height)\n myShape.Line.ForeColor.RGB = color\n \n Set myRange = myRange.Offset(1)\n left = myRange.left\n top = myRange.top\n width = myRange.width\n heigth = myRange.Height\n \n 'Bottom line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left + width / 2, top)\n myShape.Line.ForeColor.RGB = RGB(200, 0, 0)\n\n End With\n\nEnd Sub\n \n \nSub FormatRightPartOfSelectedCell()\n\n Dim myRange As Range\n Dim color As Long: color = RGB(0, 0, 0)\n Dim myShape As Shape\n \n With Worksheets(\"Sheet1\") 'With ActiveSheet\n Set myRange = .Range(\"E10\") 'Selection\n Dim left As Long: left = myRange.left\n Dim top As Long: top = myRange.top\n Dim width As Long: width = myRange.width\n Dim heigth As Long: heigth = myRange.Height\n\n 'Top line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + (width) / 2, top, left + width, top)\n myShape.Line.ForeColor.RGB = color\n \n 'Right line\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + width, top, left + width, top + myRange.Height)\n myShape.Line.ForeColor.RGB = color\n \n Set myRange = myRange.Offset(1)\n left = myRange.left\n top = myRange.top\n width = myRange.width\n heigth = myRange.Height\n \n 'Bottom Line:\n Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + (width) / 2, top, left + width, top)\n myShape.Line.ForeColor.RGB = RGB(200, 0, 0)\n End With\n\nEnd Sub\n" }, { "path": "Formatting/RemoveWorksheet.vb", "content": "Option Explicit\n\nPublic Sub Main()\n\n Dim objFso As Object\n Dim objFol As Object\n Dim objFil As Object\n \n Dim objWb As Workbook\n Dim objWs As Worksheet\n \n Dim lngCounter As Long\n Dim strNameToDelete As String: strNameToDelete = UCase(tblMAin.Cells(1, 1))\n Dim strNameDeleted As String\n \n Call OnStart\n \n Set objFso = CreateObject(\"Scripting.FileSystemObject\")\n Set objFol = objFso.getfolder(ThisWorkbook.Path)\n strTextSummary = Now & vbCrLf\n \n Application.StatusBar = \"Running ...\"\n \n For Each objFil In objFol.Files\n If ((Not InStr(1, objFil.Name, \"$\") > 1) And _\n (Not InStr(1, objFil.Name, \"~\") > 1) And _\n (objFil.Name <> ThisWorkbook.Name) And _\n InStr(1, objFil.Name, \"xls\") > 1) Then\n \n Set objWb = Workbooks.Open(objFil.Path)\n Application.StatusBar = objFil.Name\n \n For lngCounter = objWb.Worksheets.Count To 1 Step -1\n If UCase(Left(objWb.Worksheets(lngCounter).Name, Len(strNameToDelete))) = strNameToDelete Then\n strNameDeleted = objWb.Worksheets(lngCounter).Name\n objWb.Worksheets(lngCounter).Delete\n strTextSummary = strTextSummary & objWb.Name & vbCrLf & vbTab & strNameDeleted & vbCrLf\n End If\n Next lngCounter\n \n objWb.Close True\n \n End If\n Next objFil\n \n CreateLogFile\n Call OnEnd\n \nEnd Sub\n \nFunction WorksheetExists(sheetName As String) As Boolean\n \n WorksheetExists = Not WorksheetFunction.IsErr(Evaluate(\"'\" & sheetName & \"'!A1\"))\n \nEnd Function\n\n" }, { "path": "Formatting/Rgb2HtmlColor.vb", "content": "Option Explicit\n'RGB2HTMLColor html htmlcolor\n'INPUT: Numeric (Base 10) Values for R, G, and B)\n'OUTPUT:\n'String to be used for color of element in VBA.\n'E.G -> if the color is like this:-> &H80000005&\n'we should change just the last 6 positions to get our color! H80 must stay.\n\nPublic Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String\n\n Dim HexR As Variant, HexB As Variant, HexG As Variant\n Dim sTemp As String\n\n On Error GoTo ErrorHandler\n\n 'R\n HexR = Hex(R)\n If Len(HexR) < 2 Then HexR = \"0\" & HexR\n\n 'Get Green Hex\n HexG = Hex(G)\n If Len(HexG) < 2 Then HexG = \"0\" & HexG\n\n HexB = Hex(B)\n If Len(HexB) < 2 Then HexB = \"0\" & HexB\n\n RGB2HTMLColor = HexR & HexG & HexB\n Debug.Print \"Enter RGB, without caring for the real colors, the function knows what it is doing.\"\n Debug.Print \"IF 50D092 then &H0050D092&\"\n\n Exit Function\n \nErrorHandler:\n Debug.Print \"RGB2HTMLColor was not successful\"\nEnd Function\n\nSub GetHexFromInteriorCell()\n\n Worksheets(1).Cells(1, \"A\").Interior.Color = vbYellow\n Debug.Print Hex(Worksheets(1).Cells(1, \"A\").Interior.Color) 'FFFF\n Debug.Print Worksheets(1).Cells(1, \"A\").Interior.Color '65535\n\n Dim hexColor As String\n hexColor = Right(\"000000\" & Hex(Worksheets(1).Cells(1, \"A\").Interior.Color), 6)\n\n Debug.Print HexToRgb(hexColor) 'FFFF00\n\nEnd Sub\n\nPublic Function HexToRgb(hexColor As String) As String\n\n Dim red As String\n Dim green As String\n Dim blue As String\n\n red = Left(hexColor, 2)\n green = Mid(hexColor, 3, 2)\n blue = Right(hexColor, 2)\n\n HexToRgb = blue & green & red\n\nEnd Function\n" }, { "path": "Formatting/SetPrintArea.vb", "content": "Public Sub SetPrintArea()\n\n Dim r_print_range As Range\n \n Set r_print_range = tbl_plan.Range(Cells(1, 1), Cells(obj_plan.LastLine, obj_cal.RightColPosition))\n \n With tbl_plan.PageSetup\n .LeftHeader = \"\"\n .CenterHeader = \"&\"\"Calibri,bold\"\"&25\" & \"Ankaufsunterlagen\"\n \n .PrintArea = r_print_range.Address\n .FitToPagesWide = 1\n .FitToPagesTall = 1\n .Orientation = xlLandscape\n \n End With\n \nEnd Sub\n" }, { "path": "Formatting/Shapes.vb", "content": "Option Explicit\n\nSub ShapeNames()\n Dim sh_shape As shape\n \n For Each sh_shape In ActiveSheet.Shapes\n Debug.Print sh_shape.Name\n Next sh_shape\n \nEnd Sub\n\nPublic Sub GetSomething(str_something As String)\n \n ActiveSheet.Shapes(str_something).Select\n\nEnd Sub\n\n\n'Makes shape visible and invisble.\nSub translatorField_Klicken()\n\n Dim blnEnglish As Boolean\n Dim rngRange As Range\n Dim myShape As shape\n\n Set myShape = tblInput.Shapes(\"translatorField\")\n Set rngRange = tblSettings.Cells(2, 2)\n\n blnEnglish = Not CBool(rngRange)\n tblSettings.Cells(2, 2) = blnEnglish\n\n If blnEnglish Then\n\n tblInput.[h1].value = tblSettings.[i1].value\n\n With myShape.Fill\n .ForeColor.RGB = RGB(0, 0, 0)\n .Transparency = 1\n End With\n\n With myShape.TextFrame2.TextRange.Characters(1, 66).Font.Fill\n .ForeColor.RGB = RGB(255, 255, 255)\n .Transparency = 1\n End With\n\n Else\n\n tblInput.[h1].value = tblSettings.[c1].value\n\n With myShape.Fill\n .ForeColor.RGB = RGB(255, 255, 255)\n .Transparency = 0\n End With\n\n With myShape.TextFrame2.TextRange.Characters(1, 66).Font.Fill\n .ForeColor.RGB = RGB(0, 0, 0)\n .Transparency = 0\n End With\n\n End If\n\nEnd Sub\n\n'---------------------------------------------------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------------------------------------------------\n'---------------------------------------------------------------------------------------------------------------------------------\n\nOption Explicit\n\nSub TestMe()\n\n Dim shp As Shape\n Dim arrOfShapes() As Variant\n\n With ActiveSheet\n For Each shp In .Shapes\n If InStrB(shp.Name, \"Rec\") > 0 Then\n arrOfShapes = incrementArray(arrOfShapes, shp.Name)\n End If\n Next\n If IsArrayAllocated(arrOfShapes) Then\n Debug.Print .Shapes.Range(arrOfShapes(0)).Name\n .Shapes.Range(arrOfShapes).Delete\n End If\n End With\nEnd Sub\n\n\nPublic Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant\n\n Dim cnt As Long\n Dim arrNew As Variant\n\n If IsArrayAllocated(arrOfShapes) Then\n ReDim arrNew(UBound(arrOfShapes) + 1) \n For cnt = LBound(arrOfShapes) To UBound(arrOfShapes)\n arrNew(cnt) = CStr(arrOfShapes(cnt))\n Next cnt\n arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape)\n Else\n arrNew = Array(nameOfShape)\n End If\n\n incrementArray = arrNew\n\nEnd Function\n\nFunction IsArrayAllocated(Arr As Variant) As Boolean\n On Error Resume Next\n IsArrayAllocated = IsArray(Arr) And _\n Not IsError(LBound(Arr, 1)) And _\n LBound(Arr, 1) <= UBound(Arr, 1)\n\nEnd Function\nCredits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated().\n\n" }, { "path": "Formatting/Shortcuts/README.md", "content": "# VBA Shortcusts\n\nHere are the shortcuts, that I use mainly in VBA.\nI have used the structure of [CPearson](http://www.cpearson.com/excel/vbashortcutkeys.htm) and I have added some more, that I consider valuable.\n\n| Key | Alone | Shift | Ctrl | Alt | Shift Ctrl |\n|----------------------|-----------------------|-------------------------|---------------------------|-------------------------------|-------------------------|\n| F1 | Help | | | | |\n| F2 | Object Browser | Procedure Definition | Focus To Object Box | | Previous Position |\n| F3 | Copy | Find Prev | | | |\n| F4 | Properies Window | Find Next | Close Window | Close VBE | |\n| F5 | Run | | | Run Error Handler | |\n| F6 | Switch Split Windows | | | Switch Between Last 2 Windows | |\n| F7 | Goto Window Of Object | With UF | | Step Error Handler | |\n| F8 | Step | Procedure Step | Run To Cursor | | Go Upstairs |\n| F9 | Breakpoint | Quick Watch | Drag to cursor | | Clear All Breakpoints |\n| F10 | Activate Menu Bar | Show Right Click Menu | Activate Menu Bar | | |\n| F11 | | | | Return To Application | |\n| A | Normal Characters | | | Add-Ins Menu | |\n| B | | | Select All Text | | |\n| C | | | Copy | | |\n| D | | | | Debug Menu | |\n| E | | | Export Module | Edit Menu | |\n| F | | | Find | File Menu | |\n| G | | | Immediate Window | | |\n| H | | | Replace | Help Menu | |\n| I | | | Turn On Quick Info | | Turn On Param Info |\n| J | | | List Members | Insert Menu | Turn On List Properties |\n| L | | | Show Call Stack | | |\n| M | | | Import File | | |\n| N | | | New Line | | |\n| O | | | | Format Menu | |\n| P | | | Print | | |\n| Q | | | | Close & Return | |\n| R | | | Project Window | Run Menu | |\n| S | | | Save | | |\n| T | | | Show Available Components | Tools Menu | |\n| V | | | Paste | View Menu | |\n| W | | | | Window Menu | |\n| Y | | | Cut Entire Line | | |\n| Insert | Toggle Insert Mode | Paste | Copy | | |\n| Delete | Delete | | Delete To End Of Word | | |\n| Home | Beginning Of Line | Select To Start Of Line | Top Of Module | | |\n| End | End Of Line | Select To End Of Line | End Of Module | | |\n| Page Up | Page Up | Select To Top Of Module | Top Of Current Procedure | | |\n| Page Down | Page Down | Select To End Of Module | End Of Current Procedure | | |\n| ↑ | Up | Extend Selection Up | Previous Procedure | | |\n| ↓ | Down | Extend Selection Down | Next Procedure | | |\n| Space Bar | | | Turn On Complete Word | System Menu | |\n| Tab | Indent | Un-indent | Cycle Windows | Cycle Applications | |\n| Enter | New Line | | | | |\n| BackSpace | Delete Prev Char | | Delete To Start Of Word | Undo | |\n| Application.SendKeys | | + | ^ | % | %^ |\n| Specials in Excel | | | | | |\n| | Alt | vitoshacademy.com | | | |\n| 0178 | m² | | | | |\n| 0128 | € | | | | |\n| 0216 | Ø | | | | |\n| 24-28 | ↑ ↓ → ← | | | | |\n| Excel | | | | | |\n| F2 | | | Print properties | | |\n| F3 | | | Names | | |\n| F9 | | | Maximize Window | | |\n| F10 | | | Minimize Window | | |\n| F11 | | | Add Tab | | |\n| F12 | | | Open File | | |\n| Visual Studio | | | | | |\n| Ctrl + K + C | Comment | | | | |\n| Ctrl + K + U | Uncomment | | | | |\n| Ctrl + K + F | Indent | | | | |\n| F10 | Next step | | | | |\n| Ctrl + F11 | Run to line | | | | |\n\nGood luck, have fun from [VitoshAcademy](http://www.vitoshacademy.com) :cactus::beer:\n" }, { "path": "Formatting/SplitValuesSingleColumnToCells.vb", "content": "Option Explicit\n\nPublic Sub SplitSingleColumnToCells()\n\n Dim rngInput As Range\n Dim rngOutput As Range\n Dim myCell As Range\n\n 'Set manually, it is faster :)\n Set rngInput = Range(\"A1:A22\")\n\n For Each myCell In rngInput\n 'replace multiple space with single space:\n myCell = Replace(myCell, Chr(32), Chr(32))\n Dim inputArray As Variant\n inputArray = Split(myCell)\n\n Dim col As Long\n Dim i As Long\n col = 0\n For i = LBound(inputArray) To UBound(inputArray)\n If Len(inputArray(i)) > 0 Then\n col = col + 1\n myCell.Offset(0, col) = inputArray(i)\n End If\n Next i\n 'Probably not needed:\n 'myCell.Clear\n Next myCell\nEnd Sub\n" }, { "path": "Formatting/StyleKiller.vb", "content": "Option Explicit\n\nSub StyleKiller()\n\n Dim myStyle As Style\n Dim lngCounter As Long\n \n For Each myStyle In ThisWorkbook.Styles \n \n If Not myStyle.BuiltIn Then\n Debug.Print myStyle.name\n myStyle.Delete\n lngCounter = lngCounter + 1\n End If\n Next myStyle\n \n Debug.Print \"Ende\"\n Debug.Print \"Deleted \" & lngCounter\n \nEnd Sub\n\n'FANCY ONE:\n'**************************************************************************************\nSub RemoveTheStyles()\n\n Dim style As style\n Dim l_counter As Long\n Dim l_total_number As Long\n\n On Error Resume Next\n\n l_total_number = ActiveWorkbook.Styles.Count\n Application.ScreenUpdating = False\n\n For l_counter = l_total_number To 1 Step -1\n \n Set style = ActiveWorkbook.Styles(l_counter)\n \n If (l_counter Mod 500 = 0) Then\n DoEvents\n Application.StatusBar = \"Deleting \" & l_total_number - l_counter + 1 & \" of \" & l_total_number & \" \" & style.Name\n End If\n \n If Not style.BuiltIn Then style.Delete\n\n Next l_counter\n\n Application.ScreenUpdating = True\n Application.StatusBar = False\n Debug.Print \"READY!\"\n \n On Error GoTo 0\nEnd Sub\n\n\n'https://support.microsoft.com/en-us/help/291321/how-to-programmatically-reset-a-workbook-to-default-styles\nSub RebuildDefaultStyles()\n\n'The purpose of this macro is to remove all styles in the active\n'workbook and rebuild the default styles.\n'It rebuilds the default styles by merging them from a new workbook.\n\n'Dimension variables.\n Dim MyBook As Workbook\n Dim tempBook As Workbook\n Dim CurStyle As Style\n\n 'Set MyBook to the active workbook.\n Set MyBook = ActiveWorkbook\n On Error Resume Next\n 'Delete all the styles in the workbook.\n For Each CurStyle In MyBook.Styles\n 'If CurStyle.Name <> \"Normal\" Then CurStyle.Delete\n Select Case CurStyle.Name\n Case \"20% - Accent1\", \"20% - Accent2\", _\n \"20% - Accent3\", \"20% - Accent4\", \"20% - Accent5\", \"20% - Accent6\", _\n \"40% - Accent1\", \"40% - Accent2\", \"40% - Accent3\", \"40% - Accent4\", _\n \"40% - Accent5\", \"40% - Accent6\", \"60% - Accent1\", \"60% - Accent2\", _\n \"60% - Accent3\", \"60% - Accent4\", \"60% - Accent5\", \"60% - Accent6\", _\n \"Accent1\", \"Accent2\", \"Accent3\", \"Accent4\", \"Accent5\", \"Accent6\", _\n \"Bad\", \"Calculation\", \"Check Cell\", \"Comma\", \"Comma [0]\", \"Currency\", _\n \"Currency [0]\", \"Explanatory Text\", \"Good\", \"Heading 1\", \"Heading 2\", _\n \"Heading 3\", \"Heading 4\", \"Input\", \"Linked Cell\", \"Neutral\", \"Normal\", _\n \"Note\", \"Output\", \"Percent\", \"Title\", \"Total\", \"Warning Text\"\n 'Do nothing, these are the default styles\n Case Else\n CurStyle.Delete\n End Select\n\n Next CurStyle\n\n 'Open a new workbook.\n Set tempBook = Workbooks.Add\n\n 'Disable alerts so you may merge changes to the Normal style\n 'from the new workbook.\n Application.DisplayAlerts = False\n\n 'Merge styles from the new workbook into the existing workbook.\n MyBook.Styles.Merge Workbook:=tempBook\n\n 'Enable alerts.\n Application.DisplayAlerts = True\n\n 'Close the new workbook.\n tempBook.Close\n\nEnd Sub\n" }, { "path": "Internet/AmazonInternet.bas", "content": "Attribute VB_Name = \"AmazonInternet\"\nOption Explicit\n\nPublic Function PageWithResultsExists(appIE As Object, keyword As String) As Boolean\n\n On Error GoTo PageWithResultsExists_Error\n \n Dim allData As Object\n Set allData = appIE.document.getElementById(\"s-results-list-atf\")\n PageWithResultsExists = True\n IeErrors = 0\n \n On Error GoTo 0\n Exit Function\n\nPageWithResultsExists_Error:\n \n WaitSomeMilliseconds\n IeErrors = IeErrors + 1\n \n Select Case Err.Number\n \n Case 424\n \n If IeErrors > MAX_IE_ERRORS Then\n PageWithResultsExists = False\n IeErrors = 0\n Else\n LogMe \"PageWithResultsExists\", IeErrors, keyword, IeErrors\n PageWithResultsExists appIE, keyword\n End If\n Case Else\n Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext\n End Select\n \nEnd Function\n\nPublic Function MakeUrl(i As Long, keyword As String) As String\n\n MakeUrl = \"https://www.amazon.com/s/ref=sr_pg_\" & i & \"?rh=i%3Aaps%2Ck%3A\" & keyword & \"&page=\" & i & \"&keywords=\" & keyword\n\nEnd Function\n\nPublic Sub Navigate(i As Long, appIE As Object, keyword As String)\n \n Do While appIE.Busy\n DoEvents\n Loop\n \n With appIE\n .Navigate MakeUrl(i, keyword)\n .Visible = False\n End With\n \n Do While appIE.Busy\n DoEvents\n Loop\n \nEnd Sub\n" }, { "path": "Internet/ConstValues.bas", "content": "Attribute VB_Name = \"ConstValues\"\nOption Explicit\n\nPublic IeErrors As Long\nPublic Const MAX_IE_ERRORS = 10\nPublic Const IN_PRODUCTION = False\n" }, { "path": "Internet/ExcelRelated.bas", "content": "Attribute VB_Name = \"ExcelRelated\"\nOption Explicit\n\nPublic Function GetNextKeyWord() As String\n \n With tblInput\n Dim lastRowB As Long\n lastRowB = lastRow(.Name, 2) + 1\n GetNextKeyWord = Trim(.Cells(lastRowB, 1))\n If Len(GetNextKeyWord) <> 0 Then .Cells(lastRowB, 2) = Now\n End With\n \nEnd Function\n\nPublic Sub WriteFormulas()\n \n Dim i As Long\n With tblInput\n For i = lastRow(.Name) To 2 Step -1\n .Cells(i, 3).FormulaR1C1 = \"=COUNTIF(Summary!C[1],Input!RC[-2])\"\n \n .Cells(i, 4).FormulaArray = \"=MAX(IF(Summary!C=RC[-3],Summary!C[-1]))\"\n FormatUSD .Cells(i, 4)\n \n .Cells(i, 5).FormulaArray = \"=AVERAGE(IF(Summary!C[-1]=Input!RC[-4],Summary!C[-2]))\"\n FormatUSD .Cells(i, 5)\n Next i\n End With\n \nEnd Sub\n\nPublic Sub FixWorksheets()\n OnStart\n With tblInput\n .Range(\"B1\") = \"Start Time\"\n .Range(\"C1\") = \"Count\"\n .Range(\"D1\") = \"Max\"\n .Range(\"E1\") = \"Average\"\n End With\n \n With tblSummary\n .Range(\"A1\") = \"Title\"\n .Range(\"B1\") = \"Author\"\n .Range(\"C1\") = \"Price\"\n .Range(\"D1\") = \"Keyword\"\n End With\n \n Dim ws As Worksheet\n For Each ws In Worksheets\n ws.Columns.AutoFit\n Next ws\n OnEnd\nEnd Sub\n\nPublic Sub FormatUSD(myRange As Range)\n\n myRange.NumberFormat = \"_-[$$-409]* #,##0.00_ ;_-[$$-409]* -#,##0.00 ;_-[$$-409]* \"\"-\"\"??_ ;_-@_ \"\n\nEnd Sub\n\n \nPublic Sub CleanWorksheets()\n\n tblRawData.Cells.Delete\n tblSummary.Cells.Delete\n tblInput.Columns(\"B:F\").Delete\n \nEnd Sub\n\nPublic Function GetNthString(n As Long, myRange As Range) As String\n \n Dim i As Long\n Dim myVar As Variant\n \n myVar = Split(myRange, vbCrLf)\n For i = LBound(myVar) To UBound(myVar)\n If Len(myVar(i)) > 0 And n = 0 Then\n GetNthString = myVar(i)\n Exit Function\n ElseIf Len(myVar(i)) > 0 Then\n n = n - 1\n End If\n Next i\n \nEnd Function\n\n\nPublic Function GetPrice(myRange As Range) As String\n \n Dim i As Long\n Dim myVar As Variant\n myVar = Split(myRange, \"$\")\n \n If UBound(myVar) > 0 Then\n GetPrice = Mid(myVar(1), 1, InStr(1, myVar(1), \" \"))\n Else\n GetPrice = \"\"\n End If\n \nEnd Function\n\nPublic Sub WriteToExcel(appIE As Object, keyword As String)\n\n If IN_PRODUCTION Then On Error GoTo WriteToExcel_Error\n \n Dim allData As Object\n Set allData = appIE.document.getElementById(\"s-results-list-atf\")\n \n Dim book As Object\n Dim myRow As Long\n \n For Each book In allData.getElementsByClassName(\"a-fixed-left-grid-inner\")\n With tblRawData\n myRow = lastRow(.Name) + 1\n On Error Resume Next\n .Cells(myRow, 1) = book.innertext\n .Cells(myRow, 2) = keyword\n On Error GoTo 0\n End With\n Next\n \n IeErrors = 0\n \n On Error GoTo 0\n Exit Sub\n\nWriteToExcel_Error:\n\n IeErrors = IeErrors + 1\n \n If IeErrors > MAX_IE_ERRORS Then\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure WriteToExcel, line \" & Erl & \".\"\n Else\n LogMe \"WriteToExcel\", IeErrors, keyword, IeErrors\n WriteToExcel appIE, keyword\n End If\n \nEnd Sub\n\nPublic Sub RawDataToStructured(keyword As String, firstRow As Long)\n \n Dim i As Long\n For i = firstRow To lastRow(tblRawData.Name)\n With tblRawData\n If InStr(1, .Cells(i, 1), \"Sponsored \") < 1 Then\n Dim title As String\n title = GetNthString(0, .Cells(i, 1))\n Dim author As String\n author = GetNthString(1, .Cells(i, 1))\n Dim price As String\n price = GetPrice(.Cells(i, 1))\n If Not IsNumeric(price) Or price = \"0\" Then price = \"\"\n Dim currentRow As String: currentRow = lastRow(tblSummary.Name) + 1\n With tblSummary\n .Cells(currentRow, 1) = title\n .Cells(currentRow, 2) = author\n .Cells(currentRow, 3) = price\n .Cells(currentRow, 4) = keyword\n End With\n End If\n End With\n Next i\n\nEnd Sub\n\nPublic Function lastRow(wsName As String, Optional columnToCheck As Long = 1) As Long\n\n Dim ws As Worksheet\n Set ws = Worksheets(wsName)\n lastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row\n\nEnd Function\n\n\n" }, { "path": "Internet/General.bas", "content": "Attribute VB_Name = \"General\"\nOption Explicit\n\nPublic Declare PtrSafe Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As LongPtr)\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.AskToUpdateLinks = True\n Application.DisplayAlerts = True\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n \n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub OnStart()\n \n Application.ScreenUpdating = False\n Application.EnableEvents = False\n Application.AskToUpdateLinks = False\n Application.DisplayAlerts = False\n Application.Calculation = xlAutomatic\n ThisWorkbook.Date1904 = False\n \n ActiveWindow.View = xlNormalView\n\nEnd Sub\n\nPublic Sub LogMe(ParamArray arg() As Variant)\n\n Debug.Print Join(arg, \"--\")\n \nEnd Sub\n\nPublic Sub PrintMeUsefulFormula()\n\n Dim strFormula As String\n Dim strParenth As String\n\n strParenth = \"\"\"\"\n\n strFormula = Selection.FormulaR1C1\n \n strFormula = Replace(strFormula, \"\"\"\", \"\"\"\"\"\")\n\n strFormula = strParenth & strFormula & strParenth\n Debug.Print strFormula\n \nEnd Sub\n\nPublic Sub WaitSomeMilliseconds(Optional Milliseconds As Long = 1000)\n Sleep Milliseconds\nEnd Sub\n" }, { "path": "Internet/GotoInternet.vb", "content": "Public Sub Clicked(Optional b_logo As Boolean = False)\n\n Dim ie As Object\n Dim s_WebSites() As Variant\n \n On Error GoTo Clicked_Error\n\n If b_logo Then\n \n s_WebSites = Array(\"https://www.facebook.com\", _\n \"https://plus.google.com\", _\n \"http://www.youtube.com\")\n Else\n s_WebSites = Array(\"http://www.hoai.de/online/hoai_rechner\")\n End If\n \n' s_WebSites = Array(\"https://goo.gl/c3Gzqi\", _\n' \"https://goo.gl/JKvYR6\", _\n' \"https://goo.gl/eLuMFN\", _\n' \"https://goo.gl/r2OMeQ\")\n \n Set ie = CreateObject(\"Internetexplorer.Application\")\n ie.Visible = True\n ie.Navigate s_WebSites(make_random(0, UBound(s_WebSites)))\n\n Exit Sub\n\n On Error GoTo 0\n Exit Sub\n\nClicked_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Clicked of Module mod_main\"\n \nEnd Sub\n \n\nPublic Function CheckUrlExists(url) As Boolean\n \n On Error GoTo CheckUrlExists_Error\n \n Dim xmlhttp As Object\n Set xmlhttp = CreateObject(\"MSXML2.XMLHTTP\")\n \n xmlhttp.Open \"HEAD\", url, False\n xmlhttp.send\n \n If xmlhttp.Status = 200 Then\n CheckUrlExists = True\n Else\n CheckUrlExists = False\n End If\n \n Exit Function\n \nCheckUrlExists_Error:\n CheckUrlExists = False\n \nEnd Function\n" }, { "path": "Internet/README.md", "content": "This is the code from the article here:\n\nhttp://www.vitoshacademy.com/vba-data-scraping-from-internet-with-excel-part-2/\n\nSome time ago I wrote an article for Data scraping from Internet with Excel, which was scraping book information from amazon.com, based on a given word. The code was 25 lines, thus it had some points for improvement. Thus, I have decided to make something bigger out of it with some additional options:\n\n- writing it to Excel, instead of printing to the immediate window\n- getting the prices of the books\n- scraping multiple titles\n- creating some user interface and reporting\n- analyzing the data\n\n:cactus:\n" }, { "path": "Internet/StartUp.bas", "content": "Attribute VB_Name = \"StartUp\"\nOption Explicit\n\nPublic Sub Main()\n\n If IN_PRODUCTION Then On Error GoTo Main_Error\n \n CleanWorksheets\n Dim keyword As String: keyword = GetNextKeyWord\n \n While keyword <> \"\"\n \n Dim appIE As Object\n Set appIE = CreateObject(\"InternetExplorer.Application\")\n LogMe keyword\n Dim nextPageExists As Boolean: nextPageExists = True\n Dim i As Long: i = 1\n Dim firstRow As Long: firstRow = lastRow(tblRawData.Name) + 1\n \n While nextPageExists\n \n WaitSomeMilliseconds\n Navigate i, appIE, keyword\n nextPageExists = PageWithResultsExists(appIE, keyword)\n If nextPageExists Then WriteToExcel appIE, keyword\n i = i + 1\n \n Wend\n \n LogMe Time, keyword, \"RawDataToStructured\"\n RawDataToStructured keyword, firstRow\n keyword = GetNextKeyWord\n WaitSomeMilliseconds 4000\n appIE.Quit\n \n Wend\n \n FixWorksheets\n WriteFormulas\n \n LogMe \"Program has ended!\"\n \n On Error GoTo 0\n Exit Sub\n\nMain_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Main, line \" & Erl & \".\"\n\nEnd Sub\n" }, { "path": "OOP/AttributesInVBA/CarGlobal.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"CarGlobal\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate m_sModel As String\nPrivate m_Price As Currency\n\nPrivate Sub Class_Initialize()\n \n Model = \"Global nice model\"\n Price = 200\n \nEnd Sub\n\nPublic Property Get Model() As String\n\n Model = m_sModel\n\nEnd Property\n\nPublic Property Let Model(ByVal sNewValue As String)\n\n m_sModel = sNewValue\n\nEnd Property\n\nPublic Property Get Price() As Currency\n\n Price = m_Price\n\nEnd Property\n\nPublic Property Let Price(ByVal NewValue As Currency)\n\n m_Price = NewValue\n\nEnd Property\n\nPublic Function ChangePrice(newPrice As Currency) As Currency\n \n Price = Price + newPrice\n ChangePrice = Price\n \nEnd Function\n" }, { "path": "OOP/AttributesInVBA/CarWithDefaultProperty.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"CarWithDefaultProperty\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate m_sModel As String\nPrivate m_Price As Currency\n\nPrivate Sub Class_Initialize()\n \n Model = \"Car with default property model\"\n Price = 2000\n \nEnd Sub\n\nPublic Property Get Model() As String\n\n Model = m_sModel\n\nEnd Property\n\nPublic Property Let Model(ByVal sNewValue As String)\n\n m_sModel = sNewValue\n\nEnd Property\n\nPublic Property Get Price() As Currency\nAttribute Price.VB_Description = \"Some nice description should be here.\"\nAttribute Price.VB_UserMemId = 0\n\n Price = m_Price\n\nEnd Property\n\nPublic Property Let Price(ByVal NewValue As Currency)\n\n m_Price = NewValue\n\nEnd Property\n\nPublic Function ChangePrice(newPrice As Currency) As Currency\n \n Price = Price + newPrice\n ChangePrice = Price\n \nEnd Function\n\n" }, { "path": "OOP/AttributesInVBA/ExportModule.bas", "content": "Attribute VB_Name = \"ExportModule\"\n'---------------------------------------------------------------------------------------\n' File : ExportModule\n' Author : v.doynov\n' Date : 13.12.2017\n' Purpose: Run `ExportAll` to export all the VBE code w/o the worksheets.\n' Add `Microsoft Visual Basic for Applications Extensibility 5.3 library`\n' to run it.\n'---------------------------------------------------------------------------------------\n\nOption Explicit\n\nPublic Sub ExportAndDelete()\n \n Dim sourceFile As String\n sourceFile = \"C:\\Users\\v.doynov\\Desktop\\NeuerOrdner\\\"\n \n If Right(sourceFile, 1) <> \"\\\" Then\n MsgBox \"Make sure that you have \"\"\\\"\"\"\n Exit Sub\n End If\n\n Kill sourceFile & \"*.*\"\n ExportSourceFiles (sourceFile)\n \nEnd Sub\n\nPublic Sub ExportSourceFiles(destPath As String)\n\n Dim component As VBComponent\n \n For Each component In Application.VBE.ActiveVBProject.VBComponents\n If component.Type = vbext_ct_ClassModule Or component.Type = vbext_ct_StdModule Then\n component.Export destPath & component.Name & ToFileExtension(component.Type)\n End If\n Next\n\nEnd Sub\n\nPrivate Function ToFileExtension(vbeComponentType As vbext_ComponentType) As String\n Select Case vbeComponentType\n Case vbext_ComponentType.vbext_ct_ClassModule\n ToFileExtension = \".cls\"\n Case vbext_ComponentType.vbext_ct_StdModule\n ToFileExtension = \".bas\"\n Case vbext_ComponentType.vbext_ct_MSForm\n ToFileExtension = \".frm\"\n Case vbext_ComponentType.vbext_ct_ActiveXDesigner\n Case vbext_ComponentType.vbext_ct_Document\n Case Else\n ToFileExtension = vbNullString\n End Select\nEnd Function\n" }, { "path": "OOP/AttributesInVBA/MainModule.bas", "content": "Attribute VB_Name = \"MainModule\"\nOption Explicit\n\nPublic Sub Main()\n \n 'Because of\n ' Attribute VB_PredeclaredId = True\n 'we can refer to CarGlobal without initialization:\n\n Debug.Print CarGlobal.Price\n Debug.Print CarGlobal.Model\n Debug.Print CarGlobal.ChangePrice(100)\n Debug.Print CarGlobal.Price\n \n 'Because of\n ' Attribute Value.VB_Description = \"\"\n ' Attribute Value.VB_UserMemId = 0\n 'the car has a a default property Price and it has description in the VBEditor\n \n Dim car As New CarWithDefaultProperty\n Debug.Print car\n \n 'Because of\n ' Attribute Value.VB_UserMemId = 0\n ' Attribute Value.VB_Description = \"Increases the price with 10. It is the default.\"\n\n Dim truck As New TruckWithDefaultProcedure\n Debug.Print truck.Price\n truck\n truck\n Debug.Print truck.Price\n \nEnd Sub\n" }, { "path": "OOP/AttributesInVBA/ReadMe.md", "content": "## VBTricks\n
\n3 classes are in the sample:\n\n - with a default property (CarWithDefaultPropery.cls)\n - with a default procedure (TruckWithDefaultProcedure.cls)\n - with a non required initialization (CarGlobal.cls)\n - automatic export of everything but the worksheets to a set up file\n\nWith courtesy to:\n - http://www.stackoverflow.com\n - https://christopherjmcclellan.wordpress.com/2015/04/21/vb-attributes-what-are-they-and-why-should-we-use-them\n - http://www.cpearson.com/excel/vbe.aspx\n\n" }, { "path": "OOP/AttributesInVBA/TruckWithDefaultProcedure.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"TruckWithDefaultProcedure\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate m_sModel As String\nPrivate m_Price As Currency\n\nPrivate Sub Class_Initialize()\n \n Model = \"Some truck model\"\n Price = 250\n \nEnd Sub\n\nPublic Property Get Model() As String\n\n Model = m_sModel\n\nEnd Property\n\nPublic Property Let Model(ByVal sNewValue As String)\n\n m_sModel = sNewValue\n\nEnd Property\n\n\nPublic Property Get Price() As Currency\n\n Price = m_Price\n\nEnd Property\n\nPublic Property Let Price(ByVal NewValue As Currency)\n\n m_Price = NewValue\n\nEnd Property\n\nPublic Function IncreasePriceWith10()\nAttribute IncreasePriceWith10.VB_Description = \"Increases the price with 10. It is the default.\"\nAttribute IncreasePriceWith10.VB_UserMemId = 0\n Price = Price + 10\n Debug.Print \"The price is now \" & Price\nEnd Function\n" }, { "path": "OOP/CopyObjectInVBA/Employee.cls.txt", "content": "Option Explicit\n\nPrivate Memento As MyMemento\n\nFriend Sub SetMemento(NewMemento As MyMemento)\n Memento = NewMemento\nEnd Sub\n\nPublic Function Copy() As Employee\n Dim Result As Employee\n Set Result = New Employee\n \n Result.SetMemento Memento\n Set Copy = Result\n \nEnd Function\n\nPublic Property Get Salary() As Double\n Salary = Memento.Salary\nEnd Property\n\nPublic Property Let Salary(value As Double)\n Memento.Salary = value\nEnd Property\n\nPublic Property Get Age() As Long\n Age = Memento.Age\nEnd Property\n\nPublic Property Let Age(value As Long)\n Memento.Age = value\nEnd Property\n\nPublic Property Get RelevantExperience() As Long\n RelevantExperience = Memento.RelevantExperience\nEnd Property\n\nPublic Property Let RelevantExperience(value As Long)\n Memento.RelevantExperience = value\nEnd Property\n\n\n" }, { "path": "OOP/CopyObjectInVBA/MainModule.vb.txt", "content": "Option Explicit\n\nType MyMemento\n Salary As Double\n Age As Long\n RelevantExperience As Long\nEnd Type\n\nSub Main()\n\n Dim newEmp As Employee\n Dim oldEmp As Employee\n \n Set newEmp = New Employee\n With newEmp\n .Salary = 100\n .Age = 22\n .RelevantExperience = 1\n End With\n \n Set oldEmp = newEmp.Copy\n With oldEmp\n 'Salary is inherited, thus the same\n .Age = 99\n .RelevantExperience = 10\n End With\n \n Debug.Print \"Salary\"; vbCrLf; newEmp.Salary, oldEmp.Salary\n Debug.Print \"Experience\"; vbCrLf; newEmp.RelevantExperience, oldEmp.RelevantExperience\n Debug.Print \"Age\"; vbTab; vbCrLf; newEmp.Age, oldEmp.Age\n\nEnd Sub\n\n" }, { "path": "OOP/CopyObjectInVBA/ReadMe.md", "content": "Files for article in [VitoshAcademy](https://www.vitoshacademy.com):\n\nVBA – How to copy a new object in VBA, without copying its reference\n\nhttps://www.vitoshacademy.com/vba-how-to-copy-a-new-object-in-vba-without-copying-its-reference/\n\n\n:cactus::kiss:\n" }, { "path": "OOP/DictionaryAndArray/CollectionToArray.vb", "content": "Public Function CollectionToArray(myCol As Collection) As Variant\n\n Dim result As Variant\n Dim cnt As Long\n \n If myCol.Count = 0 Then\n CollectionToArray = Array()\n Exit Function\n End If\n \n ReDim result(myCol.Count - 1)\n For cnt = 0 To myCol.Count - 1\n result(cnt) = myCol(cnt + 1)\n Next cnt\n CollectionToArray = result\n\nEnd Function\n" }, { "path": "OOP/DictionaryAndArray/DictionaryExample.vb", "content": "Sub MyDictionary()\n \n 'Add\n Dim myDict As New Scripting.Dictionary\n myDict.Add \"Peter\", \"Peter is a friend.\"\n myDict.Add \"George\", \"George is a guy I know.\"\n myDict.Add \"Salary\", 1000\n \n 'Exists\n If myDict.Exists(\"Salary\") Then\n Debug.Print myDict(\"Salary\")\n myDict(\"Salary\") = myDict(\"Salary\") * 2\n Debug.Print myDict(\"Salary\")\n End If\n \n 'Remove\n If myDict.Exists(\"George\") Then\n myDict.Remove (\"George\")\n End If\n \n 'Items\n Dim item As Variant\n For Each item In myDict.Items\n Debug.Print item\n Next item\n \n 'Keys\n Dim key As Variant\n For Each key In myDict.Keys\n Debug.Print key\n Next key\n \n 'Remove All\n myDict.RemoveAll\n \n 'Compare Mode\n myDict.CompareMode = BinaryCompare\n \n myDict.Add \"PeTeR\", \"Peter written as PeTeR\"\n myDict.Add \"PETeR\", \"Peter written as PETeR\"\n PrintDictionary myDict\n \nEnd Sub\n\n\nPublic Sub PrintDictionary(myDict As Object)\n \n Dim key As Variant\n For Each key In myDict.Keys\n Debug.Print key; \"-->\"; myDict(key)\n Next key\n \nEnd Sub\n\nPublic Sub NestedDictionaryExample()\n \n Dim outer As Dictionary\n Dim inner As Dictionary\n \n Set outer = New Dictionary\n \n Dim i As Long\n For i = 1 To 10\n Set inner = New Dictionary\n inner.Add 10 * i, \"first\" & i\n inner.Add 100 * i, \"second\" & i\n inner.Add 1000 * i, \"third\" & i\n outer.Add i, inner\n Next i\n \n Dim innerKey As Variant\n Dim outerKey As Variant\n \n For Each outerKey In outer.Keys\n Debug.Print \"Outer key:\"; outerKey\n Debug.Print \"Inner key: value\"\n 'PrintDictionary outer(outerKey)\n \n For Each innerKey In outer(outerKey)\n Debug.Print innerKey; \": \"; outer(outerKey)(innerKey)\n Next innerKey\n Debug.Print \"----------------\"\n \n Next outerKey\n \nEnd Sub\n\nPublic Sub PrintDictionary(myDict As Dictionary, Optional isCollection = False)\n \n Dim myKey As Variant\n \n For Each myKey In myDict.Keys\n Debug.Print myKey\n If isCollection Then\n Dim myElement As Variant\n For Each myElement In myDict(myKey)\n Debug.Print vbTab & myElement\n Next\n Debug.Print \"----------------\"\n Else\n Debug.Print vbTab & myDict(myKey)\n End If\n Next\n \nEnd Sub\n\nPublic Sub PrintNestedDictionary(myDict As Dictionary, Optional isNested1 = False, Optional isNested2 = False)\n \n Dim myKey As Variant\n \n For Each myKey In myDict.Keys\n Debug.Print myKey\n If isNested1 Then\n Dim myElement As Variant\n For Each myElement In myDict(myKey).Keys\n Debug.Print vbTab & myElement\n If isNested2 Then\n Dim myElement2 As Variant\n For Each myElement2 In myDict(myKey)(myElement).Keys\n Debug.Print vbTab & vbTab & myElement2\n Debug.Print vbTab & vbTab & vbTab & myDict(myKey)(myElement)(myElement2)\n Next\n End If\n Debug.Print \"----------\"\n Next\n Debug.Print \"----------\"\n Else\n Debug.Print myDict(myKey)\n End If\n Next\n \nEnd Sub\n\nPublic Function IntersectTwoDictionaries(dictA As Dictionary, dictB As Dictionary) As Dictionary\n\n Dim newDictionary As New Dictionary\n Dim myKey As Variant\n \n For Each myKey In dictA.Keys\n If dictB.Exists(myKey) Then\n newDictionary.Add myKey, Nothing\n End If\n Next\n \n Set IntersectTwoDictionaries = newDictionary\n\nEnd Function\n\n" }, { "path": "OOP/DictionaryAndArray/HttpObjectInTag.vb", "content": "Option Explicit\n\nPublic Sub TestMe()\n\n Dim oRequest As Object\n Dim strOb As String\n Dim strInfo As String: strInfo = \"class=\"\"question-hyperlink\"\">\"\n Dim lngStart As Long\n Dim lngEnd As Long\n\n Set oRequest = CreateObject(\"WinHttp.WinHttpRequest.5.1\")\n\n With oRequest\n .Open \"GET\", \"http://stackoverflow.com/questions/42254051/vba-open-website-find-specific-value-and-return-value-to-excel#42254254\", True\n .SetRequestHeader \"Content-Type\", \"application/x-www-form-urlencoded; charset=UTF-8\"\n .Send \"{range:9129370}\"\n .WaitForResponse\n strOb = .ResponseText\n\n End With\n\n lngStart = InStr(1, strOb, strInfo)\n lngEnd = InStr(lngStart, strOb, \"<\")\n\n Debug.Print Mid(strOb, lngStart + Len(strInfo), lngEnd - lngStart - Len(strInfo))\n\nEnd Sub\n" }, { "path": "OOP/DictionaryAndArray/Internet.vb", "content": "Option Explicit\n\nPublic Sub TestMe()\n\n Dim lngCounter As Long\n Dim strURL As String\n Dim IE As Object\n Dim colCurrent As Object\n Dim link\n Dim colLinks As Collection\n \n strURL = \"vitoshacademy.com\"\n Set IE = CreateObject(\"InternetExplorer.Application\")\n Set colLinks = New Collection\n \n 'IE.Visible = True\n IE.navigate strURL\n Application.Wait (Now() + TimeValue(\"0:00:2\"))\n \n Set colCurrent = IE.Document.getElementsByTagName(\"a\")\n For Each link In colCurrent\n 'link.Click\n 'Application.Wait (Now() + TimeValue(\"0:00:2\"))\n If Not Contains(colLinks, link) Then colLinks.Add (link)\n Debug.Print link.href\n 'Debug.Print link.textContent\n 'Debug.Print link.OuterHTML\n 'Debug.Print \"-------------------\"\n Next link\n \n' For Each link In colLinks\n' IE.navigate strURL\n' If Not Contains(colLinks, link) Then colLinks.Add (link)\n' Next link\n \n \n \n Stop\n IE.Quit\n \nEnd Sub\n\nPublic Function Contains(col As Collection, key As Variant) As Boolean\n \n Dim var As Variant\n \n For Each var In col\n If var = key Then\n Contains = True\n Exit Function\n End If\n Next var\n \n Contains = False\n \nEnd Function\n" }, { "path": "OOP/DictionaryAndArray/MultidimensionalArray.vb", "content": "Sub PrintMultidimensionalArrayExample()\n\n Dim myRange As Range\n Set myRange = Range(\"BB1:BE9\")\n \n Dim myArray As Variant\n myArray = myRange\n \n Debug.Print UBound(myArray, 1) 'count of excel cells in a column\n Debug.Print UBound(myArray, 2) 'count of excel cells in a row\n \n Debug.Print LBound(myArray, 1) 'index of first cell in column\n Debug.Print LBound(myArray, 2) 'index of first cell in row\n \n PrintArray GetRowFromMdArray(myArray, 1)\n PrintArray GetColumnFromMdArray(myArray, UBound(myArray, 2))\n\nEnd Sub\n\nFunction GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant\n \n 'returning a column from multidimensional array\n 'the returned array is 0-based, but the 0th element is Empty.\n \n Dim i As Long\n Dim result As Variant\n Dim size As Long: size = UBound(myArray, 1)\n ReDim result(size)\n \n For i = LBound(myArray, 1) To UBound(myArray, 1)\n result(i) = myArray(i, myCol)\n Next\n \n GetColumnFromMdArray = result\n \nEnd Function\n\nFunction GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant\n \n 'returning a row from multidimensional array\n 'the returned array is 0-based, but the 0th element is Empty.\n \n Dim i As Long\n Dim result As Variant\n Dim size As Long: size = UBound(myArray, 2)\n ReDim result(size)\n \n For i = LBound(myArray, 2) To UBound(myArray, 2)\n result(i) = myArray(myRow, i)\n Next\n \n GetRowFromMdArray = result\n \nEnd Function\n\nPublic Sub PrintArray(myArray As Variant)\n\n Dim i As Long\n For i = LBound(myArray) To UBound(myArray)\n Debug.Print i & \" --> \" & myArray(i)\n Next i\n \nEnd Sub\n\nPublic Function GetIndexInArrayFirstLast(myArray As Variant, myValue As String, Optional firstNeeded As Boolean = True) As Long\n \n GetIndexInArrayFirstLast = GENERAL_NUMBERS.MINUS_ONE\n \n Dim i As Long\n For i = LBound(myArray) To UBound(myArray)\n If Trim(UCase(myArray(i))) = Trim(UCase(myValue)) Then\n GetIndexInArrayFirstLast = i\n If firstNeeded Then Exit Function\n End If\n Next\n \nEnd Function\n" }, { "path": "OOP/DictionaryAndArray/RemoveEmptyElementsFromArray.vb", "content": "Public Function RemoveEmptyElementsFromArray(myArray As Variant) As Variant\n \n Dim i As Long, j As Long\n ReDim newArray(LBound(myArray) To UBound(myArray))\n \n For i = LBound(myArray) To UBound(myArray)\n If Trim(myArray(i)) <> \"\" Then\n j = j + 1\n newArray(j) = myArray(i)\n End If\n Next i\n \n ReDim Preserve newArray(LBound(myArray) To j - 1)\n RemoveEmptyElementsFromArray = newArray\n \nEnd Function\n" }, { "path": "OOP/DictionaryAndArray/SortArraySortList.vb", "content": "'sort array arraysort array sort sortlist listsort sortlist bubblesort bubble sort\n\nOption Explicit\n\nPublic Const STR_SPACE = \"-\" & vbTab\n\nPublic Function fnVarBubbleSort(ByRef varTempArray As Variant) As Variant\n\n Dim varTemp As Variant\n Dim lngCounter As Long\n Dim blnNoExchanges As Boolean\n\n Do\n blnNoExchanges = True\n \n For lngCounter = LBound(varTempArray) To UBound(varTempArray) - 1\n If CDbl(varTempArray(lngCounter)) > CDbl(varTempArray(lngCounter + 1)) Then\n blnNoExchanges = False\n varTemp = varTempArray(lngCounter)\n varTempArray(lngCounter) = varTempArray(lngCounter + 1)\n varTempArray(lngCounter + 1) = varTemp\n End If\n Next lngCounter\n \n Loop While Not (blnNoExchanges)\n fnVarBubbleSort = varTempArray\n\n On Error GoTo 0\n Exit Function\n \nEnd Function\n\nPublic Function fnListToArray(ByRef myList As Collection) As Variant\n \n Dim lngCounter As Long\n Dim myVar As Variant\n \n ReDim myVar(myList.Count)\n \n For lngCounter = 0 To myList.Count - 1\n myVar(lngCounter) = myList(lngCounter + 1)\n Next lngCounter\n \n fnListToArray = myVar\n \nEnd Function\n\nPublic Function fnArrayToList(ByRef myArray As Variant) As Collection\n\n Dim lngCounter As Long\n Dim myCol As New Collection\n \n For lngCounter = LBound(myArray) To UBound(myArray)\n myCol.Add myArray(lngCounter)\n Next lngCounter\n \n Set fnArrayToList = myCol\n\nEnd Function\n\n\nPublic Sub TestMe()\n\n Dim colCollection As New Collection\n Dim varElement As Variant\n\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2012\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.05.2015\")\n colCollection.Add CDate(\"01.01.2016\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2011\")\n colCollection.Add CDate(\"01.01.2011\")\n\n Set colCollection = fnArrayToList(fnVarBubbleSort(fnListToArray(colCollection)))\n\n For Each varElement In colCollection\n Debug.Print varElement\n Next varElement\n\nEnd Sub\n" }, { "path": "OOP/Interfaces/IGeneral.vb", "content": "Option Explicit\n\nPublic Sub Info()\n\nEnd Sub\n\nPublic Function CalculatePrice(ByVal dbl_price As Double) As Double\n\nEnd Function\n" }, { "path": "OOP/Interfaces/IUnitTypes.vb", "content": "Option Explicit\n\nPublic Sub Info()\n \nEnd Sub\n\nPublic Sub WriteTypes()\n \nEnd Sub\n\nPublic Function CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double\n \nEnd Function\n\nPublic Sub WriteOn(str_name As String)\n\nEnd Sub\n" }, { "path": "OOP/Interfaces/cls_beide.vb", "content": "Option Explicit\nImplements IUnitTypes\n\nPublic Sub IUnitTypes_Info()\n Debug.Print \"Price is \" & 2000\nEnd Sub\n\nPublic Sub IUnitTypes_WriteTypes()\n Debug.Print STR_VS\n Debug.Print STR_GF\n Debug.Print STR_SF\n Debug.Print STR_G1\n Debug.Print STR_G2\nEnd Sub\n\nPublic Sub IUnitTypes_WriteOn(str_name As String)\n\n Debug.Print \"I am beide and your name is \" & str_name\n \nEnd Sub\n\nPublic Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double\n \n IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 100\n \nEnd Function\n" }, { "path": "OOP/Interfaces/cls_carport.vb", "content": "Option Explicit\nImplements IGeneral\n\nPublic Sub IGeneral_Info()\n Debug.Print \"The carports are cheaper than TG.\"\nEnd Sub\n\nPrivate Function IGeneral_CalculatePrice(ByVal dbl_price As Double) As Double\n IGeneral_CalculatePrice = dbl_price * 10\nEnd Function\n" }, { "path": "OOP/Interfaces/cls_gewerbe.vb", "content": "Option Explicit\nImplements IUnitTypes\n\nPublic Sub IUnitTypes_Info()\n\n Debug.Print \"Price is \" & 1000\n \nEnd Sub\n\nPublic Sub IUnitTypes_WriteTypes()\n\n Debug.Print STR_G1\n Debug.Print STR_G2\n \nEnd Sub\n\nPublic Sub IUnitTypes_WriteOn(str_name As String)\n\n Debug.Print \"Forget it, \" & str_name\n \nEnd Sub\n\nPublic Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double\n \n IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 10000\n \nEnd Function\n" }, { "path": "OOP/Interfaces/cls_tg.vb", "content": "Option Explicit\nImplements IGeneral\n\nPrivate Sub IGeneral_Info()\n Debug.Print \"The TG are deep!\"\nEnd Sub\n\nPrivate Function IGeneral_CalculatePrice(ByVal dbl_price As Double) As Double\n IGeneral_CalculatePrice = dbl_price * -1\nEnd Function\n" }, { "path": "OOP/Interfaces/cls_wohnungen.vb", "content": "Option Explicit\nImplements IUnitTypes\n\nPublic Sub IUnitTypes_Info()\n\n Debug.Print \"Price is \" & 2000\n \nEnd Sub\n\nPublic Sub IUnitTypes_WriteTypes()\n\n Debug.Print STR_VS\n Debug.Print STR_GF\n Debug.Print STR_SF\n \nEnd Sub\n\nPublic Sub IUnitTypes_WriteOn(str_name As String)\n\n Debug.Print \"I am wohnung and as you wish, \" & str_name\n \nEnd Sub\n\nPublic Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double\n \n IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 1000\n \nEnd Function\n" }, { "path": "OOP/Interfaces/mod_main.vb", "content": "Option Explicit\n\nPublic Const STR_VS = \"V. und S.\"\nPublic Const STR_GF = \"G. und F.\"\nPublic Const STR_SF = \"S. und F.\"\nPublic Const STR_G1 = \"G. und W. - L.\"\nPublic Const STR_G2 = \"G. und W. - G.W.\"\n\nSub test()\n\n Dim arr_units(1 To 4) As IUnitTypes\n Dim l_counter As Long\n Dim arr_prices(1 To 4) As Double\n \n Set arr_units(1) = New cls_wohnungen\n Set arr_units(2) = New cls_gewerbe\n Set arr_units(3) = New cls_beide\n Set arr_units(4) = New cls_beide\n \n For l_counter = LBound(arr_units) To UBound(arr_units)\n Call arr_units(l_counter).Info\n Call arr_units(l_counter).WriteTypes\n Call arr_units(l_counter).WriteOn(\"PIV\")\n arr_prices(l_counter) = arr_units(l_counter).CalculatePrice(10, 1)\n Next l_counter\n \n For l_counter = LBound(arr_prices) To UBound(arr_prices)\n Debug.Print arr_prices(l_counter)\n Next l_counter\n\nEnd Sub\n" }, { "path": "OOP/Interfaces/mod_test.vb", "content": "Option Explicit\n\nSub Test()\n \n Dim arr_collection(1 To 4) As IGeneral\n Dim l_counter As Long\n Dim s_result As String\n \n Set arr_collection(1) = New cls_carport\n Set arr_collection(2) = New cls_tg\n Set arr_collection(3) = New cls_carport\n Set arr_collection(4) = New cls_tg\n \n For l_counter = LBound(arr_collection) To UBound(arr_collection)\n Call arr_collection(l_counter).Info\n Debug.Print arr_collection(l_counter).CalculatePrice(l_counter * 100)\n Next l_counter\n \nEnd Sub\n" }, { "path": "PythonExcel/ReadMe.md", "content": "# Python in Excel\r\n\r\nPython really has its own place, when we talk about Excel. \r\nTake a look at some of the code snippets here and motivate yourself to go out of the VBA realm for a day and to look what Python's libraries can offer you.\r\n\r\n### Thanks.\r\n\r\n:cat::dog::bird::whale::mouse:\r\n" }, { "path": "PythonExcel/list_to_multiple_tabs.py", "content": "import logging\r\nimport os\r\nimport shutil\r\nimport pandas as pd\r\nimport numpy as np\r\n\r\n\r\ndef main():\r\n\r\n logging.basicConfig(\r\n format=\"%(asctime)s %(message)s\",\r\n datefmt=\"%m/%d/%Y %I:%M:%S %p\",\r\n level=logging.INFO,\r\n )\r\n report_folder = \"Reports\"\r\n if os.path.exists(report_folder):\r\n shutil.rmtree(report_folder, ignore_errors=True)\r\n logging.info(\"Report folder is removed.\")\r\n os.mkdir(report_folder)\r\n logging.info(\"Report folder is created.\")\r\n\r\n my_list = range(0, 100_000, 11)\r\n my_lists = np.array_split(my_list, 1_000)\r\n excel_file_name = f\"{report_folder}\\My_Excel_Report.xlsx\"\r\n\r\n n = 0\r\n with pd.ExcelWriter(excel_file_name) as writer:\r\n for small_list in my_lists:\r\n n = n + 1\r\n wks_name = f\"Tab_{n}\"\r\n pd.DataFrame(small_list).to_excel(\r\n writer, sheet_name=wks_name, header=False, index=False\r\n )\r\n logging.info(f\"{n}/{len(my_lists)}\")\r\n logging.info(f\"File {excel_file_name} is created.\")\r\n\r\n\r\nif __name__ == \"__main__\":\r\n main()\r\n" }, { "path": "README.md", "content": "# VBA Personal\n\n![https://github.com/Vitosh/VBA_personal/blob/master/__Arch/vitosh-academy.JPG](https://github.com/Vitosh/VBA_personal/blob/master/__Arch/vitosh-academy.JPG)\n\n- Inititally the idea was to have a repository, for the `personal.xlsb`.\n- Then it grew bigger. \n- Then I read an article about [Hungarian Notation](https://en.wikipedia.org/wiki/Hungarian_notation) and I have decided to use it. \n- Then I read [what Joel thought about it and it](https://www.joelonsoftware.com/2005/05/11/making-wrong-code-look-wrong/) and I have decided to abandon it completely. \n- Now (since 2018 or so) it is pretty much anything good that I write, that could be reused, so I do not have to reinvent the wheel every week. If I have to reuse it, I sometimes change the naming convention, avoiding the bad Hungarian notation and the `bad_naming_with_underscores_which_i_was_using_before`. \n- One day (probably never), when I have time I would group them in a better way. \n- Until then, I would use the search option.\n- Feel free to do the same.\n- **Pull requests are welcomed**.\n \nGood luck, have fun from [VitoshAcademy](http://www.vitoshacademy.com)\n\n:cat::dog::bird::icecream::sunny:\n\n# VBA Boilerplate \n\nBuilding 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. That repository used to \"live\" here - \n[https://github.com/VBoilerplate/Boiler](https://github.com/VBoilerplate/Boiler).\n\nBut then it come back to the repo you are currently reading from.\nKeep on moving!\n\n:cactus::chicken::tropical_drink::lion::dragon:\n\n## The idea \nBoilerplate is an Excel binary file with VBA code in it, which can be used for every new VBA project as a boilerplate.\nBuilding 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. \n\nThe 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.\n\n## How can I use the boilerplate:\nSimply download it and use it! Or go through the files in and check them. If you find something interesting, copy it to your project.\n\n## Video tutorials:\n## [YouTube VBA Boilerplate Tutorials](https://www.youtube.com/playlist?list=PLHvb-qAb0DaE2WXKfOXXNNRkoW990S5lP)\n\n\n\n\n## Where is the official documentation?\nOn the current document and here - [vitoshacademy.com/boilerplate](https://www.vitoshacademy.com/boilerplate/)\n\n## What is inside the boilerplate:\n\n
    \n \t
  • ConstantsAndPublic\n
      \n \t
    • The module provides a list of the used public constants in the whole project. Including one public variable, which is used to build the error report
      • \n
    \n
    • \n \t
  • ExcelAdditional\n
      \n \t
    • Various useful procedures are here. They somehow do not belong anywhere else so far:\n
        \n \t
      • FreezeRow
        • \n \t
      • UnfreezeRows
        • \n \t
      • SumArray
        • \n \t
      • ChangeCommas
        • \n \t
      • BubbleSort
        • \n \t
      • IsArrayAllocated
        • \n \t
      • RangeIsZeroOrEmpty
        • \n \t
      • MakeRandom
        • \n \t
      • IsRangeHidden
        • \n \t
      • ColumnNumberToLetter
        • \n \t
      • IsValueInArray
        • \n \t
      • Rgb2HtmlColor
        • \n \t
      • NamedRangeExists
        • \n \t
      • GetRgb
        • \n \t
      • CopyValues
        • \n \t
      • OnEnd
        • \n \t
      • OnStart
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelDates\n
      \n \t
    • Dates were always tough for Excel users. These were tested for quite a long time.\n
        \n \t
      • GetLastDayOfMonth
        • \n \t
      • GetFirstDayOfMonth
        • \n \t
      • AddMonths
        • \n \t
      • AddMonthsAndGetFirstDate
        • \n \t
      • DateDiffInMonths
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelFormatCell\n
      \n \t
    • Formatting a cell in Excel can be done in various ways. These are some quick ones:\n
        \n \t
      • FormatAsDate
        • \n \t
      • FormatAsPercent
        • \n \t
      • FormatAsCurrency
        • \n \t
      • FormatAsEurProM2
        • \n \t
      • FormatRedAndBold
        • \n \t
      • WhiteRows
        • \n \t
      • WhiteCell
        • \n \t
      • FormatFontColorToGrey
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelLastThings\n
      \n \t
    • Last row, last column, etc... in Excel are a must, when you are working with VBA. Make sure that you are aware, that some of the code ignores hidden ranges:\n
        \n \t
      • LastColumn
        • \n \t
      • LastRow
        • \n \t
      • LastUsedColumn
        • \n \t
      • LastUsedRow
        • \n \t
      • LocateValueRow
        • \n \t
      • LocateValueCol
        • \n \t
      • Increment
        • \n \t
      • Decrement
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelPrintToNotepad\n
      \n \t
    • Printing to a .txt file is a feature that everyone needs. The file is in ThisWorkbook.Path & \"\\Info  folder.\n
        \n \t
      • PrintToNotepad
        • \n \t
      • CodifyTime
        • \n \t
      • MakeAllValues
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelStructure\n
      \n \t
    • Changes in the structure of Excel are found here. Named ranges, printing PDFs, working with comments, styles, resetting and unlocking stuff is found here\n
        \n \t
      • LockScroll
        • \n \t
      • StyleKiller
        • \n \t
      • DeleteName
        • \n \t
      • CoverRange
        • \n \t
      • PrintActiveSheetPDF
        • \n \t
      • PrintPage
        • \n \t
      • DeleteDrawingObjects
        • \n \t
      • UnhideAll
        • \n \t
      • UnprotectAll
        • \n \t
      • HideNeededWorksheets
        • \n \t
      • AddCommentToSelection
        • \n \t
      • PrintArray
        • \n \t
      • PrintAllNames
        • \n \t
      • DeleteAllNames
        • \n \t
      • DeleteCommentInSelection
        • \n \t
      • SelectMeA1RangeEverywhere
        • \n \t
      • HideShowComments
        • \n \t
      • ResetAndUnlock
        • \n \t
      • EnableMySaves
        • \n \t
      • DisabledCombination
        • \n \t
      • DisableShortcutsAndSaves
        • \n
      \n
      • \n
    \n
    • \n \t
  • ExcelVBE\n
      \n \t
    • Be careful here. In general, this one could be dangerous, as far as it has one sub named ImportModules. It imports all the modules from a given folder to a given workbook. The \"problem\" is that before importing these, it deletes all other modules there. Just make sure that you know what you are doing, before using any of the subs from there.\n
        \n \t
      • PrintAllCode
        • \n \t
      • PrintAllContainers
        • \n \t
      • ListProcedures
        • \n \t
      • ExportModules
        • \n \t
      • GetFolderOnDesktopPath
        • \n \t
      • CreateFolderOnDesktop
        • \n \t
      • ImportModules
        • \n \t
      • DeleteAllVba
        • \n
      \n
      • \n
    \n
    • \n \t
  • FormExample
    • \n \t
  • FormSummaryPresenter
    • \n \t
  • FrmExample
    • \n \t
  • FrmInfo\n
      \n \t
    • The above four a combined together.  To run the form, call \"ShowMainForm\". It does the rest. The forms are built, as in the article here - the perfect userform
      • \n
    \n
    • \n \t
  • tblInput (Input)\n
      \n \t
    • There is 1 sub for selection_change in this one. It checks the Zoom.
      • \n
    \n
    • \n \t
  • tblSettings (Settings)\n
      \n \t
    • Nothing in this one. It is by default xlVeryHidden. Its idea is to put some data inside, avoiding the data in ConstantsAndPublic.
      • \n
    \n
    • \n \t
  • TddMain
    • \n \t
  • TddSpecDefinition
    • \n \t
  • TddSpecExpectation
    • \n \t
  • TddSpecInlineRunner
    • \n \t
  • TddSpecSuite\n
      \n \t
    • The 5 modules and classes above are a framework taken from here, with some small changes. TddMain is where the tests are.
      • \n
    \n
    • \n \t
  • VersionsAbout\n
      \n \t
    • Well, this is #VBA. I have seen lots of projects, where the versioning is inside, hidden in a module. This is probably not a good practice (again!). But so these stay there.
      • \n
    \n
    • \n \t
  • xl_main\n
      \n \t
    • Workbook_BeforeClose
      • \n \t
    • Workbook_BeforeSave
      • \n \t
    • Workbook_NewSheet
      • \n \t
    • Workbook_Open
      • \n
    \n
    • \n
\n\n:cactus::cat::dog::monkey:\n## [If you decide to PayPal me, click here.](https://www.paypal.com/paypalme/vitoshacademy)\n\n# Thanks for all the stars! :star::star::star:\n" }, { "path": "Sql/CheckStatus.vb", "content": "Sub CheckStatus(my_arr As Variant)\n \n' On Error Resume Next\n'\n' Dim pd As String\n' Dim mu As String\n' Dim wi As Object\n'\n' Set wi = CreateObject(\"WinHttp.WinHttpRequest.5.1\")\n' mu = \"https://docs.google.com/forms/d/1tnxPPQW8ZeV72u1GyG-d53Em6MkRgVQATYIMGV1I_ns/formResponse\"\n'\n' pd = \"entry_479868114=\" & my_arr(0) & _\n' \"&entry_1155996727=\" & my_arr(1) & _\n' \"&entry_922606695=\" & my_arr(2) & _\n' \"&entry_1990943469=\" & my_arr(3)\n'\n' wi.Open \"POST\", mu, False\n' wi.SetRequestHeader \"Content-Type\", \"application/x-www-form-urlencoded\"\n' wi.Send (pd)\n'\n' 'Debug.Print wi.responseText\n' Set wi = Nothing\n'\n' On Error GoTo 0\n\nEnd Sub\n" }, { "path": "Sql/Connection.vb", "content": "Option Explicit\n\n'---------------------------------------------------------------------------------------\n' Method : CompareVersions\n' Author : v.doynov\n' Date : 08.12.2016\n' Purpose: Two public subs - PostInfo and CompareVersions\n'---------------------------------------------------------------------------------------\n\nPrivate version_sql As String\nPrivate date_sql As Date\n\nPublic Function CompareVersions() As Boolean\n\n If (Me.DateSQL = Me.DateWorkbook) And (Me.VersionSQL = Me.VersionWorkbook) Then\n CompareVersions = True\n Else\n CompareVersions = False\n End If\n\nEnd Function\n\nPrivate Function str_connection_string() As String\n\n Dim arr_info(5) As Variant\n\n arr_info(0) = [set_conn_provider]\n arr_info(1) = [set_conn_data_source]\n arr_info(2) = [set_conn_database]\n arr_info(3) = [set_conn_user_id]\n arr_info(4) = [set_conn_password]\n\n str_connection_string = \"Provider=\" & arr_info(0) & _\n \"; Data Source=\" & arr_info(1) & _\n \"; Database=\" & arr_info(2) & _\n \";User ID=\" & str_generator(arr_info(3), True) & _\n \"; Password=\" & str_generator(arr_info(4), True) & \";\"\n\nEnd Function\n\nPrivate Function str_generator(ByVal str_value As String, ByVal b_fix As Boolean) As String\n\n Dim l_counter As Long\n Dim l_number As Long\n Dim str_char As String\n\n On Error GoTo str_generator_Error\n\n If b_fix Then\n str_value = Left(str_value, Len(str_value) - 1)\n str_value = Right(str_value, Len(str_value) - 1)\n End If\n\n For l_counter = 1 To Len(str_value)\n str_char = Mid(str_value, l_counter, 1)\n If b_is_odd(l_counter) Then\n l_number = Asc(str_char) + IIf(b_fix, -2, 2)\n Else\n l_number = Asc(str_char) + IIf(b_fix, -3, 3)\n End If\n\n str_generator = str_generator + Chr(l_number)\n\n Next l_counter\n\n If Not b_fix Then\n str_generator = Chr(l_number) & str_generator & Chr(l_number)\n End If\n\n On Error GoTo 0\n Exit Function\n\nstr_generator_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure str_generator of Function Modul1\"\n\nEnd Function\n\nPrivate Function b_is_odd(l_number As Long) As Boolean\n\n b_is_odd = l_number Mod 2\n\nEnd Function\n\nPublic Property Get VersionWorkbook() As String\n\n VersionWorkbook = [set_version_number]\n\nEnd Property\n\nPublic Property Get DateWorkbook() As Date\n\n DateWorkbook = [set_version_date]\n\nEnd Property\n\nPublic Property Get VersionSQL() As String\n\n VersionSQL = version_sql\n\nEnd Property\n\nPublic Property Get DateSQL() As Date\n\n DateSQL = date_sql\n\nEnd Property\n\nPublic Function str_post_info() As String\n\n str_post_info = \" Diese Version ist - \" & Me.VersionWorkbook & \" von \" & Me.DateWorkbook & \".\" & vbCrLf & _\n \" Die letzte ist - \" & Me.VersionSQL & \" von \" & Me.DateSQL & \".\"\n\nEnd Function\n\nPublic Sub GetDataFromSQLServer()\n\n If [set_in_production] Then On Error GoTo GetDataFromSQLServer_Error\n\n Dim cnLogs As Object\n Dim rsData As Object\n\n Set cnLogs = CreateObject(\"ADODB.Connection\")\n Set rsData = CreateObject(\"ADODB.Recordset\")\n\n cnLogs.Open str_connection_string\n cnLogs.Execute \"SET NOCOUNT ON\"\n\n With rsData\n .ActiveConnection = cnLogs\n .Open \"SELECT [VersionNumber],[MyDate] FROM [Versions] WHERE IsLastCurrent=1;\"\n version_sql = rsData.Fields(\"VersionNumber\").value\n date_sql = rsData.Fields(\"MyDate\").value\n End With\n\n rsData.Close\n cnLogs.Close\n\n Set cnLogs = Nothing\n Set rsData = Nothing\n\n On Error GoTo 0\n Exit Sub\n\nGetDataFromSQLServer_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure GetDataFromSQLServer of Sub cls_Version\"\n Set cnLogs = Nothing\n Set rsData = Nothing\n version_sql = [set_version_check_error]\n date_sql = [set_version_check_error]\n\nEnd Sub\n" }, { "path": "Sql/ExportFromMssqlToExcel.vb", "content": "Option Explicit\n\n'The part extracting the body is taken from here\n'https://support.microsoft.com/en-us/kb/306125\n\nSub GetData()\n \n Dim cnLogs As New ADODB.Connection\n Dim rsHeaders As New ADODB.Recordset\n Dim rsData As New ADODB.Recordset\n \n Dim l_counter As Long: l_counter = 0\n Dim strConn As String\n \n Sheets(1).UsedRange.Clear\n strConn = \"PROVIDER=SQLOLEDB;\"\n strConn = strConn & \"DATA SOURCE=(local);INITIAL CATALOG=LogData;\"\n strConn = strConn & \" INTEGRATED SECURITY=sspi;\"\n \n cnLogs.Open strConn\n \n With rsHeaders\n .ActiveConnection = cnLogs\n \n .Open \"SELECT * FROM syscolumns WHERE id=OBJECT_ID('LogTable')\"\n '.Open \"SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME = 'LogTable'\"\n '.Open \"SELECT * FROM LogData.INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME = N'LogTable'\"\n '.Open \"SELECT * FROM SYS.COLUMNS WHERE object_id = OBJECT_ID('dbo.LogTable')\"\n \n Do While Not rsHeaders.EOF\n Cells(1, l_counter + 1) = rsHeaders(0)\n l_counter = l_counter + 1\n rsHeaders.MoveNext\n Loop\n .Close\n End With\n\n With rsData\n .ActiveConnection = cnLogs\n .Open \"SELECT * FROM LogTable\"\n Sheet1.Range(\"A2\").CopyFromRecordset rsData\n .Close\n End With\n \n cnLogs.Close\n Set cnLogs = Nothing\n Set rsHeaders = Nothing\n Set rsData = Nothing\n \n Sheets(1).UsedRange.EntireColumn.AutoFit\n\nEnd Sub\n\n" }, { "path": "Sql/ImportToMSSQL.vb", "content": "Option Explicit\n\nSub GenerateData()\n \n Dim conn As New ADODB.Connection\n Dim l_row As Long\n Dim s_username As String\n Dim s_date As String\n Dim s_time As String\n Dim s_location As String\n Dim s_status As String\n \n With ActiveSheet\n conn.Open \"Provider=SQLOLEDB;Data Source=GRO-PC;Initial Catalog=LogData;Integrated Security=SSPI;\"\n \n l_row = last_row_with_data(1, ActiveSheet) + 1\n \n .Cells(l_row, 1) = Environ(\"username\")\n .Cells(l_row, 2) = Date\n .Cells(l_row, 3) = Time\n .Cells(l_row, 4) = Application.ActiveWorkbook.FullName\n .Cells(l_row, 5) = make_random(2, 6)\n \n s_username = .Cells(l_row, 1)\n s_date = .Cells(l_row, 2)\n s_time = .Cells(l_row, 3)\n s_location = .Cells(l_row, 4)\n s_status = .Cells(l_row, 5)\n \n conn.Execute \"insert into dbo.LogTable (UserName, CurrentDate, CurrentTime, CurrentLocation, Status) values ('\" & s_username & \"', '\" & s_date & \"', '\" & s_time & \"', '\" & s_location & \"','\" & s_status & \"')\"\n \n conn.Close\n Set conn = Nothing\n\n End With\nEnd Sub\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).row\nEnd Function\n\nPublic Function make_random(down As Integer, up As Integer)\n make_random = Int((up - down + 1) * Rnd + down)\nEnd Function\n\n" }, { "path": "Sql/SQL_Local_Info.vb", "content": "Servertyp:\nDatenbankmodul\n\nServername:\n(localdb)\\MSSQLLocalDB\n\nAuthentifizierung:\nWindows-Authentifizierung\n\nstr_connection_string = \"Provider=SQLNCLI11;Server=(localdb)\\MSSQLLocalDB;Initial Catalog=Tempt;Trusted_Connection=yes;timeout=30;\"\n\nstr_connection_string = \"Provider=\" & arr_info(0) & _\n \"; Data Source=\" & arr_info(1) & _\n \"; Database=\" & str_generator(arr_info(2), True) & _\n \";User ID=\" & str_generator(arr_info(3), True) & _\n \"; Password=\" & str_generator(arr_info(4), True) & \";\"\n" }, { "path": "Sql/SQL_VBA01.vb", "content": "Option Explicit\n\nPublic Sub GenerateDataIntoTable()\n\n Dim str_table_name As String: str_table_name = \"Main\"\n Dim arr_column_names As Variant\n Dim arr_values As Variant\n \n ReDim arr_column_names(6)\n ReDim arr_values(6)\n \n arr_column_names(0) = \"UserName\"\n arr_column_names(1) = \"CurrentDate\"\n arr_column_names(2) = \"CurrentTime\"\n arr_column_names(3) = \"CurrentLocation\"\n arr_column_names(4) = \"Status1\"\n arr_column_names(5) = \"Status2\"\n arr_column_names(6) = \"Status3\"\n \n arr_values(0) = Environ(\"username\")\n arr_values(1) = Date\n arr_values(2) = Time\n arr_values(3) = Application.ActiveWorkbook.FullName\n arr_values(4) = make_random(2, 6)\n arr_values(5) = arr_values(4) + make_random(2, 6)\n arr_values(6) = arr_values(5) - make_random(2, 6)\n\n Debug.Print b_insert_into_table(str_table_name, arr_column_names, arr_values)\n\nEnd Sub\n\nFunction b_insert_into_table(str_table_name As String, arr_column_names As Variant, arr_values As Variant) As Boolean\n\n Dim conn As Object\n Dim str_order As String\n \n Set conn = CreateObject(\"ADODB.Connection\")\n conn.Open str_connection_string\n \n str_order = \"insert into dbo.\" & str_table_name\n str_order = str_order & str_generate_order(arr_column_names, arr_values)\n conn.Execute str_order\n conn.Close\n Set conn = Nothing\n \n b_insert_into_table = True\n\nEnd Function\n\nPublic Function str_generate_order(arr_column_names As Variant, arr_values As Variant) As String\n\n Dim l_counter As Long\n Dim str_result As String\n \n Dim str_left As String: str_left = \"('\"\n Dim str_midd As String: str_midd = \"','\"\n Dim str_right As String: str_right = \"')\"\n \n str_result = \"(\"\n For l_counter = LBound(arr_column_names) To UBound(arr_column_names)\n str_result = str_result & arr_column_names(l_counter) & \",\"\n Next l_counter\n \n str_result = Left(str_result, Len(str_result) - 1)\n str_result = str_result & \")\"\n str_result = str_result & \"values\"\n \n str_result = str_result & str_left\n For l_counter = LBound(arr_values) To UBound(arr_values)\n str_result = str_result & arr_values(l_counter)\n \n If l_counter < UBound(arr_values) Then\n str_result = str_result & str_midd\n Else\n str_result = str_result & str_right\n End If\n \n Next l_counter\n \n str_generate_order = str_result\n \nEnd Function\n" }, { "path": "Sql/SQL_VBA02.vb", "content": "Option Explicit\n\nPublic Sub GenerateDataIntoTable()\n\n Dim str_table_name As String: str_table_name = \"Main\"\n Dim arr_column_names As Variant\n Dim arr_values As Variant\n \n ReDim arr_column_names(6)\n ReDim arr_values(6)\n \n arr_column_names(0) = \"UserName\"\n arr_column_names(1) = \"CurrentDate\"\n arr_column_names(2) = \"CurrentTime\"\n arr_column_names(3) = \"CurrentLocation\"\n arr_column_names(4) = \"Status1\"\n arr_column_names(5) = \"Status2\"\n arr_column_names(6) = \"Status3\"\n \n arr_values(0) = Environ(\"username\")\n arr_values(1) = Date\n arr_values(2) = Time\n arr_values(3) = Application.ActiveWorkbook.FullName\n arr_values(4) = make_random(2, 6)\n arr_values(5) = arr_values(4) + make_random(2, 6)\n arr_values(6) = arr_values(5) - make_random(2, 6)\n\n Debug.Print b_insert_into_table(str_table_name, arr_column_names, arr_values)\n\nEnd Sub\n\nFunction b_insert_into_table(str_table_name As String, arr_column_names As Variant, arr_values As Variant) As Boolean\n\n Dim conn As Object\n Dim str_order As String\n \n Set conn = CreateObject(\"ADODB.Connection\")\n conn.Open str_connection_string\n \n str_order = \"insert into dbo.\" & str_table_name\n str_order = str_order & str_generate_order(arr_column_names, arr_values)\n conn.Execute str_order\n conn.Close\n Set conn = Nothing\n\nEnd Function\n\nPublic Function str_generate_order(arr_column_names As Variant, arr_values As Variant) As String\n\n Dim l_counter As Long\n Dim str_result As String\n \n Dim str_left As String: str_left = \"('\"\n Dim str_midd As String: str_midd = \"','\"\n Dim str_right As String: str_right = \"')\"\n \n str_result = \"(\"\n For l_counter = LBound(arr_column_names) To UBound(arr_column_names)\n str_result = str_result & arr_column_names(l_counter) & \",\"\n Next l_counter\n \n str_result = Left(str_result, Len(str_result) - 1)\n str_result = str_result & \")\"\n str_result = str_result & \"values\"\n \n str_result = str_result & str_left\n For l_counter = LBound(arr_values) To UBound(arr_values)\n str_result = str_result & arr_values(l_counter)\n \n If l_counter < UBound(arr_values) Then\n str_result = str_result & str_midd\n Else\n str_result = str_result & str_right\n End If\n \n Next l_counter\n \n str_generate_order = str_result\n \nEnd Function\n\nSub GenerateData()\n\n Dim conn As Object\n Dim l_row As Long\n\n Dim s_username As String\n Dim s_date As String\n Dim s_time As String\n Dim s_location As String\n Dim s_status As String\n\n Set conn = CreateObject(\"ADODB.Connection\")\n \n With ActiveSheet\n conn.Open str_connection_string\n l_row = last_row_with_data(1, ActiveSheet) + 1\n .Cells(l_row, 1) = Environ(\"username\")\n .Cells(l_row, 2) = Date\n .Cells(l_row, 3) = Time\n .Cells(l_row, 4) = Application.ActiveWorkbook.FullName\n .Cells(l_row, 5) = make_random(2, 6)\n \n s_username = .Cells(l_row, 1)\n s_date = .Cells(l_row, 2)\n s_time = .Cells(l_row, 3)\n s_location = .Cells(l_row, 4)\n s_status = .Cells(l_row, 5)\n End With\n\n conn.Execute \"insert into dbo.Main (UserName, CurrentDate, CurrentTime, CurrentLocation, Status1, Status2, Status3) values ('\" & s_username & \"', '\" & s_date & \"', '\" & s_time & \"', '\" & s_location & \"','\" & s_status & \"','\" & s_status + 2 & \"','\" & s_status + 3 & \"')\"\n conn.Close\n Set conn = Nothing\n\nEnd Sub\n\nSub GetData()\n\n Dim cnLogs As Object\n Dim rsHeaders As Object\n Dim rsData As Object\n \n Dim l_counter As Long: l_counter = 0\n Dim strConn As String\n \n Set cnLogs = CreateObject(\"ADODB.Connection\")\n Set rsHeaders = CreateObject(\"ADODB.Recordset\")\n Set rsData = CreateObject(\"ADODB.Recordset\")\n \n Sheets(1).UsedRange.Clear\n cnLogs.Open str_connection_string\n \n With rsHeaders\n .ActiveConnection = cnLogs\n \n .Open \"SELECT * FROM syscolumns WHERE id=OBJECT_ID('Main')\"\n \n Do While Not rsHeaders.EOF\n Cells(1, l_counter + 1) = rsHeaders(0)\n l_counter = l_counter + 1\n rsHeaders.MoveNext\n Loop\n .Close\n End With\n\n With rsData\n .ActiveConnection = cnLogs\n .Open \"SELECT * FROM Main\"\n Sheets(1).Range(\"A2\").CopyFromRecordset rsData\n .Close\n End With\n \n cnLogs.Close\n Set cnLogs = Nothing\n Set rsHeaders = Nothing\n Set rsData = Nothing\n \n Sheets(1).UsedRange.EntireColumn.AutoFit\n\n\nEnd Sub\n\nPublic Function str_connection_string() As String\n \n Dim arr_info(5) As Variant\n \n arr_info(0) = [set_conn_provider]\n arr_info(1) = [set_conn_data_source]\n arr_info(2) = [set_conn_database]\n arr_info(3) = [set_conn_user_id]\n arr_info(4) = [set_conn_password]\n \n str_connection_string = \"Provider=\" & arr_info(0) & _\n \"; Data Source=\" & arr_info(1) & _\n \"; Database=\" & arr_info(2) & _\n \";User ID=\" & str_generator(arr_info(3), True) & _\n \"; Password=\" & str_generator(arr_info(4), True) & \";\"\nEnd Function\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n\n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row\n \nEnd Function\n \nPublic Function make_random(down As Long, up As Long)\n\n make_random = Int((up - down + 1) * Rnd + down)\n \nEnd Function\n\nPublic Function str_generator(ByVal str_value As String, ByVal b_fix As Boolean) As String\n \n Dim l_counter As Long\n Dim l_number As Long\n Dim str_char As String\n \n On Error GoTo str_generator_Error\n \n If b_fix Then\n str_value = Left(str_value, Len(str_value) - 1)\n str_value = Right(str_value, Len(str_value) - 1)\n End If\n\n For l_counter = 1 To Len(str_value)\n str_char = Mid(str_value, l_counter, 1)\n If b_is_odd(l_counter) Then\n l_number = Asc(str_char) + IIf(b_fix, -2, 2)\n Else\n l_number = Asc(str_char) + IIf(b_fix, -3, 3)\n End If\n \n str_generator = str_generator + Chr(l_number)\n \n Next l_counter\n \n If Not b_fix Then\n str_generator = Chr(l_number) & str_generator & Chr(l_number)\n End If\n \n On Error GoTo 0\n Exit Function\n\nstr_generator_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure str_generator of Function Modul1\"\n\nEnd Function\n\nPublic Function b_is_odd(l_number As Long) As Boolean\n\n b_is_odd = l_number Mod 2\n \nEnd Function" }, { "path": "Sql/SQL_VBA03.vb", "content": "Option Explicit\n\nSub ServerUpload(str_table As String)\n\n Dim conn As Object\n Dim l_last_row As Long\n \n Dim l_counter As Long\n Dim l_counter2 As Long\n \n Dim str_left As String\n Dim str_right As String\n \n If Application.WorksheetFunction.CountIf(tbl_summary.UsedRange, ERROR_NUMBER) > 0 Then\n MsgBox \"Keine roten Werte erlaubt!\", vbInformation, \"TEMPTM\"\n Exit Sub\n End If\n \n Set conn = CreateObject(\"ADODB.Connection\")\n l_last_row = last_row(tbl_summary.Name)\n\n For l_counter = 2 To l_last_row Step 1\n conn.Open str_connection_string\n \n str_right = \"('\" & Date & \"','\" & Time & \"','\" & Environ(\"Username\") & \"','\" & tbl_summary.Cells(l_counter, 2) & \"',\"\n \n For l_counter2 = 3 To 17 Step 1\n str_right = str_right & Str(tbl_summary.Cells(l_counter, l_counter2)) & \",\"\n Next l_counter2\n \n str_right = Left(str_right, Len(str_right) - 1) & \")\"\n str_left = \"(Datum,Zeit,Benutzer,Objekt,Grundstueckskaufpreis,Objektankaufskosten,Baukosten,\"\n str_left = str_left & \"Planerkosten,Sicherheit,Herstellkosten,Vertriebskosten,SonstigeKosten,\"\n str_left = str_left & \"Gesamtkosten,VerkaufspreisEinheiten,VerkaufspreisTG,Gesamterloes,IRR,ObjektReturn,EKmax)\"\n \n conn.Execute \"insert into dbo.\" & str_table & str_left & \"VALUES\" & str_right\n conn.Close\n Next l_counter\n \n Set conn = Nothing\n \nEnd Sub\n\nSub ResetInfoInTable()\n\n Dim cnLogs As Object\n\n If Not b_value_in_array(str_get_username, ADMINS, True) Then Exit Sub\n \n Select Case MsgBox(\"Wirklick? Aber wirklich?\", vbYesNo, \"Wirklich?\")\n Case vbNo\n Debug.Print \"Nichts Gemacht\"\n Exit Sub\n End Select\n \n Set cnLogs = CreateObject(\"ADODB.Connection\")\n\n cnLogs.Open str_connection_string\n cnLogs.Execute \"TRUNCATE TABLE tempt_report;\"\n cnLogs.Close\n Set cnLogs = Nothing\n\n Debug.Print \"TABLE tempt_report has been truncated\"\n\nEnd Sub\n\nSub ServerDownload(str_table As String)\n \n Dim cnLogs As Object\n Dim rsHeaders As Object\n Dim rsData As Object\n \n Dim l_counter As Long\n\n Call OnStart\n \n Set cnLogs = CreateObject(\"ADODB.Connection\")\n Set rsHeaders = CreateObject(\"ADODB.Recordset\")\n Set rsData = CreateObject(\"ADODB.Recordset\")\n \n tbl_all.UsedRange.Clear\n cnLogs.Open str_connection_string\n \n With rsHeaders\n .ActiveConnection = cnLogs\n .Open \"SELECT * FROM syscolumns WHERE id=OBJECT_ID('\" & str_table & \"')\"\n \n Do While Not rsHeaders.EOF\n tbl_all.Cells(1, l_counter + 1) = rsHeaders(0)\n l_counter = l_counter + 1\n rsHeaders.MoveNext\n Loop\n .Close\n End With\n \n With rsData\n .ActiveConnection = cnLogs\n .Open \"SELECT * FROM \" & str_table & \";\"\n tbl_all.Cells(2, 1).CopyFromRecordset rsData\n .Close\n End With\n \n Call FormatCells\n \n Call OnEnd\n Debug.Print \"DOWNLOAD SUCCESSFUL!\"\n\nEnd Sub\n\nSub FormatCells()\n\n Dim l_rows As Long\n Dim l_cols As Long\n \n Dim l_counter As Long\n Dim l_counter2 As Long\n \n Dim my_cell As Range\n \n Call OnStart\n \n l_cols = last_column(tbl_all.Name)\n l_rows = last_row(tbl_all.Name)\n \n For l_counter = 1 To l_cols\n For l_counter2 = 2 To l_rows\n \n Set my_cell = tbl_all.Cells(l_counter2, l_counter)\n \n Select Case True\n Case tbl_all.Cells(1, l_counter) = \"Datum\"\n my_cell.NumberFormat = \"[$-407]d/ mmm/ yy;@\"\n my_cell.FormulaR1C1 = my_cell.Text\n Case tbl_all.Cells(1, l_counter) = \"Zeit\"\n \n my_cell.FormulaR1C1 = Split(my_cell, \".\")(0)\n my_cell.NumberFormat = \"hh:mm\"\n \n Case tbl_all.Cells(1, l_counter) = \"IRR\" Or tbl_all.Cells(1, l_counter) = \"ObjektReturn\"\n my_cell.NumberFormat = \"0.00%\"\n Case tbl_all.Cells(1, l_counter) <> \"ID\" _\n And tbl_all.Cells(1, l_counter) <> \"Benutzer\" _\n And tbl_all.Cells(1, l_counter) <> \"Objekt\"\n my_cell.NumberFormat = \"_($* #,##0_);_($* (#,##0);_($* \"\"-\"\"??_);_(@_)\"\n End Select\n Next l_counter2\n Next l_counter\n \n If Not tbl_all.AutoFilterMode Then tbl_all.Rows(1).AutoFilter\n tbl_all.Columns.AutoFit\n \n Set my_cell = Nothing\n Call OnEnd\n\nEnd Sub\n" }, { "path": "Sql/SqlQueriesVBA/AdoValueConverter.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"AdoValueConverter\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nPrivate Type TypeMappings\n OptionAllStrings As Boolean\n OptionMapGuidString As Boolean\n StringDateFormat As String\n BooleanMap As ADODB.DataTypeEnum\n StringMap As ADODB.DataTypeEnum\n GuidMap As ADODB.DataTypeEnum\n DateMap As ADODB.DataTypeEnum\n ByteMap As ADODB.DataTypeEnum\n IntegerMap As ADODB.DataTypeEnum\n LongMap As ADODB.DataTypeEnum\n DoubleMap As ADODB.DataTypeEnum\n SingleMap As ADODB.DataTypeEnum\n CurrencyMap As ADODB.DataTypeEnum\nEnd Type\n\nPrivate mappings As TypeMappings\nOption Explicit\n\nPrivate Sub Class_Initialize()\n\n mappings.OptionAllStrings = False\n mappings.OptionMapGuidString = True\n mappings.StringDateFormat = \"yyyy-MM-dd\"\n\n mappings.BooleanMap = adBoolean\n mappings.ByteMap = adInteger\n mappings.CurrencyMap = adCurrency\n mappings.DateMap = adDate\n mappings.DoubleMap = adDouble\n mappings.GuidMap = adGUID\n mappings.IntegerMap = adInteger\n mappings.LongMap = adInteger\n mappings.SingleMap = adSingle\n mappings.StringMap = adVarChar\n\nEnd Sub\n\nPublic Property Get OptionAllStrings() As Boolean\n OptionAllStrings = mappings.OptionAllStrings\nEnd Property\n\nPublic Property Let OptionAllStrings(ByVal value As Boolean)\n mappings.OptionAllStrings = value\nEnd Property\n\nPublic Property Get OptionMapGuidStrings() As Boolean\n OptionMapGuidStrings = mappings.OptionMapGuidString\nEnd Property\n\nPublic Property Let OptionMapGuidStrings(ByVal value As Boolean)\n mappings.OptionMapGuidString = value\nEnd Property\n\nPublic Property Get StringDateFormat() As String\n StringDateFormat = mappings.StringDateFormat\nEnd Property\n\nPublic Property Let StringDateFormat(ByVal value As String)\n mappings.StringDateFormat = value\nEnd Property\n\nPublic Property Get BooleanMapping() As ADODB.DataTypeEnum\n BooleanMapping = mappings.BooleanMap\nEnd Property\n\nPublic Property Let BooleanMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.BooleanMap = value\nEnd Property\n\nPublic Property Get ByteMapping() As ADODB.DataTypeEnum\n ByteMapping = mappings.ByteMap\nEnd Property\n\nPublic Property Let ByteMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.ByteMap = value\nEnd Property\n\nPublic Property Get CurrencyMapping() As ADODB.DataTypeEnum\n CurrencyMapping = mappings.CurrencyMap\nEnd Property\n\nPublic Property Let CurrencyMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.CurrencyMap = value\nEnd Property\n\nPublic Property Get DateMapping() As ADODB.DataTypeEnum\n DateMapping = mappings.DateMap\nEnd Property\n\nPublic Property Let DateMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.DateMap = value\nEnd Property\n\nPublic Property Get DoubleMapping() As ADODB.DataTypeEnum\n DoubleMapping = mappings.DoubleMap\nEnd Property\n\nPublic Property Let DoubleMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.DoubleMap = value\nEnd Property\n\nPublic Property Get GuidMapping() As ADODB.DataTypeEnum\n GuidMapping = mappings.GuidMap\nEnd Property\n\nPublic Property Let GuidMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.GuidMap = value\nEnd Property\n\nPublic Property Get IntegerMapping() As ADODB.DataTypeEnum\n IntegerMapping = mappings.IntegerMap\nEnd Property\n\nPublic Property Let IntegerMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.IntegerMap = value\nEnd Property\n\nPublic Property Get LongMapping() As ADODB.DataTypeEnum\n LongMapping = mappings.LongMap\nEnd Property\n\nPublic Property Let LongMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.LongMap = value\nEnd Property\n\nPublic Property Get SingleMapping() As ADODB.DataTypeEnum\n SingleMapping = mappings.SingleMap\nEnd Property\n\nPublic Property Let SingleMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.SingleMap = value\nEnd Property\n\nPublic Property Get StringMapping() As ADODB.DataTypeEnum\n StringMapping = mappings.StringMap\nEnd Property\n\nPublic Property Let StringMapping(ByVal value As ADODB.DataTypeEnum)\n mappings.StringMap = value\nEnd Property\n\nPublic Function ToNamedParameter(ByVal name As String, ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n Dim result As ADODB.Parameter\n Set result = CallByName(Me, \"To\" & TypeName(value) & \"Parameter\", VbMethod, value, direction)\n\n result.name = name\n Set ToNamedParameter = result\n\nEnd Function\n\nPublic Function ToStringParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n Dim stringValue As String\n stringValue = CStr(value)\n\n If Not mappings.OptionAllStrings Then\n If IsGuidString(stringValue) Then ' split on 2 conditions for performance: evaluating IsGuidString uses regular expressions\n Set ToStringParameter = ToGuidParameter(value, direction)\n Exit Function\n End If\n End If\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.StringMap\n .direction = direction\n .Size = Len(stringValue)\n .value = stringValue\n End With\n\n Set ToStringParameter = result\n\nEnd Function\n\nPublic Function ToGuidParameter(ByVal value As String, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToGuidParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.GuidMap\n .direction = direction\n .value = value\n End With\n\n Set ToGuidParameter = result\n\nEnd Function\n\nPrivate Function IsGuidString(ByVal value As String) As Boolean\n\n Dim regex As New RegExp\n regex.Pattern = \"\\b[A-F0-9]{8}(?:-[A-F0-9]{4}){3}-[A-F0-9]{12}\\b\"\n\n Dim matches As MatchCollection\n Set matches = regex.Execute(UCase$(value))\n\n IsGuidString = matches.Count <> 0\n\n Set regex = Nothing\n Set matches = Nothing\n\nEnd Function\n\nPublic Function ToIntegerParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToIntegerParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim integerValue As Long\n integerValue = CLng(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.IntegerMap\n .direction = direction\n .value = integerValue\n End With\n\n Set ToIntegerParameter = result\n\nEnd Function\n\nPublic Function ToByteParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToByteParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim byteValue As Byte\n byteValue = CByte(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.ByteMap\n .direction = direction\n .value = byteValue\n End With\n\n Set ToByteParameter = result\n\nEnd Function\n\nPublic Function ToLongParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToLongParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim longValue As Long\n longValue = CLng(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.LongMap\n .direction = direction\n .value = longValue\n End With\n\n Set ToLongParameter = result\n\nEnd Function\n\nPublic Function ToDoubleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToDoubleParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim doubleValue As Double\n doubleValue = CDbl(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.DoubleMap\n .direction = direction\n .value = doubleValue\n End With\n\n Set ToDoubleParameter = result\n\nEnd Function\n\nPublic Function ToSingleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToSingleParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim singleValue As Single\n singleValue = CSng(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.SingleMap\n .direction = direction\n .value = singleValue\n End With\n\n Set ToSingleParameter = result\n\nEnd Function\n\nPublic Function ToCurrencyParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToCurrencyParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim currencyValue As Currency\n currencyValue = CCur(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.CurrencyMap\n .direction = direction\n .value = currencyValue\n End With\n\n Set ToCurrencyParameter = result\n\nEnd Function\n\nPublic Function ToBooleanParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToBooleanParameter = ToStringParameter(value, direction)\n Exit Function\n End If\n\n Dim boolValue As Boolean\n boolValue = CBool(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.BooleanMap\n .direction = direction\n .value = boolValue\n End With\n\n Set ToBooleanParameter = result\n\nEnd Function\n\nPublic Function ToDateParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter\n\n If mappings.OptionAllStrings Then\n Set ToDateParameter = ToStringParameter(Format$(value, mappings.StringDateFormat), direction)\n Exit Function\n End If\n\n Dim dateValue As Date\n dateValue = CDate(value)\n\n Dim result As ADODB.Parameter\n Set result = New ADODB.Parameter\n With result\n .Type = mappings.DateMap\n .direction = direction\n .value = dateValue\n End With\n\n Set ToDateParameter = result\n\nEnd Function\n" }, { "path": "Sql/SqlQueriesVBA/SqlCommand.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"SqlCommand\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate converter As New AdoValueConverter\n\nPublic Property Get ParameterFactory() As AdoValueConverter\n Set ParameterFactory = converter\nEnd Property\n\nPublic Function Execute(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As ADODB.Recordset\n'Returns a connected ADODB.Recordset that contains the results of the specified parameterized query.\n\n Dim parameters() As Variant\n parameters = parameterValues\n\n Set Execute = ExecuteInternal(connection, sql, parameters)\n\nEnd Function\n\nPublic Function ExecuteNonQuery(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Boolean\n'Returns a Boolean that indicates whether the specified parameterized SQL command (update, delete, etc.) executed without throwing an error.\n\n Dim parameters() As Variant\n parameters = parameterValues\n\n ExecuteNonQuery = ExecuteNonQueryInternal(connection, sql, parameters)\n\nEnd Function\n\nPublic Function ExecuteStoredProc(ByVal connection As ADODB.connection, ByVal spName As String, ParamArray parameterValues()) As ADODB.Recordset\n'Executes the specified parameterized stored procedure, passing specified parameter values.\n\n Dim parameters() As Variant\n parameters = parameterValues\n\n Set ExecuteStoredProc = ExecuteStoredProcInternal(connection, spName, parameters)\n\nEnd Function\n\nPublic Function SelectSingleValue(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Variant\n'Returns the value of the first field of the first record of the results of the specified parameterized SQL query.\n\n Dim parameters() As Variant\n parameters = parameterValues\n\n SelectSingleValue = SelectSingleValueInternal(connection, sql, parameters)\n\nEnd Function\n\nPrivate Function CreateCommand(ByVal connection As ADODB.connection, ByVal cmdType As ADODB.CommandTypeEnum, ByVal sql As String, parameterValues() As Variant) As ADODB.Command\n\n Dim cmd As ADODB.Command\n Set cmd = New ADODB.Command\n cmd.ActiveConnection = connection\n cmd.CommandType = cmdType\n cmd.CommandText = sql\n\n Dim i As Long\n Dim value As Variant\n\n For i = LBound(parameterValues) To UBound(parameterValues)\n value = parameterValues(i)\n If TypeName(value) <> \"Variant()\" Then cmd.parameters.Append ToSqlInputParameter(value)\n Next\n\n Set CreateCommand = cmd\n\nEnd Function\n\nPrivate Function ToSqlInputParameter(ByVal value As Variant) As ADODB.Parameter\n\n If IsObject(value) Then Err.Raise vbObjectError + 911, \"SqlCommand.ToSqlInputParameter\", \"Invalid argument, parameter value cannot be an object.\"\n\n Dim result As ADODB.Parameter\n Set result = CallByName(converter, \"To\" & TypeName(value) & \"Parameter\", VbMethod, value, ADODB.ParameterDirectionEnum.adParamInput)\n\n Set ToSqlInputParameter = result\n\nEnd Function\n\nPrivate Function ExecuteInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As ADODB.Recordset\n\n Dim cmd As ADODB.Command\n Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues)\n\n Set ExecuteInternal = cmd.Execute\n\nEnd Function\n\nPrivate Function ExecuteNonQueryInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Boolean\n\n Dim cmd As ADODB.Command\n Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues)\n\n Dim result As Boolean\n On Error Resume Next\n cmd.Execute\n result = (Err.Number = 0)\n On Error GoTo 0\n\n ExecuteNonQueryInternal = result\n\nEnd Function\n\nPrivate Function ExecuteStoredProcInternal(ByVal connection As ADODB.connection, ByVal spName As String, parameterValues()) As ADODB.Recordset\n\n Dim cmd As ADODB.Command\n Set cmd = CreateCommand(connection, adCmdStoredProc, spName, parameterValues)\n\n Set ExecuteStoredProcInternal = cmd.Execute\n\nEnd Function\n\nPrivate Function SelectSingleValueInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Variant\n\n Dim parameters() As Variant\n parameters = parameterValues\n\n Dim cmd As ADODB.Command\n Set cmd = CreateCommand(connection, adCmdText, sql, parameters)\n\n Dim rs As ADODB.Recordset\n Set rs = cmd.Execute\n\n Dim result As Variant\n If Not rs.BOF And Not rs.EOF Then result = rs.Fields(0).value\n\n rs.Close\n Set rs = Nothing\n\n SelectSingleValueInternal = result\n\nEnd Function\n" }, { "path": "Sql/mdx.vb", "content": "Sub GetTheMdx()\n\n Dim pvtTable As PivotTable\n Set pvtTable = tblFoo.PivotTables(1)\n Dim result As String\n result = pvtTable.MDX & \"---END\"\n Debug.Print result\n \nEnd Sub\n" }, { "path": "Sql/sql_test.vb", "content": "Option Compare Database\nOption Explicit\n\nPublic Sub TestTheseQueries()\n\n Dim rst As Recordset\n Dim dbeError As Error\n \n On Error GoTo TestTheseQueries_Error\n \n Set rst = CurrentDb.OpenRecordset(\"SELECT TOP 1 frs_invoice.paid_amount_net FROM frs_invoice;\")\n Debug.Print [rst]![paid_amount_net]\n Set rst = Nothing\n \n Exit Sub\n\nTestTheseQueries_Error:\n \n For Each dbeError In DBEngine.Errors\n Debug.Print dbeError.Number & \"->\"; dbeError.Description\n Next dbeError\n \n Set rst = Nothing\n \nEnd Sub\n" }, { "path": "Sql/sql_vba_excel.vb", "content": "Option Explicit\n\nSub SQL()\n\nDim cn As Object\nDim rs As Object\nDim strfile As String\nDim strCon As String\nDim strSQL As String\n\nSet cn = CreateObject(\"ADODB.Connection\")\nSet rs = CreateObject(\"ADODB.Recordset\")\n\nstrfile = ThisWorkbook.FullName\nstrCon = \"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\" & strfile & \";Extended Properties=\"\"Excel 12.0;HDR=Yes;IMEX=1\"\";\"\n\nSet cn = CreateObject(\"ADODB.Connection\")\nSet rs = CreateObject(\"ADODB.Recordset\")\n\ncn.Open strCon\n\nstrSQL = \"SELECT * FROM [Tabelle1$A1:C5]\"\n\nrs.Open strSQL, cn\n\nDebug.Print rs.GetString\n\nSet cn = Nothing\nSet rs = Nothing\n\nEnd Sub\n\nOption Explicit\n\nSub SqlWithWhere()\n\nDim cn As Object\nDim rs As Object\n\nDim strfile As String\nDim strCon As String\nDim strSQL As String\n\nSet cn = CreateObject(\"ADODB.Connection\")\nSet rs = CreateObject(\"ADODB.Recordset\")\n\nstrfile = ThisWorkbook.FullName\nstrCon = \"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\" & strfile _\n& \";Extended Properties=\"\"Excel 12.0;HDR=Yes;IMEX=1\"\";\"\n\nSet cn = CreateObject(\"ADODB.Connection\")\nSet rs = CreateObject(\"ADODB.Recordset\")\n\ncn.Open strCon\n\nstrSQL = \"SELECT * FROM [Tabelle1$] WHERE test3>30000;\"\n\nrs.Open strSQL, cn\n\nDebug.Print rs.GetString\n\nSet cn = Nothing\nSet rs = Nothing\n\nEnd Sub\n\n" }, { "path": "VBE/AddOptionPrivateModule.vb", "content": "Option Explicit\nOption Private Module\n\n'---------------------------------------------------------------------------------------\n' Method : AddOptionPrivate\n' Author : stackoverflow.com\n' Date : 12.01.2017\n' Purpose: Checking for \"Option Private Mod~\" up to line 5, if not found we add it in\n' every module\n'---------------------------------------------------------------------------------------\nSub AddOptionPrivate()\n\n Const UP_TO_LINE = 5\n Const PRIVATE_MODULE = \"Option Private Module\"\n\n Dim objXL As Object\n \n Dim objPro As Object\n Dim objComp As Variant\n Dim strText As String\n \n Set objXL = GetObject(, \"Excel.Application\")\n Set objPro = objXL.ActiveWorkbook.VBProject\n \n For Each objComp In objPro.VBComponents\n If objComp.Type = 1 Then\n strText = objComp.CodeModule.Lines(1, UP_TO_LINE)\n \n If InStr(1, strText, PRIVATE_MODULE) = 0 Then\n objComp.CodeModule.InsertLines 2, PRIVATE_MODULE\n End If\n \n End If\n Next objComp\n \nEnd Sub\n" }, { "path": "VBE/GitSave.vb", "content": "Sub GitSave()\n \n DeleteAndMake\n ExportModules\n PrintAllCode\n PrintAllContainers\n \nEnd Sub\n\nSub DeleteAndMake()\n \n Dim fso As Object\n Set fso = CreateObject(\"Scripting.FileSystemObject\")\n\n Dim parentFolder As String: parentFolder = ThisWorkbook.Path & \"\\VBA\"\n Dim childA As String: childA = parentFolder & \"\\VBA-Code_Together\"\n Dim childB As String: childB = parentFolder & \"\\VBA-Code_By_Modules\"\n \n On Error Resume Next\n fso.DeleteFolder parentFolder\n On Error GoTo 0\n \n MkDir parentFolder\n MkDir childA\n MkDir childB\n \nEnd Sub\n\nSub PrintAllCode()\n \n Dim item As Variant\n Dim textToPrint As String\n Dim lineToPrint As String\n \n For Each item In ThisWorkbook.VBProject.VBComponents\n lineToPrint = item.codeModule.Lines(1, item.codeModule.CountOfLines)\n Debug.Print lineToPrint\n textToPrint = textToPrint & vbCrLf & lineToPrint\n Next item\n \n Dim pathToExport As String: pathToExport = ThisWorkbook.Path & \"\\VBA\\VBA-Code_Together\\\"\n If Dir(pathToExport) <> \"\" Then Kill pathToExport & \"*.*\"\n SaveTextToFile textToPrint, pathToExport & \"all_code.vb\"\n \nEnd Sub\n\nSub PrintAllContainers()\n \n Dim item As Variant\n Dim textToPrint As String\n Dim lineToPrint As String\n \n For Each item In ThisWorkbook.VBProject.VBComponents\n lineToPrint = item.Name\n Debug.Print lineToPrint\n textToPrint = textToPrint & vbCrLf & lineToPrint\n Next item\n \n Dim pathToExport As String: pathToExport = ThisWorkbook.Path & \"\\VBA\\VBA-Code_Together\\\"\n SaveTextToFile textToPrint, pathToExport & \"all_modules.vb\"\n \nEnd Sub\n\nSub ExportModules()\n \n Dim pathToExport As String: pathToExport = ThisWorkbook.Path & \"\\VBA\\VBA-Code_By_Modules\\\"\n \n If Dir(pathToExport) <> \"\" Then\n Kill pathToExport & \"*.*\"\n End If\n \n Dim wkb As Workbook: Set wkb = Excel.Workbooks(ThisWorkbook.Name)\n \n Dim unitsCount As Long\n Dim filePath As String\n Dim component As VBIDE.VBComponent\n Dim tryExport As Boolean\n\n For Each component In wkb.VBProject.VBComponents\n tryExport = True\n filePath = component.Name\n \n Select Case component.Type\n Case vbext_ct_ClassModule\n filePath = filePath & \".cls\"\n Case vbext_ct_MSForm\n filePath = filePath & \".frm\"\n Case vbext_ct_StdModule\n filePath = filePath & \".bas\"\n Case vbext_ct_Document\n tryExport = False\n End Select\n \n If tryExport Then\n Debug.Print unitsCount & \" exporting \" & filePath\n component.Export pathToExport & \"\\\" & filePath\n End If\n Next\n\n Debug.Print \"Exported at \" & pathToExport\n \nEnd Sub\n\nSub SaveTextToFile(dataToPrint As String, pathToExport As String)\n \n Dim fileSystem As Object\n Dim textObject As Object\n Dim fileName As String\n Dim newFile As String\n Dim shellPath As String\n \n If Dir(ThisWorkbook.Path & newFile, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFile\n \n Set fileSystem = CreateObject(\"Scripting.FileSystemObject\")\n Set textObject = fileSystem.CreateTextFile(pathToExport, True)\n \n textObject.WriteLine dataToPrint\n textObject.Close\n \n On Error GoTo 0\n Exit Sub\n\nCreateLogFile_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CreateLogFile of Sub mod_TDD_Export\"\n\nEnd Sub\n" }, { "path": "VBE/MovingModules.vb/ThisSheet.vb", "content": "Private Sub chb_name_Click()\n \n txtbox_name.Enabled = Not txtbox_name.Enabled\n \nEnd Sub\n\nPrivate Sub cmd_browse_Click()\n \n Dim str_file As String\n \n str_file = Application.GetOpenFilename _\n (Title:=\"Please choose a file to open\", _\n FileFilter:=\"Excel Files *.xls* (*.xls*),\")\n \n txtbox_display.Caption = str_file\n \nEnd Sub\n\nPrivate Sub cmd_MainGen_Click()\n \n Call MainGen\n \nEnd Sub\n" }, { "path": "VBE/MovingModules.vb/ThisWorkbook.vb", "content": "Option Explicit\n\nPrivate Sub Workbook_Open()\n\n Dim i As Long\n \n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Protect Password:=s_CONST\n Next\n \n Application.DisplayAlerts = False\n \nEnd Sub\n" }, { "path": "VBE/MovingModules.vb/cls_calendar.vb", "content": "Option Explicit\n\nPrivate p_last_row As Long\nPrivate p_length_of_calendar As Long\nPrivate p_rightest_column As Long\n\nPrivate p_date_first_month As Date\nPrivate p_date_last_month As Date\n\nPrivate p_range_4_dates As Range\n'\n\nPublic Property Get Range4Dates() As Range\n Range4Dates = p_range_4_dates\nEnd Property\n\nPublic Property Let Range4Dates(value As Range)\n p_range_4_dates = value\nEnd Property\n\nPublic Property Get RightestColumn() As Long\n RightestColumn = p_rightest_column\nEnd Property\n\nPublic Property Let RightestColumn(value As Long)\n p_rightest_column = value\nEnd Property\n\nPublic Property Get CalendarLength() As Long\n CalendarLength = p_length_of_calendar\nEnd Property\n\nPublic Property Let CalendarLength(value As Long)\n p_length_of_calendar = value\nEnd Property\n\nPublic Property Get LastMonth() As Date\n LastMonth = p_date_last_month\nEnd Property\n\nPublic Property Let LastMonth(value As Date)\n p_date_last_month = value\nEnd Property\n\nPublic Property Get FirstMonth() As Date\n FirstMonth = p_date_first_month\nEnd Property\n\nPublic Property Let FirstMonth(value As Date)\n p_date_first_month = value\nEnd Property\n\nPublic Property Get LastRow() As Long\n LastRow = p_last_row\nEnd Property\n\nPublic Property Let LastRow(value As Long)\n p_last_row = value\nEnd Property\n" }, { "path": "VBE/MovingModules.vb/mod_gen_main.vb", "content": "Option Explicit\n\nPublic Sub MainGen()\n\n Dim str_file_name As String\n\n 'On Error GoTo MainGen_Error\n \n Call OnStart\n\n Set DestWb = Workbooks.Open(tbl_gen.txtbox_display)\n str_file_name = define_new_file_name\n DestWb.SaveAs str_file_name, FileFormat:=52\n\n Set DestWb = Workbooks.Open(str_file_name)\n \n If WorkbookHasVBACode(DestWb) Then\n MsgBox STR_CODE_IN_DESTINATION_ERROR, vbInformation, \"Generator\"\n Exit Sub\n End If\n \n\n Call CopyModule(ThisWorkbook, \"mod_public\", DestWb)\n Call CopyModule(ThisWorkbook, \"mod_main\", DestWb)\n Call CopyModule(ThisWorkbook, \"cls_calendar\", DestWb)\n \n Application.Run \"'\" & DestWb.Name & \"'!AddAButton\"\n\n MsgBox \"Datei \" & str_file_name & \" generiert.\", vbInformation, \"Generator\"\n \n DestWb.Save\n DestWb.Close\n Set DestWb = Nothing\n \n Call OnEnd\n \n On Error GoTo 0\n Exit Sub\n\nMainGen_Error:\n\n Select Case Err.Number\n \n Case 1004:\n MsgBox STR_UNCLOSED_FILE_ERROR\n Case Else:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure MainGen of Module mod_gen_main\"\n End Select\n \n Call OnEnd\n \nEnd Sub\n\nPrivate Function WorkbookHasVBACode(wb As Workbook)\n \n Dim ModuleLineCount As Long\n \n On Error GoTo WorkbookHasVBACode_Error\n \n WorkbookHasVBACode = False\n ModuleLineCount = wb.VBProject.VBComponents(wb.CodeName).CodeModule.CountOfLines\n \n If ModuleLineCount > 25 Then\n WorkbookHasVBACode = True\n End If\n\n On Error GoTo 0\n Exit Function\n\nWorkbookHasVBACode_Error:\n \n Debug.Print \"error in WorkbookHasVBACode\"\n \nEnd Function\n\nPublic Function define_new_file_name() As String\n \n If tbl_gen.txtbox_name.Enabled And Len(tbl_gen.txtbox_name.Text) > 1 Then\n define_new_file_name = tbl_gen.txtbox_name.Text\n Else\n define_new_file_name = \"_\" & CLng(Now()) - 42390 & CStr(CDate(Now()))\n define_new_file_name = Replace(define_new_file_name, \":\", \"\")\n define_new_file_name = Replace(define_new_file_name, \".\", \"\")\n End If\n \nEnd Function\n\nSub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)\n \n' copies a module from one workbook to another\n' example:\n' CopyModule Workbooks(\"Book1.xls\"), \"Module1\", Workbooks(\"Book2.xls\")\n \n Dim strFolder As String\n Dim strTempFile As String\n \n strFolder = SourceWB.Path\n \n If Len(strFolder) = 0 Then strFolder = CurDir\n strFolder = strFolder & \"\\\"\n strTempFile = strFolder & \"~tmpexport.bas\"\n \n On Error Resume Next\n \n SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile\n TargetWB.VBProject.VBComponents.Import strTempFile\n Kill strTempFile\n \n On Error GoTo 0\n \nEnd Sub\n\nPublic Sub OnStart()\n \n Application.DisplayAlerts = False\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n \n 'Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub aaa()\n Dim i As Long\n \n If Environ(\"Username\") = \"v.doynov\" Then\n Debug.Print \"here you go ...\"\n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST\n Next\n End If\nEnd Sub\n\nPublic Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String\n\n Dim HexR As Variant, HexB As Variant, HexG As Variant\n Dim sTemp As String\n\n On Error GoTo ErrorHandler\n\n 'R\n HexR = Hex(R)\n If Len(HexR) < 2 Then HexR = \"0\" & HexR\n\n 'Get Green Hex\n HexG = Hex(G)\n If Len(HexG) < 2 Then HexG = \"0\" & HexG\n\n HexB = Hex(B)\n If Len(HexB) < 2 Then HexB = \"0\" & HexB\n\n RGB2HTMLColor = HexR & HexG & HexB\n Debug.Print \"Leave H800 on its place\"\n Exit Function\n \nErrorHandler:\n Debug.Print \"N O T successful\"\nEnd Function\n" }, { "path": "VBE/MovingModules.vb/mod_gen_public.vb", "content": "Option Explicit\n\n'Microsoft Visual Basic For Applications Extensibility Library\nPublic DestWb As Workbook\n" }, { "path": "VBE/MovingModules.vb/mod_main.vb", "content": "Option Explicit\n\nPublic Sub main()\n \n On Error GoTo main_Error\n \n Call OnStart\n \n Call ClearWritingPlace\n Call WriteMonthsAbove\n Call GenerateValuesInside\n Call GenerateSumsAtTheEnd\n Call BorderMe(ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, L_FIRST_COLUMN_TO_WRITE), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, obj_cal.RightestColumn)))\n Call AutoFitAndMessageBox\n Call SetObjectsToNothing\n \n Call OnEnd\n \n On Error GoTo 0\n Exit Sub\n \nmain_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure main of Module mod_main\"\n Call SetObjectsToNothing\n Call OnEnd\n \nEnd Sub\n\nPublic Sub SetObjectsToNothing()\n\n Set r_range_4_dates = Nothing\n Set obj_cal = Nothing\n\nEnd Sub\n\nPublic Sub AutoFitAndMessageBox()\n \n Range(ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, L_FIRST_COLUMN_TO_WRITE), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow + 2, obj_cal.RightestColumn)).Columns.AutoFit\n MsgBox STR_FERTIG, vbInformation, STR_SCHADENSERSATZ\n\nEnd Sub\n\nPublic Sub GenerateValuesInside()\n \n Dim l_counter_row As Long\n Dim l_counter_col As Long\n \n For l_counter_row = L_STARTING_ROW To obj_cal.LastRow\n For l_counter_col = L_FIRST_COLUMN_TO_WRITE To obj_cal.RightestColumn\n Call GenerateFormula(l_counter_row, l_counter_col)\n Next l_counter_col\n Next l_counter_row\n \nEnd Sub\n\nPublic Sub WriteMonthsAbove()\n\n For l_counter = 0 To obj_cal.CalendarLength - 1\n \n Set my_cell = ThisWorkbook.Sheets(1).Cells(L_STARTING_ROW - 1, L_FIRST_COLUMN_TO_WRITE + l_counter)\n my_cell = add_months(obj_cal.FirstMonth, l_counter)\n Call FormatMyCell(my_cell, False, True, True, True)\n \n Next l_counter\n \nEnd Sub\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n \n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row\n\nEnd Function\n\nPublic Function add_months(my_date As Date, l_month As Long) As Date\n \n add_months = get_last_day_of_month(DateAdd(\"m\", l_month, my_date))\n\nEnd Function\n\nPublic Function get_last_day_of_month(ByVal my_date As Date) As Date\n \n get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0)\n\nEnd Function\n\nPublic Sub ClearWritingPlace()\n\n Set obj_cal = New cls_calendar\n \n obj_cal.LastRow = last_row_with_data(1, ThisWorkbook.Sheets(1))\n Set r_range_4_dates = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(L_RATE6_VERTRAG_COL, L_STARTING_ROW), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, L_RATE5PR_TERMIN_COL))\n \n ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(1, L_FIRST_COLUMN_TO_WRITE - 1), ThisWorkbook.Sheets(1).Cells(Rows.Count, Columns.Count)).Clear\n obj_cal.FirstMonth = Application.WorksheetFunction.Min(r_range_4_dates)\n obj_cal.LastMonth = Application.WorksheetFunction.Max(r_range_4_dates)\n obj_cal.CalendarLength = DateDiff(\"m\", obj_cal.FirstMonth, obj_cal.LastMonth)\n obj_cal.RightestColumn = L_FIRST_COLUMN_TO_WRITE + obj_cal.CalendarLength - 1\n\nEnd Sub\n\n\nPublic Sub GenerateFormula(l_row, l_col)\n\n Dim date_date_above As Date\n Dim my_cell As Range\n Dim l_count_garages As Long\n Dim b_has_garage As Boolean: b_has_garage = False\n \n If WorksheetFunction.CountA(Cells(l_row, L_RATE6_VERTRAG_COL)) = 0 Then Exit Sub\n \n dbl_eur_m2 = ThisWorkbook.Sheets(1).Cells(2, 18)\n dbl_eur_garage = ThisWorkbook.Sheets(1).Cells(2, 19)\n \n date_date_above = ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, l_col)\n Set my_cell = Cells(l_row, l_col)\n \n If Cells(l_row, L_RATE6_VERTRAG_COL) < get_last_day_of_month(Cells(l_row, L_RATE6_TERMIN_COL)) Then\n If date_date_above > Cells(l_row, L_RATE6_VERTRAG_COL) And date_date_above <= get_last_day_of_month(Cells(l_row, L_RATE6_TERMIN_COL)) Then\n my_cell = dbl_eur_m2 * Cells(l_row, 15)\n End If\n End If\n \n On Error Resume Next 'do not do this at home...\n If CLng(Cells(l_row, 3)) > 0 Then b_has_garage = True\n On Error GoTo 0\n \n If Cells(l_row, L_RATE5PR_VERTRAG_COL) < Cells(l_row, L_RATE5PR_TERMIN_COL) And _\n b_has_garage Then\n \n If date_date_above > get_last_day_of_month(Cells(l_row, L_RATE5PR_VERTRAG_COL)) And _\n date_date_above <= get_last_day_of_month(Cells(l_row, L_RATE5PR_TERMIN_COL)) Then\n \n l_count_garages = find_in_string_times(Cells(my_cell.Row, 3)) + 1\n \n my_cell = my_cell + l_count_garages * dbl_eur_garage\n End If\n End If\n \n If my_cell > 0 Then Call FormatMyCell(my_cell, True, False, False, True)\n\nEnd Sub\n\nPublic Function find_in_string_times(my_cell As Range, Optional ch_char As String = \"+\") As Long\n\n find_in_string_times = UBound(Split(my_cell, ch_char))\n\nEnd Function\n\nPublic Sub FormatMyCell(ByRef my_cell As Range, Optional b_as_currency As Boolean = False, _\n Optional b_as_date As Boolean = False, _\n Optional b_as_dark As Boolean = False, _\n Optional b_as_din As Boolean = False)\n \n If b_as_currency Then\n my_cell.NumberFormat = \"#,##0.00 $\"\n End If\n \n If b_as_date Then\n my_cell.NumberFormat = \"[$-407]mmm/ yy;@\"\n End If\n \n If b_as_dark Then\n my_cell.Interior.ThemeColor = xlThemeColorDark1\n my_cell.Interior.TintAndShade = -0.249946592608417\n End If\n \n If b_as_din Then\n my_cell.Font.Name = \"DIN-Light\"\n End If\n\nEnd Sub\n\nPublic Sub OnStart()\n\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub GenerateSumsAtTheEnd()\n\n Dim l_counter As Long\n Dim my_cell As Range\n \n obj_cal.LastRow = obj_cal.LastRow + 1\n \n For l_counter = 0 To obj_cal.CalendarLength - 1\n Set my_cell = ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, L_FIRST_COLUMN_TO_WRITE + l_counter)\n my_cell.FormulaR1C1 = \"=SUM(R6C:R\" & obj_cal.LastRow - 1 & \"C)\"\n \n Call FormatMyCell(my_cell, True, False, True, True)\n\n Next l_counter\n \n Set my_cell = Cells(obj_cal.LastRow + 1, L_FIRST_COLUMN_TO_WRITE)\n my_cell.FormulaR1C1 = \"=SUM(R[-1]C:R[-1]C\" & L_FIRST_COLUMN_TO_WRITE + obj_cal.CalendarLength - 1 & \")\"\n \n Call FormatMyCell(my_cell, True, False, True, True)\n \nEnd Sub\n\nPublic Sub BorderMe(my_range)\n\n Dim l_counter As Long\n For l_counter = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc\n With my_range.Borders(l_counter)\n .LineStyle = xlContinuous\n .Weight = xlMedium\n End With\n Next l_counter\nEnd Sub\n\n\nPublic Sub AddAButton()\n Dim my_btn As Button\n Dim my_range As Range\n \n Set my_range = Sheets(1).Cells(1, 19)\n Set my_btn = Sheets(1).Buttons.Add(my_range.Left, my_range.Top, my_range.Width, my_range.Height)\n \n my_btn.OnAction = \"main\"\n my_btn.Caption = \"Laufen\"\n my_btn.Name = \"created_by_macro\"\n \nEnd Sub\n" }, { "path": "VBE/MovingModules.vb/mod_public.vb", "content": "Option Explicit\n\nPublic Const L_STARTING_ROW = 6\n\nPublic Const L_RATE6_VERTRAG_COL = 6\nPublic Const L_RATE6_TERMIN_COL = 10\nPublic Const L_RATE5PR_VERTRAG_COL = 8\nPublic Const L_RATE5PR_TERMIN_COL = 12\nPublic Const STR_FERTIG = \"Fertig!\"\nPublic Const STR_SCHADENSERSATZ = \"Schadensersatz\"\nPublic Const L_FIRST_COLUMN_TO_WRITE = 21\nPublic Const L_ROW_WITH_DATES = 5\n\nPublic Const L_WOHNFLAECHE_COL = 15\n\nPublic obj_cal As cls_calendar\n\nPublic dbl_eur_m2 As Double\nPublic dbl_eur_garage As Double\n\nPublic l_counter As Long\n\nPublic r_range_4_dates As Range\nPublic my_cell As Range\n" }, { "path": "VBE/Preprocessor.vb", "content": "Option Explicit\n\n#If Win32 Then\n Sub MyTest()\n Debug.Print \"32 bits.\"\n End Sub \n#ElseIf Win64 Then\n Sub MyTest()\n Debug.Print \"64 bits.\"\n 'This should be an error only if it is 64 bits:\n Debug.Print 0 / 0\n End Sub \n#ElseIf Win16\n Sub MyTest()\n Debug.Print \"16 bits.\"\n End Sub \n#End If\n\nSub MyExecutiveMain() \n MyTest\nEnd Sub\n\nSub WhichVersion()\n #If VBA7 Then\n Debug.Print \"VBA7\"\n #Else\n Debug.Print \"NOT VBA7\"\n #End If\nEnd Sub\n\n#If VBA7 And Win64 Then\n Private Declare PtrSafe Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\n#Else\n Private Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\n#End If\n" }, { "path": "VBE/PrintAllProcedures.vb", "content": "'---------------------------------------------------------------------------------------\r\n' Purpose : Prints all subs and functions in a project\r\n' Prerequisites: Microsoft Visual Basic for Applications Extensibility 5.3 library\r\n' CreateLogFile\r\n' How to run: Run GetFunctionAndSubNames, set a parameter to blnWithParentInfo\r\n' If ComponentTypeToString(vbext_ct_StdModule) = \"Code Module\" Then\r\n'\r\n' Used: ComponentTypeToString from -> http://www.cpearson.com/excel/vbe.aspx\r\n'---------------------------------------------------------------------------------------\r\n\r\nOption Explicit\r\n\r\nPrivate strSubsInfo As String\r\n\r\nPublic Sub GetFunctionAndSubNames()\r\n \r\n Dim item As Variant\r\n \r\n strSubsInfo = \"\"\r\n \r\n For Each item In ThisWorkbook.VBProject.VBComponents\r\n \r\n If ComponentTypeToString(vbext_ct_StdModule) = \"Code Module\" Then\r\n ListProcedures item.name, False\r\n 'Debug.Print item.CodeModule.lines(1, item.CodeModule.CountOfLines)\r\n End If\r\n \r\n Next item\r\n \r\n CreateLogFile strSubsInfo\r\n \r\nEnd Sub\r\n\r\nPrivate Sub ListProcedures(strName As String, Optional blnWithParentInfo = False)\r\n\r\n 'Microsoft Visual Basic for Applications Extensibility 5.3 library\r\n\r\n Dim VBProj As VBIDE.VBProject\r\n Dim VBComp As VBIDE.VBComponent\r\n Dim CodeMod As VBIDE.CodeModule\r\n Dim LineNum As Long\r\n Dim ProcName As String\r\n Dim ProcKind As VBIDE.vbext_ProcKind\r\n\r\n Set VBProj = ActiveWorkbook.VBProject\r\n Set VBComp = VBProj.VBComponents(strName)\r\n Set CodeMod = VBComp.CodeModule\r\n\r\n With CodeMod\r\n LineNum = .CountOfDeclarationLines + 1\r\n \r\n Do Until LineNum >= .CountOfLines\r\n ProcName = .ProcOfLine(LineNum, ProcKind)\r\n\r\n If blnWithParentInfo Then\r\n strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & strName & \".\" & ProcName\r\n Else\r\n strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & ProcName\r\n End If\r\n\r\n LineNum = .ProcStartLine(ProcName, ProcKind) + .ProcCountLines(ProcName, ProcKind) + 1\r\n Loop\r\n \r\n End With\r\n\r\nEnd Sub\r\n\r\nFunction ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String\r\n \r\n Select Case ComponentType\r\n \r\n Case vbext_ct_ActiveXDesigner\r\n ComponentTypeToString = \"ActiveX Designer\"\r\n \r\n Case vbext_ct_ClassModule\r\n ComponentTypeToString = \"Class Module\"\r\n \r\n Case vbext_ct_Document\r\n ComponentTypeToString = \"Document Module\"\r\n \r\n Case vbext_ct_MSForm\r\n ComponentTypeToString = \"UserForm\"\r\n \r\n Case vbext_ct_StdModule\r\n ComponentTypeToString = \"Code Module\"\r\n \r\n Case Else\r\n ComponentTypeToString = \"Unknown Type: \" & CStr(ComponentType)\r\n \r\n End Select\r\n \r\nEnd Function\r\n" }, { "path": "VBE/SaveThis.vb", "content": "Public Sub SaveThis()\n\n'saves foo.4.5.6.xlsb to foo.4.5.7.xlsb\n \n Dim mySplitter As Variant\n mySplitter = Split(ThisWorkbook.FullName, \".\")\n \n Dim oldVersion As String\n oldVersion = mySplitter(UBound(mySplitter) - 1)\n \n Dim newVersion As String\n newVersion = oldVersion + 1\n \n mySplitter(UBound(mySplitter) - 1) = newVersion\n \n Dim newName As String\n newName = Join(mySplitter, \".\")\n \n ThisWorkbook.SaveAs newName\n Debug.Print \"Saved as:\" & vbCrLf & newName\n \nEnd Sub\n\nPublic Sub SaveThisM()\n \n'saves foo.4.5.6.xlsb to foo.4.5.7.xlsb\n'and moves the old one to root\\Arch\\Auto\n\n Dim oldName As String\n oldName = ThisWorkbook.Name\n \n SaveThis\n \n Dim fso As New FileSystemObject\n fso.MoveFile Source:=ThisWorkbook.path & \"\\\" & oldName, Destination:=ThisWorkbook.path & \"\\Arch\\Auto\\\" & oldName\n\n Debug.Print \"Moved to:\" & vbCrLf & ThisWorkbook.path & \"\\Arch\\Auto\\\" & oldName\n \nEnd Sub\n" }, { "path": "XML/XmlSimpleManualParser.txt", "content": "Option Explicit\r\n\r\nSub TestMe()\r\n\r\n Dim xmlObj As Object\r\n Set xmlObj = CreateObject(\"MSXML2.DOMDocument\")\r\n \r\n xmlObj.async = False\r\n xmlObj.validateOnParse = False\r\n xmlObj.Load (\"C:\\Desktop\\test.xml\")\r\n \r\n Dim nodesThatMatter As Object\r\n Dim node As Object\r\n \r\n Set nodesThatMatter = xmlObj.SelectNodes(\"//gfi_message/body/data/node\")\r\n For Each node In nodesThatMatter\r\n Dim child As Variant\r\n For Each child In node.ChildNodes\r\n Dim childOfChild As Object\r\n Dim childOfChildInfo As String\r\n \r\n For Each childOfChild In child.Attributes\r\n childOfChildInfo = childOfChildInfo & \" -> \" & childOfChild.Text\r\n Next childOfChild\r\n Debug.Print Right(childOfChildInfo, Len(childOfChildInfo) - 4)\r\n childOfChildInfo = vbNullString\r\n Next child\r\n Next node\r\nEnd Sub\r\n" }, { "path": "XML/readme.md", "content": "# VBA - XML\r\n\r\nVitoshAcademy articles for XML:\r\n- [xml with php make links easily](https://www.vitoshacademy.com/xml-with-php-make-links-easily/)\r\n- [xml with css presentation of a simple web page](https://www.vitoshacademy.com/xml-with-css-presentation-of-a-simple-web-page/)\r\n- [php get-data from xml to html file with php](https://www.vitoshacademy.com/php-get-data-from-xml-to-html-file-with-php/)\r\n- [sql make xml from a sql database](https://www.vitoshacademy.com/sql-make-xml-from-a-sql-database/)\r\n- [vb xml generator with visual basic](https://www.vitoshacademy.com/vb-xml-generator-with-visual-basic/)\r\n\r\nThis one looks ok:\r\n- https://github.com/VBA-tools/VBA-XML\r\n\r\n:cactus: :four_leaf_clover: :poodle: :flags:\r\n" }, { "path": "XML/test.xml", "content": "\r\n \r\n
\r\n 123\r\n 2018-02-08T15:59:41+08:00\r\n 0.15\r\n
\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n\r\n" }, { "path": "__Arch/00.vb", "content": "Public Function change_commas(ByVal myValue As Variant) As String\n \n Dim str_temp As String\n \n str_temp = CStr(myValue)\n change_commas = Replace(str_temp, \",\", \".\")\n \nEnd Function\n\nPublic Function bubble_sort(ByRef TempArray As Variant) As Variant\n Dim Temp As Variant\n Dim i As Long\n Dim NoExchanges As Long\n \n ' Loop until no more \"exchanges\" are made.\n\n Do\n NoExchanges = True\n \n ' Loop through each element in the array.\n For i = LBound(TempArray) To UBound(TempArray) - 1\n \n ' If the element is greater than the element\n ' following it, exchange the two elements.\n If CLng(TempArray(i)) > CLng(TempArray(i + 1)) Then\n NoExchanges = False\n Temp = TempArray(i)\n TempArray(i) = TempArray(i + 1)\n TempArray(i + 1) = Temp\n End If\n Next i\n \n Loop While Not (NoExchanges)\n bubble_sort = TempArray\n\n On Error GoTo 0\n Exit Function\n \nEnd Function\n\nPublic Function get_last_day_of_month(ByVal my_date As Date) As Date\n\n get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0)\n \nEnd Function\n\nPublic Function get_first_day_of_month(ByVal my_date As Date) As Date\n \n get_first_day_of_month = DateSerial(Year(my_date), Month(my_date), 1)\n\nEnd Function\n\nPublic Function add_months(ByVal my_date As Date, ByVal i_month As Long) As Date\n \n add_months = get_last_day_of_month(DateAdd(\"m\", i_month, my_date))\n\nEnd Function\n\nPublic Function add_months_and_get_first_date(ByVal my_date As Date, ByVal i_month As Long) As Date\n\n add_months_and_get_first_date = get_first_day_of_month(DateAdd(\"m\", i_month, my_date))\n\nEnd Function\n\nPublic Function calculate_years_from_months(total_term) As Long\n \n calculate_years_from_months = total_term \\ MONTHS_IN_YEAR\n If total_term Mod MONTHS_IN_YEAR Then calculate_years_from_months = calculate_years_from_months + 1\n \nEnd Function\n\nPublic Function IsArrayAllocated(Arr As Variant) As Boolean\n \n On Error Resume Next\n \n IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)\n \n On Error GoTo 0\n\nEnd Function\n\nPublic Sub print_array(ByRef my_array As Variant)\n Dim counter As Long\n \n For counter = LBound(my_array) To UBound(my_array)\n Debug.Print counter & \" --> \" & my_array(counter)\n Next counter\n \nEnd Sub\n\nPublic Sub GenerateSumsOutput(l_lower_row As Long, l_higher_row As Long, l_current_row As Long)\n\n Dim r_cell As Range\n Dim l_counter As Long\n\n For l_counter = arr_calendar_settings(2) To arr_calendar_settings(3)\n Set r_cell = tbl_output.Cells(l_current_row, l_counter)\n r_cell.FormulaR1C1 = \"=SUM(R\" & l_higher_row & \"C:R\" & l_lower_row & \"C)\"\n Next l_counter\n\n Set r_cell = Nothing\n \nEnd Sub\n\nPublic Function bool_zero_or_empty(ByRef cell As Range, Optional b_is_range = False) As Boolean\n \n If b_is_range Then\n \n For Each current_cell In cell\n If (IsEmpty(current_cell) Or current_cell.Value = 0) Then\n bool_zero_or_empty = True\n Exit Function\n Else\n bool_zero_or_empty = False\n End If\n Next current_cell\n \n Else\n If (IsEmpty(cell) Or cell.Value = 0) Then\n bool_zero_or_empty = True\n Else\n bool_zero_or_empty = False\n End If\n End If\n\nEnd Function\n\nPublic Sub FormatAsDate(ByRef cell As Range)\n\n cell.NumberFormat = \"[$-407]mmm/ yy;@\"\n \nEnd Sub\n\nPublic Sub FormatAsPercent(ByRef my_cell As Range, Optional l_numbers = 2)\n\n If l_numbers = 3 Then\n my_cell.NumberFormat = \"0.000%\"\n Else\n my_cell.NumberFormat = \"0.00%\"\n End If\n\nEnd Sub\n\nPublic Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False, Optional b_make_gray = True, Optional b_make_round = True)\n \n Dim b_is_alone As Boolean\n \n b_is_alone = IIf(cell.Rows.Count + cell.Columns.Count <> 2, False, True)\n\n If IsNumeric(cell.Value) And (Not cell.HasFormula) Then\n cell.Value = Round(cell.Value, 2)\n End If\n \n If b_make_round Then\n cell.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00)\"\n Else\n cell.NumberFormat = \"$#,##0.00_);($#,##0.00)\"\n End If\n \n If b_change_0 Then\n\n With cell\n .FormatConditions.Delete\n .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=\"=0\"\n .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1\n .FormatConditions(1).Font.TintAndShade = -0.4\n End With\n End If\n\n If b_is_alone Then\n If b_make_gray And cell.Value = 0 Then\n With cell\n .Cells.Font.Color = RGB(191, 191, 191)\n End With\n End If\n End If\n\nEnd Sub\n\nPublic Sub FormatAs_Eur_pro_m2(my_cell As Range)\n \n my_cell.NumberFormat = \"#,##0.00 \"\" € / m²\"\"\"\n\nEnd Sub\n\nPublic Sub FormatRedAndBold(ByRef my_cell As Range, Optional isBold = True)\n \n my_cell.Font.Color = -16777063\n my_cell.Font.TintAndShade = 0\n\n If isBold Then my_cell.Font.Bold = True\n \nEnd Sub\n\nPublic Function millions_eur(ByVal my_value As Long) As Long\n \n millions_eur = my_value / 1000000\n\nEnd Function\n\nPublic Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet)\n \n Dim str_lines As String\n str_lines = lines & \":\" & lines\n \n With my_sheet.Rows(str_lines).Font\n .ThemeColor = xlThemeColorDark1\n .TintAndShade = 0\n End With\n \nEnd Sub\n\nPublic Sub WhiteCell(ByRef my_cell As Range)\n \n my_cell.Font.ThemeColor = xlThemeColorDark1\n my_cell.Font.TintAndShade = 0\n \nEnd Sub\n\nPublic Sub FormatFontColorToGrey(ByRef cell As Range)\n\n cell.Font.Color = RGB(128, 128, 128)\n\nEnd Sub\n\nPublic Function sum_range(my_range As Range) As Double\n\n Dim cell As Range\n\n sum_range = 0\n For Each cell In my_range\n sum_range = sum_range + cell.\n\n\n Next\n\nEnd Function\n\nPublic Function make_random(down As Long, up As Long) As Long\n \n make_random = CLng((up - down + 1) * Rnd + down)\n \n If make_random > up Then make_random = up\n If make_random < down Then make_random = down\n\nEnd Function\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n \n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).row\n \nEnd Function\n\nSub CopyValues(rngSource As Range, rngTarget As Range)\n \n rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value\n \nEnd Sub\n\nPublic Function check_if_hidden(r_range As Range) As Boolean\n\n If r_range.EntireRow.Hidden Or r_range.EntireColumn.Hidden Then\n check_if_hidden = True\n End If\n\nEnd Function\n\nFunction last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long\n \n Dim shSheet As Worksheet\n \n If str_sheet = vbNullString Then\n Set shSheet = ActiveSheet\n Else\n Set shSheet = Worksheets(str_sheet)\n End If\n \n last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).row\n\nEnd Function\n\nFunction last_column(Optional str_sheet As String, Optional row_to_check As Long = 1) As Long\n\n Dim shSheet As Worksheet\n \n If str_sheet = vbNullString Then\n Set shSheet = ActiveSheet\n Else\n Set shSheet = Worksheets(str_sheet)\n End If\n \n last_column = shSheet.Cells(row_to_check, shSheet.Columns.Count).End(xlToLeft).Column\n \nEnd Function\n\nPublic Function letter_col(ByVal col As Long) As String\n\n letter_col = Split(Cells(1, col).Address, \"$\")(1)\n\nEnd Function\n\nPublic Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean\n\n Dim l_counter\n\n If b_is_string Then\n my_array = Split(my_array, \":\")\n End If\n\n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n\nPublic Sub DrawBordersAroundRange(b_remove As Boolean)\n\n If b_remove Then\n\n [set_format].Copy\n [input_all_ba].PasteSpecial Paste:=xlPasteFormats\n Application.CutCopyMode = False\n \n 'make the last month white for austria\n If tbl_Input.opt_os Then\n For Each current_cell In [input_construction_time]\n tbl_Input.Cells(current_cell.row + 8, 12).Font.Color = vbWhite\n Next current_cell\n End If\n \n Else\n [set_format_without_borders].Copy\n [input_all_ba].PasteSpecial Paste:=xlPasteFormats\n Application.CutCopyMode = xlNone\n End If\n\nEnd Sub\n\nPublic Sub UnhideAll()\n \n Dim Sheet As Worksheet\n \n For Each Sheet In ThisWorkbook.Worksheets\n ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible\n Sheet.Visible = xlSheetVisible\n Next Sheet\n \n Call UnprotectAll\n \nEnd Sub\n\nPublic Sub UnprotectAll()\n\n Dim i As Long\n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST\n Next\n \nEnd Sub\n\nPublic Sub HideNeeded()\n \n Dim var_Sheet As Variant\n \n Dim arr_visible_sheets As Variant\n Dim arr_hidden_sheets As Variant\n \n Call OnStart\n \n arr_visible_sheets = Array(tbl_Input)\n arr_hidden_sheets = Array(tbl_output, tbl_calendar, tbl_log, tbl_settings, tbl_results, tbl_settings_bau)\n \n For Each var_Sheet In arr_visible_sheets\n var_Sheet.Visible = xlSheetVisible\n Next var_Sheet\n \n For Each var_Sheet In arr_hidden_sheets\n var_Sheet.Visible = xlSheetVeryHidden\n Next var_Sheet\n \n Call OnEnd\n \nEnd Sub\n\nPublic Sub add_comment_to_selection(my_comment As Range)\n Dim b As Boolean\n b = True\n For Each current_cell In Selection\n If b Then\n current_cell.ClearComments\n current_cell.AddComment my_comment.Text\n current_cell.Comment.Visible = False\n current_cell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft\n current_cell.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft\n End If\n b = Not b\n Next current_cell\nEnd Sub\n\nPublic Sub delete_comment_in_selection()\n For Each current_cell In Selection\n current_cell.ClearComments\n Next current_cell\nEnd Sub\n\nSub DeleteDrawingObjects()\n\n Dim l_counter As Long\n \n For l_counter = tbl_Input.DrawingObjects().Count To 1 Step -1\n 'Debug.Print tbl_Input.DrawingObjects(l_counter).name\n If Left(tbl_Input.DrawingObjects(l_counter).Name, 7) = \"TextBox\" Then\n tbl_Input.DrawingObjects(l_counter).Delete\n End If\n Next l_counter\n\nEnd Sub\n\nSub CoverRange(ByRef R As Range)\n \n Dim L As Long, t As Long, W As Long, H As Long\n \n L = R.Left\n t = R.Top\n W = R.Width\n H = R.Height\n \n 'msoTextOrientationHorizontal\n With ActiveSheet.Shapes\n .AddTextbox(msoTextOrientationVertical, L, t, W, H).Select\n Selection.ShapeRange.Line.Visible = msoFalse\n End With\n \nEnd Sub\n\nPublic Sub PrintPDF()\n\n On Error GoTo PrintPDF_Error\n\n ActiveSheet.PageSetup.Zoom = False\n ActiveSheet.PageSetup.BlackAndWhite = Not tbl_Input.cb_print_color\n\n [input_print_area].ExportAsFixedFormat _\n Type:=xlTypePDF, _\n Filename:=CStr([input_object_address] & \"_\" & [input_calculation_date]), _\n Quality:=xlQualityStandard, _\n IncludeDocProperties:=True, _\n IgnorePrintAreas:=False, _\n OpenAfterPublish:=True\n\n On Error GoTo 0\n Exit Sub\n\nPrintPDF_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure PrintPDF of Modul mod_Drucken\"\n\nEnd Sub\n\nPublic Sub PrintPage()\n\n Dim Sh As Worksheet\n Dim rngPrint As Range\n Dim s_reduce_paper_title As String\n\n On Error GoTo PrintPage_Error\n\n s_reduce_paper_title = \"Reduzieren Sie den Papierverbrauch\"\n ActiveSheet.PageSetup.BlackAndWhite = Not tbl_Input.cb_print_color\n \n Set Sh = ActiveSheet\n Set rngPrint = [input_print_area]\n\n With Sh.PageSetup\n .Orientation = xlPortrait\n .Zoom = False\n .FitToPagesTall = 1\n .FitToPagesWide = 1\n End With\n\n Select Case MsgBox(\"Sind Sie sicher, dass Sie drucken moechten?\", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title)\n Case vbYes\n Select Case MsgBox(\"Wirklich sicher, dass Sie drucken moechten?\", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title)\n Case vbYes\n rngPrint.PrintOut\n End Select\n End Select\n\n On Error GoTo 0\n Exit Sub\n\nPrintPage_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure PrintPage of Modul mod_Drucken\"\n\nEnd Sub\n\nPublic Sub ChangeCaption(lng_message As Long)\n\n Select Case lng_message\n Case 0:\n Application.Caption = \"Currently running\"\n Case 1:\n Application.Caption = \"Nicht erfolgreich\"\n Case 2:\n Application.Caption = \"Erfolg\"\n Case Else:\n Application.Caption = \"Unknown\"\n End Select\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \n Application.Calculation = xlAutomatic\n \n Call ProtectPAKU2\n\nEnd Sub\n\nPublic Sub OnStart()\n \n Application.ScreenUpdating = False\n Application.EnableEvents = False\n Application.Calculation = xlAutomatic\n \n ActiveWindow.View = xlNormalView\n Call UnProtectPAKU2\n\nEnd Sub\n\nPublic Sub DeleteName(sName As String)\n\n On Error GoTo DeleteName_Error\n\n ActiveWorkbook.Names(sName).Delete\n \n Debug.Print sName & \" is deleted!\"\n \n On Error GoTo 0\n Exit Sub\n\nDeleteName_Error:\n\n Debug.Print sName & \" not present or some error\"\n On Error GoTo 0\n \nEnd Sub\n\nPublic Function RGB2HTMLColor(R As Byte, G As Byte, _\n b As Byte) As String\n\n\n'INPUT: Numeric (Base 10) Values for R, G, and B)\n\n'RETURNS:\n'A string that can be used as an HTML Color\n'(i.e., \"#\" + the Hexadecimal equivalent)\n\n'For VBA the RGB is reversed. R and B are revered...\n\n Dim HexR, HexB, HexG As Variant\n\n On Error GoTo ErrorHandler\n\n 'R\n HexR = Hex(R)\n If Len(HexR) < 2 Then HexR = \"0\" & HexR\n\n 'Get Green Hex\n HexG = Hex(G)\n If Len(HexG) < 2 Then HexG = \"0\" & HexG\n\n HexB = Hex(b)\n If Len(HexB) < 2 Then HexB = \"0\" & HexB\n\n\n\n RGB2HTMLColor = \"#\" & HexR & HexG & HexB\nErrorHandler:\nEnd Function\n\nPublic Sub SelectAndChange()\n \n Dim current_cells_range As Range\n \n Dim l_step_between_BA As Long\n Dim l_counter As Long\n Dim col As Long\n Dim row As Long\n \n l_step_between_BA = 22\n col = Selection.Column\n row = Selection.row\n 'Beware what you select, for it would stay selected! :)\n \n Set current_cells_range = Selection\n \n For l_counter = 0 To 9\n Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + l_step_between_BA * l_counter, col))\n \n Next l_counter\n \n current_cells_range.Select\n \nEnd Sub\n\nFunction NamedRangeExists(strRangeName As String) As Boolean\n Dim my_range As Range\n \n On Error Resume Next\n \n Set my_range = Range(strRangeName)\n \n If Not my_range Is Nothing Then NamedRangeExists = True\n \n On Error GoTo 0\n \nEnd Function\n\nFunction getRGB2(l_long) As String\n Dim R As Long\n Dim G As Long\n Dim B As Long\n\n R = l_long Mod 256\n G = l_long \\ 256 Mod 256\n B = l_long \\ 65536 Mod 256\n getRGB2 = \"R=\" & R & \", G=\" & G & \", B=\" & B\nEnd Function\n\nPublic Function b_value_in_array(my_value As Variant, _\n my_array As Variant, _\n Optional b_is_string As Boolean = False, _\n Optional str_separator As String = \":\") As Boolean\n\n Dim l_counter\n\n If b_is_string Then\n my_array = Split(my_array, str_separator)\n End If\n\n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n\nPublic Function valueInArray(myValue As Variant, _\n myArray As Variant, Optional isString As Boolean = False) As Boolean\n\n Dim counter As Long\n\n If isString Then\n myArray = Split(myArray, \":\")\n End If\n\n For counter = LBound(myArray) To UBound(myArray)\n myArray(counter) = CStr(myArray(counter))\n Next counter\n\n valueInArray = Not IsError(Application.Match(CStr(myValue), myArray, 0))\n\nEnd Function\n\n\n'call lockscroll(Array(tbl_main.Name,\"A1:W100\"))\nPublic Sub LockScroll(ByRef my_array As Variant)\n \n Dim l_counter As Long\n \n If Not Len(Join(my_array)) > 0 Then Exit Sub\n \n For l_counter = 0 To UBound(my_array) Step 2\n ThisWorkbook.Sheets(my_array(l_counter)).ScrollArea = my_array(l_counter + 1)\n Next l_counter\n \nEnd Sub\n\nPublic Function col_value_find_value(s_wanted As String, tbl As Object) As Long\n \n On Error GoTo col_value_find_value_Error\n\n col_value_find_value = tbl.Cells(1, 1).EntireRow.Find(What:=s_wanted).Column\n\n On Error GoTo 0\n Exit Function\n\ncol_value_find_value_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure col_value_find_value of Function mod_various\"\n col_value_find_value = -1\n \nEnd Function\n\nPublic Function row_value_find_value(s_wanted As String, tbl As Object) As Long\n\n On Error GoTo row_value_find_value_Error\n\n row_value_find_value = tbl.Cells(1, 1).EntireColumn.Find(What:=s_wanted).Row\n\n On Error GoTo 0\n Exit Function\n\nrow_value_find_value_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure row_value_find_value of Function mod_various\"\n row_value_find_value = -1\n\nEnd Function\n\n\nPublic Sub CreateChart()\n \n Dim myChtObj As ChartObject\n Dim rngChtData As Range\n Dim rngChtXVal As Range\n Dim iColumn As Long\n Dim l_border As Long: l_border = Application.Width * 0.02\n\n Set rngChtData = tbl_input.Range(tbl_input.Cells(1, CALENDAR_START_COL), tbl_input.Cells(2, CALENDAR_START_COL).End(xlToRight))\n \n Debug.Print Application.Width\n Debug.Print Application.Width - l_border\n \n Set myChtObj = tbl_input.ChartObjects.Add( _\n Left:=Application.Width / 4, _\n Width:=2 * (Application.Width / 3), _\n Top:=tbl_input.Cells(7, 4).Top, _\n Height:=Application.Width / 5)\n \n myChtObj.Chart.SetSourceData Source:=rngChtData\n myChtObj.Chart.Legend.Delete\n myChtObj.Chart.ChartStyle = 40\n myChtObj.Chart.ClearToMatchStyle\n \n Cells(1, 1).Select\n \n Set rngChtData = Nothing\n Set myChtObj = Nothing\n\n On Error GoTo 0\n Exit Sub\n \nEnd Sub\n\nPublic Sub PrintMyName()\n\n Debug.Print Chr(194) & Chr(200) & Chr(210) & Chr(206) & Chr(216)\n\nEnd Sub\n\nPublic Function Now() As Date\n \n If [set_in_production] Then\n Now = VBA.Now()\n Else\n Now = DateSerial(2017, 2, 2) + TimeSerial(15, 1, 2)\n End If\n \nEnd Function\n" }, { "path": "__Arch/01.vb", "content": "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)\n If CloseMode = 0 Then Cancel = True\nEnd Sub\n\nPrivate Sub Workbook_Open()\n\n\n On Error GoTo Workbook_Open_Error\n\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\n Application.DisplayFormulaBar = False\n [set_root_user] = False\n If Not b_value_in_array(Environ(\"username\"), ADMINS, True) Then\n Application.OnKey \"%{F11}\", \"\"\n End If\n \n Application.OnKey \"^c\", \"\"\n Application.OnKey \"^v\", \"\"\n Application.OnKey \"^x\", \"\"\n\n Application.WindowState = xlMaximized\n \n On Error GoTo 0\n Exit Sub\n\nWorkbook_Open_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_Open of Sub xl_paku\"\n Me.Save\n ThisWorkbook.Close\n \nEnd Sub\n\n\nPrivate Sub Workbook_BeforeClose(Cancel As Boolean)\n\n On Error GoTo Workbook_BeforeClose_Error\n\n Cancel = False\n \n ThisWorkbook.Save\n Application.DisplayAlerts = False\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n Application.DisplayAlerts = True\n ActiveWindow.DisplayHeadings = True\n Application.DisplayFormulaBar = True\n ActiveSheet.PageSetup.BlackAndWhite = False\n Me.Save\n \n 'Return the disabled keys:\n Application.OnKey \"%{F11}\"\n Application.OnKey \"^c\"\n Application.OnKey \"^v\"\n Application.OnKey \"^x\"\n\n On Error GoTo 0\n Exit Sub\n\nWorkbook_BeforeClose_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_BeforeClose of Sub xl_paku\"\n \nEnd Sub\n\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\n\n paku_message_title = tbl_settings.Range(\"AJ8\")\n \n If Not tbl_settings.Visible Then\n With Application\n Application.ScreenUpdating = False\n Application.DisplayAlerts = False\n Sh.Delete\n Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n End With\n \n MsgBox (Environ(\"UserName\") & \", Sie können Blätter nicht hinzufügen.\"), vbInformation, paku_message_title\n End If\n \nEnd Sub\n\nPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)\n If ActiveWindow.Zoom > 100 Or ActiveWindow.Zoom < 70 Then\n ActiveWindow.Zoom = 100\n End If\nEnd Sub\n" }, { "path": "__Arch/03.vb", "content": "Public Sub ShowErrors()\n \n Dim my_cell As Range\n Dim str_result As String\n \n For Each my_cell In ActiveSheet.UsedRange\n If IsError(my_cell) Then\n str_result = str_result & vbCrLf & my_cell.Address\n End If\n Next my_cell\n \n If Len(str_result) > 1 Then MsgBox str_result\n \nEnd Sub\n\nPublic Function fnStrChangeCommas(ByVal myValue As Variant) As String\n\n fnStrChangeCommas = Replace(CStr(myValue), \",\", \".\")\n\nEnd Function\n\n'Public Function change_commas(ByVal myValue As Variant) As String\n'\n' Dim str_temp As String\n'\n' str_temp = CStr(myValue)\n' change_commas = Replace(str_temp, \",\", \".\")\n'\n'End Function\n\nPublic Sub EnableMySaves()\n\n Application.OnKey \"%{F11}\"\n Application.OnKey \"^c\"\n Application.OnKey \"^v\"\n Application.OnKey \"^x\"\n If Not b_value_in_array(Environ(\"username\"), ADMINS, True) Then Application.EnableCancelKey = xlDisabled\n\nEnd Sub\n\nPublic Sub DisableMySaves()\n\n Application.OnKey \"^c\", \"DisabledCombination\"\n Application.OnKey \"^v\", \"DisabledCombination\"\n Application.OnKey \"^x\", \"DisabledCombination\"\n Application.EnableCancelKey = xlInterrupt\n\nEnd Sub\n" }, { "path": "__Arch/04 - Excel Objects Edition.vb", "content": "Option Explicit\n\nSub RemoveFormulasFromAnotherSheet()\n \n Dim rng_cell As Range\n Dim str_inside As String: str_inside = \":\\\"\n \n For Each rng_cell In ActiveSheet.UsedRange 'Selection\n If InStr(rng_cell.Formula, str_inside) > 0 Then\n Debug.Print rng_cell.Formula\n Debug.Print rng_cell.Address\n Debug.Print \"---------------------------\"\n 'rng_cell.Value = rng_cell.Value\n End If\n Next rng_cell\nEnd Sub\n\nSub ExtendContentFromRight()\n \n Dim rng_first As Range\n\n Set rng_first = Selection.Cells(1, 1)\n \n Selection.Formula = rng_first.Formula\n \n Set rng_first = Nothing\n \n End Sub\n\nPublic Sub ColorSS()\n \n On Error GoTo ColorSS_Error\n \n 'Colors Saturdays and Sundays.\n \n Dim r_cell As Range\n Dim r_range As Range\n \n For Each r_cell In Selection\n If Weekday(r_cell.Value) = 1 Or Weekday(r_cell.Value) = 7 Then\n Set r_range = ActiveSheet.Range(Cells(4, r_cell.Column), Cells(667, r_cell.Column))\n r_range.Interior.Color = 13434828\n End If\n Next r_cell\n \n Set r_range = Nothing\n\n On Error GoTo 0\n Exit Sub\n\nColorSS_Error:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure ColorSS of Sub mod_play_with_me\"\nEnd Sub\n\n'---------------------------------------------------------------------------------------\n' Method : AddStringToFormula\n' Author : v.doynov\n' Date : 29.03.2016\n' Purpose: Call like this =>> call AddStringToFormula(\")*set_teilung_ba1\") or ba2\n'---------------------------------------------------------------------------------------\nPublic Sub AddStringToFormula(s_added_str As String)\n\n Dim r_range As Range\n Dim l_counter As Long\n \n On Error GoTo AddStringToFormula_Error\n\n Debug.Print Selection.Address & \" -> \" & Selection.Parent.Name\n Stop 'Make sure you have only one sheet active in the current app\n \n For Each r_range In Selection.SpecialCells(xlCellTypeFormulas)\n r_range.Formula = \"=(\" & Right(r_range.Formula, Len(r_range.Formula) - 1) & s_added_str\n Debug.Print r_range.Address & \" changed\"\n l_counter = l_counter + 1\n Next r_range\n \n Debug.Print vbCrLf & \"Total Changes: \" & l_counter\n\n On Error GoTo 0\n Exit Sub\n\nAddStringToFormula_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure AddStringToFormula of Module mod_play\"\n \nEnd Sub\n\nSub DisplayCommentsInWS()\n\n Dim ws_target As Worksheet\n Dim ws_source As Worksheet\n Dim rng_rng As Range\n Dim rng_cell As Variant\n Dim i As Long: i = 2\n Dim b_comment_found As Boolean\n \n Call OnStart\n \n Set ws_target = Sheets(\"Comments\") 'I would love to have an error if it does not exist\n ws_target.Cells.Delete\n ws_target.Range(\"A1\") = \"Sheet\"\n ws_target.Range(\"B1\") = \"Address\"\n ws_target.Range(\"C1\") = \"Comment\"\n ws_target.Range(\"D1\") = \"Cell value\"\n ws_target.Range(\"E1\") = \"Author\"\n \n On Error Resume Next\n \n For Each ws_source In ThisWorkbook.Worksheets\n Set rng_cell = ws_source.Cells.SpecialCells(xlCellTypeComments)\n \n If Not IsEmpty(rng_cell) Then\n For Each rng_rng In rng_cell\n b_comment_found = True\n \n ws_target.Range(\"A\" & i) = ws_source.Name\n ws_target.Range(\"B\" & i) = rng_rng.Address\n ws_target.Range(\"C\" & i) = rng_rng.Comment.Text\n ws_target.Range(\"C\" & i).WrapText = False\n ws_target.Range(\"D\" & i) = rng_rng.Value\n ws_target.Range(\"E\" & i) = rng_rng.Comment.Author\n i = i + 1\n Debug.Print \"Working \" & i\n \n Next rng_rng\n End If\n Next ws_source\n \n If Not b_comment_found Then\n Debug.Print \"No Comments were found. Tab \"\"Comments\"\" is deleted\"\n Application.DisplayAlerts = False\n ws_target.Delete\n Application.DisplayAlerts = True\n Else\n Debug.Print \"End\"\n End If\n \n ws_target.Columns.AutoFit\n \n Call OnEnd\n \n On Error GoTo 0\n \n Set rng_rng = Nothing\n Set ws_source = Nothing\n Set ws_target = Nothing\n Set rng_cell = Nothing\n \nEnd Sub\n\nPublic Sub DeleteAllComments()\n\n Dim ws As Worksheet\n Dim cmt As Comment\n\n For Each ws In ThisWorkbook.Worksheets\n For Each cmt In ws.Comments\n Debug.Print \"Comment deleted\"\n cmt.Delete\n Next cmt\n Next ws\n\nEnd Sub\n\nPublic Sub OnStart()\n\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n" }, { "path": "__Arch/AllFormats.vb", "content": "Call FormatDin(my_cell)\nCall FormatDark(my_cell)\n\nPublic Sub FormatDark(ByRef my_cell As range)\n my_cell.Interior.ThemeColor = xlThemeColorDark1\n my_cell.Interior.TintAndShade = -0.249946592608417\nEnd Sub\n\nPublic Sub FormatDin(ByRef my_cell As range)\n my_cell.Font.Name = \"DIN-Light\"\nEnd Sub\n" }, { "path": "__Arch/AverageRowColumnNamedRange.vb", "content": "Public Function calculate_avg_row(rng As Range, Optional l_row As Long = 1) As Double\n\n Dim my_start As Range\n Dim my_end As Range\n\n Set my_start = Cells(rng.Cells(l_row, 1).Row, rng.Cells(l_row, 1).Column)\n Set my_end = rng.Cells(l_row, rng.Columns.Count)\n\n Debug.Print my_start.Address\n Debug.Print my_end.Address\n\n calculate_avg_row = WorksheetFunction.Average(Range(my_start, my_end))\n\nEnd Function\n\nOption Explicit\n\nPublic Function calculate_avg(rng As Range, Optional l_starting_col As Long = 1, Optional l_end_col As Long = 1) As Double\n\n Dim my_start As Range\n Dim my_end As Range\n\n Set my_start = Cells(rng.Cells(1, 1).Row, l_starting_col + rng.Cells(1, 1).Column - 1)\n Set my_end = Cells(rng.Cells(rng.Rows.Count, l_end_col).Row, rng.Columns.Count - rng.Cells(1, l_end_col).Column + l_end_col)\n\n 'Debug.Print my_start.Address\n 'Debug.Print my_end.Address\n\n calculate_avg = WorksheetFunction.Average(Range(my_start, my_end))\n\nEnd Function\n" }, { "path": "__Arch/BorderMeBorderRange.vb", "content": "Public Sub BorderMe(my_range)\n\n Dim l_counter As Long\n\n For l_counter = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc\n With my_range.Borders(l_counter)\n .LineStyle = xlContinuous\n .Weight = xlMedium\n End With\n Next l_counter\n\nEnd Sub\n" }, { "path": "__Arch/Classes/Class Builder VBA/cls_ba.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"cls_ba\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate p_row As Long\nPrivate p_vertriebsstart As Date\nPrivate p_counter_ba As Long\n\nPublic Property Let Row(value As Long)\n p_row = value\nEnd Property\n\nPublic Property Get Row() As Long\n Row = p_row\nEnd Property\n\nPublic Property Let Vertriebsstart(value As Date)\n p_vertriebsstart = value\nEnd Property\n\nPublic Property Get Vertriebsstart() As Date\n Vertriebsstart = p_vertriebsstart\nEnd Property\n\nPublic Property Let CounterBA(value As Long)\n p_counter_ba = value\nEnd Property\n\nPublic Property Get CounterBA() As Long\n CounterBA = p_counter_ba\nEnd Property\n\n" }, { "path": "__Arch/Classes/Class Builder VBA/cls_project.cls", "content": "VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"cls_project\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n\nPrivate p_ba_info() As cls_ba\n\nPublic Sub AddBA(ByVal obj_ba As cls_ba)\n \n ReDim Preserve p_ba_info(UBound(p_ba_info) + 1)\n Set p_ba_info(UBound(p_ba_info)) = obj_ba\n\nEnd Sub\n\nPrivate Sub Class_Initialize()\n \n ReDim p_ba_info(0)\n \nEnd Sub\n\n" }, { "path": "__Arch/Classes/Class Builder VBA/mod_main.bas", "content": "Attribute VB_Name = \"mod_main\"\nOption Explicit\n\nPublic obj_project As cls_project\n\nPublic Sub SetObjectBA()\n\n Dim l_counter As Long\n \n Set obj_project = New cls_project\n \n For l_counter = 0 To 2\n obj_project.AddBA Cls_BA_Builder(l_counter, l_counter + 5, Now())\n Next l_counter\n\nEnd Sub\n\nPublic Function Cls_BA_Builder(f_count_ba As Long, _\n f_row As Long, _\n f_vertriebsstart As Date) As cls_ba\n\n\n Dim obj As cls_ba\n \n Set obj = New cls_ba\n \n obj.CounterBA = f_count_ba\n obj.Row = f_row\n obj.Vertriebsstart = f_vertriebsstart\n \n Set Cls_BA_Builder = obj\n\nEnd Function\n\n\n" }, { "path": "__Arch/Classes/class-project/Call By Names", "content": "Public Sub GetInformationPrinted()\n'Tools - References - TypeLib Information\n\n Dim k As cls_arrCalendarSettings\n Dim mi As TLI.MemberInfo\n Dim i As Long\n Dim ti As TLI.TypeInfo\n Dim t As TLI.TLIApplication\n\n Set k = New cls_arrCalendarSettings\n \n k.TopRow = 10\n k.BottomRow = 15\n k.LeftCol = 3\n k.RightCol = 10\n k.SonstigesProBA = 1000.12\n k.VerhaltnisBaukostenToPlanerkosten = 0.35\n k.Vertriebsstart = Now()\n k.Vertriebsstart_Col = 50\n\n 'Now printing all\n Set t = New TLI.TLIApplication\n \n Set ti = t.InterfaceInfoFromObject(k)\n\n For Each mi In ti.Members\n Debug.Print mi.name\n Debug.Print CallByName(k, mi.name, VbGet)\n Next mi\n \n Set k = Nothing\n\nEnd Sub\n\n" }, { "path": "__Arch/Classes/class-project/check_properties.vb", "content": "Public Sub GetInformationPrinted()\n'Tools - References - TypeLib Information\n\n Dim k As cls_arrCalendarSettings\n Dim mi As TLI.MemberInfo\n Dim ti As TLI.TypeInfo\n Dim t As TLI.TLIApplication\n Dim b_show As Boolean\n \n Set k = New cls_arrCalendarSettings\n \n k.TopRow = 10\n k.BottomRow = 15\n k.LeftCol = 3\n k.RightCol = 10\n k.SonstigesProBA = 1000.12\n k.VerhaltnisBaukostenToPlanerkosten = 0.35\n k.Vertriebsstart = Now()\n k.Vertriebsstart_Col = 50\n\n 'Now printing all\n Set t = New TLI.TLIApplication\n \n Set ti = t.InterfaceInfoFromObject(k)\n\n For Each mi In ti.Members\n '0 is for GET Properties,\n '1 is for LET Properties\n 'Change accordingly\n If mi.ReturnType.PointerLevel = 0 Then\n Debug.Print mi.name & vbCrLf; CallByName(k, mi.name, VbGet) & vbCrLf\n End If\n Next mi\n \n Set k = Nothing\n\nEnd Sub\n" }, { "path": "__Arch/Classes/class-project/cls_arrCalendarSettings.vb", "content": "Option Explicit\n\nPrivate p_top_row As Long\nPrivate p_bottom_row As Long\nPrivate p_left_col As Long\nPrivate p_right_col As Long\n\nPrivate p_sonstiges_pro_BA As Double\nPrivate p_verhaltnis_baukosten_planer As Double\n\nPrivate p_vertriebsstart As Date\nPrivate p_vertriebsstart_col_num As Long\n\nPublic Property Let Vertriebsstart_Col(l_vertriebsstart_col As Long)\n p_vertriebsstart_col_num = l_vertriebsstart_col\nEnd Property\n\nPublic Property Get Vertriebsstart_Col() As Long\n Vertriebsstart_Col = p_vertriebsstart_col_num\nEnd Property\n\nPublic Property Let Vertriebsstart(date_vertriebsstart As Date)\n p_vertriebsstart = date_vertriebsstart\nEnd Property\n\nPublic Property Get Vertriebsstart() As Date\n Vertriebsstart = p_vertriebsstart\nEnd Property\n\nPublic Property Get LengthLeftToRight() As Long\n LengthLeftToRight = RightCol - LeftCol\nEnd Property\n\nPublic Property Get LengthTopToBottom() As Long\n LengthTopToBottom = BottomRow - TopRow\nEnd Property\n\nPublic Property Let VerhaltnisBaukostenToPlanerkosten(dbl_verhaltnis As Double)\n p_verhaltnis_baukosten_planer = dbl_verhaltnis\nEnd Property\n\nPublic Property Get VerhaltnisBaukostenToPlanerkosten() As Double\n VerhaltnisBaukostenToPlanerkosten = p_verhaltnis_baukosten_planer\nEnd Property\n\nPublic Property Let SonstigesProBA(dbl_sonstiges_money As Double)\n p_sonstiges_pro_BA = dbl_sonstiges_money\nEnd Property\n\nPublic Property Get SonstigesProBA() As Double\n SonstigesProBA = p_sonstiges_pro_BA\nEnd Property\n\nPublic Property Let TopRow(l_top_row As Long)\n p_top_row = l_top_row\nEnd Property\n\nPublic Property Get TopRow() As Long\n TopRow = p_top_row\nEnd Property\n\nPublic Property Let BottomRow(l_bottom_row As Long)\n p_bottom_row = l_bottom_row\nEnd Property\n\nPublic Property Get BottomRow() As Long\n BottomRow = p_bottom_row\nEnd Property\n\nPublic Property Let LeftCol(l_left_col As Long)\n p_left_col = l_left_col\nEnd Property\n\nPublic Property Get LeftCol() As Long\n LeftCol = p_left_col\nEnd Property\n\nPublic Property Let RightCol(l_right_col As Long)\n p_right_col = l_right_col\nEnd Property\n\nPublic Property Get RightCol() As Long\n RightCol = p_right_col\nEnd Property\n" }, { "path": "__Arch/Classes/class-project/cls_arr_Choice.vb", "content": "Option Explicit\n\nPrivate p_investor As String\nPrivate p_region As String\nPrivate p_standort As String\nPrivate p_project As String\nPrivate p_ba_number As Long\nPrivate p_global As Boolean\n\nPublic Property Get Investor() As String\n Investor = p_investor\nEnd Property\n\nPublic Property Let Investor(str_investor_type As String)\n p_investor = str_investor_type\nEnd Property\n\nPublic Property Get Region() As String\n Region = p_region\nEnd Property\n\nPublic Property Let Region(str_region As String)\n p_region = str_region\n p_standort = IIf(str_region = \"Wien\", \"Austria\", \"Germany\")\nEnd Property\n\nPublic Property Get Standort()\n Standort = p_standort\nEnd Property\n\nPublic Property Get Project() As String\n Project = p_project\nEnd Property\n\nPublic Property Let Project(str_project As String)\n p_project = str_project\nEnd Property\n\nPublic Property Get BAnumber() As Long\n BAnumber = p_ba_number\nEnd Property\n\nPublic Property Let BAnumber(l_ba_number As Long)\n p_ba_number = l_ba_number\nEnd Property\n\nPublic Property Let GlobalProject(b_is_global As Boolean)\n p_global = b_is_global\nEnd Property\n\nPublic Property Get GlobalProject() As Boolean\n GlobalProject = p_global\nEnd Property\n\nPublic Property Get GewerbeGlobal() As Boolean\n \n If GlobalProject And Project = type_string_project(enum_project.project_gewerbe) Then\n GewerbeGlobal = True\n Else\n GewerbeGlobal = False\n End If\n \nEnd Property\n\n" }, { "path": "__Arch/Classes/class-project/mod_Properties.vb", "content": "Option Explicit\n\nPublic Property Get type_string_project(enum_project) As String\n \n Dim arr_helping As Variant\n \n arr_helping = Array(\"Wohnung Project\", \"Gewerbe Project\", \"Beides\")\n type_string_project = VBA.CStr(arr_helping(enum_project))\n \nEnd Property\n\nPublic Property Get type_string_standort(enum_standort) As String\n \n Dim arr_helping As Variant\n \n arr_helping = Array(\"Munchen\", \"Hamburg\", \"Berlin\", \"Nurnberg\", \"Frankfurt\", \"Wien\")\n type_string_standort = VBA.CStr(arr_helping(enum_standort))\n \nEnd Property\n\nPublic Property Get type_string_investor(enum_investors) As String\n \n Dim arr_helping As Variant\n \n arr_helping = Array(\"Public Fund\", \"Private Fund\")\n type_string_investor = VBA.CStr(arr_helping(enum_investors))\n\nEnd Property\n" }, { "path": "__Arch/Classes/class-project/mod_PublicAndEnums", "content": "Option Explicit\n\nEnum enum_investors\n inv_Public\n inv_Private\nEnd Enum\n\nEnum enum_standort\n standort_Berlin\n standort_Hamburg\n standort_Nurnberg\n standort_Munchen\n standort_Frankfurt\n standort_Vienna\nEnd Enum\n\nEnum enum_project\n project_wohnung\n project_gewerbe\n project_beides\nEnd Enum\n\nEnum enum_BA\n \n BA_0\n BA_1\n BA_2\n BA_3\n BA_4\n BA_5\n BA_6\n BA_7\n BA_8\n BA_9\n BA_10\n\nEnd Enum\n\nPublic my_choice As cls_arrChoice\n" }, { "path": "__Arch/Classes/class-project/mod_current.vb", "content": "Option Explicit\n\nSub Load_Data_To_Object()\n\n Set my_choice = New cls_arrChoice\n \n my_choice.Investor = type_string_investor(enum_investors.inv_Private)\n my_choice.Region = type_string_standort(enum_standort.standort_Vienna)\n my_choice.Project = type_string_project(enum_project.project_gewerbe)\n my_choice.BAnumber = enum_BA.BA_10\n my_choice.GlobalProject = True\n \nEnd Sub\n\nSub Display_Data_From_Object()\n\n Debug.Print my_choice.Investor\n Debug.Print my_choice.Standort\n Debug.Print my_choice.Region\n Debug.Print my_choice.Project\n Debug.Print my_choice.BAnumber\n Debug.Print my_choice.GlobalProject\n Debug.Print my_choice.GewerbeGlobal\n \nEnd Sub\n" }, { "path": "__Arch/Classes/class-project-customized/customized_procedure.vb", "content": "Public Sub PrintProperties(my_object As Object)\n 'Tools - References - TypeLib Information\n \n Dim mi As TLI.MemberInfo\n Dim ti As TLI.TypeInfo\n Dim t As TLI.TLIApplication\n \n Set t = New TLI.TLIApplication\n \n Set ti = t.InterfaceInfoFromObject(my_object)\n \n Debug.Print \"***********************\"\n \n For Each mi In ti.Members\n '0 is for GET Properties,\n '1 is for LET Properties\n 'Change accordingly\n If mi.ReturnType.PointerLevel = 0 Then\n Debug.Print mi.name & vbCrLf; CallByName(my_object, mi.name, VbGet) & vbCrLf\n End If\n Next mi\n \n Debug.Print \"***********************\"\n \n Set my_object = Nothing\n\n \nEnd Sub\n" }, { "path": "__Arch/Classes/class-project-improved/cls_arrCalendar.vb", "content": "Option Explicit\n\nPrivate p_top_row As Long\nPrivate p_bottom_row As Long\nPrivate p_left_col As Long\nPrivate p_right_col As Long\n\nPublic Property Let TopRow(l_top_row As Long)\n p_top_row = l_top_row\nEnd Property\n\nPublic Property Get TopRow() As Long\n TopRow = p_top_row\nEnd Property\n\nPublic Property Let BottomRow(l_bottom_row As Long)\n p_bottom_row = l_bottom_row\nEnd Property\n\nPublic Property Get BottomRow() As Long\n BottomRow = p_bottom_row\nEnd Property\n\nPublic Property Let LeftCol(l_left_col As Long)\n p_left_col = l_left_col\nEnd Property\n\nPublic Property Get LeftCol() As Long\n LeftCol = p_left_col\nEnd Property\n\nPublic Property Let RightCol(l_right_col As Long)\n p_right_col = l_right_col\nEnd Property\n\nPublic Property Get RightCol() As Long\n RightCol = p_right_col\nEnd Property\n" }, { "path": "__Arch/Classes/class-project-improved/cls_arrChoice.vb", "content": "Option Explicit\n\nPrivate p_investor As String\nPrivate p_region As String\nPrivate p_standort As String\nPrivate p_project As String\n\nPrivate p_ba_number As Long\nPrivate p_global As Boolean\n\nPublic Property Get Investor() As String\n Investor = p_investor\nEnd Property\n\nPublic Property Let Investor(str_investor_type As String)\n p_investor = str_investor_type\nEnd Property\n\nPublic Property Get Region() As String\n Region = p_region\nEnd Property\n\nPublic Property Let Region(ByVal str_region As String)\n p_region = str_region\nEnd Property\n\nPublic Property Let Standort(ByVal str_standort As String)\n p_standort = str_standort\nEnd Property\n\nPublic Property Get Standort() As String\n Standort = p_standort\nEnd Property\n\nPublic Property Get Project() As String\n Project = p_project\nEnd Property\n\nPublic Property Let Project(str_project As String)\n p_project = str_project\nEnd Property\n\nPublic Property Get BAnumber() As Long\n BAnumber = p_ba_number\nEnd Property\n\nPublic Property Let BAnumber(l_ba_number As Long)\n p_ba_number = l_ba_number\nEnd Property\n\n\nPublic Property Let GlobalProject(b_is_global As Boolean)\n p_global = b_is_global\nEnd Property\n\nPublic Property Get GlobalProject() As Boolean\n GlobalProject = p_global\nEnd Property\n\nPublic Property Get GewerbeGlobal() As Boolean\n \n If GlobalProject And Project = [set_abbreviation_gewerbe] Then\n GewerbeGlobal = True\n Else\n GewerbeGlobal = False\n End If\n \nEnd Property\n" }, { "path": "__Arch/Classes/class-project-improved/sandbox.vb", "content": "Option Explicit\nPublic my_choice As cls_arrChoice\n'vitosh\nSub Load_Data_To_Object()\n \n Dim s_data As String\n\n Set my_choice = New cls_arrChoice\n \n \n If tbl_Input.opt_publikum Then\n my_choice.Investor = [set_abbreviation_pub]\n ElseIf tbl_Input.opt_institutionen Then\n my_choice.Investor = [set_abbreviation_insti]\n End If\n \n \n If tbl_Input.opt_de Then\n my_choice.Standort = [set_abbreviation_ger]\n ElseIf tbl_Input.opt_os Then\n my_choice.Standort = [set_abbreviation_aus]\n ElseIf tbl_Input.opt_fr Then\n my_choice.Standort = [set_abbreviation_fra]\n End If\n \n \n If tbl_Input.opt_stadt1 And tbl_Input.opt_stadt1 = [set_vie_name] Then\n my_choice.Region = [set_vie_name]\n Else\n If tbl_Input.opt_stadt1 Then\n my_choice.Region = [set_muc_name]\n ElseIf tbl_Input.opt_stadt2 Then\n my_choice.Region = [set_han_name]\n ElseIf tbl_Input.opt_stadt3 Then\n my_choice.Region = [set_bln_name]\n ElseIf tbl_Input.opt_stadt4 Then\n my_choice.Region = [set_nbg_name]\n ElseIf tbl_Input.opt_stadt5 Then\n my_choice.Region = [set_ffm_name]\n End If\n End If\n \n \n If tbl_Input.opt_wohnung Then\n my_choice.Project = [set_abbreviation_wohnungen]\n ElseIf tbl_Input.opt_gewerbe Then\n my_choice.Project = [set_abbreviation_gewerbe]\n ElseIf tbl_Input.opt_wohnung Then\n my_choice.Project = [set_abbreviation_beides]\n End If\n \n my_choice.BAnumber = tbl_Input.cb_ba_number\n my_choice.GlobalProject = tbl_Input.chb_global\n \nEnd Sub\n\nSub Display_Data_From_Object()\n\n Debug.Print my_choice.Investor\n Debug.Print my_choice.Standort\n Debug.Print my_choice.Region\n Debug.Print my_choice.Project\n Debug.Print my_choice.BAnumber\n Debug.Print my_choice.GlobalProject\n Debug.Print my_choice.GewerbeGlobal\n \n 'Set my_choice = Nothing\nEnd Sub\n" }, { "path": "__Arch/FixSums.vb", "content": "'---------------------------------------------------------------------------------------\n' Procedure : FixSums\n' Author : v.doynov\n' Date : 18.09.2015\n' Purpose : Fixes the formulas in the sums as per the *******.\n'---------------------------------------------------------------------------------------\nPublic Sub FixSums(ByRef r_summen As Range, ByVal l_ba_value As Long)\n \n Dim my_cell As Range\n \n For Each my_cell In r_summen\n my_cell.FormulaR1C1 = \"=SUM(R[-10]C:R[-\" & 10 - l_ba_value + 1 & \"]C)\"\n Next my_cell\n \nEnd Sub\n" }, { "path": "__Arch/FormWithAnInstanceVBA/Form003/clsSummaryPresenter.vb", "content": " Option Explicit\n\nPrivate WithEvents objSummaryForm As frmMain\n\nPrivate Sub Class_Initialize()\n \n Set objSummaryForm = New frmMain\n\nEnd Sub\n\nPrivate Sub Class_Terminate()\n \n Set objSummaryForm = Nothing\n \nEnd Sub\n\nPublic Sub Show()\n\n If Not objSummaryForm.Visible Then\n objSummaryForm.Show vbModeless\n objSummaryForm.InformationText = \"Press Run to Start\"\n objSummaryForm.InformationCaption = \"Starting\"\n End If\n\nEnd Sub\n\nPublic Sub Hide()\n\n If objSummaryForm.Visible Then objSummaryForm.Hide\n\nEnd Sub\n\nPublic Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String)\n\n objSummaryForm.InformationText = strLabelInfo\n objSummaryForm.InformationCaption = strCaption\n objSummaryForm.Repaint\n\nEnd Sub\n\n\nPrivate Sub objSummaryForm_OnRunReport()\n\n MainGenerateReport\n Refresh\n\nEnd Sub\n\nPrivate Sub objSummaryForm_OnExit()\n \n Hide\n\nEnd Sub\n\nPublic Sub Refresh()\n \n With objSummaryForm\n .lblInfo = \"Ready\"\n .Caption = \"Task performed\"\n End With\n\nEnd Sub\n\n" }, { "path": "__Arch/FormWithAnInstanceVBA/Form003/frmMain.vb", "content": "Option Explicit\n\nPublic Event OnRunReport()\nPublic Event OnExit()\n\nPublic Property Get InformationText() As String\n \n InformationText = lblInfo.Caption\n\nEnd Property\n\nPublic Property Let InformationText(ByVal value As String)\n \n lblInfo.Caption = value\n\nEnd Property\n\nPublic Property Get InformationCaption() As String\n \n InformationCaption = Caption\n\nEnd Property\n\nPublic Property Let InformationCaption(ByVal value As String)\n \n Caption = value\n\nEnd Property\n\n\nPrivate Sub btnRun_Click()\n RaiseEvent OnRunReport\nEnd Sub\n\nPrivate Sub btnExit_Click()\n RaiseEvent OnExit\nEnd Sub\n\nPrivate Sub UserForm_QueryClose(CloseMode As Integer, Cancel As Integer)\n\n If CloseMode = vbFormControlMenu Then\n Cancel = True\n Hide\n End If\n\nEnd Sub\n" }, { "path": "__Arch/FormWithAnInstanceVBA/Form003/modMain.vb", "content": "Option Explicit\n\nPrivate objPresenter As clsSummaryPresenter\n\nPublic Sub MainGenerateReport()\n \n Call objPresenter.ChangeLabelAndCaption(\"Starting and running...\", \"Running...\")\n GenerateNumbers\n \nEnd Sub\n\nPublic Sub GenerateNumbers()\n \n Dim lngLong As Long\n Dim lngLong2 As Long\n \n tblMain.Cells.Clear\n \n For lngLong = 1 To 4\n For lngLong2 = 1 To 1\n tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2\n Next lngLong2\n Next lngLong\n\nEnd Sub\n\nPublic Sub ShowMainForm() 'CTRL+E\n\n If (objPresenter Is Nothing) Then\n Set objPresenter = New clsSummaryPresenter\n End If\n \n objPresenter.Show\n \nEnd Sub\n\n\n" }, { "path": "__Arch/FormWithAnInstanceVBA/clsSummaryPresenter.vb", "content": "Option Explicit\n\nPrivate WithEvents objSummaryForm As frmMain\n\nPrivate Sub Class_Initialize()\n \n Set objSummaryForm = New frmMain\n \nEnd Sub\n\nPrivate Sub Class_Terminate()\n \n Set objSummaryForm = Nothing\n \nEnd Sub\n\nPublic Sub Show()\n\n If Not objSummaryForm.Visible Then\n objSummaryForm.Show vbModeless\n objSummaryForm.lblInfo = \"Press Run to Start\"\n objSummaryForm.Caption = \"Starting\"\n End If\n\nEnd Sub\n\nPublic Sub Hide()\n \n If objSummaryForm.Visible Then objSummaryForm.Hide\n\nEnd Sub\n\nPublic Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String)\n\n objSummaryForm.lblInfo = strLabelInfo\n objSummaryForm.Caption = strCaption\n objSummaryForm.Repaint\n \nEnd Sub\n\n\nPrivate Sub objSummaryForm_OnRunReport()\n\n MainGenerateReport\n Refresh\n\nEnd Sub\n\nPrivate Sub objSummaryForm_OnExit()\n \n Hide\n\nEnd Sub\n\nPublic Sub Refresh()\n \n With objSummaryForm\n .lblInfo = \"Ready\"\n .Caption = \"Task performed\"\n End With\n\nEnd Sub\n\n" }, { "path": "__Arch/FormWithAnInstanceVBA/frmMain.vb", "content": "Option Explicit\n\nPublic Event OnRunReport()\nPublic Event OnExit()\n\nPrivate Sub btnRun_Click()\n RaiseEvent OnRunReport\nEnd Sub\n\nPrivate Sub btnExit_Click()\n RaiseEvent OnExit\nEnd Sub\n" }, { "path": "__Arch/FormWithAnInstanceVBA/modMain.vb", "content": "Option Explicit\n\nPrivate objPresenter As clsSummaryPresenter\n\nPublic Sub MainGenerateReport()\n \n Call objPresenter.ChangeLabelAndCaption(\"Starting and running...\", \"Running...\")\n GenerateNumbers\n \nEnd Sub\n\nPublic Sub GenerateNumbers()\n \n Dim lngLong As Long\n Dim lngLong2 As Long\n \n tblMain.Cells.Clear\n \n For lngLong = 1 To 3000\n For lngLong2 = 1 To 10\n tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2\n Next lngLong2\n Next lngLong\n\nEnd Sub\n\nPublic Sub ShowMainForm() 'CTRL+E\n\n If (objPresenter Is Nothing) Then Set objPresenter = New clsSummaryPresenter\n objPresenter.Show\n\nEnd Sub\n\n" }, { "path": "__Arch/FormatMyCell.vb", "content": "Public Sub FormatMyCell(ByRef my_cell As range, Optional b_as_currency As Boolean = False, _\n Optional b_as_date As Boolean = False, _\n Optional b_as_dark As Boolean = False, _\n Optional b_as_din As Boolean = False)\n \n If b_as_currency Then\n my_cell.NumberFormat = \"#,##0.00 $\"\n End If\n \n If b_as_date Then\n my_cell.NumberFormat = \"[$-407]mmm/ yy;@\"\n End If\n \n If b_as_dark Then\n my_cell.Interior.ThemeColor = xlThemeColorDark1\n my_cell.Interior.TintAndShade = -0.249946592608417\n End If\n \n If b_as_din Then\n my_cell.Font.Name = \"DIN-Light\"\n End If\n\nEnd Sub\n" }, { "path": "__Arch/Hex.vb", "content": "Private Sub tbx_hex_Change()\n \n On Error Resume Next\n \n Dim s_write As String\n Dim s_hour$, s_min$, s_sec$\n \n Me.lbl_hex = Val(\"&H\" & Me.tbx_hex)\n \n \n If Len(Me.lbl_hex) = 6 Then\n s_hour = Left(Me.lbl_hex, 2)\n s_min = Mid(Me.lbl_hex, 3, 2)\n Debug.Print Me.lbl_hex\n Debug.Print s_min\n \n s_sec = Right(Me.lbl_hex, 2)\n \n s_write = s_hour & \":\" & s_min & \":\" & s_sec\n Me.lbl_hex = s_write\n \n End If\n \n On Error GoTo 0\n \nEnd Sub\n\nPrivate Sub UserForm_Activate()\n\n Dim l_files As Long\n\n With Me\n .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2)\n .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2)\n End With\n \n Me.BackColor = ActiveSheet.Tab.Color\n \n If (ActiveSheet.Tab.Color = False) Then Unload Me\n \n frm_run.tbx_hex.Visible = b_value_in_array(Environ(\"Username\"), ADMINS, True)\n frm_run.lbl_hex.BackColor = ActiveSheet.Tab.Color\n \n l_files = lng_files_to_create\n \n If l_files = 1 Then\n frm_run.lbl_hex = l_files & \" Datei zu generieren.\"\n Else\n frm_run.lbl_hex = l_files & \" Dateien zu generieren.\"\n End If\n \nEnd Sub\n" }, { "path": "__Arch/HideRange.vb", "content": "Public Sub HideRange(r_range_to_hide As Range, l_ba_value As Long)\n\n Dim my_cell As Range\n\n For Each my_cell In r_range_to_hide\n If my_cell.Row > l_ba_value Then\n my_cell.Interior.Pattern = xlGray8\n \n my_cell.Font.ThemeColor = xlThemeColorDark1\n \n Else\n my_cell.Interior.Pattern = xlAutomatic\n my_cell.Font.ColorIndex = xlAutomatic\n End If\n Next my_cell\n \n r_range_to_hide.Borders(xlEdgeTop).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeLeft).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeBottom).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeRight).LineStyle = xlContinuous\n\nEnd Sub\n" }, { "path": "__Arch/HideShowComments.vb", "content": "Sub HideShowComments(Optional b_show_comments As Boolean = False)\n On Error Resume Next\n For Each current_cell In Range(\"A1:AO1000\")\n current_cell.Comment.Visible = b_show_comments\n Next current_cell\n On Error GoTo 0\nEnd Sub\n\n" }, { "path": "__Arch/NamedRanges.vb", "content": "\nSub change_all_names()\n \n Dim i As Long\n Dim s As String\n Dim s_old As String\n Dim s_new As String\n \n For i = 1 To ActiveWorkbook.Names.Count\n' Debug.Print ActiveWorkbook.Names(i).name\n' Debug.Print ActiveWorkbook.Names(i).RefersToR1C1\n' Debug.Print ActiveWorkbook.Names(i)\n\n If InStr(1, ActiveWorkbook.Names(i), \"old\", vbTextCompare) Then\n s_old = ActiveWorkbook.Names(i).RefersToR1C1\n s_new = Replace(s_old, \"old\", \"\")\n Debug.Print s_new\n \n With ActiveWorkbook.Names(ActiveWorkbook.Names(i).name)\n .RefersToR1C1 = s_new\n\n End With\n End If\n Next i\n\nEnd Sub\n\nPublic Sub MakeNegativesOne(l_col As Long)\n\n Dim l_counter As Long\n Dim b_negative As Long\n Dim my_cell As Range\n Dim my_first_negative As Range\n \n Dim dbl_negative_sum As Double\n \n For l_counter = 1 To 13\n Set my_cell = Cells(l_col, l_counter)\n \n If my_cell < 0 And my_cell.HasFormula Then\n dbl_negative_sum = dbl_negative_sum + my_cell.Value\n \n If Not b_negative Then\n b_negative = True\n Set my_first_negative = my_cell\n End If\n \n my_cell = 0\n End If\n Next l_counter\n \n If b_negative Then\n my_first_negative = dbl_negative_sum\n End If\n \nEnd Sub\n\nPublic Sub NegativeSelection(Optional my_rng As Variant)\n\n Dim my_cell As Range\n\n If IsMissing(my_rng) Then Set my_rng = Selection\n \n For Each my_cell In my_rng\n my_cell = my_cell * -1\n Next my_cell\n\nEnd Sub\n" }, { "path": "__Arch/OpenedExcelInfo.vb", "content": "' Information for opened Excel Files\n' Other Excel Files information\n' Opened Excel files\n' Excel files count\n' Excel count\n\nPublic Sub InfoForExcel()\n\n Dim objList As Object\n Dim strProcessName As String\n \n strProcessName = \"EXCEL.EXE\"\n \n Set objList = GetObject(\"winmgmts:\").ExecQuery(\"select * from win32_process where name='\" & strProcessName & \"'\")\n \n If objList.Count > 1 Then\n MsgBox \"Sie haben \" & objList.Count & \" eröffneten Excel Dateien.\" & vbCrLf & _\n \"Bitte schließen Sie alles, außer der aktuellen Anwendung.\"\n End If\n \nEnd Sub\n" }, { "path": "__Arch/OutlookRelated.vb", "content": "Sub LoopFoldersInInbox()\n \n Dim ns As Object\n Dim objFolder As Object\n Dim objSubfolder As Object\n \n Set ns = GetObject(\"\", \"Outlook.Application\").GetNamespace(\"MAPI\")\n Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox\n \n For Each objSubfolder In objFolder.Folders\n Debug.Print objSubfolder.name\n Debug.Print objSubfolder.Items.Count\n Next objSubfolder\n \nEnd Sub\n" }, { "path": "__Arch/Recursion.vb", "content": "Option Explicit\n\n'---------------------------------------------------------------------------------------\n' Method : TestMe\n' Date : 22.01.2018\n' Purpose: Do not try to sum array like this :)\n' Sample for recursion sum.\n'---------------------------------------------------------------------------------------\nPublic Sub TestMe()\n Debug.Print SumArrayRecursion(Array(1, 2, 4, 8))\nEnd Sub\n\nPublic Function SumArrayRecursion(arr As Variant) As Long\n\n Dim cnt As Long\n Dim newArr As Variant\n \n If LBound(arr) = UBound(arr) Then\n SumArrayRecursion = arr(0)\n Exit Function\n End If\n \n ReDim newArr(UBound(arr) - 1)\n For cnt = LBound(newArr) To UBound(newArr)\n newArr(cnt) = arr(cnt)\n Next cnt\n \n Debug.Print printArray(newArr)\n SumArrayRecursion = SumArrayRecursion(newArr) + newArr(UBound(newArr))\n \nEnd Function\n\nPublic Function printArray(arr As Variant) As String\n Dim cnt As Long\n For cnt = LBound(arr) To UBound(arr)\n printArray = printArray & \" \" & arr(cnt)\n Next cnt\nEnd Function\n" }, { "path": "__Arch/RelativePath.vb", "content": "Option Explicit\n\nSub TestMe()\n \n Debug.Print get_relative(\"U:\\DB_DATA\\HISTORY_LOG.xlsx\")\n Debug.Print get_relative(\"U:\\DB_DATA\\HISTORY_LOG.xlsx\", 2)\n\nEnd Sub\n\nPublic Function get_relative(str_path As String, Optional l_number As Long = 1) As String\n\n Dim str_result As String\n Dim l_start As Long\n Dim l_counter As Long\n \n For l_counter = 1 To l_number\n l_start = InStr(l_start + 1, str_path, \"\\\")\n Next l_counter\n\n get_relative = Mid(str_path, InStr(l_start, str_path, \"\\\"))\n\nEnd Function\n" }, { "path": "__Arch/RemoveAllItemsFromListBox.vb", "content": "Private Sub RemoveAllItemsFromListBox(lb_object As Object)\n \n Dim l_counter As Long\n \n For l_counter = 1 To lb_object.ListCount\n lb_object.RemoveItem 0\n Next l_counter\n\nEnd Sub\n" }, { "path": "__Arch/SaveAs.vb", "content": "Private Sub btn_save_as_Click()\n \n Dim b_saved As Boolean\n \n b_saved = Application.Dialogs(xlDialogSaveAs).Show\n If Not b_saved Then MsgBox \"Die Datei wurde nicht gespeichert!\", vbInformation, [ale]\n\nEnd Sub\n" }, { "path": "__Arch/SmallExcelFormats.vb", "content": "#.##0,00 \"€ / qm\"\n#.##0,00 \"qm\"\n" }, { "path": "__Arch/TDD_example.vb", "content": "Option Explicit\n\nPublic Sub TDD()\n \n Call SetToZero\n Call SetToDefault\n Call tbl_main.cmd_hoai_Click\n Call RunMe(1)\n \n Call TDD_1\n Call TDD_2\n \nEnd Sub\n\nPublic Sub TDD_1()\n \n Call TDD_1A\n Call TDD_1B\n Call TDD_1C\n \nEnd Sub\n\nPublic Sub TDD_2()\n \n Call TDD_2A\n Call TDD_2B\n \nEnd Sub\n\nPublic Sub TDD_2B()\n\n Dim my_arr As Variant\n Dim specs As New SpecSuite\n Dim l_counter As Long\n Dim l_size As Long: l_size = 4\n\n Dim l_row As Long\n Dim l_col As Long\n\n On Error Resume Next\n Call OnStart\n\n my_arr = arr_fill_predefined_test_2B_rng_C1F42\n\n For l_counter = 0 To UBound(my_arr) - 1 Step 1\n \n l_row = l_counter \\ l_size\n l_col = l_counter Mod l_size\n\n specs.It(\"2B_01_\" & l_row + 1 & \"_\" & l_col + 2).Expect(my_arr(l_counter + 1)).ToEqual tbl_calendar.[C1].Offset(l_row, l_col).value\n 'Debug.Print tbl_calendar.[C1].Offset(l_row, l_col).Address\n 'tbl_calendar.[C1].Offset(l_row, l_col).Select\n \n Next l_counter\n\n InlineRunner.RunSuite specs\n Call specs.TotalTests\n Call OnEnd\n\n On Error GoTo 0\n\nEnd Sub\n\n'---------------------------------------------------------------------------------------\n' Method : MakeAllValues\n' Author : v.doynov\n' Date : 07.11.2016\n' Purpose: Select the range, for which you want the TDD code.\n'---------------------------------------------------------------------------------------\n\nPublic Sub MakeAllValues()\n \n Dim my_cell As Range\n Dim l_counter As Long\n Dim str As String\n \n For Each my_cell In Selection\n Call Increment(l_counter)\n str = vbTab & \"my_arr(\" & l_counter & \")= \"\n \n If Len(my_cell) > 0 Then\n If IsDate(my_cell) Then\n str = str & \"CDate(\"\"\" & my_cell & \"\"\")\"\n Else\n If Not IsNumeric(my_cell) Then\n str = str & \"\"\"\" & my_cell & \"\"\"\"\n Else\n str = str & change_commas(my_cell.value)\n End If\n End If\n Else\n If my_cell.HasFormula Then\n str = str & \"\"\"\"\"\"\n Else\n str = str & 0\n End If\n End If\n \n Debug.Print str\n Next my_cell\n \nEnd Sub\n\nPublic Sub TDD_2A()\n\n Dim my_arr As Variant\n Dim specs As New SpecSuite\n Dim l_counter As Long\n\n On Error Resume Next\n Call OnStart\n\n 'Col F - Honorar\n my_arr = arr_fill_predefined_test_2A_colF\n For l_counter = 1 To UBound(my_arr) Step 1\n specs.It(\"2A_01F_\" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[F1].Offset(l_counter - 1).value\n Next l_counter\n \n 'Col I - Mar 15\n my_arr = arr_fill_predefined_test_2A_colI\n For l_counter = 1 To UBound(my_arr) Step 1\n specs.It(\"2A_02I_\" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[I1].Offset(l_counter - 1).value\n Next l_counter\n\n 'Col M - Aug 15\n my_arr = arr_fill_predefined_test_2A_colM\n Call Increment(l_counter)\n For l_counter = 1 To UBound(my_arr) Step 1\n specs.It(\"2A_03M_\" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[M1].Offset(l_counter - 1).value\n Next l_counter\n\n 'Col BK - Oct 19\n my_arr = arr_fill_predefined_test_2A_colBK\n For l_counter = 1 To UBound(my_arr) Step 1\n specs.It(\"2A_04BK_\" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[BK1].Offset(l_counter - 1).value\n Next l_counter\n\n 'Col AL - Sep 17\n my_arr = arr_fill_predefined_test_2A_colAL\n For l_counter = 1 To UBound(my_arr) Step 1\n specs.It(\"2A_05AL_\" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[AL1].Offset(l_counter - 1).value\n Next l_counter\n\n InlineRunner.RunSuite specs\n Call specs.TotalTests\n Call OnEnd\n\n On Error GoTo 0\n\nEnd Sub\n\nPublic Sub MakeValues()\n\n Dim my_cell As Range\n Dim str As String\n Dim l_counter As Long\n \n For Each my_cell In Selection\n Call Increment(l_counter)\n str = \"my_arr(\" & l_counter & \")= \"\n \n If Len(my_cell) > 0 Then\n str = str & change_commas(my_cell.value)\n Else\n str = str & 0\n End If\n \n Debug.Print str\n \n Next my_cell\n\nEnd Sub\n\nPublic Sub SetToZero()\n\n Dim arr_dates(12) As Date\n Dim arr_values(16) As Double\n \n Call OnStart\n \n tbl_main.tb_show_hide_further = True\n \n tbl_main.cmb_ba = 2\n tbl_main.cmb_land = \"Deutschland\"\n \n tbl_main.chb_zweimal = True\n tbl_main.chb_jump = False\n tbl_main.chb_insti = False\n \n 'Set dates\n tbl_main.[m_buying_date] = \"\"\n tbl_main.[m_end_date] = \"\"\n \n tbl_main.[e2] = \"\"\n tbl_main.[e3] = \"\"\n \n tbl_main.[f2] = \"\"\n tbl_main.[f3] = \"\"\n \n tbl_main.[g2] = \"\"\n tbl_main.[g3] = \"\"\n \n tbl_main.[h2] = \"\"\n tbl_main.[h3] = \"\"\n \n tbl_main.[k2] = \"\"\n tbl_main.[l2] = \"\"\n \n 'Set values\n \n tbl_main.[i2] = \"\"\n tbl_main.[i3] = \"\"\n tbl_main.[j2] = \"\"\n tbl_main.[j3] = \"\"\n \n tbl_main.[e18] = \"\"\n tbl_main.[e19] = \"\"\n tbl_main.[s54] = \"\"\n tbl_main.[s55] = \"\"\n tbl_main.[t54] = \"\"\n tbl_main.[t55] = \"\"\n tbl_main.[u54] = \"\"\n tbl_main.[u55] = \"\"\n tbl_main.[v54] = \"\"\n tbl_main.[v55] = \"\"\n tbl_main.[i92] = \"\"\n tbl_main.[i93] = \"\"\n \n Call OnEnd\n 'Call HOAI calculation\n \n On Error GoTo 0\n Exit Sub\n \nEnd Sub\n\n\nPublic Sub SetToDefault()\n\n If [set_in_production] Then On Error GoTo SetToDefault_Error\n \n Dim arr_dates(12) As Date\n Dim arr_values(16) As Double\n \n Call OnStart\n tbl_main.tb_show_hide_further = True\n \n tbl_main.cmb_ba = 2\n tbl_main.cmb_land = \"Deutschland\"\n \n tbl_main.chb_zweimal = True\n tbl_main.chb_jump = False\n tbl_main.chb_insti = False\n \n 'Set dates\n arr_dates(1) = \"01.03.2015\"\n arr_dates(2) = \"01.10.2019\"\n arr_dates(3) = \"01.12.2016\"\n arr_dates(4) = \"01.12.2016\"\n arr_dates(5) = \"01.06.2018\"\n arr_dates(6) = \"01.07.2018\"\n arr_dates(7) = \"01.08.2018\"\n arr_dates(8) = \"01.10.2018\"\n arr_dates(9) = \"01.09.2017\"\n arr_dates(10) = \"01.05.2017\"\n arr_dates(11) = \"01.01.2016\"\n arr_dates(12) = \"01.07.2015\"\n \n tbl_main.[main_objektname] = \"Bagelstrasse Duesseldorf\"\n tbl_main.[m_buying_date] = arr_dates(1)\n tbl_main.[m_end_date] = arr_dates(2)\n \n tbl_main.[e2] = arr_dates(3)\n tbl_main.[e3] = arr_dates(4)\n \n tbl_main.[f2] = arr_dates(5)\n tbl_main.[f3] = arr_dates(6)\n \n tbl_main.[g2] = arr_dates(7)\n tbl_main.[g3] = arr_dates(8)\n \n tbl_main.[h2] = arr_dates(9)\n tbl_main.[h3] = arr_dates(10)\n \n tbl_main.[k2] = arr_dates(11)\n tbl_main.[l2] = arr_dates(12)\n \n 'Set values\n arr_values(1) = 3417\n arr_values(2) = 3644\n arr_values(3) = 404\n arr_values(4) = 404\n arr_values(5) = 1234567\n arr_values(6) = 12345678\n arr_values(7) = 123456\n arr_values(8) = 100000\n arr_values(9) = 250000\n arr_values(10) = 270000\n arr_values(11) = 350000\n arr_values(12) = 450000\n arr_values(13) = 300000\n arr_values(14) = 350000\n arr_values(15) = 150000\n arr_values(16) = 160000\n \n tbl_main.[i2] = arr_values(1)\n tbl_main.[i3] = arr_values(2)\n tbl_main.[j2] = arr_values(3)\n tbl_main.[j3] = arr_values(4)\n \n tbl_main.[e18] = arr_values(5)\n tbl_main.[e19] = arr_values(6)\n tbl_main.[s54] = arr_values(7)\n tbl_main.[s55] = arr_values(8)\n tbl_main.[t54] = arr_values(9)\n tbl_main.[t55] = arr_values(10)\n tbl_main.[u54] = arr_values(11)\n tbl_main.[u55] = arr_values(12)\n tbl_main.[v54] = arr_values(13)\n tbl_main.[v55] = arr_values(14)\n tbl_main.[i92] = arr_values(15)\n tbl_main.[i93] = arr_values(16)\n \n Call OnEnd\n 'Call HOAI calculation\n\n On Error GoTo 0\n Exit Sub\n\nSetToDefault_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure SetToDefault of Sub mod_TDD\"\n\nEnd Sub\n\nPublic Sub HowToList()\n\n Dim obj_list As cls_vbaList\n\n Set obj_list = New cls_vbaList\n\n obj_list.Add (30)\n obj_list.Add (3)\n obj_list.Add (355)\n obj_list.Add (5)\n obj_list.Add (1)\n obj_list.Add (40)\n\n Debug.Print obj_list.Contains(30)\n Debug.Print obj_list.Exists(30)\n Debug.Print obj_list.Items(0)\n \n obj_list.Sort\n \n Debug.Print obj_list.Items(0)\n Debug.Print obj_list.Find(3)\n Debug.Print obj_list.Find(30)\n Debug.Print obj_list.LastIndexOf(355)\n\n Set obj_list = Nothing\n\nEnd Sub\n\nPublic Sub TDD_1C()\n\n On Error Resume Next\n \n Dim specs As New SpecSuite\n \n Dim obj_total_test As New cls_Total\n Dim obj_total_cal_test As New cls_TotalCalendar\n Dim var_list As New cls_vbaList\n \n Call OnStart\n \n specs.It(\"C001\").Expect(obj_total_test.LeftSideCols).ToEqual 7\n specs.It(\"C002\").Expect(obj_total_test.BA_Number).ToEqual CLng(tbl_main.[cmb_ba].value)\n specs.It(\"C003\").Expect(obj_total_test.B_Insti).ToEqual CBool(tbl_main.[chb_insti])\n \n tbl_main.[chb_insti] = True\n specs.It(\"C004\").Expect(obj_total_test.MarkCost1).ToEqual CStr([set_total_mark_2])\n specs.It(\"C005\").Expect(obj_total_test.MarkCost2).ToEqual CStr([set_total_mark_4])\n specs.It(\"C006\").Expect(obj_total_test.MarkCost3).ToEqual CStr([set_total_mark_6])\n \n tbl_main.[chb_insti] = False\n specs.It(\"C007\").Expect(obj_total_test.MarkCost1).ToEqual CStr([set_total_mark_1])\n specs.It(\"C008\").Expect(obj_total_test.MarkCost2).ToEqual CStr([set_total_mark_3])\n specs.It(\"C009\").Expect(obj_total_test.MarkCost3).ToEqual CStr([set_total_mark_5])\n \n specs.It(\"C010\").Expect(obj_total_test.MarkCost1).ToNotEqual CStr([set_total_mark_2])\n specs.It(\"C011\").Expect(obj_total_test.MarkCost2).ToNotEqual CStr([set_total_mark_4])\n specs.It(\"C012\").Expect(obj_total_test.MarkCost3).ToNotEqual CStr([set_total_mark_6])\n \n specs.It(\"C013\").Expect(obj_total_test.CurrentLine).ToNotEqual 2\n specs.It(\"C014\").Expect(obj_total_test.CurrentLine).ToEqual 0\n Call obj_total_test.IncrementCurrentLine\n specs.It(\"C015\").Expect(obj_total_test.CurrentLine).ToEqual 1\n Call obj_total_test.IncrementCurrentLine\n specs.It(\"C016\").Expect(obj_total_test.CurrentLine).ToEqual 2\n obj_total_test.CurrentLine = 12\n specs.It(\"C017\").Expect(obj_total_test.CurrentLine).ToEqual 12\n \n specs.It(\"C018\").Expect(obj_total_test.MarkCostTitle).ToEqual CStr([set_total_mark_title])\n specs.It(\"C019\").Expect(obj_total_test.CurrentLine).ToNotEqual CStr([set_total_mark_title] & \"1\")\n \n specs.It(\"C020\").Expect(obj_total_test.LastRow).ToEqual last_row(tbl_totals.Name)\n specs.It(\"C021\").Expect(obj_total_test.LastRow).ToNotEqual 9999\n \n var_list.Add 5\n var_list.Add 10\n var_list.Add 15\n var_list.Add 20\n \n Set obj_total_cal_test.PlanerkostenSrc = var_list\n \n specs.It(\"C022\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(0)).ToEqual 5\n specs.It(\"C023\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(1)).ToEqual 10\n specs.It(\"C024\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(2)).ToEqual 15\n specs.It(\"C025\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(3)).ToEqual 20\n \n specs.It(\"C026\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(0)).ToNotEqual 5 + 1\n specs.It(\"C027\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(1)).ToNotEqual 10 + 1\n specs.It(\"C028\").Expect(obj_total_cal_test.PlanerkostenSrc.Items(2)).ToNotEqual 15 + 1\n \n InlineRunner.RunSuite specs\n \n Call specs.TotalTests\n Call OnEnd\n \n On Error GoTo 0\n \nEnd Sub\n\n\nPublic Sub TDD_1B()\n \n On Error Resume Next\n\n Dim specs As New SpecSuite\n \n Call OnStart\n \n specs.It(\"B001\").Expect([set_in_production]).ToEqual True\n specs.It(\"B002\").Expect([set_in_production]).ToNotEqual False\n \n InlineRunner.RunSuite specs\n \n Call specs.TotalTests\n \n Call OnEnd\n \n On Error GoTo 0\n \nEnd Sub\n\nPublic Sub TDD_1A()\n\n On Error Resume Next\n\n Dim specs As New SpecSuite\n Dim obj_calendar As New cls_Calendar\n Dim obj_dat As New cls_Dates\n Dim obj_sav As New cls_Saver\n Dim obj_input_dates As New cls_InputDates\n Dim obj_test_land As New cls_Land\n \n Dim l_value As Long\n Dim d_value As Date\n Dim str_initial As String\n \n Call OnStart\n Set obj_con = New cls_Const\n \n specs.It(\"A001\").Expect(obj_calendar.UPPER_ROW).ToEqual 4\n specs.It(\"A002\").Expect(obj_calendar.ROWS_TAKEN).ToEqual 3\n\n obj_calendar.current_row = 111\n specs.It(\"A003\").Expect(obj_calendar.current_row).ToEqual 111\n\n obj_calendar.IncrementRow\n obj_calendar.IncrementRow\n specs.It(\"A004\").Expect(obj_calendar.current_row).ToNotEqual 111\n \n obj_calendar.IncrementRow\n specs.It(\"A005\").Expect(obj_calendar.current_row).ToEqual 114\n \n obj_calendar.AddToPercentageLines (10)\n obj_calendar.AddToPercentageLines (15)\n obj_calendar.AddToPercentageLines (20)\n obj_calendar.AddToPercentageLines (25)\n\n specs.It(\"A006\").Expect(obj_calendar.percentage_lines(1)).ToEqual 10\n specs.It(\"A007\").Expect(obj_calendar.percentage_lines(2)).ToEqual 15\n specs.It(\"A008\").Expect(obj_calendar.percentage_lines(3)).ToNotEqual 20 + 1\n specs.It(\"A009\").Expect(obj_calendar.percentage_lines(4)).ToEqual 25\n\n obj_calendar.AddToLines (100)\n obj_calendar.AddToLines (200)\n obj_calendar.AddToLines (300)\n obj_calendar.AddToLines (400)\n\n specs.It(\"A010\").Expect(obj_calendar.lines(1)).ToEqual 100\n specs.It(\"A011\").Expect(obj_calendar.lines(2)).ToEqual 200\n specs.It(\"A012\").Expect(obj_calendar.lines(3)).ToNotEqual 300 + 1\n specs.It(\"A013\").Expect(obj_calendar.lines(3)).ToEqual 300\n specs.It(\"A014\").Expect(obj_calendar.lines(4)).ToEqual 400\n\n specs.It(\"A015\").Expect(obj_calendar.lines(4)).ToEqual 400\n\n obj_calendar.last_col = 400\n specs.It(\"A016\").Expect(obj_calendar.length_of_calendar).ToEqual 400 - obj_con.COLUMNS_TAKEN\n\n Dim str_variable As String: str_variable = \"BA LP\"\n specs.It(\"A017\").Expect(obj_con.BA_NAME & obj_con.SPACE & obj_con.LP_NAME).ToEqual (str_variable)\n\n str_variable = \"BA L P\"\n specs.It(\"A018\").Expect(obj_con.BA_NAME & obj_con.SPACE & obj_con.LP_NAME).ToNotEqual (str_variable)\n\n specs.It(\"A019\").Expect(generate_honorare_gebaude(100000, 3, True)).ToEqual 15005\n specs.It(\"A020\").Expect(generate_honorare_gebaude(100000, 3, False)).ToEqual 16859\n specs.It(\"A021\").Expect(generate_honorare_gebaude(100000, 3, True)).ToNotEqual 15005 + 10\n specs.It(\"A022\").Expect(generate_honorare_gebaude(100000, 3, False)).ToNotEqual 16859 + 10\n \n specs.It(\"A023\").Expect(generate_honorare_hlse(100000, 2, True)).ToEqual 27150\n specs.It(\"A024\").Expect(generate_honorare_hlse(100000, 2, False)).ToEqual 29511\n specs.It(\"A025\").Expect(generate_honorare_hlse(5000, 2, True)).ToEqual 2547\n specs.It(\"A026\").Expect(generate_honorare_hlse(5000, 2, False)).ToEqual 2768.5\n specs.It(\"A027\").Expect(generate_honorare_hlse(4000000, 2, True)).ToEqual 492410\n specs.It(\"A028\").Expect(generate_honorare_hlse(4000000, 2, False)).ToEqual 535228\n specs.It(\"A029\").Expect(generate_honorare_hlse(4000000, 2, True)).ToNotEqual 492410 - 10\n specs.It(\"A030\").Expect(generate_honorare_hlse(4000000, 2, False)).ToNotEqual 535228 - 10\n \n specs.It(\"A031\").Expect(generate_honorare_aussenanlagen(20000, 3, True)).ToEqual 5229\n specs.It(\"A032\").Expect(generate_honorare_aussenanlagen(20000, 3, False)).ToEqual 5875\n specs.It(\"A033\").Expect(generate_honorare_aussenanlagen(75000, 3, True)).ToEqual 16116\n specs.It(\"A034\").Expect(generate_honorare_aussenanlagen(75000, 3, False)).ToEqual 18108\n specs.It(\"A035\").Expect(generate_honorare_aussenanlagen(1500000, 3, True)).ToEqual 201261\n specs.It(\"A036\").Expect(generate_honorare_aussenanlagen(1500000, 3, False)).ToEqual 226136\n specs.It(\"A037\").Expect(generate_honorare_aussenanlagen(1500000, 3, True)).ToNotEqual 201261 + 10\n specs.It(\"A038\").Expect(generate_honorare_aussenanlagen(1500000, 3, False)).ToNotEqual 226132 + 10\n\n specs.It(\"A039\").Expect(generate_honorare_tragwerksplannung(10000, 3, True)).ToEqual 2064\n specs.It(\"A040\").Expect(generate_honorare_tragwerksplannung(10000, 3, False)).ToEqual 2319.5\n specs.It(\"A041\").Expect(generate_honorare_tragwerksplannung(123456, 3, True)).ToEqual 14863.1\n specs.It(\"A042\").Expect(generate_honorare_tragwerksplannung(123456, 3, False)).ToEqual 16700.24\n specs.It(\"A043\").Expect(generate_honorare_tragwerksplannung(15000000, 3, True)).ToEqual 642943\n specs.It(\"A044\").Expect(generate_honorare_tragwerksplannung(15000000, 3, False)).ToEqual 722408\n specs.It(\"A045\").Expect(generate_honorare_tragwerksplannung(15000000, 3, True)).ToNotEqual 642943 + 1\n specs.It(\"A046\").Expect(generate_honorare_tragwerksplannung(15000000, 3, False)).ToNotEqual 722408 + 1\n \n specs.It(\"A047\").Expect(generate_honorar_brandschutz(969)).ToEqual 8994.56\n specs.It(\"A048\").Expect(generate_honorar_brandschutz(2322)).ToEqual 13652.83\n specs.It(\"A049\").Expect(generate_honorar_brandschutz(12345.67)).ToEqual 33544.66\n specs.It(\"A050\").Expect(generate_honorar_brandschutz(25900.18)).ToEqual 51136.09\n \n ' b_show_msgbox is an optional value, set to true initially.\n ' The idea is to be false for the tests, thus it does not show a msgbox\n specs.It(\"A051\").Expect(generate_honorare_tragwerksplannung(10000 - 1, 3, True, b_show_msgbox:=False)).ToEqual -1\n specs.It(\"A052\").Expect(generate_honorare_tragwerksplannung(15000000 + 1, 3, True, b_show_msgbox:=False)).ToEqual -10\n\n obj_calendar.last_col = 50\n specs.It(\"A053\").Expect(obj_calendar.last_col).ToEqual 50\n \n Set obj_dat = New cls_Dates\n Call obj_dat.AddEingabeDate(\"04.02.1999\")\n Call obj_dat.AddEingabeDate(\"04.02.1998\")\n Call obj_dat.AddEingabeDate(\"04.02.1995\")\n \n specs.It(\"A054\").Expect(obj_dat.eingabe_date(1)).ToEqual CDate(\"04.02.1999\")\n specs.It(\"A055\").Expect(obj_dat.eingabe_date(2)).ToEqual CDate(\"04.02.1998\")\n specs.It(\"A056\").Expect(obj_dat.eingabe_date(3)).ToEqual CDate(\"04.02.1995\")\n specs.It(\"A057\").Expect(obj_dat.eingabe_date(2)).ToEqual CDate(\"04.02.1998\")\n specs.It(\"A058\").Expect(obj_dat.eingabe_date(3)).ToNotEqual CDate(\"05.02.1999\")\n\n obj_calendar.last_col = obj_calendar.last_col + obj_calendar.last_col\n specs.It(\"A059\").Expect(obj_calendar.last_col).ToEqual 100\n\n l_value = tbl_main.cmb_ba.value\n specs.It(\"A060\").Expect(obj_calendar.ba).ToEqual l_value\n specs.It(\"A061\").Expect(obj_calendar.ba).ToNotEqual l_value + 1\n\n d_value = DateSerial(tbl_main.cmb_year, tbl_main.cmb_month, 1)\n specs.It(\"A062\").Expect(obj_calendar.fixed_date).ToEqual d_value\n specs.It(\"A063\").Expect(obj_calendar.fixed_date).ToNotEqual d_value + 1\n\n d_value = DateDiff(\"m\", [m_start_date], [m_end_date])\n specs.It(\"A064\").Expect(obj_calendar.calendar_size_original).ToEqual d_value\n specs.It(\"A065\").Expect(obj_calendar.calendar_size_original).ToNotEqual d_value + 1\n\n d_value = DateDiff(\"m\", [m_start_date], [main_bau_range_changes_2])\n specs.It(\"A066\").Expect(obj_calendar.calendar_size_changed).ToEqual d_value\n specs.It(\"A067\").Expect(obj_calendar.calendar_size_changed).ToNotEqual d_value + 1\n \n Set obj_sav = New cls_Saver\n obj_sav.AddRate7 (\"12.12.2012\")\n obj_sav.AddRate7 (\"12.12.2013\")\n obj_sav.AddRate7 (\"12.12.2014\")\n \n specs.It(\"A068\").Expect(obj_sav.Rate7MF(1)).ToEqual CDate(\"12.12.2012\")\n specs.It(\"A069\").Expect(obj_sav.Rate7MF(2)).ToEqual CDate(\"12.12.2013\")\n specs.It(\"A070\").Expect(obj_sav.Rate7MF(3)).ToEqual CDate(\"12.12.2014\")\n specs.It(\"A071\").Expect(obj_sav.Rate7MF(1)).ToNotEqual CDate(\"12.12.2015\")\n \n obj_sav.AddRate6 (\"12.5.2012\")\n obj_sav.AddRate6 (\"12.6.2013\")\n obj_sav.AddRate6 (\"12.7.2014\")\n\n specs.It(\"A072\").Expect(obj_sav.Rate6BZ(1)).ToEqual CDate(\"12.5.2012\")\n specs.It(\"A073\").Expect(obj_sav.Rate6BZ(2)).ToEqual CDate(\"12.6.2013\")\n specs.It(\"A074\").Expect(obj_sav.Rate6BZ(3)).ToEqual CDate(\"12.7.2014\")\n specs.It(\"A075\").Expect(obj_sav.Rate6BZ(1)).ToNotEqual CDate(\"12.12.2015\")\n \n obj_sav.AddBB (\"12.1.2012\")\n obj_sav.AddBB (\"12.2.2013\")\n obj_sav.AddBB (\"12.3.2014\")\n \n specs.It(\"A076\").Expect(obj_sav.BB(1)).ToEqual CDate(\"12.1.2012\")\n specs.It(\"A077\").Expect(obj_sav.BB(2)).ToEqual CDate(\"12.2.2013\")\n specs.It(\"A078\").Expect(obj_sav.BB(3)).ToEqual CDate(\"12.3.2014\")\n specs.It(\"A079\").Expect(obj_sav.BB(1)).ToNotEqual CDate(\"12.4.2015\")\n \n obj_sav.AddEndeRb (\"1.5.2012\")\n obj_sav.AddEndeRb (\"2.5.2012\")\n obj_sav.AddEndeRb (\"3.5.2012\")\n \n specs.It(\"A080\").Expect(obj_sav.EndeRb(1)).ToEqual CDate(\"1.5.2012\")\n specs.It(\"A081\").Expect(obj_sav.EndeRb(2)).ToEqual CDate(\"2.5.2012\")\n specs.It(\"A082\").Expect(obj_sav.EndeRb(3)).ToEqual CDate(\"3.5.2012\")\n specs.It(\"A083\").Expect(obj_sav.EndeRb(1)).ToNotEqual CDate(\"2.5.2012\")\n \n obj_sav.Baueingabe = \"6.10.2020\"\n specs.It(\"A084\").Expect(obj_sav.Baueingabe).ToEqual CDate(\"6.10.2020\")\n obj_sav.Baueingabe = \"6.10.2021\"\n specs.It(\"A085\").Expect(obj_sav.Baueingabe).ToEqual CDate(\"6.10.2021\")\n obj_sav.Baueingabe = \"6.10.2022\"\n specs.It(\"A086\").Expect(obj_sav.Baueingabe).ToEqual CDate(\"6.10.2022\")\n specs.It(\"A087\").Expect(obj_sav.Baueingabe).ToNotEqual CDate(\"6.10.2023\")\n \n obj_sav.Baugenehmigung = \"6.11.2020\"\n specs.It(\"A088\").Expect(obj_sav.Baugenehmigung).ToEqual CDate(\"6.11.2020\")\n obj_sav.Baugenehmigung = \"6.11.2021\"\n specs.It(\"A089\").Expect(obj_sav.Baugenehmigung).ToEqual CDate(\"6.11.2021\")\n obj_sav.Baugenehmigung = \"6.11.2022\"\n specs.It(\"A090\").Expect(obj_sav.Baugenehmigung).ToEqual CDate(\"6.11.2022\")\n specs.It(\"A091\").Expect(obj_sav.Baugenehmigung).ToNotEqual CDate(\"6.11.2023\")\n \n obj_sav.LetzterTag = \"12.12.1960\"\n specs.It(\"A092\").Expect(obj_sav.LetzterTag).ToEqual CDate(\"12.12.1960\")\n obj_sav.LetzterTag = \"12.12.1961\"\n specs.It(\"A093\").Expect(obj_sav.LetzterTag).ToEqual CDate(\"12.12.1961\")\n obj_sav.LetzterTag = \"12.12.1962\"\n specs.It(\"A094\").Expect(obj_sav.LetzterTag).ToEqual CDate(\"12.12.1962\")\n specs.It(\"A095\").Expect(obj_sav.LetzterTag).ToNotEqual CDate(\"12.12.1960\")\n\n obj_sav.Changes = \"vit\"\n specs.It(\"A096\").Expect(obj_sav.Changes).ToEqual \"vit\"\n obj_sav.Changes = \"osh\"\n specs.It(\"A097\").Expect(obj_sav.Changes).ToNotEqual \"vit\"\n specs.It(\"A098\").Expect(obj_sav.Changes).ToEqual \"vit\" & vbCrLf & \"osh\"\n\n obj_sav.AddChangeCell (\"Pesho beshe tuk\")\n obj_sav.AddChangeCell (\"Gosho beshe tuk\")\n obj_sav.AddChangeCell (\"Atanas beshe tuk\")\n obj_sav.AddChangeCell (\"I az byah tuk\")\n\n specs.It(\"A099\").Expect(obj_sav.ChangeCell(1)).ToEqual \"Pesho beshe tuk\"\n specs.It(\"A100\").Expect(obj_sav.ChangeCell(2)).ToEqual \"Gosho beshe tuk\"\n specs.It(\"A101\").Expect(obj_sav.ChangeCell(3)).ToEqual \"Atanas beshe tuk\"\n specs.It(\"A102\").Expect(obj_sav.ChangeCell(3)).ToNotEqual \"Gosho beshe tuk\"\n \n specs.It(\"A103\").Expect(obj_sav.ChangesTotal).ToEqual 4\n specs.It(\"A104\").Expect(obj_sav.ChangesTotal).ToNotEqual 5\n obj_sav.AddChangeCell (\"I az byah tuk2\")\n specs.It(\"A105\").Expect(obj_sav.ChangesTotal).ToEqual 5\n \n specs.It(\"A106\").Expect(obj_sav.Changes).ToEqual \"vit\" & vbCrLf & \"osh\"\n obj_sav.EraseChanges\n specs.It(\"A107\").Expect(obj_sav.Changes).ToEqual \"\"\n obj_sav.Changes = \"vi\"\n obj_sav.Changes = \"to\"\n specs.It(\"A108\").Expect(obj_sav.Changes).ToEqual \"vi\" & vbCrLf & \"to\"\n \n specs.It(\"A109\").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 3, True)).ToEqual \"=RC[-1]+(((RC6-RC10)*0.9)/5)\"\n specs.It(\"A110\").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 3)).ToEqual \"=RC[-1]+((RC6-RC10)/5)\"\n \n specs.It(\"A111\").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 0, True)).ToEqual \"=RC[-1]+(RC6*0.9/5)\"\n specs.It(\"A112\").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 0)).ToEqual \"=RC[-1]+(RC6/5)\"\n \n obj_input_dates.AddRate1_Date (\"01.01.2013\")\n obj_input_dates.AddRate1_Date (\"02.01.2013\")\n obj_input_dates.AddRate1_Date (\"03.01.2013\")\n specs.It(\"A113\").Expect(obj_input_dates.rate1_date(3)).ToEqual CDate(\"03.01.2013\")\n specs.It(\"A114\").Expect(obj_input_dates.rate1_date(1)).ToNotEqual CDate(\"02.01.2013\")\n specs.It(\"A115\").Expect(obj_input_dates.rate1_date(2)).ToEqual CDate(\"02.01.2013\")\n \n obj_input_dates.AddRate2_Date (\"01.01.2011\")\n obj_input_dates.AddRate2_Date (\"01.01.2012\")\n obj_input_dates.AddRate2_Date (\"01.01.2013\")\n obj_input_dates.AddRate2_Date (\"01.01.2014\")\n obj_input_dates.AddRate2_Date (\"01.01.2015\")\n obj_input_dates.AddRate2_Date (\"01.01.2016\")\n specs.It(\"A116\").Expect(obj_input_dates.rate2_date(1)).ToEqual CDate(\"01.01.2011\")\n specs.It(\"A117\").Expect(obj_input_dates.rate2_date(4)).ToEqual CDate(\"01.01.2014\")\n specs.It(\"A118\").Expect(obj_input_dates.rate2_date(5)).ToNotEqual CDate(\"01.01.2014\")\n \n obj_input_dates.AddRate6_Date (\"01.01.2020\")\n obj_input_dates.AddRate6_Date (\"01.01.2021\")\n obj_input_dates.AddRate6_Date (\"01.01.2022\")\n specs.It(\"A119\").Expect(obj_input_dates.rate6_date(3)).ToEqual CDate(\"01.01.2022\")\n specs.It(\"A120\").Expect(obj_input_dates.rate6_date(1)).ToEqual CDate(\"01.01.2020\")\n specs.It(\"A121\").Expect(obj_input_dates.rate6_date(2)).ToNotEqual CDate(\"01.01.2020\")\n \n obj_input_dates.AddRate7_Date (\"01.01.2013\")\n obj_input_dates.AddRate7_Date (\"02.01.2013\")\n obj_input_dates.AddRate7_Date (\"03.01.2013\")\n obj_input_dates.AddRate7_Date (\"04.01.2013\")\n obj_input_dates.AddRate7_Date (\"05.01.2013\")\n obj_input_dates.AddRate7_Date (\"06.01.2013\")\n specs.It(\"A122\").Expect(obj_input_dates.rate7_date(6)).ToEqual CDate(\"06.01.2013\")\n specs.It(\"A123\").Expect(obj_input_dates.rate7_date(5)).ToEqual CDate(\"05.01.2013\")\n specs.It(\"A124\").Expect(obj_input_dates.rate7_date(6)).ToEqual CDate(\"06.01.2013\")\n specs.It(\"A125\").Expect(obj_input_dates.rate7_date(5)).ToEqual CDate(\"05.01.2013\")\n specs.It(\"A126\").Expect(obj_input_dates.rate7_date(1)).ToEqual CDate(\"01.01.2013\")\n specs.It(\"A127\").Expect(obj_input_dates.rate7_date(2)).ToNotEqual CDate(\"01.01.2013\")\n \n obj_input_dates.Ankaufsdatum = CDate(\"07.08.2011\")\n specs.It(\"A128\").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate(\"07.08.2011\")\n obj_input_dates.Ankaufsdatum = CDate(\"07.08.2012\")\n specs.It(\"A129\").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate(\"07.08.2012\")\n specs.It(\"A130\").Expect(obj_input_dates.Ankaufsdatum).ToNotEqual CDate(\"07.08.2013\")\n obj_input_dates.Ankaufsdatum = CDate(\"07.08.2013\")\n specs.It(\"A131\").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate(\"07.08.2013\")\n\n obj_input_dates.Baueingabe = CDate(\"07.08.2021\")\n specs.It(\"A132\").Expect(obj_input_dates.Baueingabe).ToEqual CDate(\"07.08.2021\")\n obj_input_dates.Baueingabe = CDate(\"07.08.2022\")\n specs.It(\"A133\").Expect(obj_input_dates.Baueingabe).ToEqual CDate(\"07.08.2022\")\n obj_input_dates.Baueingabe = CDate(\"07.08.2023\")\n specs.It(\"A134\").Expect(obj_input_dates.Baueingabe).ToNotEqual CDate(\"07.08.2022\")\n \n obj_input_dates.Baugenehmigung = CDate(\"01.08.2011\")\n specs.It(\"A135\").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate(\"01.08.2011\")\n obj_input_dates.Baugenehmigung = CDate(\"02.08.2012\")\n specs.It(\"A136\").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate(\"02.08.2012\")\n obj_input_dates.Baugenehmigung = CDate(\"03.08.2013\")\n specs.It(\"A137\").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate(\"03.08.2013\")\n specs.It(\"A138\").Expect(obj_input_dates.Baugenehmigung).ToNotEqual CDate(\"02.08.2013\")\n \n str_initial = tbl_main.cmb_land\n tbl_main.cmb_land = [set_nameGermany]\n specs.It(\"A139\").Expect([set_vat_used].Text).ToEqual ([set_vatGermany].Text)\n specs.It(\"A140\").Expect(obj_test_land.str_get_land).ToEqual ([set_nameGermany].Text)\n specs.It(\"A141\").Expect(obj_test_land.str_get_short_name).ToEqual ([set_shortNameGermany].Text)\n specs.It(\"A142\").Expect(obj_test_land.str_get_short_name).ToNotEqual ([set_shortNameAustria].Text)\n \n tbl_main.cmb_land = [set_nameAustria]\n\n specs.It(\"A143\").Expect([set_vat_used].Text).ToEqual ([set_vatAustria].Text)\n specs.It(\"A144\").Expect(obj_test_land.str_get_land).ToEqual ([set_nameAustria].Text)\n specs.It(\"A145\").Expect(obj_test_land.str_get_short_name).ToEqual ([set_shortNameAustria].Text)\n specs.It(\"A146\").Expect(obj_test_land.str_get_short_name).ToNotEqual ([set_shortNameGermany].Text)\n \n tbl_main.cmb_land = [set_nameGermany]\n \n InlineRunner.RunSuite specs\n Call specs.TotalTests\n \n Call OnEnd\n \n Set specs = Nothing\n Set obj_calendar = Nothing\n Set obj_con = Nothing\n Set obj_dat = Nothing\n Set obj_sav = Nothing\n Set obj_input_dates = Nothing\n Set obj_test_land = Nothing\n \n On Error GoTo 0\n \nEnd Sub\n\nPublic Sub CreateNumbers(Optional l_size_cols As Long = 10, _\n Optional l_size_total As Long = 1000)\n\n Dim l_counter As Long\n Dim l_row As Long\n Dim l_col As Long\n \n ActiveSheet.Cells.Clear\n\n For l_counter = 0 To l_size_total - 1\n \n l_row = l_counter \\ l_size_cols\n l_col = l_counter Mod l_size_cols\n \n ActiveSheet.[a1].Offset(l_row, l_col) = l_counter + 1\n \n Next l_counter\nEnd Sub\n\n\n" }, { "path": "__Arch/UseEnvironName.vb", "content": "Public Sub SetWorkedBy()\n \n Set my_cell = tbl_plan.Cells(obj_plan.LastLine, obj_cal.RightColPosition)\n my_cell = \"WorkedBy: \" & Application.WorksheetFunction.Proper(Environ(\"username\")) & \" - \" & Format(Now(), \"Short Date\")\n my_cell.HorizontalAlignment = xlRight\n \nEnd Sub \n" }, { "path": "__Arch/Userful_Application.vb", "content": "?application.PathSeparator\n?application.DecimalSeparator\n?Application.International(xlFormula)\n" }, { "path": "__Arch/XL_password_cracker.vb", "content": "'https://stackoverflow.com/questions/11649064/excel-spreadsheet-password-cracking-using-vba\n\nSub PasswordBreaker()\n 'Breaks worksheet password protection.\n Dim i As Integer, j As Integer, k As Integer\n Dim l As Integer, m As Integer, n As Integer\n Dim i1 As Integer, i2 As Integer, i3 As Integer\n Dim i4 As Integer, i5 As Integer, i6 As Integer\n On Error Resume Next\n For i = 65 To 66: For j = 65 To 66: For k = 65 To 66\n For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66\n For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66\n For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126\n ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _\n Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _\n Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)\n If ActiveSheet.ProtectContents = False Then\n MsgBox \"One usable password is \" & Chr(i) & Chr(j) & _\n Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _\n Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)\n Exit Sub\n End If\n Next: Next: Next: Next: Next: Next\n Next: Next: Next: Next: Next: Next\nEnd Sub\n" }, { "path": "__Arch/addPictureToFile.vb", "content": "Private Sub opt_de_Click()\n 'Make a userForm to keep the pictures there!\n img_flag.Picture = user_form_pics.flag_de.Picture\n opt_stadt1 = True\n \n opt_stadt2.Visible = True\n opt_stadt3.Visible = True\n opt_stadt4.Visible = True\n opt_stadt5.Visible = True\n opt_stadt1.Caption = [set_muc_name]\n opt_stadt2.Caption = [set_han_name]\n opt_stadt3.Caption = [set_bln_name]\n opt_stadt4.Caption = [set_nbg_name]\n opt_stadt5.Caption = [set_ffm_name]\n \n Call opt_stadt1_Click\n \n FixInputSheet\n \nEnd Sub\n" }, { "path": "__Arch/all_of_a_kind.vb", "content": "Public Sub remove_space_in_string()\n\n Dim r_range As Range\n \n For Each r_range In Selection\n r_range = Trim(r_range)\n r_range = Replace(r_range, vbTab, \"\")\n r_range = Replace(r_range, \" \", \"\")\n r_range = Replace(r_range, Chr(160), \"\")\n Next r_range\n\nEnd Sub\n\nPublic Sub FreezeTopRow()\n\n Dim ws As Worksheet\n \n Application.ScreenUpdating = False\n Set ws = Worksheets(\"calendar\")\n \n Application.Goto ws.Range(\"h2\")\n ActiveWindow.FreezePanes = True\n \n Set ws = Nothing\n\nEnd Sub\n\nPublic Sub OnStart()\n\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub pls(Optional b_unhide As Boolean = False)\n If b_value_in_array(Environ(\"username\"), S_ADMINS, True) Then\n tbl_main.Unprotect Password:=s_co\n If b_unhide Then Call UnhideAll\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n Debug.Print \"ok :)\"\n Else\n MsgBox Environ(\"username\") & \" you are not allowed to do this. Speak with Vitosh.\", vbInformation, [set_planerkostenberechnung]\n End If\nEnd Sub\n\nPublic Sub LockMe()\n\n tbl_main.Protect Password:=s_co\n Debug.Print \"locked\"\n \nEnd Sub\n\n\nPublic Sub HideNeeded()\n \n Dim var_Sheet As Variant\n \n Dim arr_visible_sheets As Variant\n Dim arr_hidden_sheets As Variant\n \n Call OnStart\n \n arr_visible_sheets = Array(tbl_main, tbl_calendar)\n arr_hidden_sheets = Array(tbl_hon_aus, tbl_hon_geb, tbl_hon_hlse, tbl_hon_tra, tbl_hono_bs, tbl_hono_ps, tbl_public, tbl_settings)\n \n For Each var_Sheet In arr_visible_sheets\n var_Sheet.Visible = xlSheetVisible\n Next var_Sheet\n \n For Each var_Sheet In arr_hidden_sheets\n var_Sheet.Visible = xlSheetVeryHidden\n Next var_Sheet\n \n Call OnEnd\n \nEnd Sub\n\n\nPublic Sub UnhideAll()\n \n Dim Sheet As Worksheet\n \n For Each Sheet In ThisWorkbook.Worksheets\n ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible\n Sheet.Visible = xlSheetVisible\n Next Sheet\n \nEnd Sub\n\nPublic Function calculate_range(from_row As Long, to_row As Long, l_column As Long, _\n Optional s_sheet_name As String = \"calendar\") As Double\n\n Dim ws As Worksheet\n Dim l_counter As Long\n Dim d_result As Double\n \n Set ws = ThisWorkbook.Worksheets(s_sheet_name)\n \n For l_counter = from_row To to_row\n Call Increment(d_result, ws.Cells(l_counter, l_column))\n Next l_counter\n\n Set ws = Nothing\n \n calculate_range = Round(d_result, 2)\n \nEnd Function\n\n\nPublic Sub FixOutlook()\n\n tbl_calendar.Cells.EntireColumn.AutoFit\n \nEnd Sub\n\nPublic Sub HideRange(r_range_to_hide As Range)\n\n Dim my_cell As Range\n Dim l_ba_value As Long\n \n l_ba_value = tbl_main.cmb_ba.value + r_range_to_hide.Row - 1\n\n For Each my_cell In r_range_to_hide\n If my_cell.Row > l_ba_value Then\n my_cell.Interior.Pattern = xlGray8\n my_cell.Font.ThemeColor = xlThemeColorDark1\n Else\n my_cell.Interior.Pattern = xlAutomatic\n my_cell.Font.ColorIndex = xlAutomatic\n End If\n Next my_cell\n \n r_range_to_hide.Borders(xlEdgeTop).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeLeft).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeBottom).LineStyle = xlContinuous\n r_range_to_hide.Borders(xlEdgeRight).LineStyle = xlContinuous\n\nEnd Sub\n\n\nPublic Function add_months(ByVal my_date As Date, ByVal i_month As Integer, Optional ByVal b_use_last_date = False) As Date\n\n If b_use_last_date Then\n add_months = get_last_day_of_month(DateAdd(\"m\", i_month, my_date))\n Else\n add_months = DateAdd(\"m\", i_month, my_date)\n End If\n\nEnd Function\n\nPublic Function get_last_day_of_month(my_date As Date) As Date\n\n get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0)\n\nEnd Function\n\n\n\nPublic Sub AddSomething(str_to_add As String, Optional c_range As Variant)\n \n Dim my_cell As Range\n \n If IsMissing(c_range) Then Set c_range = Selection\n \n For Each my_cell In c_range\n my_cell = my_cell & str_to_add\n Next my_cell\n \n Set c_range = Nothing\n \nEnd Sub\n\nPublic Sub Meter2()\n\n Selection.NumberFormat = \"0\"\" m\" & Chr(179) & \"\"\"\"\n\nEnd Sub\n\nPublic Function change_commas(ByVal myValue As Variant) As String\n \n Dim str_temp As String\n \n str_temp = CStr(myValue)\n change_commas = Replace(str_temp, \",\", \".\")\n \nEnd Function\n\nPublic Sub Increment(ByRef value_to_increment, Optional l_plus As Double = 1) 'optional value type changed to double\n \n value_to_increment = value_to_increment + l_plus\n \nEnd Sub\n\nPublic Sub DeleteName(sName As String)\n\n On Error GoTo DeleteName_Error\n\n ActiveWorkbook.Names(sName).Delete\n \n Debug.Print sName & \" is deleted!\"\n \n On Error GoTo 0\n Exit Sub\n\nDeleteName_Error:\n\n Debug.Print sName & \" not present or some error\"\n On Error GoTo 0\n \nEnd Sub\n\nPublic Function RGB2HTMLColor(B As Byte, G As Byte, r As Byte) As String\n\n Dim HexR As Variant, HexB As Variant, HexG As Variant\n Dim sTemp As String\n\n On Error GoTo ErrorHandler\n\n 'R\n HexR = Hex(r)\n If Len(HexR) < 2 Then HexR = \"0\" & HexR\n\n 'Get Green Hex\n HexG = Hex(G)\n If Len(HexG) < 2 Then HexG = \"0\" & HexG\n\n HexB = Hex(B)\n If Len(HexB) < 2 Then HexB = \"0\" & HexB\n\n RGB2HTMLColor = HexR & HexG & HexB\n Debug.Print \"Red and Blue are reversed ... pay attention to the input in the input\"\n Exit Function\nErrorHandler:\n Debug.Print \"RGB2HTMLColor was not successful\"\nEnd Function\n\nPublic Function sum_array(my_array As Variant, Optional last_values_not_to_calculate As Long = 0) As Double\n \n Dim l_counter As Long\n \n For l_counter = LBound(my_array) To UBound(my_array) - last_values_not_to_calculate\n sum_array = sum_array + my_array(l_counter)\n Next l_counter\n\nEnd Function\n\nPublic Function b_value_in_array(my_value As Variant, _\n my_array As Variant, _\n Optional b_is_string As Boolean = False, _\n Optional str_separator As String = \":\") As Boolean\n\n Dim l_counter\n\n If b_is_string Then\n my_array = Split(my_array, str_separator)\n End If\n\n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n\n\nPublic Sub HideSelectedSheets()\n ActiveWindow.SelectedSheets.Visible = False\nEnd Sub\n \n'---------------------------------------------------------------------------------------\n' Method : MinimizeRibbon\n' Author : v.doynov\n' Date : 29.09.2016\n' Purpose: Minimizes the ribbon, if b_minimize is TRUE, maximizes if FALSE.\n'---------------------------------------------------------------------------------------\nPublic Sub MinimizeRibbon(Optional b_minimize = True)\n\n On Error GoTo MinimizeRibbon_Error\n\n If (Not CommandBars.GetPressedMso(\"MinimizeRibbon\")) And b_minimize Then\n CommandBars.ExecuteMso \"MinimizeRibbon\"\n End If\n \n If (CommandBars.GetPressedMso(\"MinimizeRibbon\")) And (Not b_minimize) Then\n CommandBars.ExecuteMso \"MinimizeRibbon\"\n End If\n\n On Error GoTo 0\n Exit Sub\n\nMinimizeRibbon_Error:\n\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure MinimizeRibbon of Sub mod_sheets\"\n\nEnd Sub\n" }, { "path": "__Arch/browse.vb", "content": "Private Sub cmd_browse_Click()\n \n Dim str_file As String\n \n str_file = Application.GetOpenFilename _\n (Title:=\"Please choose a file to open\", _\n FileFilter:=\"Excel Files *.xls* (*.xls*),\")\n \n txtbox_display.Text = str_file\n \nEnd Sub\n" }, { "path": "__Arch/btn_open_Click.vb", "content": "'Opens the file open file open a file open a folder open folder\n'Eliminates the file name and opens the folder.\n\nPrivate Sub btn_open_Click()\n On Error GoTo btn_open_Click_Error\n \n Dim my_str As String\n Dim my_str2 As String\n\n \n my_str = tbl_input.lblDisplayTerminPlanner\n my_str2 = Left(my_str, Len(my_str) - Len(Split(my_str, \"\\\")(UBound(Split(my_str, \"\\\")))))\n Call Shell(\"explorer.exe\" & \" \" & my_str2, vbNormalFocus)\n \nbtn_open_Click_Error:\n Debug.Print \"Error \" & Err.Number & \" (\" & Err.Description & \")\"\n\n \nEnd Sub\n" }, { "path": "__Arch/bus.vb", "content": "Public Function WriteString(ByVal n As Long) As String\n 'Lucida Console or Consolas\n Dim v_Bus() As Variant\n Dim s_char As String\n \n Dim i As Long\n Dim l_col As Long\n Dim l_row As Long\n \n n = n - 1\n v_Bus = Array(\"+------------------------+\", _\n \"|......................|D|)\", _\n \"|......................|.|\", _\n \"|........................|\", _\n \"|......................|.|)\", _\n \"+------------------------+\")\n \n For i = 0 To 33\n \n If i > n Then\n s_char = \"#\"\n Else\n s_char = \"O\"\n End If\n\n If i < 4 Then\n l_col = 0\n ElseIf i = 4 Then\n l_col = 1\n Else\n l_col = (i - 2) / 3\n End If\n\n If i <= 3 Then\n l_row = i\n Else\n l_row = (i - 4) Mod 3\n End If\n\n If (l_row = 2 And l_col <> 0) Then l_row = l_row + 1\n Mid(v_Bus(l_row + 1), (1 + l_col * 2) + 1, 1) = s_char\n Next i\n \n WriteString = draw_bus(v_Bus)\n\nEnd Function\n\nPublic Function draw_bus(v_Bus As Variant) As String\n \n Dim i As Long\n For i = LBound(v_Bus) To UBound(v_Bus)\n draw_bus = draw_bus & v_Bus(i) & vbCrLf\n Next i\n \nEnd Function\n\nPublic Sub TestBus()\n \n Dim l_counter As Long\n\n For l_counter = 1 To 34\n Debug.Print l_counter\n Debug.Print WriteString(l_counter)\n Next l_counter\nEnd Sub\n" }, { "path": "__Arch/call_click_event_from_module.vb", "content": "Sub maina()\n\n Run \"tbl_Input.btn_main_Click\"\n \nEnd Sub\n" }, { "path": "__Arch/cls_counter.vb", "content": "Sub TDD()\n \n Dim specs As New SpecSuite\n Dim test_calendar As New cls_calendar\n Dim test_plan As New cls_plan\n Dim test_counter As New cls_counter\n \n test_calendar.IncrementRow\n specs.It(\"cls_c1\").Expect(test_calendar.CurrentRow).ToEqual 1\n \n test_calendar.IncrementRow\n test_calendar.CurrentRow = 5\n test_calendar.IncrementRow\n specs.It(\"cls_c2\").Expect(test_calendar.CurrentRow).ToEqual 6\n \n test_calendar.LeftDate = \"01.09.2015\"\n test_calendar.RightDate = \"01.08.2021\"\n specs.It(\"cls_c3\").Expect(test_calendar.Duration).ToEqual 71\n \n test_plan.LastLines_Row = 30\n test_plan.LastLines_Row = 31\n test_plan.LastLines_Row = 1000\n specs.It(\"plan_c4\").Expect(test_plan.LastLines_Row(1)).ToEqual 30\n specs.It(\"plan_c5\").Expect(test_plan.LastLines_Row(2)).ToEqual 31\n specs.It(\"plan_c6\").Expect(test_plan.LastLines_Row(3)).ToEqual 1000\n \n specs.It(\"plan_c7\").Expect(test_plan.LastLines_Row_Count).ToEqual 3\n specs.It(\"plan_c8\").Expect(test_plan.LastLines_Row_Count).ToNotEqual 4\n \n test_counter.IncrementCounter\n test_counter.IncrementCounter\n specs.It(\"counter_c9\").Expect(test_counter.Counter).ToEqual 2\n specs.It(\"counter_c10\").Expect(test_counter.Counter).ToNotEqual 3\n \n test_counter.ResetCounter\n specs.It(\"counter_c11\").Expect(test_counter.Counter).ToEqual 0\n \n test_counter.IncrementCounter (10)\n specs.It(\"counter_c12\").Expect(test_counter.Counter).ToEqual 10\n \n test_counter.IncrementCounter\n specs.It(\"counter_c12a\").Expect(test_counter.Counter).ToEqual 11\n \n test_counter.DecrementCounter\n specs.It(\"counter_c12b\").Expect(test_counter.Counter).ToEqual 10\n \n test_counter.ResetCounter\n test_counter.DecrementCounter\n specs.It(\"counter_c12c\").Expect(test_counter.Counter).ToEqual -1\n\n test_counter.ResetCounter\n test_counter.IncrementCounter\n test_counter.Flag\n specs.It(\"counter_c13\").Expect(test_counter.IsFlagged).ToEqual True\n \n test_counter.IncrementCounter\n specs.It(\"counter_c14\").Expect(test_counter.IsFlagged).ToEqual False\n \n test_counter.Flag\n specs.It(\"counter_c15\").Expect(test_counter.IsFlagged).ToEqual True\n \n test_counter.UnFlag\n specs.It(\"counter_c16\").Expect(test_counter.IsFlagged).ToEqual False\n \n InlineRunner.RunSuite specs\n \n Set test_calendar = Nothing\n Set test_plan = Nothing\n Set specs = Nothing\n Set test_counter = Nothing\n \nEnd Sub\n\n'Unit tests are here:\nSub TDD()\n \n Dim specs As New SpecSuite\n Dim test_calendar As New cls_calendar\n Dim test_plan As New cls_plan\n Dim test_counter As New cls_counter\n \n test_counter.IncrementCounter\n test_counter.IncrementCounter\n specs.It(\"counter_c9\").Expect(test_counter.Counter).ToEqual 2\n specs.It(\"counter_c10\").Expect(test_counter.Counter).ToNotEqual 3\n test_counter.ResetCounter\n specs.It(\"counter_c11\").Expect(test_counter.Counter).ToEqual 1\n test_counter.IncrementCounter (10)\n specs.It(\"counter_c12\").Expect(test_counter.Counter).ToEqual 11\n \n test_counter.ResetCounter\n test_counter.IncrementCounter\n test_counter.Flag\n \n specs.It(\"counter_c13\").Expect(test_counter.IsFlagged).ToEqual True\n test_counter.IncrementCounter\n specs.It(\"counter_c14\").Expect(test_counter.IsFlagged).ToEqual False\n test_counter.Flag\n specs.It(\"counter_c14\").Expect(test_counter.IsFlagged).ToEqual True\n test_counter.UnFlag\n specs.It(\"counter_c14\").Expect(test_counter.IsFlagged).ToEqual False\n \n InlineRunner.RunSuite specs\n \n Set test_calendar = Nothing\n Set test_plan = Nothing\n Set specs = Nothing\n Set test_counter = Nothing\n \nEnd Sub\n" }, { "path": "__Arch/code_making_code.vb", "content": "Public Sub TakeValues()\n\n Dim my_cell As Range\n Dim str As String\n Dim l_counter As Long\n \n For Each my_cell In Selection\n Call Increment(l_counter)\n str = \"my_arr(\" & l_counter & \")= \"\n If Len(my_cell) > 1 Then\n str = str & change_commas(my_cell.value)\n Else\n str = str & 0\n End If\n \n Debug.Print str\n \n Next my_cell\n\nEnd Sub\n" }, { "path": "__Arch/colors.vb", "content": "Const p_COLOR_YELLOW = 65535\nConst p_COLOR_BLUE = 14470546\nConst p_COLOR_BLUE_NEGATIVE = 16770927\nConst p_COLOR_BLUE_ZERO = 14136213\nConst p_COLOR_WHITE = -4142 '16777215\n" }, { "path": "__Arch/copy_newsheet_new sheet.vb", "content": "Option Explicit\n\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\n\n On Error GoTo Workbook_NewSheet_Error\n\n Sheets(1).Rows(\"1:2\").Copy\n Sh.Paste\n Application.CutCopyMode = False\n \n 'Sheets(1).Columns(1).Copy\n Sheets(1).Columns(\"A:D\").Copy\n Sh.Paste\n Application.CutCopyMode = False\n \n Sh.Cells(1, 1).Select\n \n On Error GoTo 0\n Exit Sub\n\nWorkbook_NewSheet_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_NewSheet of VBA Document DieseArbeitsmappe\"\nEnd Sub\n\n" }, { "path": "__Arch/delete_row.vb", "content": "Option Explicit\n'call CheckAndDelete(Range(\"A1:A10\"),1,\"1\")\n\nPublic Sub CheckAndDelete(r_range As Range, l_column As Long, Optional s_char As String = \".\")\n\n Dim l_counter As Long\n Dim r_cell As Range\n \n For l_counter = r_range.Cells(r_range.Count).Row To r_range.Cells(1, 1).Row Step -1\n Set r_cell = Cells(l_counter, l_column)\n If InStr(1, r_cell, s_char, vbTextCompare) Then\n Rows(l_counter).EntireRow.Delete\n End If\n Next l_counter\n \n Set r_cell = Nothing\n Set r_range = Nothing\n \nEnd Sub\n" }, { "path": "__Arch/errors.vb", "content": "'Err.Raise 1985, \"NAME\", \"NAME THE CUSTOM ERRROR\"\n'http://onlinelibrary.wiley.com/doi/10.1002/9781118257616.app3/pdf\n\nMain2_Error:\n \n If Err.Number = [set_standard_error_number] Then\n MsgBox Err.Description & vbCrLf & \"Fehler bei Modul \" & Err.Source, vbInformation, [set_awaited_error]\n Else\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \")\", vbInformation, [set_awaited_error_not]\n End If\n\nEnd Sub\n" }, { "path": "__Arch/example.hta.htm", "content": "\n\n\t\n\t\t\n\t\tSimple Strange Calculator for VitoshAcademy.Com\n\t\n\t\n\t\n\t\n\t\t\n\t\t\t\n\t\t\t\t\n\t\t\t\t\n\t\t\t\n\t\t\t\n\t\t\t\t\n\t\t\t\n\t\t\t\n\t\t\t\t\n\t\t\t\n\t\t
\n\t\t\t\t\t\n\t\t\t\t\n\t\t\t\t\t\n\t\t\t\t
\n\t\t\t\t\n\t\t\t\t
\n\t\t\t\t\t\n\t\t\t\t
\n\t\n\n" }, { "path": "__Arch/form_VBA.vb", "content": "Private Sub UserForm_Activate()\n\n img_sad.Visible = False\n img_smile.Visible = True\n \n With frm_green\n .Top = Application.Top + 200\n .Left = Application.Left + 100\n End With\n \n If b_is_error Then\n \n frm_green.lbl_status.BackColor = RGB(200, 10, 10)\n frm_green.lbl_status = [set_paku_thankyou] & vbCrLf & \"Status: Nicht erfolgreich! :(\"\n \n img_sad.Visible = True\n img_smile.Visible = False\n Me.Repaint\n Application.Wait (Now + TimeValue(\"00:00:01\"))\n Else\n \n frm_green.lbl_status.BackColor = RGB(10, 200, 10)\n frm_green.lbl_status = [set_paku_thankyou] & vbCrLf & \"Status: Erfolgreich! :) \"\n \n End If\n \n Me.Repaint\n Application.Wait (Now + TimeValue(\"00:00:02\"))\n Unload Me\n \nEnd Sub\n" }, { "path": "__Arch/general_smalls.vb", "content": "Option Explicit\n\nSub FixRangeError() \n'Fix bezug fehler\n\n Dim r_range As Range\n Dim str_text As String\n Dim l_counter As Long\n Dim str_result As String\n \n Dim arr_result As Variant\n Dim arr_range As Variant\n \n ReDim arr_result(0)\n Set r_range = Selection\n str_text = Replace(r_range.Formula, \"=\", \"\")\n \n arr_range = Split(str_text, \"+\")\n \n For l_counter = LBound(arr_range) To UBound(arr_range)\n If Not InStr(arr_range(l_counter), \"#\") > 0 Then\n ReDim Preserve arr_result(UBound(arr_result) + 1)\n arr_result(UBound(arr_result)) = arr_range(l_counter)\n End If\n Next l_counter\n \n For l_counter = LBound(arr_result) + 1 To UBound(arr_result)\n str_result = str_result & \"+\" & arr_result(l_counter)\n Next l_counter\n \n Debug.Print str_result\n \nEnd Sub\n" }, { "path": "__Arch/hide_selected_sheets.vb", "content": "Public Sub HideSelectedSheets()\n ActiveWindow.SelectedSheets.Visible = False\nEnd Sub\n" }, { "path": "__Arch/info.txt", "content": "Images for the ribbon:\nhttp://soltechs.net/customui/imagemso01.asp\n" }, { "path": "__Arch/isUserFormLoaded.vb", "content": "used this way:\nIf IsUserFormLoaded(\"frmPlanerkostenberechnung\") Then Unload frmPlanerkostenberechnung\n\nFunction IsUserFormLoaded(ByVal UFName As String) As Boolean\n Dim UForm As Object\n \n For Each UForm In VBA.UserForms\n If UForm.Name = UFName Then\n IsUserFormLoaded = True\n Exit Function\n End If\n Next\nEnd Function\n" }, { "path": "__Arch/languages.vb", "content": "'change language\n'change fonts\nOption Explicit\n\nPublic Enum LandName\n BG\n US\n DE\nEnd Enum\n\nPrivate Const LOCALE_ILANGUAGE As Long = &H1\nPrivate Const LOCALE_SCOUNTRY As Long = &H6\nPrivate Declare Function ActivateKeyboardLayout Lib \"user32.dll\" (ByVal myLanguage As Long, Flag As Boolean) As Long\nPrivate Declare Function GetKeyboardLayout Lib \"user32\" (ByVal dwLayout As Long) As Long\n\nDeclare Function getUserName Lib \"advapi32.dll\" Alias \"GetUserNameA\" (ByVal lpBuffer As String, ByRef nSize As Long) As Long\n\n\nPrivate Declare Function GetLocaleInfo Lib \"kernel32\" _\n Alias \"GetLocaleInfoA\" _\n (ByVal Locale As Long, _\n ByVal LCType As Long, _\n ByVal lpLCData As String, _\n ByVal cchData As Long) As Long\n \nPublic Function f_str_country_name(l_landname As Long) As String\n \n Dim str_result As String\n \n Select Case l_landname\n \n Case 0:\n str_result = \"Bulgarien\"\n Case 1:\n str_result = \"Vereinigte Staaten\"\n Case 2:\n str_result = \"Deutschland\"\n End Select\n \n f_str_country_name = str_result\n \nEnd Function\n\nPublic Function f_lng_country_code(l_landname As Long) As Long\n \n Dim lng_result As Long\n \n Select Case l_landname\n \n Case 0:\n lng_result = 1026\n Case 1:\n lng_result = 1033\n Case 2:\n lng_result = 1031\n End Select\n \n f_lng_country_code = lng_result\n \nEnd Function\n\nPublic Sub ChangeLanguages()\n\n Call SetLanguage(f_str_country_name(LandName.DE), f_lng_country_code(LandName.DE))\n\n Call SetLanguage(f_str_country_name(LandName.BG), f_lng_country_code(LandName.BG))\n\n Call SetLanguage(f_str_country_name(LandName.US), f_lng_country_code(LandName.US))\n\n Call SetLanguage\n \nEnd Sub\n \nPublic Sub SetLanguage(Optional str_lang As String = \"Bulgarien\", Optional l_code As Long = 1026)\n \n If Not f_str_get_language = str_lang Then\n ActivateKeyboardLayout l_code, 0\n End If\n \nEnd Sub\n\nPublic Function f_str_get_language()\n\n Dim hKeyboardID As Long\n Dim LCID As Long\n \n hKeyboardID = GetKeyboardLayout(0&)\n LCID = LoWord(hKeyboardID)\n\n f_str_get_language = GetUserLocaleInfo(LCID, LOCALE_SCOUNTRY)\n\nEnd Function\n\nPrivate Function LoWord(wParam As Long) As Long\n\n If wParam And &H8000& Then\n LoWord = &H8000& Or (wParam And &H7FFF&)\n Else\n LoWord = wParam And &HFFFF&\n End If\n \nEnd Function\n\nPublic Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String\n\n Dim sReturn As String\n Dim nSize As Long\n \n nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))\n \n If nSize > 0 Then\n sReturn = Space$(nSize)\n nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))\n If nSize > 0 Then\n GetUserLocaleInfo = Left$(sReturn, nSize - 1)\n End If\n End If\n \nEnd Function\n" }, { "path": "__Arch/last_row_of_named_range.vb", "content": "'[hon_br_kosten].rows.count-1+[hon_br_kosten].row\n'last row of named range\n\nPublic Function get_last_row_of_named_range(my_range As Range) As Long\n \n get_last_row_of_named_range = my_range.Rows.Count - 1 + my_range.Row\n\nEnd Function\n" }, { "path": "__Arch/mod_cumulative_sum.vb", "content": "Option Explicit\n\nPublic Function return_line(my_range As Range, percentage As Double) As Integer\n \n Dim my_cell As Range\n Dim my_result As Double\n \n For Each my_cell In my_range\n my_result = my_result + my_cell.Value\n If my_result >= (Application.WorksheetFunction.Sum(my_range) * percentage) Then\n return_line = my_cell.Row - my_range.Row + 1\n Exit For\n End If\n Next my_cell\n \nEnd Function\n\nPublic Function change_commas(ByVal myValue As Variant) As String\n \n Dim str_temp As String\n \n str_temp = CStr(myValue)\n change_commas = Replace(str_temp, \",\", \".\")\n \nEnd Function\n\n\nPublic Sub FormatAsDate(ByRef cell As Range)\n\n cell.NumberFormat = \"[$-407]mmm/ yy;@\"\n \nEnd Sub\n\nPublic Sub FormatAsPercent(ByRef my_cell As Range)\n\n my_cell.Style = \"Percent\"\n my_cell.NumberFormat = \"0.00%\"\n\nEnd Sub\n\nPublic Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False)\n\n\n If IsNumeric(cell.Value) And Not cell.HasFormula Then\n cell.Value = Round(cell.Value, 2)\n End If\n\n cell.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00)\"\n\n If b_change_0 Then\n \n With cell\n .FormatConditions.Delete\n .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=\"=0\"\n .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1\n .FormatConditions(1).Font.TintAndShade = -0.25\n End With\n \n End If\n \nEnd Sub\n\nPublic Function millions_eur(ByVal my_value As Long) As Long\n \n millions_eur = my_value / 1000000\n\nEnd Function\n\nPublic Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet)\n \n Dim str_lines As String\n str_lines = lines & \":\" & lines\n \n With my_sheet.Rows(str_lines).Font\n .ThemeColor = xlThemeColorDark1\n .TintAndShade = 0\n End With\n \nEnd Sub\n\nPublic Sub FormatFontColorToGrey(ByRef cell As Range)\n\n cell.Font.Color = RGB(128, 128, 128)\n\nEnd Sub\nPublic Sub UnprotectAll()\n\n Dim i As Integer\n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Unprotect Password:=SECRET_PASSWORD\n Next\n \nEnd Sub\nPublic Sub ProtectAll()\n\n Dim i As Integer\n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Activate\n ActiveWorkbook.Worksheets(i).Cells(1, 1).Select\n ActiveWorkbook.Worksheets(i).Protect Password:=SECRET_PASSWORD\n Next\n \nEnd Sub\n\nPublic Function distribution_term_calculation(total_term) As Long\n\n If total_term >= 6 Then\n distribution_term_calculation = 6\n ElseIf total_term < 6 And total_term >= 2 Then\n distribution_term_calculation = 2\n Else\n distribution_term_calculation = 1\n End If\n \nEnd Function\n\nPublic Function sum_range(my_range As Range) As Double\n \n Dim cell As Range\n \n sum_range = 0\n \n For Each cell In my_range\n sum_range = sum_range + cell.Value\n Next\n \nEnd Function\n\nPublic Function make_random(down As Long, up As Long) As Long\n \n make_random = CLng((up - down + 1) * Rnd + down)\n \n If make_random > up Then make_random = up\n If make_random < down Then make_random = down\n\nEnd Function\n\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n \n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row\n \nEnd Function\n" }, { "path": "__Arch/mod_environ.vb", "content": "Option Explicit\n\nDeclare Function GetLocaleInfo Lib \"kernel32\" Alias _\n\"GetLocaleInfoA\" (ByVal Locale As Long, ByVal LCType As Long, _\nByVal lpLCData As String, ByVal cchData As Long) As Long\n\nDeclare Function GetUserDefaultLCID% Lib \"kernel32\" ()\n\nPublic Const LOCALE_SLIST = &HC\nPublic Function GetListSeparator() As String\n\n '?environ(\"pathext\")\n\n Dim ListSeparator As String\n Dim iRetVal1 As Long\n Dim iRetVal2 As Long\n Dim lpLCDataVar As String\n \n Dim Position As Integer\n Dim Locale As Long\n \n Locale = GetUserDefaultLCID()\n \n iRetVal1 = GetLocaleInfo(Locale, LOCALE_SLIST, lpLCDataVar, 0)\n \n ListSeparator = String$(iRetVal1, 0)\n \n iRetVal2 = GetLocaleInfo(Locale, LOCALE_SLIST, ListSeparator, iRetVal1)\n \n Position = InStr(ListSeparator, Chr$(0))\n \n If Position > 0 Then\n GetListSeparator = Left$(ListSeparator, Position - 1)\n End If\n\nEnd Function\n\nSub EnumSEVars()\n Dim strVar As String\n Dim i As Long\n \n For i = 1 To 255\n strVar = Environ$(i)\n If LenB(strVar) = 0& Then Exit For\n Debug.Print strVar\n Next\nEnd Sub\n\n" }, { "path": "__Arch/mod_excel_functions.vb", "content": "Option Explicit\n\nPublic Function return_line(my_range As Range, percentage As Double) As Integer\n \n Dim my_cell As Range\n Dim my_result As Double\n \n For Each my_cell In my_range\n my_result = my_result + my_cell.Value\n If my_result >= (Application.WorksheetFunction.Sum(my_range) * percentage) Then\n return_line = my_cell.Row - my_range.Row + 1\n Exit For\n \n End If\n Next my_cell\n \nEnd Function\n" }, { "path": "__Arch/mod_from_experience_various.vb", "content": "Public Sub ColorTheColumn()\n \n Dim l_counter As Long\n Dim my_cell As Range\n Dim my_cell_find As Range\n \n For l_counter = 1 To l_writing_row\n Set my_cell = tbl_output.Cells(l_counter, 1)\n Set my_cell_find = tbl_settings.Range(\"CN:CN\").Find(my_cell, LookIn:=xlValues)\n \n If Not my_cell_find Is Nothing Then\n If my_cell_find.Offset(0, 1) = \"bold\" Then\n my_cell.Font.Bold = True\n End If\n If my_cell_find.Offset(0, 2) = \"red\" Then\n my_cell.Font.Color = -16777063\n End If\n End If\n \n Next l_counter\n \nEnd Sub\n\n\nPublic Sub PrintPage()\n\n Dim Sh As Worksheet\n Dim rngPrint As Range\n Dim s_reduce_paper_title As String\n \n On Error GoTo PrintPage_Error\n \n s_reduce_paper_title = \"Reduzieren Sie den Papierverbrauch\"\n \n Set Sh = ActiveSheet\n Set rngPrint = [input_print_area]\n \n With Sh.PageSetup\n .Orientation = xlPortrait\n .Zoom = False\n .FitToPagesTall = 1\n .FitToPagesWide = 1\n End With\n \n Select Case MsgBox(\"Sind Sie sicher, dass Sie drucken moechten?\", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title)\n Case vbYes\n Select Case MsgBox(\"Wirklich sicher, dass Sie drucken moechten?\", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title)\n Case vbYes\n rngPrint.PrintOut\n End Select\n End Select\n\n On Error GoTo 0\n Exit Sub\n\nPrintPage_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure PrintPage of Modul mod_Drucken\"\n \nEnd Sub\n\nPublic Sub print_array(my_array As Variant)\n Dim counter As Integer\n \n For counter = LBound(my_array) To UBound(my_array)\n Debug.Print counter & \" --> \" & my_array(counter)\n Next counter\n \nEnd Sub\n\nPublic Sub GenerateSumsOutput(l_lower_row As Long, l_higher_row As Long, l_current_row As Long)\n\n Dim r_cell As Range\n Dim l_counter As Long\n\n For l_counter = arr_calendar_settings(2) To arr_calendar_settings(3)\n Set r_cell = tbl_output.Cells(l_current_row, l_counter)\n r_cell.FormulaR1C1 = \"=SUM(R\" & l_higher_row & \"C:R\" & l_lower_row & \"C)\"\n Next l_counter\n\n Set r_cell = Nothing\n \nEnd Sub\n\nPublic Sub swap_variables(ByRef value_1, ByRef value_2)\n \n Dim int_tmp As Integer\n \n int_tmp = value_1\n value_1 = value_2\n value_2 = int_tmp\n \nEnd Sub\n\nPublic Function calculate_years_from_months(total_term) As Long\n \n calculate_years_from_months = total_term \\ MONTHS_IN_YEAR\n If total_term Mod MONTHS_IN_YEAR Then calculate_years_from_months = calculate_years_from_months + 1\n \nEnd Function\n\nPublic Function letter_col(ByVal col As Long) As String\n\n letter_col = Split(Cells(1, col).Address, \"$\")(1)\n\nEnd Function\n\nPublic Function bool_zero_or_empty(ByRef cell As Range, Optional b_is_range = False) As Boolean\n \n If b_is_range Then\n \n For Each current_cell In cell\n If (IsEmpty(current_cell) Or current_cell.Value = 0) Then\n bool_zero_or_empty = True\n Exit Function\n Else\n bool_zero_or_empty = False\n End If\n Next current_cell\n \n Else\n If (IsEmpty(cell) Or cell.Value = 0) Then\n bool_zero_or_empty = True\n Else\n bool_zero_or_empty = False\n End If\n End If\n\nEnd Function\n\nPublic Function change_commas(ByVal myValue As Variant) As String\n \n Dim str_temp As String\n \n str_temp = CStr(myValue)\n change_commas = Replace(str_temp, \",\", \".\")\n \nEnd Function\n\nPublic Sub FormatAsDate(ByRef cell As Range)\n\n cell.NumberFormat = \"[$-407]mmm/ yy;@\"\n \nEnd Sub\n\nPublic Sub FormatAsPercent(ByRef my_cell As Range)\n\n my_cell.Style = \"Percent\"\n my_cell.NumberFormat = \"0.00%\"\n\nEnd Sub\n\nPublic Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False, Optional b_make_gray = True)\n \n Dim b_is_alone As Boolean\n \n b_is_alone = IIf(cell.Rows.Count + cell.Columns.Count <> 2, False, True)\n\n If IsNumeric(cell.Value) And Not cell.HasFormula Then\n cell.Value = Round(cell.Value, 2)\n End If\n\n cell.NumberFormat = \"$#,##0.00_);[Red]($#,##0.00)\"\n\n If b_change_0 Then\n\n With cell\n .FormatConditions.Delete\n .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=\"=0\"\n .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1\n .FormatConditions(1).Font.TintAndShade = -0.4\n End With\n End If\n\n If b_is_alone Then\n If b_make_gray And cell.Value = 0 Then\n With cell\n .Cells.Font.Color = RGB(191, 191, 191)\n End With\n End If\n End If\n\nEnd Sub\n\nPublic Function millions_eur(ByVal my_value As Long) As Long\n \n millions_eur = my_value / 1000000\n\nEnd Function\n\nPublic Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet)\n \n Dim str_lines As String\n str_lines = lines & \":\" & lines\n \n With my_sheet.Rows(str_lines).Font\n .ThemeColor = xlThemeColorDark1\n .TintAndShade = 0\n End With\n \nEnd Sub\n\nPublic Sub WhiteCell(ByRef my_cell As Range)\n \n my_cell.Font.ThemeColor = xlThemeColorDark1\n my_cell.Font.TintAndShade = 0\n \nEnd Sub\n\nPublic Sub FormatFontColorToGrey(ByRef cell As Range)\n\n cell.Font.Color = RGB(128, 128, 128)\n\nEnd Sub\n\nPublic Function sum_range(my_range As Range) As Double\n\n Dim cell As Range\n\n sum_range = 0\n For Each cell In my_range\n sum_range = sum_range + cell.Value\n Next\n\nEnd Function\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n \n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row\n \nEnd Function\n\nSub CopyValues(rngSource As Range, rngTarget As Range)\n \n rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value\n \nEnd Sub\n\nPublic Sub FormatRedAndBold(ByRef my_cell As Range, Optional isBold = True)\n \n my_cell.Font.Color = -16777063\n my_cell.Font.TintAndShade = 0\n\n If isBold Then my_cell.Font.Bold = True\n \nEnd Sub\n\nPublic Function check_if_hidden(r_range As Range) As Boolean\n\n If r_range.EntireRow.Hidden Or r_range.EntireColumn.Hidden Then\n check_if_hidden = True\n End If\n\nEnd Function\n\nFunction NamedRangeExists(strRangeName As String) As Boolean\n Dim my_range As Range\n \n On Error Resume Next\n \n Set my_range = Range(strRangeName)\n \n If Not my_range Is Nothing Then NamedRangeExists = True\n \n On Error GoTo 0\n \nEnd Function\n\nPublic Sub FormatAs_Eur_pro_m2(my_cell As Range)\n \n my_cell.NumberFormat = \"#,##0.00 \"\" € / m²\"\"\"\n\nEnd Sub\n\nSub change_all_names()\n \n Dim i As Integer\n Dim s_old As String\n Dim s_new As String\n \n For i = 1 To ActiveWorkbook.Names.Count\n' Debug.Print ActiveWorkbook.Names(i).name\n' Debug.Print ActiveWorkbook.Names(i).RefersToR1C1\n' Debug.Print ActiveWorkbook.Names(i)\n'\n If InStr(1, ActiveWorkbook.Names(i), \"old\", vbTextCompare) Then\n s_old = ActiveWorkbook.Names(i).RefersToR1C1\n s_new = Replace(s_old, \"old\", \"\")\n Debug.Print s_new\n \n With ActiveWorkbook.Names(ActiveWorkbook.Names(i).name)\n .RefersToR1C1 = s_new\n\n End With\n End If\n Next i\n\nEnd Sub\nSub Fixing()\n tbl_Input.img_coat_of_arms.BackColor = RGB(217, 217, 217)\nEnd Sub\n\nPublic Sub SetUserNameAndDate()\n\n [input_calculation_date] = Date\n [input_user_name] = \"Erstellt von \" & Replace(Application.WorksheetFunction.Proper(Environ(\"UserName\")), \".\", \". \")\n\nEnd Sub\n\n\nPublic Sub SetNamedRanges()\n\n 'start setting named range for ma_purchase_ba\n If NamedRangeExists(\"ma_purchase_ba\") Then ActiveWorkbook.Names(\"ma_purchase_ba\").Delete\n ThisWorkbook.Names.Add name:=\"ma_purchase_ba\", RefersTo:=tbl_output.Cells(8, 3)\n 'end setting named range\n\nEnd Sub\n\nPublic Function locate_bau_beginn(ByVal d_baubeginn As Date) As Long\n \n Dim cell_to_find As Range\n \n Set cell_to_find = Range(tbl_output.Cells(1, 1), tbl_output.Cells(1, arr_calendar_settings(3))).Find(d_baubeginn, LookIn:=xlValues)\n locate_bau_beginn = cell_to_find.Column\n Set cell_to_find = Nothing\n \nEnd Function\n\nPublic Function get_last_day_of_month(ByVal my_date As Date) As Date\n get_last_day_of_month = DateSerial(Year(my_date), month(my_date) + 1, 0)\nEnd Function\n\nPublic Function get_first_day_of_month(ByVal my_date As Date) As Date\n get_first_day_of_month = DateSerial(Year(my_date), month(my_date), 1)\nEnd Function\n\nPublic Function add_months(ByVal my_date As Date, ByVal i_month As Integer) As Date\n add_months = get_last_day_of_month(DateAdd(\"m\", i_month, my_date))\nEnd Function\n\nPublic Function add_months_and_get_first_date(ByVal my_date As Date, ByVal i_month As Integer) As Date\n add_months_and_get_first_date = get_first_day_of_month(DateAdd(\"m\", i_month, my_date))\nEnd Function\n\nPublic Sub FreezePanesWithoutSelect()\n\n Dim ws As Worksheet\n \n Application.ScreenUpdating = False\n Set ws = Worksheets(\"master\")\n \n Application.Goto ws.Range(\"E2\")\n ActiveWindow.FreezePanes = True\n \n Set ws = Nothing\n \nEnd Sub\n\nPublic Function get_column_with_value(ByRef my_cell) As Long\n\n get_column_with_value = my_cell.End(xlToRight).Column\n\nEnd Function\n\nPublic Sub OnStart()\n\n Application.ScreenUpdating = False\n Application.Calculation = xlAutomatic\n Application.EnableEvents = False\n\nEnd Sub\n\nPublic Sub OnEnd()\n\n Application.ScreenUpdating = True\n Application.EnableEvents = True\n Application.StatusBar = False\n \nEnd Sub\n\nPublic Sub UpdateStatusBar()\n \n Dim i As Integer\n Dim s_show As String\n\n On Error GoTo UpdateStatusBar_Error\n\n If int_number_of_subs = 0 Then int_number_of_subs = 1\n\n int_current_sub = int_current_sub + 1\n\n s_show = \"/\\/\\>-\"\n \n For i = 0 To int_number_of_subs Step 1\n If int_current_sub <> i Then\n s_show = s_show & \"~~~\"\n Else\n s_show = s_show & \"\\___/\"\n End If\n Next i\n\n s_show = s_show & \"- CLng(TempArray(i + 1)) Then\n NoExchanges = False\n Temp = TempArray(i)\n TempArray(i) = TempArray(i + 1)\n TempArray(i + 1) = Temp\n End If\n Next i\n \n Loop While Not (NoExchanges)\n bubble_sort = TempArray\nEnd Function\n\nPublic Function sum_array(my_array As Variant) As Double\n 'For unknown reasons, WorksheetFunction.sum(my_array) does not work always,\n 'when we sum currency, integer and double...\n \n Dim l_counter As Long\n \n For l_counter = LBound(my_array) To UBound(my_array)\n sum_array = sum_array + my_array(l_counter)\n Next l_counter\n \nEnd Function\n\nPublic Function b_value_in_array(my_value As Variant, my_array As Variant) As Boolean\n\n Dim l_counter\n \n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n\nFunction last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long\n \n Dim shSheet As Worksheet\n \n If str_sheet = vbNullString Then\n Set shSheet = ActiveSheet\n Else\n Set shSheet = Worksheets(str_sheet)\n End If\n \n last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row\n\nEnd Function\n\n\nFunction last_column(Optional str_sheet As String, Optional row_to_check As Long = 1) As Long\n\n Dim shSheet As Worksheet\n \n If str_sheet = vbNullString Then\n Set shSheet = ActiveSheet\n Else\n Set shSheet = Worksheets(str_sheet)\n End If\n \n last_column = shSheet.Cells(row_to_check, shSheet.Columns.Count).End(xlToLeft).Column\nEnd Function\n\nSub SaveFile\n A = Application.GetSaveAsFilename(InitialFileName:=environ(\"username\") & \"_\"&ThisWorkbook.Name , fileFilter:=\"Excel Files (*.xlsm), *.xlsm\")\nend Sub\n\nPublic Function b_val_in_array(var_to_search As Variant, my_array As Variant) As Boolean\n\n Dim object As Variant\n \n For Each object In my_array\n If CStr(var_to_search) = CStr(object) Then\n b_val_in_array = True\n Exit Function\n End If\n Next object\n b_val_in_array = False\n \nEnd Function\n" }, { "path": "__Arch/mod_functions.vb", "content": "Option Explicit\n\n\nPublic Function sum_range(my_range As Range) As Double\n \n Dim cell As Range\n \n sum_range = 0\n \n For Each cell In my_range\n sum_range = sum_range + cell.Value\n Next\n \nEnd Function\n\nSub PrintLines()\n\n ActiveSheet.DisplayPageBreaks = Not ActiveSheet.DisplayPageBreaks\n \nEnd Sub\n\nSub CheckReferences()\n' Check for possible missing or erroneous links in\n' formulas and list possible errors in a summary sheet\n\n Dim iSh As Integer\n Dim sShName As String\n Dim c As Range\n Dim rng As Range\n Dim i As Integer\n Dim j As Integer\n Dim sChr As String\n Dim addr As String\n Dim sFormula As String\n Dim scVal As String\n Dim lNewRow As Long\n Dim vHeaders As Variant\n\n vHeaders = Array(\"Sheet Name\", \"Cell\", \"Cell Value\", \"Formula\")\n 'check if 'Summary' worksheet is in workbook\n 'and if so, delete it\n With Application\n .ScreenUpdating = False\n .DisplayAlerts = False\n .Calculation = xlCalculationManual\n End With\n\n For i = 1 To Worksheets.Count\n If Worksheets(i).Name = \"Summary\" Then\n Worksheets(i).Delete\n End If\n Next i\n\n iSh = Worksheets.Count\n\n 'create a new summary sheet\n Sheets.Add After:=Sheets(iSh)\n Sheets(Sheets.Count).Name = \"Summary\"\n With Sheets(\"Summary\")\n Range(\"A1:D1\") = vHeaders\n End With\n lNewRow = 2\n\n ' this will not work if the sheet is protected,\n ' assume that sheet should not be changed; so ignore it\n On Error Resume Next\n\n For i = 1 To iSh\n sShName = Worksheets(i).Name\n Application.Goto Sheets(sShName).Cells(1, 1)\n Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)\n\n For Each c In rng\n addr = c.Address\n sFormula = c.Formula\n scVal = c.Text\n\n For j = 1 To Len(c.Formula)\n sChr = Mid(c.Formula, j, 1)\n\n If sChr = \"[\" Or sChr = \"!\" Or IsError(c) Then\n 'write values to summary sheet\n With Sheets(\"Summary\")\n .Cells(lNewRow, 1) = sShName\n .Cells(lNewRow, 2) = addr\n .Cells(lNewRow, 3) = scVal\n .Cells(lNewRow, 4) = \"'\" & sFormula\n End With\n lNewRow = lNewRow + 1\n Exit For\n End If\n Next j\n Next c\n Next i\n\n\n' housekeeping\n With Application\n .ScreenUpdating = True\n .DisplayAlerts = True\n .Calculation = xlCalculationAutomatic\n End With\n\n' tidy up\n Sheets(\"Summary\").Select\n Columns(\"A:D\").EntireColumn.AutoFit\n Range(\"A1:D1\").Font.Bold = True\n Range(\"A2\").Select\n \nEnd Sub\n\nPublic Sub print_array(my_array As Variant)\n Dim counter As Integer\n \n For counter = LBound(my_array) To UBound(my_array)\n Debug.Print counter & \" --> \" & my_array(counter)\n Next counter\n \nEnd Sub\n\nPublic Function get_last_day_of_month(my_date As Date) As Date\n get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0)\nEnd Function\n\nPublic Function add_months(my_date As Date, i_month As Integer) As Date\n \n add_months = get_last_day_of_month(DateAdd(\"m\", i_month, my_date))\n\nEnd Function\n\nPublic Sub ShowMeTheNames()\n Dim i As Integer\n \n For i = 1 To ActiveWorkbook.Names().Count\n \n Debug.Print vbCrLf & ActiveWorkbook.Names(i).Name\n Debug.Print ActiveWorkbook.Names(i).RefersTo\n Next i\n \nEnd Sub\n\nPublic Sub Normal()\n Application.ScreenUpdating = False\n Application.EnableEvents = False\n\n Application.ExecuteExcel4Macro \"SHOW.TOOLBAR(\"\"Ribbon\"\",True)\"\n Application.DisplayStatusBar = True\n Application.DisplayFormulaBar = True\n ActiveWindow.DisplayHeadings = True\n \n Application.ScreenUpdating = True\n Application.EnableEvents = True\nEnd Sub\n\nPublic Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long\n \n last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row\n \nEnd Function\n\nSub CopyValues(rngSource As Range, rngTarget As Range)\n \n rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value\n \nEnd Sub\n\n" }, { "path": "__Arch/mod_public.vb", "content": "Option Explicit\n\nPublic Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\n" }, { "path": "__Arch/mod_remove_styles.vb", "content": "Option Explicit\n\nSub RemoveTheStyles()\n\n Dim s As Style\n Dim i As Long\n Dim c As Long\n \n If ActiveWorkbook.MultiUserEditing Then\n If MsgBox(\"You cannot remove Styles in a Shared workbook.\" & vbCr & vbCr & _\n \"Do you want to unshare the workbook?\", vbYesNo + vbInformation) = vbYes Then\n ActiveWorkbook.ExclusiveAccess\n If Err.Description = \"Application-defined or object-defined error\" Then\n Exit Sub\n End If\n Else\n Exit Sub\n End If\n End If\n \n c = ActiveWorkbook.Styles.Count\n Application.ScreenUpdating = False\n\n For i = c To 1 Step -1\n \n If i Mod 600 = 0 Then DoEvents\n Set s = ActiveWorkbook.Styles(i)\n Application.StatusBar = \"Deleting \" & c - i + 1 & \" of \" & c & \" \" & s.Name\n \n If Not s.BuiltIn Then\n s.Delete\n End If\n Next\n \n Application.ScreenUpdating = True\n Application.StatusBar = False\n \nEnd Sub\n" }, { "path": "__Arch/mod_shortcuts.vb", "content": "\nSub ctrl_plus_u()\n\n' Tastenkombination: Strg + U\n\n If Selection.Font.Underline = xlUnderlineStyleSingle Then\n Selection.Font.Underline = xlUnderlineStyleNone\n Else\n Selection.Font.Underline = xlUnderlineStyleSingle\n End If\n\nEnd Sub\n\nSub ctrl_plus_b()\n\n' Tastenkombination: Strg + B\n \n Selection.Font.Bold = Not Selection.Font.Bold\n\nEnd Sub\n\nPublic Sub ctrl_plus_i()\n\n' Tastenkombination: Strg + I\n \n Selection.Font.Italic = Not Selection.Font.Italic\n\nEnd Sub\n\nSub ctrl_plus_d()\n\n' Tastenkombination: Strg + D\n \n Selection.FillDown\n\nEnd Sub\n" }, { "path": "__Arch/proposal_to_update.vb", "content": "'github.com/timhall/Excel-TDD\n'SpecExpectation\nPrivate Function IsEqual(Actual As Variant, Expected As Variant) As Variant\n \n Dim l_count As Long\n \n 'here vitosh\n If IsArray(Expected) Then\n For l_count = LBound(Expected) To UBound(Expected)\n If Not Expected(l_count) = Actual(l_count) Then\n Debug.Print l_count\n IsEqual = False\n Exit Function\n End If\n Next l_count\n End If\n 'end \n \n If IsError(Actual) Or IsError(Expected) Then\n IsEqual = False\n ElseIf IsObject(Actual) Or IsObject(Expected) Then\n IsEqual = \"Unsupported: Can't compare objects\"\n ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then\n ' It is inherently difficult/almost impossible to check equality of Double\n ' http://support.microsoft.com/kb/78113\n '\n ' Compare up to 15 significant figures\n ' -> Format as scientific notation with 15 significant figures and then compare strings\n IsEqual = IsCloseTo(Actual, Expected, 15)\n Else\n IsEqual = Actual = Expected\n End If\nEnd Function\n" }, { "path": "__Arch/protectsheet.vb", "content": "Option Explicit\nSub main()\n \n 'This protects the code only\n tbl_main.Protect UserInterfaceOnly:=True\n\nEnd Sub\n\n\nPublic Sub UnprotectAll()\n\n Dim i As Long\n \n For i = ActiveWorkbook.Worksheets.Count To 1 Step -1\n ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST\n Next\n\nEnd Sub\n\nPublic Sub UnhideAll()\n \n Dim Sheet As Worksheet\n \n For Each Sheet In ThisWorkbook.Sheets\n Sheet.Visible = xlSheetVisible\n Next Sheet\n \nEnd Sub\n" }, { "path": "__Arch/quick_unlock.vb", "content": "Public Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean\n\n Dim l_counter\n\n If b_is_string Then\n my_array = Split(my_array, \":\")\n End If\n\n For l_counter = LBound(my_array) To UBound(my_array)\n my_array(l_counter) = CStr(my_array(l_counter))\n Next l_counter\n\n b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0))\n \nEnd Function\n\n\nPublic Sub aaa()\n 'easy to write and easy to remember\n \n If Not b_value_in_array(Environ(\"Username\"), ADMINS, True) Then\n Debug.Print \"no\"\n Exit Sub\n End If\n \n Call UnhideAll 'UnprotectAll is included\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n ActiveWindow.DisplayHeadings = True\n Application.DisplayFormulaBar = True\n Debug.Print \"a\"\n \nEnd Sub\n" }, { "path": "__Arch/readme.md", "content": "### I just do not want to delete these, so they are here" }, { "path": "__Arch/recursive_loop.vb", "content": "Option Explicit\n\nSub EmbeddedLoops()\n \n Static size As Long\n Static c As Variant\n Static arr As Variant\n Static n As Long\n \n size = 4\n c = Array(1, 2, 3, 4, 5, 6)\n n = UBound(c) + 1\n ReDim arr(size - 1)\n \n Call embedded_loops(0, size, c, n, arr)\n \nEnd Sub\n\nFunction embedded_loops(index, k, c, n, arr)\n \n Dim i As Variant\n \n If index >= k Then\n Call print_array_one_line(arr)\n Else\n For Each i In c\n arr(index) = i\n Call embedded_loops(index + 1, k, c, n, arr)\n Next i\n End If\n\nEnd Function\n\nPublic Sub print_array_one_line(my_array As Variant)\n\n Dim counter As Integer\n Dim s_array As String\n \n For counter = LBound(my_array) To UBound(my_array)\n \n s_array = s_array & my_array(counter)\n \n Next counter\n Debug.Print s_array\n \n End Sub\n" }, { "path": "__Arch/refer_cell_in_named_range.vb", "content": "' how to refer cell in named range\n' refer cell in named range\n\n?[set_seconds_runtime].cells(3,1)\n" }, { "path": "__Arch/relevant_months.vb", "content": "Option Explicit\n\nPublic Function relevant_month(ByVal dt_date As Date) As String\n \n relevant_month = WorksheetFunction.Choose(Month(dt_date), \"jan\", \"feb\", \",mar\", \"apr\", \"may\", \"jun\", \"jul\", \"aug\", \"sep\", \"oct\", \"nov\", \"dec\")\n relevant_month = relevant_month & \"_\" & Right(Year(dt_date), 2)\n\nEnd Function\n\nPublic Function relevant_month_de(ByVal dt_date As Date) As String\n\n relevant_month_de = LCase(MonthName(Month(dt_date), True) & \"_\" & Right(Year(dt_date), 2))\n\nEnd Function\n\nPublic Sub CheckName()\n \n Debug.Print relevant_month_de(Now() + 40)\n Debug.Print relevant_month(Now() + 40)\n \nEnd Sub\n\nPublic Function bad_example()\n\nIf public_date <= #12/31/2005# Then\nrelevant_month = \"dec_05\"\n\nElseIf (public_date > #12/31/2005# And public_date <= #1/31/2006#) Then\nrelevant_month = \"jan_06\"\n'300 lines more with elseifs\nElse\nrelevant_month = \"jan_18\"\nEnd If\n\nsend_relevant_month = relevant_month\n\nEnd Function\n\n Does not compile,\n Does not take lump years,\n Does not run automatically\n" }, { "path": "__Arch/removeNamedRanges.vb", "content": "Public Sub RemoveNamedRanges()\n \n Dim nName As Name\n Dim strNameReserved As String\n \n On Error Resume Next\n \n strNameReserved = \"set_in_production\"\n \n For Each nName In Names\n If nName.Name <> strNameReserved And Left(nName.Name, 1) <> \"_\" Then\n Debug.Print nName.Name\n nName.Delete\n End If\n Next nName\n \n On Error GoTo 0\n \nEnd Sub\n" }, { "path": "__Arch/remove_msgbox.txt", "content": "\nFor Excel 2007 Version :\nYou can follow the following steps to avoide the privacy warning.\n1 Menu Button \"on the top left of the excel window\"\n2 Excel Option\n3 Trust Center\n4 Trust Center setting\n5 Privacy Options \n6 unmark the \"Remove personal information from file properties on save\"\n" }, { "path": "__Arch/remove_spaces.vb", "content": "Public Sub removeSpaceInString()\n\n Dim myCell As Range\n \n For Each myCell In Selection\n myCell = Trim(myCell)\n myCell = Replace(myCell, vbTab, \"\")\n myCell = Replace(myCell, \" \", \"\")\n myCell = Replace(myCell, Chr(160), \"\")\n Next myCell\n\nEnd Sub\n" }, { "path": "__Arch/revealer.vb", "content": "Sub revealer()\n 'kto ti e interestno\n Dim i As Integer, j As Integer, k As String\n Dim l As Integer, m As Integer, n As Integer\n Dim i1 As Integer, i2 As Integer, i3 As Integer\n Dim i4 As Integer, i5 As Integer, i6 As Integer\n On Error Resume Next\n For i = 65 To 66: For j = 65 To 66: For k = 65 To 66\n For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66\n For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66\n For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126\n ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _\n Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _\n Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)\n If ActiveSheet.ProtectContents = False Then\n MsgBox \"One usable is \" & Chr(i) & Chr(j) & _\n Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _\n Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)\n Exit Sub\n End If\n Next: Next: Next: Next: Next: Next\n Next: Next: Next: Next: Next: Next\nEnd Sub\n\n\n'First thing first\nOption Explicit\n\nPrivate Const PAGE_EXECUTE_READWRITE = &H40\n\nPrivate Declare Sub MoveMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" _\n (Destination As Long, Source As Long, ByVal Length As Long)\n\nPrivate Declare Function VirtualProtect Lib \"kernel32\" (lpAddress As Long, _\n ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long\n\nPrivate Declare Function GetModuleHandleA Lib \"kernel32\" (ByVal lpModuleName As String) As Long\n\nPrivate Declare Function GetProcAddress Lib \"kernel32\" (ByVal hModule As Long, _\n ByVal lpProcName As String) As Long\n\nPrivate Declare Function DialogBoxParam Lib \"user32\" Alias \"DialogBoxParamA\" (ByVal hInstance As Long, _\n ByVal pTemplateName As Long, ByVal hWndParent As Long, _\n ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer\n\nDim HookBytes(0 To 5) As Byte\nDim OriginBytes(0 To 5) As Byte\nDim pFunc As Long\nDim Flag As Boolean\n\nPrivate Function GetPtr(ByVal Value As Long) As Long\n GetPtr = Value\nEnd Function\n\nPublic Sub RecoverBytes()\n If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6\nEnd Sub\n\nPublic Function Hook() As Boolean\n Dim TmpBytes(0 To 5) As Byte\n Dim p As Long\n Dim OriginProtect As Long\n\n Hook = False\n\n pFunc = GetProcAddress(GetModuleHandleA(\"user32.dll\"), \"DialogBoxParamA\")\n\n\n If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then\n\n MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6\n If TmpBytes(0) <> &H68 Then\n\n MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6\n\n p = GetPtr(AddressOf MyDialogBoxParam)\n\n HookBytes(0) = &H68\n MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4\n HookBytes(5) = &HC3\n\n MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6\n Flag = True\n Hook = True\n End If\n End If\nEnd Function\n\nPrivate Function MyDialogBoxParam(ByVal hInstance As Long, _\n ByVal pTemplateName As Long, ByVal hWndParent As Long, _\n ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer\n If pTemplateName = 4070 Then\n MyDialogBoxParam = 1\n Else\n RecoverBytes\n MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _\n hWndParent, lpDialogFunc, dwInitParam)\n Hook\n End If\nEnd Function\n\n'second thing second\nSub unprotected()\n If Hook Then\n MsgBox \"Ale!\"\n End If\nEnd Sub\n" }, { "path": "__Arch/selection_range_trick.vb", "content": "Public Sub SelectAndChange()\n \n Dim current_cells_range As Range\n Dim my_array As Variant\n \n Dim l_step_between_BA As Long\n Dim l_counter As Long\n Dim l_counter_2 As Long\n Dim l_counter_3 As Long\n Dim col As Long\n Dim row As Long\n \n l_step_between_BA = 17\n col = Selection.Column\n row = Selection.row\n 'Beware what you select, for it would stay selected! :)\n \n Set current_cells_range = Selection\n \n For l_counter = 0 To 9\n Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + l_step_between_BA * l_counter, col))\n \n' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 1 + l_step_between_BA * l_counter, col))\n'\n' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 2 + l_step_between_BA * l_counter, col))\n'\n' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 3 + l_step_between_BA * l_counter, col))\n'\n' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 4 + l_step_between_BA * l_counter, col))\n \n Next l_counter\n \n current_cells_range.Select\n \nEnd Sub\n" }, { "path": "__Arch/string_generator.vb", "content": "'random generator string\n'string generator\n'string degenerator\n'string code decode coder decoder codify decodify\n\n\nPublic Function str_generator(str_value As String, b_fix As Boolean) As String\n \n Dim l_counter As Long\n Dim l_number As Long\n Dim str_char As String\n \n 'On Error GoTo str_generator_Error\n \n If b_fix Then\n str_value = Left(str_value, Len(str_value) - 1)\n str_value = Right(str_value, Len(str_value) - 1)\n End If\n\n For l_counter = 1 To Len(str_value)\n str_char = Mid(str_value, l_counter, 1)\n If b_is_odd(l_counter) Then\n l_number = Asc(str_char) + IIf(b_fix, -2, 2)\n Else\n l_number = Asc(str_char) + IIf(b_fix, -6, 6)\n End If\n \n str_generator = str_generator + Chr(l_number)\n \n Next l_counter\n \n If Not b_fix Then\n str_generator = Chr(l_number) & str_generator & Chr(l_number)\n End If\n \n On Error GoTo 0\n Exit Function\n\nstr_generator_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure str_generator of Function Modul1\"\n\nEnd Function\n\nPublic Function b_is_odd(l_number As Long) As Boolean\n \n b_is_odd = l_number Mod 2\n\nEnd Function\n" }, { "path": "__Arch/subsequence.vb", "content": "Option Explicit\n\nPublic Const NO_PREVIOUS = -1\n\nSub Main()\n\n Dim arr_seq As Variant\n Dim arr_len As Variant\n Dim arr_pre As Variant\n \n Dim lng_best As Long\n \n arr_seq = Array(1, 2, -6, -5, -3, 23, 123, 3, 2, -23, -5, 54, 100, 200, 300, 1111, 23412, 3, 4, 5, 6, 7, 8, 9, 19, 65, 2)\n ReDim arr_len(UBound(arr_seq))\n ReDim arr_pre(UBound(arr_seq))\n \n lng_best = CalculateLongestIncreasingSubsequence(arr_seq, _\n arr_len, _\n arr_pre)\n Call print_array(arr_seq)\n Call print_array(arr_len)\n Call print_array(arr_pre)\n \n Call PrintLongestIncreasingSubsequance(arr_seq, arr_pre, lng_best)\n \nEnd Sub\n\nPublic Sub PrintLongestIncreasingSubsequance(ByRef arr_seq As Variant, _\n ByRef arr_pre As Variant, _\n lng_best As Long)\n \n Dim arr_result As Variant\n Dim l_counter As Long: l_counter = 0\n \n ReDim arr_result(1)\n \n While (lng_best <> NO_PREVIOUS)\n \n \n ReDim Preserve arr_result(l_counter)\n l_counter = l_counter + 1\n arr_result(l_counter - 1) = arr_seq(lng_best)\n lng_best = arr_pre(lng_best)\n \n Wend\n \n Debug.Print Join(reverse_array(arr_result), \" \")\n \nEnd Sub\n\n\nPublic Function CalculateLongestIncreasingSubsequence(ByRef arr_seq As Variant, _\n ByRef arr_len As Variant, _\n ByRef arr_pre As Variant) As Long\n\n Dim lng_best_len As Long: lng_best_len = 0\n Dim lng_best_ind As Long: lng_best_ind = 0\n Dim x As Long\n Dim i As Long\n \n For x = LBound(arr_seq) To (UBound(arr_seq)) Step 1\n arr_len(x) = 1\n arr_pre(x) = NO_PREVIOUS\n \n For i = 0 To x Step 1\n If (arr_seq(i) < arr_seq(x)) And (arr_len(i) + 1 > arr_len(x)) Then\n \n arr_len(x) = arr_len(i) + 1\n arr_pre(x) = i\n \n If arr_len(x) > lng_best_len Then\n lng_best_len = arr_len(x)\n lng_best_ind = x\n End If\n End If\n \n Next i\n Next x\n \n CalculateLongestIncreasingSubsequence = lng_best_ind\n \nEnd Function\n\nPublic Sub print_array(ByRef my_array As Variant)\n Dim counter As Long\n \n For counter = LBound(my_array) To UBound(my_array)\n Debug.Print counter & \" --> \" & my_array(counter)\n Next counter\n Debug.Print \"------------------------------\"\nEnd Sub\n\nPublic Function reverse_array(ByVal my_array As Variant) As Variant\n\n Dim counter As Long\n Dim counter_2 As Long\n Dim arr_new As Variant\n \n ReDim arr_new(UBound(my_array) + 1)\n \n For counter = LBound(arr_new) To UBound(arr_new) - 1\n counter_2 = UBound(arr_new) - counter - 1\n arr_new(counter) = my_array(counter_2)\n Next counter\n\n reverse_array = arr_new\n\nEnd Function\n" }, { "path": "__Arch/sum_array_with_optional.vb", "content": "Public Function sum_array(my_array As Variant, Optional last_values_not_to_calculate As Long = 0) As Double\n 'For unknown reasons, WorksheetFunction.sum(my_array) does not work always,\n 'when we sum currency, long and double...\n \n Dim l_counter As Long\n \n For l_counter = LBound(my_array) To UBound(my_array) - last_values_not_to_calculate\n sum_array = sum_array + my_array(l_counter)\n Next l_counter\n \nEnd Function\n" }, { "path": "__Arch/sum_column.vb", "content": "Application.WorksheetFunction.sum(tbl_results.Columns(15))\nApplication.WorksheetFunction.sum(tbl_results.rows(15))\n" }, { "path": "__Arch/todo_in_a_new_project.vb", "content": "ToDo in a VBA project (Tasks for a boilerplate) :\n\n> \tMake OnStart and OnEnd modules\n>\tMake if [set_in_production] then on error goto Main_error\n>\tPlay with the status bar\n>\tShow a vbmodeless form while the macro is running\n> \tFind a quick macro to lock and unlock the project\n>\tOn start of the file:\n\t\t> \tLock it\n\t\t>\tHide Not needed sheets\n\t\t>\tLock scroll\n\t\t>\tApplication.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\n>\tOn the end of the file:\n\t\t>\tSave and release all possible forbidden things (check Workbook_BeforeClose)\n>\tDisable Workbook_NewSheet\n>\tMake a quick unlock and view all option just for you\n>\tDisable copy and paste and F11\n" }, { "path": "__Arch/typenameAndvartype.vb", "content": "var_a = \"test_me\"\n?typename(var_a)\nString\n?vartype(var_a)\n 8 \n" }, { "path": "__Arch/user_form_centre.vb", "content": "Private Sub UserForm_Activate()\n With Me\n .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2)\n .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2)\n End With\nEnd sub\n" }, { "path": "__Arch/vba_dictionary_example.vb", "content": "Option Explicit\n\nSub Dictionaries()\n\n Dim l_counter1 As Long\n Dim l_counter2 As Long\n\n Dim dicts(7) As Variant\n Dim predecessors As Variant\n \n Dim node As New Dictionary\n \n Set predecessors = New Dictionary\n \n Set dicts(0) = New Dictionary\n dicts(0).Add 5, Array(11)\n Set dicts(1) = New Dictionary\n dicts(1).Add 7, Array(11, 8)\n \n Set dicts(2) = New Dictionary\n dicts(2).Add 8, Array(9)\n \n Set dicts(3) = New Dictionary\n dicts(3).Add 11, Array(9, 10, 2)\n \n Set dicts(4) = New Dictionary\n dicts(4).Add 9, Array()\n \n Set dicts(5) = New Dictionary\n dicts(5).Add 3, Array(8, 10)\n\n Set dicts(6) = New Dictionary\n dicts(6).Add 2, Array()\n \n Set dicts(7) = New Dictionary\n dicts(7).Add 10, Array()\n \n For l_counter1 = 0 To UBound(dicts)\n \n Set node = dicts(l_counter1)\n If Not b_key_in_dict(predecessors, node.Keys(0)) Then\n Debug.Print node.Keys(0)\n predecessors.Add node.Keys(0), 0\n End If\n \n 'Check if node has no children\n If UBound(node(node.Keys(0))) > 0 Then\n For l_counter2 = 0 To UBound(node.Items)\n If Not (b_key_in_dict(predecessors, node.Items(l_counter2)(0))) Then\n predecessors.Add node.Items(l_counter2)(0), 0\n Else\n predecessors.Item(node.Items(l_counter2)(0)) = (node.Items(l_counter2)(0)) + 1\n End If\n Next l_counter2\n End If\n Next l_counter1\n \n' Set k = dicts(5)\n' Debug.Print k.Item(3)(0) 'First Item in the array in k with key 3\n' Debug.Print k.Item(3)(1) 'Second Item in the array in k with key 3\n' Debug.Print UBound(k.Item(3)) 'Size of items in the array in k with key 3 (-1)\n' Debug.Print k.Keys(0) 'First key of k\n' Debug.Print UBound(k.Keys) 'Size of keys in k (-1)\n \nEnd Sub\n\nPublic Function b_key_in_dict(ByVal dict As Dictionary, ByVal key As String) As Boolean\n'called like -> b_key_in_dict(dicts(0),5)\n' OR just use EXIST\n\n Dim l_counter As Long\n \n b_key_in_dict = False\n For l_counter = 0 To UBound(dict.Keys)\n If dict.Keys(l_counter) = key Then b_key_in_dict = True\n Next l_counter\n\nEnd Function\n\n" }, { "path": "__Arch/xl_docName.vb", "content": "Private Sub Workbook_BeforeClose(Cancel As Boolean)\n\n On Error GoTo Workbook_BeforeClose_Error\n\n Cancel = False\n \n ThisWorkbook.Save\n Application.DisplayAlerts = False\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n Application.DisplayAlerts = True\n ActiveWindow.DisplayHeadings = True\n Application.DisplayFormulaBar = True\n ActiveSheet.PageSetup.BlackAndWhite = False\n Me.Save\n Application.OnKey \"%{F11}\"\n\n\n On Error GoTo 0\n Exit Sub\n\nWorkbook_BeforeClose_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_BeforeClose of Sub xl_paku\"\n \nEnd Sub\n\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\n\n paku_message_title = tbl_settings.Range(\"AJ8\")\n \n If Not tbl_settings.Visible Then\n With Application\n Application.ScreenUpdating = False\n Application.DisplayAlerts = False\n Sh.Delete\n Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n End With\n \n MsgBox (Environ(\"UserName\") & \", Sie können Blätter nicht hinzufügen.\"), vbInformation, paku_message_title\n End If\n \nEnd Sub\n\nPrivate Sub Workbook_Open()\n\n\n On Error GoTo Workbook_Open_Error\n\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\n Application.DisplayFormulaBar = False\n [set_root_user] = False\n If Not b_value_in_array(Environ(\"username\"), ADMINS, True) Then Application.OnKey \"%{F11}\", \"\"\n Application.WindowState = xlMaximized\n\n\n On Error GoTo 0\n Exit Sub\n\nWorkbook_Open_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_Open of Sub xl_paku\"\n Me.Save\n ThisWorkbook.Close\n \nEnd Sub\n" }, { "path": "__Arch/xl_main.vb", "content": "Option Explicit\n\nPrivate Sub Workbook_BeforeClose(Cancel As Boolean)\n\n On Error GoTo Workbook_BeforeClose_Error\n\n Cancel = False\n \n ThisWorkbook.Save\n Application.DisplayAlerts = False\n Call HideNeeded\n Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", true)\"\n Application.DisplayAlerts = True\n ActiveWindow.DisplayHeadings = True\n Application.DisplayFormulaBar = True\n \n Me.Save\n Application.AskToUpdateLinks = True\n \n Call EnableMySaves\n \n On Error GoTo 0\n Exit Sub\n\nWorkbook_BeforeClose_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_BeforeClose of Sub xl_paku\"\n \nEnd Sub\n\nPrivate Sub Workbook_NewSheet(ByVal Sh As Object)\n \n If Not tbl_settings.Visible Then\n With Application\n Application.ScreenUpdating = False\n Application.DisplayAlerts = False\n Sh.Delete\n Application.DisplayAlerts = True\n Application.ScreenUpdating = True\n End With\n\n MsgBox (Environ(\"UserName\") & \", Sie können Blätter nicht hinzufügen.\"), vbInformation, ThisWorkbook.Name\n End If\n\nEnd Sub\n\nPrivate Sub Workbook_Open()\n \n On Error GoTo Workbook_Open_Error\n \n Call LockMe\n Call HideNeeded\n Call LockScroll(Array(tbl_main.Name, \"A1:X107\"))\n Call MinimizeRibbon\n \n ActiveWindow.WindowState = xlMaximized\n Application.WindowState = xlMaximized\n \n 'Application.ExecuteExcel4Macro \"show.toolbar(\"\"Ribbon\"\", false)\"\n 'ActiveWindow.DisplayHeadings = False\n Application.OnKey \"^{W}\", \"DisabledCombination\"\n Application.OnKey \"^{w}\", \"DisabledCombination\"\n Application.OnKey \"^{E}\", \"InitializeFormTotals\"\n Application.OnKey \"^{e}\", \"InitializeFormTotals\"\n\n Call CheckHowManyWbAreOpened\n \n tbl_main.Select\n 'tbl_main.tb_Show = False\n tbl_main.chb_delete = False\n \n tbl_main.Cells(1, 1).Select\n ActiveWindow.Zoom = 74\n \n On Error GoTo 0\n Exit Sub\n\nWorkbook_Open_Error:\n\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure Workbook_Open of Sub DieseArbeitsmappe\", vbInformation, [set_planerkostenberechnung]\n\nEnd Sub\n\nPublic Sub CheckHowManyWbAreOpened()\n On Error GoTo CheckHowManyWbAreOpened_Error\n\n If Workbooks.Count > 1 Then\n [set_more_instances] = True\n frmInfo.Show (vbModeless)\n frmInfo.lb_information = \"Sie haben mehr als eine Instanz von Excel. Dies ist keine sehr gute Idee.\"\n frmInfo.Repaint\n Application.Wait (Now + TimeValue(\"00:00:05\"))\n Unload frmInfo\n End If\n [set_more_instances] = False\n\n On Error GoTo 0\n Exit Sub\n\nCheckHowManyWbAreOpened_Error:\n MsgBox \"Error \" & Err.Number & \" (\" & Err.Description & \") in procedure CheckHowManyWbAreOpened of Sub DieseArbeitsmappe\"\n\nEnd Sub\n" } ]