Add files via upload

1_InvokeUF.txt

@@ -0,0 +1,22 @@
+' ==================================================================================================
+' Purpose of this code is to invoke the User Form when user double click the line on the spreadsheet
+' ==================================================================================================
+
+Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
+
+' Define variables needed
+Dim iRow As Integer
+' Initialize variables
+iRow = Target.Row
+
+' Update Inputs in the form
+UpdateInputs iRow
+
+' Cancel = false means form can not be modified together with cell
+Cancel = True
+
+'possible to modify cell when the form is up
+MyCarCheckListForm.Show False
+
+End Sub
+

Functions.bas

@@ -0,0 +1,114 @@
+Attribute VB_Name = "Functions"
+        ' (C) 2017 VZ Home Experiments Vladimir Zhbanko //vz.home.experiments@gmail.com
+        ' VBA code to make work with Excel User Forms easier
+        ' More time to spend on more interesting stuff.
+
+'========================================
+' FUNCTION that keep First available Capital letter in the string
+'========================================
+Function getFirstCapitalLetter(myInput As String) As String
+    ' Declaring variables
+    Dim myResult As String    ' This is the return string
+    Dim i As Long             ' Counter for character position
+
+    ' Initialise return string to empty
+    myResult = ""
+
+    ' For every character in input string, copy digits to
+    '   return string if they are passing criteria
+    For i = 1 To Len(myInput)
+        If Mid(myInput, i, 1) >= "A" And Mid(myInput, i, 1) <= "Z" Then
+            myResult = myResult + Mid(myInput, i, 1)
+            Exit For
+        End If
+    Next
+
+    ' Then return the return string.                          '
+    getFirstCapitalLetter = myResult
+End Function
+
+'========================================
+' FUNCTION that keep All available Capital letters in the string
+'========================================
+Function getAllCapitalLetters(myInput As String) As String
+    ' Declaring variables
+    Dim myResult As String    ' This is the return string
+    Dim i As Long             ' Counter for character position
+
+    ' Initialise return string to empty
+    myResult = ""
+
+    ' For every character in input string, copy digits to
+    '   return string if they are passing criteria
+    For i = 1 To Len(myInput)
+        If Mid(myInput, i, 1) >= "A" And Mid(myInput, i, 1) <= "Z" Then
+            myResult = myResult + Mid(myInput, i, 1)
+        End If
+    Next
+
+    ' Then return the return string.                          '
+    getAllCapitalLetters = myResult
+End Function
+'========================================
+' FUNCTION that removes all text from string, and leave only numbers
+'========================================
+Function getOnlyDigit(myInput As String) As String
+    ' Declaring variables
+    Dim myResult As String  ' This is the return string
+    Dim i As Long           ' Counter for character position
+
+    ' Initialise return string to empty
+    myResult = ""
+
+    ' For every character in input string, copy digit to
+    '   return string if they are passing criteria
+    For i = 1 To Len(myInput)
+        If Mid(myInput, i, 1) >= "0" And Mid(myInput, i, 1) <= "9" Then
+            myResult = myResult + Mid(myInput, i, 1)
+            Exit For
+        End If
+    Next
+
+    ' Then return the return string.                          '
+    getOnlyDigit = myResult
+End Function
+'========================================
+' FUNCTION that tells if string contains digits
+'========================================
+' function is adapted using function getOnlyDigits
+Function isDigit(myInput As String) As Boolean
+    ' Variables needed (remember to use "option explicit")
+    Dim myResult As Boolean ' This is the return boolean
+    Dim i As Integer        ' Counter for character position
+
+    ' Initialise return result to be false
+    myResult = False
+
+    ' For every character in input string, check if there are
+    ' numbers. Stop if found at least one number
+    For i = 1 To Len(myInput)
+        If Mid(myInput, i, 1) >= "0" And Mid(myInput, i, 1) <= "9" Then
+            myResult = True
+            Exit For
+        Else
+            myResult = False
+        End If
+    Next
+
+    ' Then return the results
+    isDigit = myResult
+End Function
+'========================================
+' FUNCTION that count cell color in a range
+'========================================
+' This is a user defined function! UDF!
+Function CountCellColor(range_data As Range, criteria As Range) As Long
+    Dim datax As Range
+    Dim xcolor As Long
+xcolor = criteria.Interior.ColorIndex
+For Each datax In range_data
+    If datax.Interior.ColorIndex = xcolor Then
+        CountCcolor = CountCcolor + 1
+    End If
+Next datax
+End Function

