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

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_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(sFolderPath As String, _
                         sFileName As String, _
                         Optional iUpdateLinks As Integer = 3, _
                         Optional sAdditional As String = "", _
                         Optional sExtension As String = ".xls", _
                         Optional 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