Assortment of Excel VBA UDFs

mdlGen_Functions.vb

'Module containing generic functions. Any requisite functions/variables are now annotated
'in the routine header, allowing this module to be swapped out more easily
'
' (c) R Shenoy 30/07/2013
'
' Last Updated 16/11/2018

Option Explicit

'Used for function that gets screen size
#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As LongPtr) As LongPtr
#Else
    Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
#End If

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

'Used for translation function
Private Const strSHORTCODES As String = ",en,af,sq,ar,hy,az,eu,be,bn,bg,ca,zh,hr,cs,da,nl,eo,et,tl,fi,fr,gl,ka,de,el,gu,ht,iw,hi,hu,is,id,ga,it,ja,kn,ko,lo,la,lv,lt,mk,ms,mt,no,fa,pl,pt-PT,ro,ru,sr,sk,sl,es,sw,sv,ta,te,th,tr,uk,ur,vi,cy,yi"

Public Enum eLanguage
    auto_detect = 0
    English = 1
    Afrikaans = 2
    Albanian = 3
    Arabic = 4
    Armenian = 5
    Azerbaijani = 6
    Basque = 7
    Belarusian = 8
    Bengali = 9
    Bulgarian = 10
    Catalan = 11
    Chinese = 12
    Croatian = 13
    Czech = 14
    Danish = 15
    Dutch = 16
    Esperanto = 17
    Estonian = 18
    Filipino = 19
    Finnish = 20
    French = 21
    Galician = 22
    Georgian = 23
    German = 24
    Greek = 25
    Gujarati = 26
    Haitian_Creole = 27
    Hebrew = 28
    Hindi = 29
    Hungarian = 30
    Icelandic = 31
    Indonesian = 32
    Irish = 33
    Italian = 34
    Japanese = 35
    Kannada = 36
    Korean = 37
    Lao = 38
    Latin = 39
    Latvian = 40
    Lithuanian = 41
    Macedonian = 42
    Malay = 43
    Maltese = 44
    Norwegian = 45
    Persian = 46
    Polish = 47
    Portuguese = 48
    Romanian = 49
    Russian = 50
    Serbian = 51
    Slovak = 52
    Slovenian = 53
    Spanish = 54
    Swahili = 55
    Swedish = 56
    Tamil = 57
    Telugu = 58
    Thai = 59
    Turkish = 60
    Ukrainian = 61
    Urdu = 62
    Vietnamese = 63
    Welsh = 64
    Yiddish = 65
End Enum




Function CheckColumnHeaders(wks As Worksheet, strHeader As String, Optional intHeaderRow As Integer = 1) As Boolean
'Check whether column headers all exist in wks
'Requisites: none
    Dim arr     As Variant
    Dim i       As Integer
    Dim srch    As Range
    
    arr = Split(strHeader, ";")
    
    CheckColumnHeaders = True
    For i = 0 To UBound(arr)
        Set srch = wks.Rows(intHeaderRow).Find(arr(i), , xlValues, xlWhole)
        If srch Is Nothing Then
            CheckColumnHeaders = False
            Exit For
        End If
    Next i
    
    'Reset search interface defaults
    'Set srch = wks.Rows(intHeaderRow).Find("", , xlValues, xlPart)
    ResetFindSettings

End Function


Function GetColumnHeaders(wks As Worksheet, strHeader As String, Optional intHeaderRow As Integer = 1) As Scripting.Dictionary
'Create collection of column headers from wks
'Requisites: none
    Dim arr     As Variant
    Dim i       As Integer
    Dim srch    As Range
    Dim dic     As New Scripting.Dictionary
    
    arr = Split(strHeader, ";")
    For i = 0 To UBound(arr)
        Set srch = wks.Rows(intHeaderRow).Find(arr(i), , xlValues, xlWhole)
        If Not srch Is Nothing Then dic.Add arr(i), srch.Column
    Next i
    
    Set GetColumnHeaders = dic
    
    'Reset search interface defaults
    'Set srch = wks.Rows(intHeaderRow).Find("", , xlValues, xlPart)
    ResetFindSettings
    
End Function


