Category: Snippets

MatchesPattern

Public Function MatchesPattern( _
    strInputTest As String, _
    strInputPattern As String, _
    Optional IgnoreCase As Boolean = True, _
    Optional IsGlobal As Boolean = True _
) As Boolean
    On Error GoTo Catch
    Dim objRegExp As New RegExp
    Set objRegExp = Nothing
    objRegExp.IgnoreCase = IgnoreCase
    objRegExp.Global = IsGlobal
    objRegExp.Pattern = strInputPattern
    MatchesPattern = objRegExp.Test( _
        strInputTest _
    )
    Set objRegExp = Nothing
    Exit Function
Catch:
    Set objRegExp = Nothing
End Function

April 10, 2019

SlicerCount

Public Function SlicerCount( _
    scl As SlicerCacheLevel, _
    Optional NonBlankOnly As Boolean = True, _
    Optional Verbose As Boolean = True _
)
    Dim si As SlicerItem
    Dim iCount As Integer
    Dim iVerboseCount As Integer
    Dim iTotal As Integer
    iCount = 0
    If Verbose Then
        iVerboseCount = 0
        iTotal = scl.SlicerItems.Count
    End If
    For Each si In scl.SlicerItems
        If NonBlankOnly Then
            If SlicerItemIsPopulated(si) Then
                iCount = iCount + 1
            End If
        Else
            iCount = iCount + 1
        End If
        If Verbose Then
            iVerboseCount = iVerboseCount + 1
            Application.StatusBar = _
                "Counting Slicer Items (" & _
                Pct( _
                    iVerboseCount, _
                    iTotal _
                ) & _
                " complete)..."
        End If
    Next si
    SlicerCount = iCount
    If Verbose Then
        Application.StatusBar = False
    End If
End Function

April 9, 2019

DeleteHiddenSourceColumnsFromTarget

Public Sub DeleteHiddenSourceColumnsFromTarget( _
    rngSource As Range, _
    rngTarget As Range _
)
    Dim _
        rngColumn As Range, _
        intSourceColumnInitialOffset As Integer, _
        intSourceRowInitialOffset As Integer, _
        iColumn As Integer
    With rngSource.Cells(1, 1)
        intSourceColumnInitialOffset = .Column
        intSourceRowInitialOffset = .Row
    End With
    For iColumn = rngSource.Columns.Count To 1 Step -1
        If rngSource.Columns(iColumn).Hidden Then
            rngTarget.Columns(iColumn).Delete
        End If
    Next iColumn
End Sub

April 9, 2019

Ellipsize

Public Function Ellipsize( _
    strInput As String, _
    Optional MaxLength As Integer = 16 _
) As String
    If Len(strInput) > MaxLength Then
        Ellipsize = Left(strInput, MaxLength) & Chr(133)
    Else
        Ellipsize = strInput
    End If
End Function

April 8, 2019

TransferRangeDataAsArray

Public Function TransferRangeDataAsArray( _
    rngSource As Range, _
    rngTarget As Range, _
    Optional xlrvd As XlRangeValueDataType = xlRangeValueDefault _
) As Range
    Set TransferRangeDataAsArray = _
        rngTarget.Resize( _
            rngSource.Rows.Count, _
            rngSource.Columns.Count _
        )
    TransferRangeDataAsArray.Value( _
        xlrvd _
    ) = _
        rngSource.Value( _
            xlrvd _
        )
    End Function

April 8, 2019

HasKey

Function HasKey( _
    coll As Collection, _
    index As Variant _
) As Boolean
On Error GoTo ErrorHandler
    Dim elTest As Variant
    HasKey = False
    elTest = coll(index)
    HasKey = True
    Exit Function
ErrorHandler:
End Function

April 8, 2019

ElapsedTime

Function ElapsedTime( _
    endTime As Date, _
    startTime As Date _
) As String
    Dim Interval As Date
    ' Calculate the time interval.
    Interval = endTime - startTime
    ' Format and print the time interval in 
    ' days, hours, minutes and seconds.
    ElapsedTime = _
        Int( _
            CSng( _
                Interval _
            ) _
        ) & _
        " days " & _
        Format( _
            Interval, _
            "hh" _
        ) & _
        " Hours " & _
        Format( _
            Interval, _
            "nn" _
        ) & _
        " Minutes " & _
        Format( _
            Interval, _
            "ss" _
        ) & _
        " Seconds"
End Function

This has been adapted from https://docs.microsoft.com/en-us/office/vba/access/concepts/date-time/calculate-elapsed-time

April 8, 2019

RenderListControlHeadings

Public Sub RenderListControlHeadings( _
    ListControl As Control, _
    ColumnHeadingString As String, _
    Optional FontWeight As Long = 400, _
    Optional OffsetLeft As Long = 8 _
)
    Dim ctls As Controls
    Dim iCtl As Control
    Dim strControlNameStub As String
    Dim strLabelNameStub As String
    Set ctls = ListControl.Parent.Controls
    strLabelNameStub = "lbheading_"
    strControlNameStub = _
        strLabelNameStub & _
        ListControl.Name
    Set ctls = ListControl.Parent.Controls
    For Each iCtl In ctls
        If Left( _
            iCtl.Name, _
            Len( _
                strControlNameStub _
            ) _
        ) = strControlNameStub Then
            ctls.Remove iCtl.Name
        End If
    Next iCtl
    If ColumnHeadingString = "" Then Exit Sub
    Dim arrWidths As Variant
    Dim arrHeadings As Variant
    arrWidths = Split( _
        ListControl.ColumnWidths, _
        ";" _
    )
    arrHeadings = Split( _
        ColumnHeadingString, _
        ";" _
    )
    Dim i As Integer
    Dim accLeftPosition As Long
    accLeftPosition = ListControl.Left + OffsetLeft
    For i = 0 To UBound(arrHeadings)
        With ctls.Add( _
            "Forms.Label.1", _
            strControlNameStub & i _
        )
            .Caption = arrHeadings(i)
            .Left = accLeftPosition
            .Top = ListControl.Top - 12
            .Font.Size = 7
            .Font.Weight = FontWeight
            .BackStyle = fmBackStyleTransparent
        End With
        accLeftPosition = _
            accLeftPosition + _
            CLng( _
                Trim( _
                    Replace( _
                        arrWidths(i), _
                        " pt", "" _
                    ) _
                ) _
            )
    Next i
End Sub

April 7, 2019

DeleteAllFilesInFolder

Public Sub DeleteAllFilesInFolder( _
    strPathToFolder As String _
)
    Dim _
        fs As Object, _
        fldr As Object, _
        f As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fldr = fs.GetFolder(strPathToFolder)
    For Each f In fldr.Files
        Application.StatusBar = _
            "Deleting file " & _
            f.Name & _
            " from folder " & _
            strPathToFolder
        DoEvents
        f.Delete True
    Next
    Set f = Nothing
    Set fldr = Nothing
    Set fs = Nothing
    Application.StatusBar = False
End Sub

April 4, 2019

HasHiddenColumns

Public Function HasHiddenColumns( _
  rng As Range _
) As Boolean
  Dim _
    rngColumn As Range
  HasHiddenColumns = False
  For Each rngColumn In rng.Columns
    If rngColumn.Hidden Then
      HasHiddenColumns = True
    End If
  Next rngColumn
End Function

Usage:

Dim _
  wsSource As Worksheet, _
  rngSource as Range
Set wsSource = ThisWorkbook.Sheets("Sheet1")
Set rngSource = wsSource.Range("A1", "K32")
If HasHiddenColumns( _
  rngSource _
) Then
  ' Handle it
End If

April 4, 2019