MyCarCheckListForm.frm

@@ -0,0 +1,213 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MyCarCheckListForm 
+   Caption         =   "User Form for Car Evaluation"
+   ClientHeight    =   8520
+   ClientLeft      =   45
+   ClientTop       =   375
+   ClientWidth     =   10515
+   OleObjectBlob   =   "MyCarCheckListForm.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "MyCarCheckListForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+        ' (C) 2017 VZ Home Experiments Vladimir Zhbanko //vz.home.experiments@gmail.com
+        ' VBA code to make work with Excel User Forms easier
+        ' More time to spend on more interesting stuff.
+' =======================================================================================================
+' declaring global variables for cross using in the other functions
+' =======================================================================================================
+Public Fail As String           ' 2 types Yes/No
+Public picPath As String        ' string is containing the path to the picture file
+Public lRow As Long             ' variable to pass row information
+' =======================================================================================================
+' this button closes the form
+' =======================================================================================================
+Private Sub buttonCancel_Click()
+Unload Me
+End Sub
+' =======================================================================================================
+' information about the program shown by clicking on the button "I am inspired"
+' =======================================================================================================
+Private Sub buttonHelp_Click()
+MsgBox "User Form for Car Evaluation" & vbCrLf & "(C) 2017 VZ Home Experiments vz.home.experiments@gmail.com", vbOKOnly + vbInformation, "I am inspired!"
+End Sub
+' =======================================================================================================
+' add Spin Buttons control
+' =======================================================================================================
+Private Sub SpinButton1_SpinUp()
+If Me.tboxRow.Value <= 2 Then
+    Exit Sub
+End If
+Worksheets(Me.tboxSheet.Text).Activate
+UpdateInputs Me.tboxRow.Value - 1
+End Sub
+Private Sub SpinButton1_SpinDown()
+Worksheets(Me.tboxSheet.Text).Activate
+UpdateInputs Me.tboxRow.Value + 1
+End Sub
+
+' =======================================================================================================
+' first form initialization bringing default values
+' =======================================================================================================
+Private Sub UserForm_Initialize()
+' Not used; code below will be executed on form initialization
+
+End Sub
+' =======================================================================================================
+' User Dialogue "Import Picture"
+' =======================================================================================================
+' this portion should point to the picture to enter to the userform
+' user select picture browsing to the file and picture is grabbed inside the form
+' path to the picture will be stored into Public variable so
+' user will continue to write issue description and upon submitting picture is placed to the cell...
+' Button "Insert Picture"
+Private Sub buttonPicture_Click()
+
+' File dialog to load picture into the form
+With Application.FileDialog(msoFileDialogFilePicker)
+    .AllowMultiSelect = False
+    .ButtonName = "Submit"
+    .Title = "Select an image file"
+    .Filters.Add "Image", "*.gif; *.jpg; *.jpeg", 1
+
+    If .Show = -1 Then
+        'file has been selected
+        picPath = .SelectedItems(1) ' this will save path to the picture!
+
+        'display preview image in image control
+        Me.imageReport.PictureSizeMode = fmPictureSizeModeZoom
+        Me.imageReport.Picture = LoadPicture(picPath)
+
+    Else
+        ' executed when nothing was selected
+
+    End If
+End With
+
+' picture is now in the image box
+' path of the picture picPath is saved into Global variable
+
+End Sub
+' =======================================================================================================
+' Copy to the Report page
+' =======================================================================================================
+' This code will copy form data from UserForm to the Report page
+' Also required to paste comment and score to the reference page if it was changed
+' Report page should increase it's size by one row automatically
+Private Sub buttonSubmit_Click()
+
+Dim i As Integer: Dim lRow As Long: Dim lCol As Long: Dim nextRowValue As String
+Dim wshDest As Worksheet: Set wshDest = Worksheets("Report")
+Dim wshSource As Worksheet: Set wshSource = Worksheets(Me.tboxSheet.Text)
+
+    ' =======================================
+    ' code below will check position of radio buttons
+    ' =======================================
+    If (Me.optionYes.Value = True) Then
+    Fail = "Yes"
+    End If
+
+    If (Me.optionNo.Value = True) Then
+    Fail = "No"
+    End If
+
+    ' Adding protection against incomplete entry - Case Study 1
+    If (Me.optionYes.Value = False) And (Me.optionNo.Value = False) Then
+        Me.optionNo.SetFocus
+        MsgBox "Check must either pass or fail, please choose at least one option"
+        Exit Sub
+    End If
+
+    ' =======================================
+    ' This portion refreshes the comment and the score on the source sheet
+    ' =======================================
+    ' refreshing data on the source sheet
+    ' define the source sheet
+    ' write the comment and score to the source sheet (it might be changed)
+    wshSource.Cells(Me.tboxRow.Value, 6) = Fail               'score
+    wshSource.Cells(Me.tboxRow.Value, 7) = Me.tboxComments.Value   'comment
+
+    ' =======================================
+    ' below portion will handle updating the Action page from the UserForm
+    ' =======================================
+    ' only if cboxNeedAction is true
+    If Me.cboxNeedAction.Value = False Then
+        ' exit sub if action is not needed
+        MsgBox "Comment and Score are updated, No Action is created", vbOKOnly + vbInformation, "Source sheet is refreshed"
+        Exit Sub
+
+    Else
+        ' =======================================
+        ' find the next empty row in the destination sheet
+        ' =======================================
+        wshDest.Activate
+        ' method below will fill  the next available empty row
+        ' lRow will contain the last written row (ready to write)
+        For i = 1 To 2000         ' There can not be more than a 2000 rows really!?
+            currentRowValue = Cells(i, 3).Value
+            nextRowValue = Cells(i + 1, 1).Value ' saving content of the next rows to add rows dynamically
+
+           ' find where is the last available row in the table
+            If IsEmpty(currentRowValue) Or currentRowValue = "" Then
+                lRow = i
+                If isDigit(Cells(i - 1, 1).Value) = False Then ' if the cell is not number it is a header
+                    wshDest.Cells(i, 1).Value = 1 ' place the starting number
+                Else
+                    wshDest.Cells(i, 1).Value = wshDest.Cells(i - 1, 1).Value + 1 ' place the consecutive number
+                    wshDest.Cells(i + 1, 1).Value = wshDest.Cells(i, 1).Value + 1 ' place the consecutive number
+                End If
+                    Exit For
+            End If
+
+        Next
+        ' =======================================
+        ' check for a completness of the form when gaps are identified
+        ' =======================================
+        ' logic behind: If Fail is 'Yes' then Comments and Actions are required!
+        If (Me.optionYes.Value = True) And (Trim(Me.tboxComments.Value) = "") Then
+            Me.tboxComments.SetFocus
+            MsgBox "Please complete the Action and Comment fields of the form as gaps are identified"
+                Exit Sub
+
+        End If
+
+        ' =======================================
+        ' populate the Result sheet
+        ' =======================================
+            wshDest.Cells(lRow, 3).Value = Me.tboxCategory.Value        'Category
+            wshDest.Cells(lRow, 4).Interior.ColorIndex = Me.tboxKey.Value        'Key color
+            wshDest.Cells(lRow, 5).Value = Me.tboxComments.Value     'Comments
+            wshDest.Cells(lRow, 6).Value = Me.tboxAction.Value           'Action
+            wshDest.Cells(lRow, 7).Value = Me.tboxCost.Value          'Cost
+            wshDest.Cells(lRow, 8).Value = picPath       'Path of the picture
+
+         ' Clear the data to be able to fill more again - Case Study 1
+            Me.tboxComments.Value = ""
+            Me.tboxAction.Value = ""
+            Me.tboxCost.Value = ""
+            Me.cboxNeedAction.Value = False
+            Me.optionNo = False
+            Me.optionYes = False
+
+         ' Adding Budget field - Case Study 1
+         Call UpdateBudget
+
+    End If
+
+' =======================================
+' Code will paste picture to the Result sheet
+' =======================================
+' exit if there was no picture added
+  If picPath = "" Then
+      Exit Sub
+  Else
+  ' add picture using function PastePicture (see module Functions)
+    PastePicture picPath, lRow
+  End If
+
+End Sub
+
+' =======================================================================================================