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(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