Function StringToDict(str As String, Optional strDelim As String = ";") As Scripting.Dictionary
'Create dictionary from delimited string
'Requisites: none
    Dim arr     As Variant
    Dim i       As Integer
    Dim srch    As Range
    Dim dic     As New Scripting.Dictionary
    
    arr = Split(str, strDelim)
    For i = 0 To UBound(arr)
        dic.Add CStr(arr(i)), CStr(arr(i))
    Next i
    
    Set StringToDict = dic

End Function

Function DictToString(dict As Scripting.Dictionary, Optional strDelim As String = ", ", Optional blnKeys As Boolean = True, Optional blnItems As Boolean = False) As String
'Create delimited string from dictionary, using either keys or items
    Dim i As Variant
    
    For Each i In dict.Keys
        DictToString = DictToString & IIf(blnKeys, CStr(i) & strDelim, "") & IIf(blnItems, (CStr(dict(i))) & strDelim, "")
    Next i
    DictToString = Left(DictToString, Len(DictToString) - Len(strDelim))
    
End Function

Public Function Username()
'Return current user's windows login
'Requisites: none
    Username = Environ("USERNAME")
End Function


Public Function GetClientVersion(strClient As String)
'Return latest version of client as defined in database
'Requisites: none
    dicParams.RemoveAll
    dicParams.Add "@ClientName", strClient
    
    Set rs = sqlStoredProc("pGetClientVersion", dicParams)
    
    If IsEmptyRS(rs) Then
        GetClientVersion = 0
    Else
        GetClientVersion = rs("CurrentVersion")
    End If
End Function


Public Function ISOWeekNum(dat As Date) As Integer
'Returns ISO (Fusion) week number - Attributed to Daniel Maher
'Requisites: none
    Dim d2 As Long
    d2 = DateSerial(Year(dat - WeekDay(dat - 1) + 4), 1, 3)
    ISOWeekNum = Int((dat - d2 + WeekDay(d2) + 5) / 7)
End Function

Function ISOYearNum(ByVal AnyDate As Date) As Long
'Returns ISO Year Number for a given date
'copied from http://www.vbaexpress.com/kb/getarticle.php?kb_id=744
'Requisites: FirstMonday
    Dim NextFirstMonday         As Date
    Dim PreviousFirstMonday     As Date
    Dim ThisYear                As Integer
    Dim ThisFirstMonday         As Date
    Dim YearNum                 As Integer
    
    AnyDate = DateAdd("d", 2, AnyDate)  'add two days to date so works with Saturday as first day of week for Fusion
    ThisYear = Year(AnyDate)
    ThisFirstMonday = FirstMonday(ThisYear)
    PreviousFirstMonday = FirstMonday(ThisYear - 1)
    NextFirstMonday = FirstMonday(ThisYear + 1)
    Select Case AnyDate
        Case Is >= NextFirstMonday
            ISOYearNum = Year(AnyDate) + 1
        Case Is < ThisFirstMonday
            ISOYearNum = Year(AnyDate) - 1
        Case Else
            ISOYearNum = Year(AnyDate)
    End Select
End Function


Public Function ISODate(intYear As Integer, intWeekNum As Integer) As Date
'Returns monday date that intWeekNum begins with - R Shenoy 2013
'Requisites: FirstMonday
    Dim YearStart As Date
    
    YearStart = FirstMonday(intYear)
    ISODate = (intWeekNum - 1) * 7 + YearStart
    
End Function


Function FirstMonday(WhichYear As Integer) As Date
'copied from http://www.vbaexpress.com/kb/getarticle.php?kb_id=744
    Dim NewYear As Date
    Dim WeekDay As Integer
     
    NewYear = DateSerial(WhichYear, 1, 1)
    WeekDay = (NewYear - 2) Mod 7
    If WeekDay < 4 Then
        FirstMonday = NewYear - WeekDay
    Else
        FirstMonday = NewYear - WeekDay + 7
    End If
End Function


Function GetUnique(rng As Range) As Collection ', index As Integer
'Returns collection of unique values from selected range
    Dim colValues As New Collection
    Dim i As Integer
    Dim c As Range
    
    On Error Resume Next
    For Each c In rng.Cells
        If c.value <> "" Then colValues.Add c, CStr(c)
    Next c
    On Error GoTo 0
    
    Set GetUnique = colValues '(index)

