ReadTextFile, GetFolder, ExcelToHtml, PathValidator, Wait, Dimensions, RunShellCmdInHidden, FileCount functions in Excel VBA

UseFulFunctions.vba

Function ReadTextFile(ByVal fPath As String)
    ' A reference to "Microsoft Scripting Runtime library" has to be made before using FileSystemObject.
    Dim FSobj As New FileSystemObject
    Dim textfile As TextStream

    Set textfile = FSobj.GetFile(fPath).OpenAsTextStream(1, -2)
    ReadTextFile = textfile.ReadAll
 
    textfile.Close
End Function

Function GetFolder() As String
    Dim folderSelector As FileDialog
    Set folderSelector = Application.FileDialog(msoFileDialogFolderPicker)
    With folderSelector
        .Title = "Select HTML files folder"
        .AllowMultiSelect = False
        .InitialFileName = Environ("USERPROFILE") & "/Desktop/"
        If .Show <> -1 Then GoTo NextCode
        GetFolder = .SelectedItems(1)
        Exit Function
    End With
NextCode:
    GetFolder = ""
End Function

Function ExcelToHtml(ByVal RngStr As String)
    tempfile = ThisWorkbook.path & "\" & "TempFile.htm"
 
    ' Convert the workbook range into an HTML file.
    With ThisWorkbook.PublishObjects
       .Add(SourceType:=xlSourceRange, _
            Filename:=tempfile, _
            Sheet:=ActiveSheet.Name, _
            Source:=ActiveSheet.Range(RngStr).Address, _
            HtmlType:=xlHtmlStatic) _
       .Publish Create:=True
    End With
    ' Reading Html file.
    HtmlText = ReadTextFile(tempfile)
    ExcelToHtml = HtmlText
    Kill tempfile
End Function

Sub PathValidator(path As String)
    If Dir(path, vbDirectory) = "" Then
        MsgBox "Folder doesn't exist. Please select again.", vbExclamation, "Folder Error"
        End
    End If
End Sub

Sub Wait(seconds As Integer)
    till = Timer + seconds
    Do While Timer < till
        DoEvents
    Loop
End Sub

Function Dimensions(ByVal arr As Variant) As String
    With Application
        If Not IsError(.Index(arr, 1, 2)) And Not IsError(.Index(arr, 2, 1)) Then
            Dimensions = "Multi-Dimensional"
        ElseIf Not IsError(.Index(arr, 1, 2)) Then
            Dimensions = "Single Column"
        ElseIf Not IsError(.Index(arr, 2, 1)) Then
            Dimensions = "Single Row"
        ElseIf Not IsError(.Index(arr, 1, 1)) Then
            Dimensions = "Single Cell"
        End If
    End With
End Function

Function RunShellCmdInHidden(ByVal cmdStr As String) As String
    comd = cmdStr & " | clip"
    ' Using a hidden window, pipe the output of the command to the CLIP.EXE utility...
    CreateObject("WScript.Shell").Run comd, 0, True
    
    ' Now read the clipboard text...
    Dim strOutput
    strOutput = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text")
    RunShellCmdInHidden = WorksheetFunction.Trim(strOutput)
End Function

Function FileCount(ByVal folPath As String, ByVal ext As String)
    Dim f, c
    If Right(folPath, 1) <> "/" Or Right(folPath, 1) <> "\" Then folPath = folPath & "/"
    f = Dir(folPath & "*." & ext)
    
    c = 0
    Do While f <> ""
        c = c + 1
        f = Dir
    Loop
     
    FileCount = c
End Function

Sub SendSlackMsg(ByVal msg As String, ByVal channel As String)
    Dim handle As WinHttpRequest
    Dim body As String
    Dim response
    
    On Error GoTo OnError
    
    body = "{'username': 'Vikas', 'channel': '" & channel & "', 'text': '" & msg & "'}"
    
    Set handle = New WinHttpRequest
    With handle
        .Open "POST", "SlackHookUrl", False
        .SetRequestHeader "Content-Type", "application/json"
        .Send body
        response = .ResponseText
    End With
    
OnError:
    If Err.Number Then Resume
End Sub

Sub BeautifyComments()
    Dim MyComments As Comment
    For Each MyComments In ActiveSheet.Comments
        With MyComments.Shape
            .AutoShapeType = msoShapeRoundedRectangle
            .TextFrame.Characters.Font.Name = "Calibri"
            .TextFrame.Characters.Font.Size = 12
            .TextFrame.Characters.Font.Bold = False
            .Fill.Visible = msoTrue
            .Height = 25 * 5
            .Width = 50 * 8
        End With
    Next
End Sub

Sub addEle(ByRef arr() As Variant, ByRef ele As Variant)
    Dim i As Integer: i = UBound(arr) + 1
    ReDim Preserve arr(0 To i)
    arr(i) = ele
End Sub

Sub SaveCopyAsXlsx(ByVal path As String)
    Application.DisplayAlerts = False
    
    tempXlsmPath = ThisWorkbook.path & "\ClientAccountCountTemp.xlsm"
    ThisWorkbook.SaveCopyAs tempXlsmPath
    
    With Workbooks.Open(tempXlsmPath)
        .SaveAs path, xlOpenXMLWorkbook
        .Close
    End With
    
    Kill tempXlsmPath
    Application.DisplayAlerts = True
End Sub

Sub Mail_Worksheet_Html(ByVal RecTo As String, _
                        ByVal RecCC As String, _
                        ByVal htmlbody As String, _
                        ByVal subText As String, _
                        ByVal atchPath As String)
    Dim olApp As New Outlook.Application
    Dim olMail As Outlook.MailItem
    
    Set olMail = olApp.CreateItem(olMailItem)
    
    With olMail
        .To = RecTo
        .CC = RecCC
        '.SentOnBehalfOfName = ""
        .Subject = subText
        .BodyFormat = olFormatHTML
        .htmlbody = htmlbody
        .Attachments.Add atchPath
        .Send
        '.Display
    End With

End Sub