// Text file with excel vba code
// - lines start with | get ignored
// - lines start with 'Title: will shown as a title above the code box
// - lines start with 'Description: will shown as a description above the code box
// - after titles and desciption starts a new codebox
// - lines start with show a 'Image: filename.jpg show the image the codebox will be interrupted

'Title: Convert a column number / letter 
'Description: Convert a column number into a column letter or opposite


Function FuncColNumberToColLetter$(ByVal intColNumber%)
' Function: Change a column number into a column character (works up to ZZ)
' Input:    column number
' Output:   column letter as string
    Dim intFirst%, strCol$, intColNr%
        intColNr% = intColNumber%
        intFirst% = Int((intColNr% - 1) / 26)
        strCol$ = ""
        If intFirst% > 0 Then
            intColNr% = intColNr% - intFirst% * 26
            strCol$ = Chr(64 + intFirst%)
        End If
        FuncColNumberToColLetter$ = strCol$ & Chr(64 + intColNr%)
End Function

Function FuncColNumberToColLetter$(ByVal intColNumber%)
' Function: Change a column number into a column character (works up to ZZ)
' Input:    column letter as string
' Output:   column number as integer
    Dim intFirst%, strCol$, intColNr%
        intColNr% = intColNumber%
        intFirst% = Int((intColNr% - 1) / 26)
        strCol$ = ""
        If intFirst% > 0 Then
            intColNr% = intColNr% - intFirst% * 26
            strCol$ = Chr(64 + intFirst%)
        End If
        FuncColNumberToColLetter$ = strCol$ & Chr(64 + intColNr%)
End Function

'Title: Check sheet exist
'Description: check is the sheet in the workbook 

Function CheckIsSheet(strSheetName$, Optional strWorkbook$) As Boolean
' Function: Check Sheet exists
' Input:    strSheetName$= sheetname for the check
'           strWorkbook$ (Optional)= workbookname in case the sheet is not to search in the active workbook
' Output:   column letter as string
    Dim Wks As Worksheet
    CheckIsSheet = False
    If strWorkbook$ = "" Then strWorkbook$ = ActiveWorkbook.Name
    For Each Wks In Workbooks(strWorkbook$).Worksheets
        If strSheetName$ = Wks.Name Then
            CheckIsSheet = True
            Exit Function
        End If
    Next Wks
End Function

'Title: Check file exist
'Description: check is a file existing 

Function CheckIsFile(ByVal strfile$, Optional bytPTyp As Byte) As Boolean
' Function: Check file exists local or in sharepoint - standard is local
' Input:    strfile$= filename including path for the check
'           bytPTyp (Optional): 1 = local address / 2=sharepoint address (need function CheckIsURL)
' Output:   Returns TRUE if the provided name points to an existing file - Returns FALSE if not existing, or it's a folder

    If bytPTyp = 2 Then
        If Left(strfile$, 4) = "http" Then
            CheckIsFile = CheckIsURL(strfile$)
        Else
            On Error Resume Next
            CheckIsFile = ((GetAttr(strfile$) And vbDirectory) <> vbDirectory)
        End If
    Else
        On Error Resume Next
        CheckIsFile = ((GetAttr(strfile$) And vbDirectory) <> vbDirectory)
    End If
End Function

'Title: Check path exist
'Description: check is the path existing 

Function CheckIsPath(ByVal strpath$, Optional bytPTyp As Byte) As Boolean
' Function: Check path exists local or in sharepoint - standard is local
'           Standard folder get set too on simple way - for 100% you should use the registry value
' Input:    strpath$= pathname or standard folder aliases for the check
'           bytPTyp (Optional): 1 = local address / 2=sharepoint address (need function CheckIsURL)
' Output:   Returns TRUE if the provided name points to an existing file - Returns FALSE if not existing, or it's a folder

    If strpath$ = "Downloads" Then strpath$ = FuncGetSystemPath(1)
    If strpath$ = "Documents" Then strpath$ = FuncGetSystemPath(2)
    If strpath$ = "Desktop" Then strpath$ = FuncGetSystemPath(3)

     If bytPathTyp = 2 And bytPTyp = 0 Then
        bytPTyp = 2
    End If
    If bytPTyp = 2 Then
        If Left(strpath$, 4) = "http" Then
            CheckIsPath = CheckIsURL(strpath$)
        Else
            If Dir(strpath$, vbDirectory) = vbNullString Then
                CheckIsPath = False
            Else
                CheckIsPath = True
            End If
        End If
    Else
        If Dir(strpath$, vbDirectory) = vbNullString Then
            CheckIsPath = False
        Else
            CheckIsPath = True
        End If
    End If
End Function

'Title: Check an url
'Description: check is it an url and is it valid. Websites might need an authentication will not respond on this. Reference to Microsoft XML V6 required.

Function CheckIsURL(url$) As Boolean ' Reference to Microsoft XML V6 required
' Function: check an URL (Sharepoint Path or File) exists
' Ref.:     Require the VBA Reference 'Microsoft XML V6'
' Input:    url$= url to check
' Output:   Returns TRUE if it exist or FALSE if it not exist (or in case no access)
    Dim Request  As New MSXML2.XMLHTTP60
    On Error Resume Next
    With Request
        .Open "GET", url, False
        .send
        CheckIsURL = IIf(.Status = 200, True, False)
    End With
