Excel VBA - generic application routines that usually get called from the Quick Access Toolbar. These affect the application itself, not a workbook.

mdl_Gen_ApplicationSubs.vb

'Module containing generic application routines. 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


Public Sub AppSettings(Optional Setting As Boolean = True)
'Toggle most Excel application settings to avoid macro slowdown
'Requisites: ResetFindSettings()
    With Application
        .ScreenUpdating = Setting
        .EnableEvents = Setting
        .DisplayAlerts = Setting
        .Calculation = IIf(Setting, xlCalculationAutomatic, xlCalculationManual)
        .StatusBar = False
    End With

    ResetFindSettings

End Sub


Public Sub ResetFindSettings()
'Reset Excel's Find options, usually for after 'Entire Cell' has been used
'Requisites: none
    Dim r As Range
    
    On Error Resume Next
    Set r = Cells.Find(What:="", LookIn:=xlFormulas, SearchOrder:=xlRows, lookat:=xlPart, MatchCase:=False)
    On Error GoTo 0
End Sub


Public Sub ResetTextToColumns()
'Reset Excel's Text to Columns options, which can interfere with subsequent Paste operations
'Requisites: none
    If IsEmpty(Range("A1")) Then Range("A1") = "XYZZY"
    Range("A1").TextToColumns Destination:=Range("A1"), _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=True, _
        semiColon:=False, _
        comma:=False, _
        Space:=False, _
        Other:=False, _
        OtherChar:=""
    If Range("A1") = "XYZZY" Then Range("A1") = ""
    If Err.Number <> 0 Then MsgBox Err.Description
End Sub


Public Sub ShowMessage(strMessage As String, Optional strDuration As Integer = 5)
'Show message on statusbar then clear it after 3 seconds
'Requisites: ClearStatusBar()

    Application.StatusBar = strMessage
    Application.OnTime Now + TimeValue("00:00:" & Format(strDuration, "00")), "ClearStatusBar"
End Sub


Public Sub ClearStatusBar()
'Clear the status bar
'Requisites: none

    Application.StatusBar = False
End Sub


Private Sub OpenNewWorkbook()
'Open a new workbook if none open
'Requisites: none
    If Workbooks.Count = 0 Then
        Workbooks.Add
    End If
End Sub


Function ComparePaths(strPath1 As String, strPath2 As String) As Boolean
'Trim final backslash from paths then compare
'Requisites: CleanPath
    ComparePaths = CleanPath(strPath1) = CleanPath(strPath2)
End Function


