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 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).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( _
         ByVal iNoOfWbks As Integer, _
         ByVal bSave As Boolean, _
Optional ByVal sWbkName As String = "")

Const sPROCNAME As String = "Wbk_Close"

Dim icount As Integer

   On Error GoTo ErrorHandler

   If sWbkName <> "" Then 
      Workbooks(sWbkName).Activate
   End If

   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, sPROCNAME, 1, "", "NO")
End Sub

Wbk_GetAllWsh

Public Function Wbk_GetAllWsh( _
Optional ByVal sWbkName As String = "") _
         As String

Const sPROCNAME As String = "Wbk_GetAllWsh"

Dim sallwshs As String
Dim wshname As Worksheet

   On Error GoTo AnError
   
   sallwshs = ""
   For Each wshname In ActiveWorkbook.Worksheets
      sallwshs = sallwshs & ";" & wshname.Name
   Next wshname
   Wbk_GetAllWsh = Right(sallwshs, Len(sallwshs) - 1)

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

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( _
         ByVal sFileName As String, _
Optional ByVal bInformUser As Boolean = False) _
         As Boolean

Const sPROCNAME 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")
         End If
      Else
         Wbk_IsOpen = False
      End If
   Next iwkbcount
   Exit Function
ErrorHandler:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 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 sPROCNAME 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, sPROCNAME, 2, "WB7", "NO")
End Function

Wbk_OpenAndCheck

Public Function Wbk_OpenAndCheck( _
         ByVal sFolderPath As String, _
         ByVal sWbkName As String, _
Optional ByVal sExtension As String = ".xls", _
Optional ByVal bInformUser As Boolean = False) _
         As Boolean

Const sPROCNAME 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, sPROCNAME, 2, "", "NO")
End Function

Wbk_ReturnNewName

Public Function Wbk_ReturnNewName() _
         As String

Const sPROCNAME 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, sPROCNAME, 2, "", "NO")
End Function

Wbk_WshsAllToString

Public Function Wbk_WshsAllToString( _
Optional ByVal 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()

Dim ws As Excel.Worksheet

   For Each ws In ActiveWorkbook.Sheets
      ws.Visible = True
   Next ws

End Sub