End Function

'Title: Format a Path
'Description: Format a Path of sharepoint or local address with then ending / or \ or replace standard path aliases

Function OpFormatPath(strpath$, Optional bytPTyp As Byte) As String
' Function: format a path correctly to use it with files and also replace standard path aliases (sort way - for 100% use a register solution)
' Input:    strpath$= path to analyse and correct
'           bytPTyp (Optional): 0 or empty = change to networkpath / 2 = use http path
' Output:   corrected path for use as string
   
    If strpath$ = "Downloads" Then strpath$ = FuncGetSystemPath(1)
    If strpath$ = "Documents" Then strpath$ = FuncGetSystemPath(2)
    If strpath$ = "Desktop" Then strpath$ = FuncGetSystemPath(3)

    If bytPathTyp = 2 And bytPTyp = 0 Then
        bytPTyp = 2
    End If
    If bytPTyp = 2 Then
        If Left(strpath$, 4) = "http" Then
            strpath$ = Replace(strpath$, "/:f:/", "/")
            strpath$ = Replace(strpath$, "/r/", "/")
            strpath$ = Replace(strpath$, "%20", " ")
            If InStr(1, strpath$, "?") > 0 Then strpath$ = Left(strpath$, InStr(1, strpath$, "?") - 1)
            If Right(strpath$, 1) <> "/" Then strpath$ = strpath$ & "/"
            'strPath$ = Replace(strPath$, " ", "%20")
            'strPath$ = Replace(strPath$, "%20", " ")
        Else
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        End If
    Else
        If Left(strpath$, 5) = "https" Then
            strpath$ = Replace(Replace(strpath$, "https:", ""), "/", "\")
            strpath$ = Replace(strpath$, Split(strpath$, "\")(2), Split(strpath$, "\")(2) & "@SSL")
            strpath$ = Replace(strpath$, "%20", " ")
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        ElseIf Left(strpath$, 5) = "http:" Then
            strpath$ = Replace(Replace(strpath$, "https:", ""), "/", "\")
            If Right(strpath$, 1) <> "/" Then strpath$ = strpath$ & "/"
        Else
            If Right(strpath$, 1) <> "\" Then strpath$ = strpath$ & "\"
        End If
    End If
    OpFormatPath = strpath$
End Function

'Title: Go to a sheet in the active workbook
'Description: Go to a sheet in the active workbook. If the sheet is hidden it unhide it. If the parameter is empty and the caller is a button it takes the button name as sheetname

Sub OpGotoSheet(Optional strOpGotoSheet$)
' Function: Goto to the sheet from the parameter or based on the Text on the button
' Input:    strOpGotoSheet$ (Optional)= sheet name to go to
' Output:   N/A
    If strOpGotoSheet$ = "" Then ' Button as caller
        strOpGotoSheet$ = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
    End If
    strOpGotoSheet$ = Replace(strOpGotoSheet$, "Goto ", "")
    If CheckIsSheet(strOpGotoSheet$) = True Then
        If Worksheets(strOpGotoSheet$).Visible = 0 Then Worksheets(strOpGotoSheet$).Visible = -1
        Worksheets(strOpGotoSheet$).Select
    Else
        MsgBox strOpGotoSheet$ & " do not found!"
    End If
End Sub

'Title: Add or remove Delimiter
'Description: Add or remove Delimiter at the beginn or end.

Function OpAddRemoveDelimiter$(strVal$, Optional strDelimiter$, Optional bytTyp As Byte)
' Function: Check and Add/Remove Delimiter on the beginn and/or end
' Input:    strVal$ = the Value where the Delimiter has to be added or removed
'           Delimiter$ (Optional)= the character for add/remove - default is ";"
'           bytTyp (Optional):  1= add the Delimiter right - not check left
'                              10= add the Delimiter left - not check right
'                              12= add the Delimiter left, remove right (is the default)
'                              21= add the Delimiter right, remove left
'                              11= add the Delimiter on both end
'                              22= remove the Delimiter on both end
' Output:   the value as string with the added delimiter
    If strDelimiter$ = "" Then strDelimiter = ";"
    If strVal$ <> "" Then
        Select Case bytTyp
            Case 1:
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 10:
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
            Case 11:
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 12: ' default if nothing defined
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) = strDelimiter$ Then strVal$ = Left(strVal$, Len(strVal$) - 1)
            Case 21
                If Left(strVal$, 1) = strDelimiter$ Then strVal$ = Right(strVal$, Len(strVal$) - 1)
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
            Case 22
                If Left(strVal$, 1) = strDelimiter$ Then strVal$ = Right(strVal$, Len(strVal$) - 1)
                If Right(strVal$, 1) = strDelimiter$ Then strVal$ = Left(strVal$, Len(strVal$) - 1)
            Case Else
                If Left(strVal$, 1) <> strDelimiter$ Then strVal$ = strDelimiter$ & strVal$
                If Right(strVal$, 1) <> strDelimiter$ Then strVal$ = strVal$ & strDelimiter$
        End Select
    End If
    OpAddRemoveDelimiter$ = strVal$

End Function

'Title: Search the last row
'Description: Search the last row by checking a key column or just the first 7 columns if they have entry. Excel sometimes do not recognise the last row if some format is further below.

Function FuncLastRow(strfile$, strTab$, Optional ByVal intStartRow%, Optional strKeyCol$) As Single
' Function: Check Data end Row, Try to find last row on a defined KeyCol or just by check first 7 columns. 5 empty rows = defined end of data
' Input:    strfile$ = Filename where it has to be checked (has to be open)
'           strTab$ = Sheet name to check
'           intStartRow% (Optional)= Optional the start where the check should start - default first row
'           strKeyCol$ (Optional) = Optionale Column which has to be checked - default first 7 columns
' Output:   number of the last row with data as single

Dim sngUsedRows!, nRow!, strVal$, bytC As Byte, bytCTotal As Byte

    bytCTotal = 5 ' to check empty rows to make sure there is not just a single or like 2 empty rows
    If intStartRow% = 0 Then intStartRow% = 1
    sngUsedRows! = Workbooks(strfile$).Worksheets(strTab$).UsedRange.SpecialCells(xlCellTypeLastCell).Row

    For nRow! = intStartRow% To sngUsedRows! + 3
        bytC = 0
        If strKeyCol$ <> "" Then ' if no key defined just read all data
            For bytC = 0 To bytCTotal
                strVal$ = Workbooks(strfile$).Worksheets(strTab$).Range(strKeyCol$ & nRow! + bytC).Value
                strVal$ = Trim(strVal$)
                If strVal$ <> "" Then Exit For
            Next
            If bytC >= bytCTotal Then
                FuncLastRow! = nRow!
                Exit For
            End If
        Else ' check 7 first columns (slow version)
            For bytC = 0 To bytCTotal
                strVal$ = Workbooks(strfile$).Worksheets(strTab$).Cells(nRow!, 1).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 2).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 3).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 4).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 5).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 6).Value & _
                            Workbooks(strfile$).Worksheets(strTab$).Cells(nRow! + bytC, 7).Value
                strVal$ = Trim(strVal$)
                If strVal$ <> "" Then Exit For
            Next
            If bytC >= bytCTotal Then
                FuncLastRow! = nRow!
                Exit For
            End If
        End If
    Next