Function CleanPath(strPath) As String
'Trim final backslash
'Requisites: none
    CleanPath = Replace(strPath & "\", "\\", "\")
End Function


Public Sub FreezeTopRow()
'Freeze top row, return to originally selected range
'Requisites: none
    Dim sel As Range
    Dim r   As Long
    Dim c   As Long
    
    If Not Selection Is Nothing Then Set sel = Selection
    r = ActiveWindow.ScrollRow
    c = ActiveWindow.ScrollColumn
    
    Application.ScreenUpdating = False
    ActiveWindow.FreezePanes = False
    Rows(2).Select
    ActiveWindow.FreezePanes = True
    sel.Select
    ActiveWindow.ScrollColumn = c
    ActiveWindow.ScrollRow = r
        
    Application.ScreenUpdating = True

End Sub

Option Explicit


Public Function LocalWorkbookName(ByRef wbk As Workbook) As String
'Return local wb name in case containing folder is synced with OneDrive

    LocalWorkbookName = LocalWorkbookPath(wbk) & "\" & wbk.Name

End Function

Public Function LocalWorkbookPath(ByRef wbk As Workbook)
'Return local wb name in case containing folder is synced with OneDrive
    Dim Ctr As Long
    Dim objShell As Object
    Dim UserProfilePath As String
    
    'Check if it looks like a OneDrive location
    If InStr(1, wbk.Path, "https://", vbTextCompare) > 0 Then
    
        'Replace LocalWorkbookName slashes with back slashes
        LocalWorkbookPath = Replace(wbk.FullName, "/", "\")
        
        'Get environment path using vbscript
        Set objShell = CreateObject("WScript.Shell")
        UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
        
        'Trim OneDrive designators
        For Ctr = 1 To 4
           LocalWorkbookPath = Mid(LocalWorkbookPath, InStr(LocalWorkbookPath, "\") + 1)
        Next
        
        'Construct the name
        LocalWorkbookPath = UserProfilePath & "\OneDrive\" & LocalWorkbookPath
        
    Else
      LocalWorkbookPath = wbk.Path
    End If
End Function


Public Sub OpenCurrentFileLocation()
'Opens the containing folder of the active workbook
    Dim Foldername As String
    Foldername = LocalWorkbookPath(ActiveWorkbook) 'FullName
    Shell "C:\WINDOWS\explorer.exe """ & Foldername & "", vbNormalFocus

End Sub

Public Sub FormatDateTime()
    Selection.NumberFormat = "dd/MM/yyyy hh:mm"
End Sub


Public Sub PasteValues()
'Replaces contents of cells with their values (rather than formulas)
    Dim c   As Range
    Dim rng As Range
    If Not Selection Is Nothing Then
        Set rng = Intersect(Selection, ActiveSheet.UsedRange)
        If Not rng Is Nothing Then
            For Each c In rng
                c.value = c.value
            Next c
        End If
    End If
End Sub


Public Sub TrimValues()
'Trim leading and trailing spaces from cell values
    Dim c   As Range
    Dim rng As Range
    If Not Selection Is Nothing Then
        Set rng = Intersect(Selection, ActiveSheet.UsedRange)
        If Not rng Is Nothing Then
            For Each c In rng
                c.value = Trim(c.value)
            Next c
        End If
    End If
End Sub


Public Sub CopyText(Text As String)
'VBA Macro using late binding to copy text to clipboard.
'By Justin Kay, 8/15/2014
    Dim MSForms_DataObject As Object
    Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MSForms_DataObject.SetText Text
    MSForms_DataObject.PutInClipboard
    Set MSForms_DataObject = Nothing
End Sub


Public Sub RaiseError(Message As String, Optional ErrorNumber As Long = 1)
'Raise a custom error
    Err.Raise vbObjectError + ErrorNumber, , Message
End Sub



Public Sub AutosizeWindow(wbk As Workbook, Optional rng As Range, Optional blnFocus = False)
'Autosize workbook window to fit contents (or selected range)
    Dim wbkActive As Workbook
    
    Set wbkActive = ActiveWorkbook
    wbk.Activate
    
    If rng Is Nothing Then
        Set rng = wbk.ActiveSheet.UsedRange
    End If
    
    With Application
        .WindowState = xlNormal
        .Width = Application.Min(GetRangeWidth(rng) + 80, GetScreenWidth())
        .Height = Application.Min(GetRangeHeight(rng) + 200, GetScreenHeight())
        If CommandBars("Ribbon").Height > 150 Then CommandBars.ExecuteMso "MinimizeRibbon"
    End With
    If Not blnFocus Then wbkActive.Activate

End Sub



'----------TESTING ONLY

Sub TestAutosize()

    AutosizeWindow Workbooks("book1.xlsx")

End Sub



Public Sub ShowMenuName()
    Dim Cbar As CommandBar
    For Each Cbar In Application.CommandBars
        With Cbar
            If .Type = msoBarTypePopup Then
                On Error Resume Next
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "Name for VBA = " & Cbar.Name
                    .Tag = "NameButtonInContextMenu"
                End With
                On Error GoTo 0
            End If
        End With
    Next
End Sub


Public Sub HideMenuName()
    Dim Cbar As CommandBar
    Dim ctrl As CommandBarControl
    For Each Cbar In Application.CommandBars
        With Cbar
            If .Type = msoBarTypePopup Then
                For Each ctrl In .Controls
                    If ctrl.Tag = "NameButtonInContextMenu" Then
                        ctrl.Delete
                    End If
                Next ctrl
            End If
        End With
    Next
End Sub