'Module:        ComExcel
'Purpose:       Common Excel procedures
'VB Version:    Excel 97 SR-1
'Written by:    David Crawford
'
Option Explicit
'
'Purpose:   Add a menu item to Prepare menu
'Arguments: <MenuItem> Menu item to add to menu
'           <Action> Action performed by menu item
'
Function AddMenuItem(MenuItem As String, Optional Action As String)

    Dim Found As Boolean
    Dim Menu As Object
    Dim Item As Object
    
    'check if item to be added is already on Prepare menu
    Found = False
    Set Menu = CommandBars.ActiveMenuBar.Controls.Item("Prepare").Controls
    For Each Item In Menu
    
        'if item exists set Found to true and exit loop
        If Item.Caption = MenuItem Then
            Found = True
            Exit For
        End If
    
    Next Item
    
    'if item does not exist add it
    If Found = False Then
    
        Set Menu = CommandBars.ActiveMenuBar.Controls.Item("Prepare")
        Set Item = Menu.Controls.Add(Type:=msoControlButton, Temporary:=True)
        Item.Caption = MenuItem
        Item.OnAction = Action
        
    End If
    
End Function
'
'Purpose:   Convert row and column coordinates to A1 address string
'Examples:  ConvertRCToA1(1,1) -> "A1"
'           ConvertRCToA1(30000,27) -> "AA30000"
'
Function ConvertRCToA1( _
     Row As Long, _
     Column As Integer) As String

    Dim AddressA1 As String
    
    'if column is greater than 26 address get first letter
    If Column > 26 Then
        AddressA1 = Chr$(Int(Column / 26) + 64)
    End If
    
    'get letter and row
    AddressA1 = AddressA1 & Chr$((Column - Int(Column / 26) * 26) + 64)
    AddressA1 = AddressA1 & Trim$(Str$(Row))
    ConvertRCToA1 = AddressA1
    
End Function
'
'Purpose:   Create an empty Excel workbook and save it.
'Arguments: <WorkbookName> Name of workbook with .xls extension
'Examples:  CreateEmptyWorkbook("DeleteMe.xls") -> True | False
'
Function CreateEmptyWorkbook(WorkbookName As String) As Boolean
On Error GoTo HandleErrors

    Dim NewWorkbookName As String
        
    'create a new Excel workbook
    Workbooks.Add
    NewWorkbookName = ActiveWorkbook.Name
    ActiveWorkbook.SaveAs FileName:=WorkbookName, FileFormat:=xlNormal
    Workbooks(WorkbookName).Close
    
    'return true
    CreateEmptyWorkbook = True
    
ExitProcedure:

    Exit Function
    
HandleErrors:

    'close workbook and return false
    Workbooks(NewWorkbookName).Close
    CreateEmptyWorkbook = False
    Resume ExitProcedure
        
End Function
'
'Purpose:   Return true if an address is in A1 format and is relative.
'Examples:  IsAddressA1Relative("A1") -> True
'           isAddressA1Relative("A$1$") -> False
'
Function IsAddressA1Relative(AddressVariant As Variant) As Boolean
On Error GoTo HandleErrors

    Dim AddressString As String
    Dim PositionFirstNumber As Integer
    Dim Column As String
    Dim Row As String
    
    'convert variant to string
    AddressString = CStr(AddressVariant)
    
    'split column and row
    PositionFirstNumber = GetPositionAnyCharacter(AddressString, "123456789")
    Column = Left$(AddressString, PositionFirstNumber - 1)
    Row = Mid$(AddressString, PositionFirstNumber)
    
    'if column has one letter
    If Len(Column) = 1 Then
    
        'if column is not A-Z then return false and exit function
        If IsCharacterLetter(Column) = False Then
            IsAddressA1Relative = False
            Exit Function
        End If
        
    'if column has two letters
    ElseIf Len(Column) = 2 Then
    
        'if first letter is A-H
        If IsCharacterLetter(Left$(Column, 1), "A", "H") Then
        
            'if second letter is not A-Z return false and exit function
            If Not IsCharacterLetter(Mid$(Column, 2), "A", "Z") Then
                IsAddressA1Relative = False
                Exit Function
            End If
            
        'if first letter is I
        ElseIf Left$(Column, 1) = "I" Then
        
            'if second letter is not A-V  then return false and exit function
            If Not IsCharacterLetter(Mid$(Column, 2, 1), "A", "V") Then
                IsAddressA1Relative = False
                Exit Function
            End If
        
        'else column is higher than IV return false and exit function
        Else
            IsAddressA1Relative = False
            Exit Function
        End If
        
    'else there are more than two letters return false and exit function
    Else
        IsAddressA1Relative = False
        Exit Function
    End If
    
    'if row is not a number then return false and exit function
    If ValidateString(Row, "1234567890") = False Then
        IsAddressA1Relative = False
        Exit Function
    End If
    
    'if row is not 1 to 65536 then return false and exit function
    If Val(Row) < 1 Or Val(Row) > 65536 Then
        IsAddressA1Relative = False
        Exit Function
    End If
      
    'address is valid return true
    IsAddressA1Relative = True
    