End Function

Function SortCollection(col As Collection) As Collection

    Dim colWorking As Collection
    Dim vItm As Variant
    Dim i As Long, j As Long
    Dim vTemp As Variant

    Set colWorking = New Collection

    'copy the collection
    For i = 1 To col.Count
        colWorking.Add col(i), col(i)
    Next i


    'Two loops to bubble sort
    For i = 1 To colWorking.Count - 1
        For j = i + 1 To colWorking.Count
            If colWorking(i) > colWorking(j) Then
                'store the lesser item
                vTemp = colWorking(j)
                'remove the lesser item
                colWorking.Remove j
                're-add the lesser item before the greater Item
                colWorking.Add vTemp, vTemp, i
            End If
        Next j
    Next i

    Set SortCollection = colWorking

    'Test it
    'For Each vItm In colWorking
    '    Debug.Print vItm
    'Next vItm

End Function


Function FlattenCollection(col As Collection, Optional strDelimiter As String = ",") As String
'Flatten all items into a single delimited string
    Dim i As Long
    Dim strResult As String
    
    For i = 1 To col.Count
        strResult = strResult & col(i) & strDelimiter
    Next i
    
    FlattenCollection = Left(strResult, Len(strResult) - 1)

End Function


Function GetUniqueString(rng As Range, Optional strDelimiter As String = ",") As String
'Returns collection of unique values from selected range flattened into a string
    Dim colValues As New Collection
    Dim i As Integer
    Dim c As Range
    Dim strResult As String
    
    On Error Resume Next
    For Each c In rng.Cells
        If c.value <> "" Then colValues.Add c, CStr(c)
    Next c
    On Error GoTo 0
    
    GetUniqueString = FlattenCollection(colValues)

End Function

Public Function CountUnique(rng As Range)
'Count unique values in a range
    Dim colValues As New Collection
    Dim c As Range
    
    On Error Resume Next
    For Each c In rng.Cells
        If c.value <> "" Then colValues.Add c, CStr(c)
    Next c
    
    CountUnique = colValues.Count
End Function


Function IsTime(rng As Range) As Boolean
'checks if value is a value time value
    Dim sValue As String
    sValue = rng.Cells(1).Text
    On Error Resume Next
    IsTime = IsDate(TimeValue(sValue))
    On Error GoTo 0
End Function

Public Function ExOr(val1 As Variant, val2 As Variant)
'Provides worksheet function equivalent of VBA Xor operator

    ExOr = val1 Xor val2
    
End Function


Function RangeConcat(rng As Range, Optional strDelim As String = ", ", Optional blnIncludeBlanks As Boolean = True) As String
'Returns concatenated string of all cells in rng
    Dim c As Range
    For Each c In rng.Cells
        If blnIncludeBlanks Or c <> "" Then
            RangeConcat = RangeConcat & c & strDelim
        End If
    Next c
    If RangeConcat <> "" Then
        RangeConcat = Left(RangeConcat, Len(RangeConcat) - Len(strDelim))
    End If

End Function

Function RangeConcatNum(rng As Range) As Long
'Build up a number based on integers in a range
    Dim c As Range
    For Each c In rng.Cells
        If IsNumeric(c) And Int(c) = c Then
            RangeConcatNum = 10 * RangeConcatNum + c
        End If
    Next c
End Function

Function RangeConcatSQL(rng As Range, Optional blankIsNull As Boolean = True, _
                        Optional StringCoerce As Boolean = False, Optional TrimSpaces As Boolean = True) As String
