VBA Snippets

Message_CustomDoesNotExist

Public Sub Message_PropertyCustomDoesNotExist( _
         ByVal sPropertyName As String)

Dim sMessage As String
   sMessage = "The custom workbook property '" & sPropertyName & "' does not exist."

   Call MsgBox(sMessage, vbOKOnly + vbInformation, "Property")
   Call Tracer_Add("MESSAGE", sMessage)
End Sub

Message_NoWorkbooksOpen

Public Sub Message_NoWorkbooksOpen( _
    Optional ByVal bInformUser As Boolean = False)

Dim sMessage As String
    sMessage = "There are no workbooks currently open."

    If (bInformUser = True) Then
        Call MsgBox(sMessage, vbOKOnly + vbInformation, "No Workbook")
    End If
    Call Tracer_Add("MESSAGE", sMessage)
End Sub

Message_WorkbookIsSharedRemoveSharingFirst

Public Sub Message_WorkbookIsSharedRemoveSharingFirst()

Dim sMessage As String
   sMessage = "You are unable to create or format charts in a shared workbook."

   Call MsgBox(sMessage, vbOKOnly + vbInformation, "Shared Workbook")
   Call Tracer_Add("MESSAGE", sMessage)
End Sub

Message_WorkbookNotSaved

Public Sub Message_WorkbookNotSaved()

Dim sMessage As String
   sMessage = "You must save your Excel workbook first."

   Call MsgBox(sMessage, vbOKOnly + vbInformation, "Workbook Not Saved")
   Call Tracer_Add("MESSAGE", sMessage)
End Sub

Property_CustomAdd

Public Function Property_CustomAdd( _
    ByVal sPropertyName As String, _
    ByVal vPropertyValue As Variant, _
    Optional ByVal sPropertyType As String = "Text", _
    Optional ByVal sWbkName As String = "", _
    Optional ByVal bCheckExists As Boolean = True) As Boolean

Const sPROCNAME As String = "Property_CustomAdd"
Dim oDocumentProperties As Office.DocumentProperties
Dim oDocumentProperty As Office.DocumentProperty
Dim oPropertyType As MsoDocProperties

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
        
    Set oDocumentProperties = ActiveWorkbook.CustomDocumentProperties

    If (bCheckExists = True) Then
        If (Property_CustomExists(sPropertyName, False) = True) Then
            Property_CustomAdd = False
            Exit Function
        End If
    End If

    If (sPropertyType = "Text") Then oPropertyType = MsoDocProperties.msoPropertyTypeString
    
    Set oDocumentProperty = oDocumentProperties.Add(Name:=sPropertyName, _
                            LinkToContent:=False, _
                            Type:=oPropertyType, _
                            Value:=vPropertyValue)
    Property_CustomAdd = True
    
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
    Property_CustomAdd = False
End Function

Property_CustomDelete

Public Sub Property_CustomDelete( _
    ByVal sPropertyName As String, _
    Optional ByVal sWbkName As String = "")
    
Const sPROCNAME As String = "Property_CustomDelete"
Dim oDocumentProperties As Office.DocumentProperties

    On Error GoTo ErrorHandler
    
    If (Len(sWbkName) = 0) Then sWbkName = ActiveWorkbook.Name
    Set oDocumentProperties = Workbooks(sWbkName).CustomDocumentProperties
    
    Dim ipropertycount As Integer
    Dim sitemname As String
    
    For ipropertycount = 1 To oDocumentProperties.Count
       sitemname = oDocumentProperties.Item(ipropertycount).Name
    
       If sitemname = sPropertyName Then
          oDocumentProperties.Item(ipropertycount).Delete
          Exit Sub
       End If
    Next ipropertycount
    
    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Property_CustomExists

Public Function Property_CustomExists( _
    ByVal sPropertyName As String, _
    Optional ByVal bInformUser As Boolean = False, _
    Optional ByVal sWbkName As String = "") As Boolean

Const sPROCNAME As String = "Property_CustomExists"
Dim ipropertycount As Integer
Dim oDocumentProperties As Office.DocumentProperties
      
    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    If (Len(sWbkName) = 0) Then sWbkName = ActiveWorkbook.Name
    Set oDocumentProperties = Workbooks(sWbkName).CustomDocumentProperties
    
    For ipropertycount = 1 To oDocumentProperties.Count
        If oDocumentProperties.Item(ipropertycount).Name = sPropertyName Then
            Property_CustomExists = True
            Exit Function
        End If
    Next ipropertycount

    If (bInformUser = True) Then
        'Call modMessages.Message_PropertyCustomDoesNotExist(sPropertyName)
    End If
    
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Property_CustomGet