End Function

'Title: Select a folder
'Description: Open a dialogbox for select a folder and give the foldername back.

Function FuncGetFolder(Optional strTitle$) As String
' Function: Open a dialog for select a folder and give selected folder back
' Input:    strTitle$ (Optional)= Title for the dialogbox
' Output:   Folder as string

    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        If strTitle$ <> "" Then
            fldr.Title = strTitle$
        Else
            .Title = "Select a Folder"
        End If
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FuncGetFolder = sItem
    Set fldr = Nothing
End Function

'Title: Wait for given time
'Description: Wait the processing of vba for given seconds

Function OpWait(bytSeconds As Byte)
' Function: wait as many seconds as the input is (max 255)
' Input:    bytSeconds = seconds to wait as byte
' Output:   N/A 
    Dim bytMinutes As Byte
    If bytSeconds > 60 Then
        bytMinutes = Int(bytSeconds / 60)
        bytSeconds = bytSeconds - (bytMinutes * 60)
    Else
        bytMinutes = 0
    End If
    Application.Wait (Now + TimeValue("0:" & Right("0" & bytMinutes, 2) & ":" & Right("0" & bytSeconds, 2)))
End Function

'Title: System Path
'Description: Give some system path back

Function FuncGetSystemPath(bytTyp As Byte) As String
' Function: returns user specific folders (simple way - not works in all cases)
' Input:    bytTyp=number for the liked system path
' Output:   path as string 
    Select Case bytTyp
        Case 1: FuncGetSystemPath = Environ("USERPROFILE") & "\Downloads"
        Case 2: FuncGetSystemPath = Environ("USERPROFILE") & "My Documents"
        Case 3: FuncGetSystemPath = Environ("USERPROFILE") & "\Desktop"
    End Select
End Function

'Title: Protect a sheet
'Description: Protect or unprotect a sheet in the active workbook. Can be forced or just do opposite as it is.

Function OpProtectSheet(Optional bytStat As Byte, Optional strSheet$)
' Function: returns user specific folders (simple way - not works in all cases)
' Input:    strSheet$ = the to protect sheet - if empty protect/unprotect active sheet
'           bytStat 1= protect sheet, 2=unrotect sheet , empty is opposite now
' Output:   N/A

    If strSheet$ = "" Then strSheet$ = ActiveSheet.Name
    If IsEmpty(bytStat) Then
        If Worksheets(strSheet$).ProtectContents = True Then
            bytStat = 2
        Else
            bytStat = 1
        End If
    End If
    
    If bytStat = 1 Then
        On Error Resume Next
        Worksheets(strSheet$).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Err.Clear
    Else
        On Error Resume Next
        Worksheets(strSheet$).Unprotect
        Err.Clear
    End If
    
End Function