ExitProcedure:

    Exit Function

HandleErrors:

    IsAddressA1Relative = False
    Resume ExitProcedure
    
End Function
'
'Purpose:   Returns true if menu exists on xlWorksheet menubar
'Arguments: <MenuCaption> Caption of Menu must include & in front of letters
'           with underscores eg &File.
'Examples:  IsMenu("&File") -> True | False
'
Function IsMenu(MenuCaption As String) As Boolean
On Error GoTo HandleErrors

    Dim MenuBar As Object
    Dim MenuIndex As Integer
    Dim MenuCount As Integer
    
    'get menu bar object
    Set MenuBar = Application.MenuBars(xlWorksheet).Menus

    'for each menubar item
    MenuCount = MenuBar.Count
    For MenuIndex = 1 To MenuCount - 1
    
        'if menu exist return true and exit function
        If MenuBar(MenuIndex).Caption = MenuCaption Then
            IsMenu = True
            Exit Function
        End If
        
    Next MenuIndex
    
    'Menu does not exist return false
    IsMenu = False
    
ExitProcedure:
    Exit Function
    
HandleErrors:
    MsgErr "IsMenu", Err
    Resume ExitProcedure
    
End Function
'
'Purpose:   Check if range exists in a workbook
'Examples:  IsRange(Workbook, RangeName)
'
Function IsRange( _
    Workbook As Object, _
    SheetName As String, _
    RangeName As String)
    
On Error GoTo HandleErrors

    Dim RangeObject As Range

    Set RangeObject = Workbook.Sheets(SheetName).Range(RangeName)

    IsRange = True
    
ExitProcedure:

    Exit Function
    
HandleErrors:

    IsRange = False
    Resume ExitProcedure
    
End Function
'
'Purpose:   Check if specified sheet is in specified workbook
'Examples:  IsSheet(MyWorkbook, "Sheet1") -> True | False
'
Function IsSheet(Workbook As Object, SheetName As String)

    Dim Sheet As Object
    
    'make sheet name upper case so match is not case sensitive
    SheetName = UCase$(SheetName)
    
    'for each sheet in workbook
    For Each Sheet In Workbook.Sheets
    
        'if sheet exist return true and exit function
        If UCase$(UCase(Sheet.Name)) = SheetName Then
            IsSheet = True
            Exit Function
        End If
        
    Next
    
    'sheet does not exist return false
    IsSheet = False

End Function
'
'Purpose:   Return true specified workbook is open
'Examples:  IsWorkbookOpen("Book1")
'
Function IsWorkbookOpen(WorkbookName As String)

    Dim WorkbookIndex As Integer
    Dim WorkbookCount As Integer
 
    'for each open workbook
    WorkbookCount = Workbooks.Count
    For WorkbookIndex = 1 To WorkbookCount
        
        'if workbook is open return true and exit function
        If UCase(Workbooks(WorkbookIndex).Name) = UCase(WorkbookName) Then
            IsWorkbookOpen = True
            Exit Function
        End If
        
    Next
    
    'workbook not open return false
    IsWorkbookOpen = False
    
End Function
'
'Purpose:   Unfreeze all sheets
'
Sub UnfreezeAllSheets()

    Dim Sheet As Object
    
    For Each Sheet In Workbooks(WORKBOOK_NAME).Sheets
        Sheet.Activate
        ActiveWindow.FreezePanes = False
    Next Sheet

End Sub
'
'Purpose:   Unprotect all sheets
'
Sub UnprotectAllSheets()

    Dim Sheet As Object
    
    For Each Sheet In Workbooks(WORKBOOK_NAME).Sheets
        Sheet.Unprotect
    Next Sheet


End Sub