Public Function Property_CustomGet( _
    ByVal sPropertyName As String, _
    Optional ByVal vDefaultValue As Variant = "") As Variant
    
Const sPROCNAME As String = "Property_CustomGet"
Dim oDocumentProperties As Office.DocumentProperties

    On Error GoTo ErrorHandler
    
    Set oDocumentProperties = ActiveWorkbook.CustomDocumentProperties
    
    If Property_CustomExists(sPropertyName) = True Then
        Property_CustomGet = oDocumentProperties.Item(sPropertyName).Value
    Else
        Property_CustomGet = vDefaultValue
    End If
    
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Property_CustomSet

Public Function Property_CustomSet( _
    ByVal sPropertyName As String, _
    ByVal spropertyvalue As String, _
    Optional ByVal sWbkName As String = "")

Const sPROCNAME As String = "Property_CustomSet"
Dim ipropertycount As Integer
Dim sitemname As String
Dim oDocumentProperties As Office.DocumentProperties

    On Error GoTo ErrorHandler
    
    If (Len(sWbkName) = 0) Then sWbkName = ActiveWorkbook.Name
    Set oDocumentProperties = Workbooks(sWbkName).CustomDocumentProperties
    
    For ipropertycount = 1 To oDocumentProperties.Count
        sitemname = oDocumentProperties.Item(ipropertycount).Name
        
        If sitemname = sPropertyName Then
            oDocumentProperties.Item(ipropertycount).Value = spropertyvalue
            Exit Function
        End If
    Next ipropertycount
      
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Wbk_Close

Public Sub Wbk_Close(iNoOfWbks As Integer, _
                     bSave As Boolean, _
                     Optional sWbkName As String = "")
Const PROCNAME As String = "Wbk_Close"
Dim icount As Integer
   On Error GoTo ErrorHandler
   If sWbkName <> "" Then Workbooks(sWbkName).Activate
   For icount = 1 To iNoOfWbks                     
      If Workbooks.Count > 0 Then
         Application.StatusBar = "Closing the file : " & ActiveWorkbook.Name & " ..."
         ActiveWorkbook.Close savechanges:=bSave                  
      Else
         GoTo ErrorHandler
      End If
   Next icount
   Application.StatusBar = False
   Exit Sub       
ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 1, "", "NO")
End Sub

Wbk_GetAllWshs

Public Function Wbk_GetAllWshs(ByVal sWbkName as String, _
                               ByVal sFolderPath As String) As String
Dim sallwshs As String

   On Error GoTo ErrorHandler
   If Wbk_Open(sFolderPath, _
               sWbkName, 0, "", "", True) = True Then
      sallwshs = Wbk_GetAllWsh
      ActiveWorkbook.Close (False)                   
   End If
   GetAllWshs = sallwshs
   Exit Function

ErrorHandler:
End Function

Wbk_GetFolderPath