'Returns concatenated string of all cells in rng for an INSERT statement
    Dim c As Range
    If rng Is Nothing Then Exit Function
    
    RangeConcatSQL = "("
    For Each c In rng.Cells
        If c = "" Then
            If blankIsNull Then
                RangeConcatSQL = RangeConcatSQL & "NULL, "
            Else
                RangeConcatSQL = RangeConcatSQL & "'', "
            End If
        ElseIf c = "NULL" Then
            RangeConcatSQL = RangeConcatSQL & "NULL, "
        ElseIf IsDate(c.value) Then
            RangeConcatSQL = RangeConcatSQL & "'" & Format(c.value, "yyyy-MM-dd hh:mm:ss") & "', "
        ElseIf IsTime(c) Then
            RangeConcatSQL = RangeConcatSQL & "'" & Format(c.value, "hh:mm:ss") & "', "
        ElseIf IsNumeric(c.value) And Not StringCoerce Then
            RangeConcatSQL = RangeConcatSQL & c & ", "

        Else
            RangeConcatSQL = RangeConcatSQL & "'" & IIf(TrimSpaces, _
                    Trim(Replace(Replace(Replace(c, "'", "''"), Chr(10), ""), Chr(13), "")), _
                    Replace(Replace(Replace(c, "'", "''"), Chr(10), ""), Chr(13), "")) & "', "
        End If
    Next c
    
    RangeConcatSQL = Left(RangeConcatSQL, Len(RangeConcatSQL) - Len(", ")) & ")"
    

End Function


Function RangeConcatSQLHeaders(rng As Range) As String
'Returns concatenated string of all cells in rng for the FIELDS clause of an INSERT statement
    Dim c As Range
    Dim strDelim As String
    If rng Is Nothing Then Exit Function
    
    RangeConcatSQLHeaders = "(["
    strDelim = "], ["

    For Each c In rng.Cells
        If c <> "" Then
            RangeConcatSQLHeaders = RangeConcatSQLHeaders & c & strDelim
        End If
    Next c
    
    If RangeConcatSQLHeaders <> "" Then
        RangeConcatSQLHeaders = Left(RangeConcatSQLHeaders, Len(RangeConcatSQLHeaders) - Len(strDelim)) & "])"
    End If
    

End Function


Function InStrRevXL(str As String, substr As String, Optional start As Integer = -1, Optional compare As Integer = 1)
'Worksheet equivalent of InStrRev
    InStrRevXL = InStrRev(str, substr, start, compare)
End Function


Function ProperName(Name As String) As String
'Format a name to proper case - only works for Mc and Mac but can be extended as required
    Dim arr() As String
    Dim x As Integer
    
    arr = Split(Name)
    For x = 0 To UBound(arr)
        arr(x) = LCase(arr(x))

        If Left(arr(x), 2) = "mc" And Len(arr(x)) > 3 Then
            arr(x) = Replace(arr(x), "mc", "mc ")
        ElseIf Left(arr(x), 3) = "mac" And Len(arr(x)) > 4 Then
            arr(x) = Replace(arr(x), "mac", "mac ")
        End If
        
        arr(x) = Replace(WorksheetFunction.Proper(arr(x)), " ", "")
        
    Next x
    ProperName = Join(arr)
End Function