Public Function GetWorkbookDirectory() As String
Dim sFolderPath As String
Dim sLatestDirectory As String
Dim sDay As String
Dim sMonth As String
Dim sYear As String

   On Error GoTo ErrorHandler
   sLatestDirectory = ""
   sFolderPath = Dir(ThisWorkbook.Path & "\*", vbDirectory)
   Do Until sFolderPath = ""
      If (GetAttr(ThisWorkbook.Path & "\" & sFolderPath) And _
         vbDirectory <> 0) And _
         IsNumeric(sFolderPath) Then
         If sFolderPath > sLatestDirectory Then
            sLatestDirectory = sFolderPath
         End If
      End If
      sFolderPath = Dir
   Loop
   GetWorkbookDirectory = ThisWorkbook.Path & "\" & sLatestDirectory & "\"
   Exit Function
ErrorHandler:
End Function

Wbk_IsActive

Public Function Wbk_IsActive( _
Optional bInformUser As Boolean = False) As Boolean
    
Dim sWbkName As String

    On Error GoTo ErrorHandler
   
    sWbkName = Application.ActiveWorkbook.Name
    Wbk_IsActive = True

    Exit Function
ErrorHandler:
    'Call modMessages.Message_NoWorkbooksOpen(bInformUser)
    Wbk_IsActive = False
End Function

Wbk_IsOpen

Public Function Wbk_IsOpen(sFileName As String, _
                           Optional bInformUser As Boolean = False) As Boolean
Const PROCNAME As String = "Wbk_IsOpen"
Dim iwkbcount As Integer
Dim sWkbName As String

   On Error GoTo ErrorHandler
   For iwkbcount = 1 To Workbooks.Count
      If sFileName = Workbooks(iwkbcount).Name Then
         Wbk_IsOpen = True
         If bInformUser = True Then _
            Call MsgBox("The File : """ & sFileName & """ is already open")
      Else
         Wbk_IsOpen = False
      End If
   Next iwkbcount
   Exit Function
ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "", "NO")
End Function

Wbk_Open

Public Function Wbk_Open( _
         ByVal sFolderPath As String, _
         ByVal sFileName As String, _
Optional ByVal iUpdateLinks As Integer = 3, _
Optional ByVal sAdditional As String = "", _
Optional ByVal sExtension As String = ".xlsx", _
Optional ByVal bInformUser As Boolean = False) As Boolean

Const PROCNAME As String = "Wbk_Open"
   On Error GoTo ErrorHandler
              
   Application.StatusBar = "Opening the file : " & _
                            sFolderPath & sFileName & sAdditional & sExtension & " ..."
   Workbooks.Open(FileName:=sFolderPath & sFileName & sAdditional & sExtension, _
         UpdateLinks:=iUpdateLinks).RunAutoMacros Which:=xlAutoOpen
   Wbk_Open = True                        
   Application.StatusBar = False

   Exit Function                                       
ErrorHandler:
   If bInformUser = True Then _
      Call MsgBox("Cannot Open file : " & vbCrLf & _
                  """" & sFolderPath & sFileName & """")
   Wbk_Open = False                              'assigns false as open was unsuccessful
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "WB7", "NO")
End Function

Wbk_OpenAndCheck

Public Function Wbk_OpenAndCheck(sFolderPath As String, _
                                 sWbkName As String, _
                                 Optional sExtension As String = ".xls", _
                                 Optional bInformUser As Boolean = False) As Boolean
Const PROCNAME As String = "Wbk_OpenAndCheck"
Dim bcontinue As Boolean
   On Error GoTo AnError
   bcontinue = True
   If sWbkName = "" Then bcontinue = False
   sFolderPath = Folder_AddLine(sFolderPath)                      'check there is a slash
   sWbkName = File_AddExt(sWbkName, sExtension)              'check there is an extension
   If bcontinue = True Then _
      bcontinue = Folder_Exists(sFolderPath, bInformUser)            'check folder exists
   If bcontinue = True Then _
      bcontinue = File_Exists(sFolderPath, sWbkName, bInformUser)      'check file exists
   If bcontinue = True Then _
      bcontinue = Not Wbk_IsOpen(sWbkName, bInformUser)           'check file is not open
   If bcontinue = True Then _
      bcontinue = Wbk_Open(sFolderPath, sWbkName, 0, "", "", bInformUser)
   Wbk_OpenAndCheck = bcontinue                         'return whether successful or not
   Exit Function
AnError:
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "", "NO")
End Function

Wbk_ReturnNewName

Public Function Wbk_ReturnNewName() As String
Const PROCNAME As String = "Wbk_ReturnNewName"
Dim aWorkbookNames() As String                                 'declare the dynamic array
Dim icount As Integer
Dim iwbkcount As Integer
Dim bfound As Boolean

   On Error GoTo ErrorHandler
   ReDim aWorkbookNames(1)                                      'initialise the size to 0
   icount = 0: bfound = False
   For iwbkcount = 1 To Workbooks.Count
      icount = icount + 1
      ReDim Preserve aWorkbookNames(icount)
      aWorkbookNames(icount) = Workbooks(iwbkcount).Name
   Next iwbkcount
   Workbooks.Add                                                      'add a new workbook
   For iwbkcount = 1 To Workbooks.Count
      bfound = False
      For icount = 1 To UBound(aWorkbookNames)
          If aWorkbookNames(icount) = Workbooks(iwbkcount).Name Then
              bfound = True
              Exit For
          End If
      Next icount
      If bfound = False Then                           'the workbook was not in the array
          Wbk_ReturnNewName = Workbooks(iwbkcount).Name
          Exit For
      End If
   Next iwbkcount
   Exit Function
ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "", "NO")
End Function

Wbk_WshsAllToString

Public Function Wbk_WshsAllToString(Optional sWbkName As String = "") As String
Const sPROCNAME As String = "Wbk_WshsAllToString"
Dim sallwshs As String
Dim wshname As Worksheet
   On Error GoTo ErrorHandler
   
   sallwshs = ""
   For Each wshname In ActiveWorkbook.Worksheets
      sallwshs = sallwshs & ";" & wshname.Name
   Next wshname
   Wbk_GetAllWsh = Right$(sallwshs, Len(sallwshs) - 1)

   Exit Function
ErrorHandler:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1, _
        "")
End Function

Wbk_WshsUnhideAll

Public Sub Wbk_WshsUnhideAll()
   For Each ws In ActiveWorkbook.Sheets
      ws.Visible = True
   Next ws
End Sub