Function CellColour(Optional rng As Range = Nothing) As Long
'Return an index based on the cell's colour. (nb - doesn't work on conditional format results)
    If rng Is Nothing Then Set rng = ActiveCell
    CellColour = rng.Cells(1, 1).Interior.ColorIndex
End Function


Function RowCompare(rng As Range, Optional rng2 As Range) As Variant
'Compare contents of rows, return column letters for any non-similar rows
    Dim intColumns As Integer
    Dim intRows As Integer
    Dim rngColumn As Range
    Dim rngRow As Range
    Dim x As Integer
    Dim blnDiff As Boolean
    
    intRows = rng.Rows.Count
    intColumns = rng.Columns.Count
        
    'Single range argument
    If rng2 Is Nothing Then
        If intRows > 1 Then
            For Each rngColumn In rng.Columns
                blnDiff = False
                For x = 1 To intRows - 1
                    If rngColumn.Cells(x, 1) <> rng2.Cells(x, 1) Then blnDiff = True
                Next x
                If blnDiff Then RowCompare = RowCompare & Split(rngColumn.Cells(1, 1).Address, "$")(1) & ", "
            Next rngColumn
            
        Else    'only one row supplied
            GoTo ErrorHandler
        End If
            
    'Multiple row argument
    ElseIf rng2.Columns.Count = intColumns Then
        For x = 1 To intColumns
            If rng.Cells(1, x) <> rng2.Cells(1, x) Then RowCompare = RowCompare & Split(rng.Cells(1, x).Address, "$")(1) & ", "
        Next x
    Else
    
        GoTo ErrorHandler
        
    End If
    
    If RowCompare <> "" Then RowCompare = Left(RowCompare, Len(RowCompare) - 2)
            
    Exit Function
    
ErrorHandler:
     RowCompare = CVErr(xlErrRef)
        
End Function


Sub TranslateCell()
'Original borrowed from http://analystcave.com/excel-google-translate-functionality/
    Dim getParam As String
    Dim trans As String
    Dim translateFrom As String
    Dim translateTo As String
    Dim URL As String
    Dim objHTTP As Object
    
    translateFrom = "nl"
    translateTo = "en"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    getParam = ConvertToGet(ActiveCell.value)
    URL = "https://translate.google.pl/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
        trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
        ActiveCell.value = Clean(trans)
    Else
        MsgBox ("Error")
    End If
End Sub
 

Public Function Translate(rng As Range, Optional translateFrom As String = "nl", Optional translateTo As String = "en")
'Modified from the previous function to work as a UDF (by me)
    Dim getParam As String
    Dim trans As String
    Dim objHTTP As Object
    Dim URL As String
    
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    getParam = ConvertToGet(rng.value)
    URL = "https://translate.google.pl/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
        trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
        Translate = Clean(trans)
    Else
        Translate = CVErr(xlErrValue)
    End If
End Function
  
 
'----Used functions----
Function ConvertToGet(Val As String)
    Val = Replace(Val, " ", "+")
    Val = Replace(Val, vbNewLine, "+")
    Val = Replace(Val, "(", "%28")
    Val = Replace(Val, ")", "%29")
    ConvertToGet = Val
End Function


Function Clean(Val As String)
    Val = Replace(Val, "&quot;", """")
    Val = Replace(Val, "%2C", ",")
    Val = Replace(Val, "&#39;", "'")
    Clean = Val
End Function


Public Function RegexExecute(str As String, reg As String, _
                             Optional matchIndex As Long, _
                             Optional subMatchIndex As Long) As String
    Dim regex, matches
    On Error GoTo ErrHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
    regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For efficiency
    If regex.test(str) Then
        Set matches = regex.Execute(str)
        RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
        Exit Function
    End If
ErrHandl:
    RegexExecute = CVErr(xlErrValue)
End Function

Public Function Eval(str As String) As Variant
    Application.Volatile
    Eval = Evaluate(str)
End Function

Public Function Prime(num As Long)
'Test if a number is prime
    Dim i As Long
    Prime = True
    If CLng(num) <> num Or num < 2 Then
        Prime = False
    Else
        For i = 2 To CLng(num ^ 0.5)
            If num Mod i = 0 Then Prime = False
        Next i
    End If
End Function

Sub testprimes()
    Dim i As Long
    For i = 0 To 100
        Debug.Print i & " - " & Prime(i)
    Next i
End Sub



Public Function DividendTax(GrossIncome As Double, Optional Salary As Double = 8060) As Double
'Calculates Dividend Tax owed (2016/17)
    Dim PersAllowance As Double, HigherThreshold As Double, AdditionalThreshold As Double
    Dim BasicRate As Double, HigherRate As Double, AdditionalRate As Double
    Dim SalaryPA As Double, SalaryBR As Double, SalaryHR As Double, SalaryAR As Double
    Dim DividendPA As Double, DividendBR As Double, DividendHR As Double, DividendAR As Double
    Dim Dividend As Double, DividendAllowance As Double
    
    'Definitions
    PersAllowance = 11000
    BasicRate = 0.075
    HigherThreshold = 43000
    HigherRate = 0.325
    AdditionalThreshold = 150000
    AdditionalRate = 0.381
    DividendAllowance = 5000
    
    
    'If GrossIncome < PersAllowance Then Exit Function
    
    Dividend = GrossIncome - Salary
    
    'Allocate to personal allowance
    SalaryPA = WorksheetFunction.Min(Salary, PersAllowance)
    DividendPA = WorksheetFunction.Min(GrossIncome, PersAllowance - SalaryPA)
    
    'Unallocated Income
    Salary = WorksheetFunction.Max(0, Salary - SalaryPA)
    Dividend = WorksheetFunction.Max(0, Dividend - DividendPA)
    
    'Amount taxed at basic rate
    SalaryBR = WorksheetFunction.Min(Salary, HigherThreshold - PersAllowance)
    DividendBR = WorksheetFunction.Min(Dividend, HigherThreshold - PersAllowance - SalaryBR)
    
    'Unallocated Income
    Salary = WorksheetFunction.Max(0, Salary - SalaryBR)
    Dividend = WorksheetFunction.Max(0, Dividend - DividendBR)
    
    'Amount taxed at higher rate
    SalaryHR = WorksheetFunction.Min(Salary, AdditionalThreshold - HigherThreshold)
    DividendHR = WorksheetFunction.Min(Dividend, AdditionalThreshold - HigherThreshold - SalaryHR)
    
    'Unallocated Income - taxed at additional rate
    SalaryAR = WorksheetFunction.Max(0, Salary - SalaryHR)
    DividendAR = WorksheetFunction.Max(0, Dividend - DividendHR)
    

    'Apply Dividend allowance
    If DividendAllowance >= DividendBR Then
        DividendAllowance = DividendAllowance - DividendBR
        DividendBR = 0
    Else
        DividendBR = DividendBR - DividendAllowance
        DividendAllowance = 0
    End If
    
    If DividendAllowance >= DividendHR Then
        DividendAllowance = DividendAllowance - DividendHR
        DividendHR = 0
    Else
        DividendHR = DividendHR - DividendAllowance
        DividendAllowance = 0
    End If
    
    'Apply tax to each band
    DividendTax = DividendBR * BasicRate + DividendHR * HigherRate + DividendAR * AdditionalRate
    
End Function


Public Function tblLookup(TableName As String, LookupColumn As String, ReturnColumn As String, ByVal value As String)
'Carry out a vLookup on a Table
    Dim rngLookup As Range
    Dim rngReturn As Range
    Dim rngSearch As Range
    Dim intColOffset As Integer
    Dim index As Integer

    On Error GoTo ErrorHandler
    Set rngLookup = Range(TableName & "[" & LookupColumn & "]")
    Set rngReturn = Range(TableName & "[" & ReturnColumn & "]")
    
    If Not (rngLookup Is Nothing Or rngReturn Is Nothing) Then
    
        intColOffset = rngReturn.Column - rngLookup.Column
        Set rngSearch = rngLookup.Find(value, lookat:=xlWhole)
        
        tblLookup = rngSearch.Offset(0, intColOffset)
    End If
    
    
ErrorHandler:
    If Err.Number <> 0 Then Debug.Print Err.Description
    
    ResetFindSettings
    
End Function


Function IfEmpty(value As String, ValueIfEmpty As String)
'Equivalent to ISNULL for Empty Strings
    IfEmpty = value
    If IfEmpty = "" Then IfEmpty = ValueIfEmpty
End Function

Function IfNotEmpty(value As String, ValueIfNotEmpty As String)
'Opposite of IfEmpty
    IfNotEmpty = value
    If IfNotEmpty <> "" Then IfNotEmpty = ValueIfNotEmpty
End Function



Function TrimTo(value As String, Delim As String, Optional blnTrim As Boolean = True)
'Trims string to first occurrence of delimiter
    Dim arr As Variant
    arr = Split(value, Delim)
    TrimTo = IIf(blnTrim, Trim(arr(0)), arr(0))
    
End Function

Function PingServer(Host As String)
'Ping a server and process the response
    Dim objPing As Object
    Dim objStatus As Object
    Dim strResult As String
    
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
       
    'PingServer = False
    
    'report the results
    For Each objStatus In objPing
    
        Select Case objStatus.statuscode
            Case 0: strResult = "Connected"
            Case 11001: strResult = "Buffer too small"
            Case 11002: strResult = "Destination net unreachable"
            Case 11003: strResult = "Destination host unreachable"
            Case 11004: strResult = "Destination protocol unreachable"
            Case 11005: strResult = "Destination port unreachable"
            Case 11006: strResult = "No resources"
            Case 11007: strResult = "Bad option"
            Case 11008: strResult = "Hardware error"
            Case 11009: strResult = "Packet too big"
            Case 11010: strResult = "Request timed out"
            Case 11011: strResult = "Bad request"
            Case 11012: strResult = "Bad route"
            Case 11013: strResult = "Time-To-Live (TTL) expired transit"
            Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
            Case 11015: strResult = "Parameter problem"
            Case 11016: strResult = "Source quench"
            Case 11017: strResult = "Option too big"
            Case 11018: strResult = "Bad destination"
            Case 11032: strResult = "Negotiating IPSEC"
            Case 11050: strResult = "General failure"
            Case Else: strResult = "Unknown host"
        End Select
      
        'If objStatus.statuscode = 0 Then PingServer = True
        PingServer = strResult
    Next
   
    'reset object ping variable
    Set objPing = Nothing


End Function


Sub MeasureSelection()
'PURPOSE: Provide Height and Width of Currently Selected Cell Range
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

    Dim cell As Range
    Dim Width As Long
    Dim Height As Long
    
    'Measure Selection Height
    For Each cell In Selection.Cells.Columns(1)
        Height = Height + cell.Height
    Next cell
    
    'Measure Selection Width
    For Each cell In Selection.Cells.Rows(1)
        Width = Width + cell.Width
    Next cell
    
    'Report Results
      MsgBox "Height:  " & Height & "px" & vbCr & "Width:   " & Width & "px", , "Dimensions"

End Sub


Function GetRangeWidth(rng As Range)
'Get pixel width of selected range
    Dim c As Range
    
    For Each c In rng.Rows(1)
        GetRangeWidth = GetRangeWidth & c.Width
    Next c
End Function


Function GetRangeHeight(rng As Range)
'Get pixel height of selected range
    Dim c As Range
    
    For Each c In rng.Columns(1)
        GetRangeHeight = GetRangeHeight & c.Height
    Next c
End Function


Function GetScreenWidth()
'Get screen pixel width
    GetScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function


Function GetScreenHeight()
'Get screen pixel height
    GetScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Function






'----------NOT WORKING YET------------------



Function LargeIntegerToDate(value As Variant)
'takes Microsoft LargeInteger value (Integer8) and returns according the date and time
    Dim sho             As Object
    Dim timeShiftValue  As Variant
    Dim timeShift       As Long
    Dim i               As Long
    Dim secs            As Long
    Dim i8High          'As Long
    Dim i8Low           'As Long

    'first determine the local time from the timezone bias in the registry
    Set sho = CreateObject("Wscript.Shell")
    timeShiftValue = sho.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
    If IsArray(timeShiftValue) Then
        timeShift = 0
        For i = 0 To UBound(timeShiftValue)
            timeShift = timeShift + (timeShiftValue(i) * 256 ^ i)
        Next
    Else
        timeShift = timeShiftValue
    End If

    value = CDbl(value)
    'get the large integer into two long values (high part and low part)
    i8High = value.highpart
    i8Low = value.lowpart
    If (i8Low < 0) Then
           i8High = i8High + 1
    End If

    'calculate the date and time: 100-nanosecond-steps since 12:00 AM, 1/1/1601
    If (i8High = 0) And (i8Low = 0) Then
        LargeIntegerToDate = #1/1/1601#
    Else
        LargeIntegerToDate = #1/1/1601# + (((i8High * 2 ^ 32) + i8Low) / 600000000 - timeShift) / 1440
    End If
End Function

Function DateToLargeIntegerString(value) As String
'takes a date/time and returns the according Microsoft LargeInteger value (Intger8)
    Dim sho             As Object
    Dim timeShiftValue  As Variant
    Dim timeShift       As Double
    Dim i               As Double
    Dim secs            As Double
    
    'first determine the local time from the timezone bias in the registry
    Set sho = CreateObject("Wscript.Shell")
    timeShiftValue = sho.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
    If IsArray(timeShiftValue) Then
        timeShift = 0
        For i = 0 To UBound(timeShiftValue)
            timeShift = timeShift + (timeShiftValue(i) * 256 ^ i)
        Next
    Else
        timeShift = timeShiftValue
    End If

    'adjust the local time to UTC
    value = DateAdd("n", timeShift, value)

    'how much seconds since 1601 are in the time?
    secs = DateDiff("s", #1/1/1601#, value)

    'convert it to 100-nanosecond steps
    DateToLargeIntegerString = CStr(secs) & "0000000"
End Function