Demo entry 6870092

vba

   

Submitted by anonymous on Aug 21, 2019 at 11:10
Language: VB.net. Code size: 8.2 kB.

Option Explicit
'==================================================================================================
' General code for adding reference to IG-XL (taken from ASCIIUtils)
'==================================================================================================
Public Function AddReference(AddInFileName As String, _
                             Optional AddInProjectName As String) As Long
 
    Dim wb As Workbook                      '<- Workbook object
    Dim wbName As String                    '<- Workbook name
    Dim NewFullPath As String               '<- Fully rooted name of AddIn
    Dim RefType As String                   '<- Type of reference (XLA, etc)
    Dim AddInName As String                 '<- AddIn name (not the file name)
    Dim AddInList As String                 '<- <AddInName> , <AddinProjectName>
    Dim AddInNameArray As Variant           '<- Array of AddIn name, project name
    Dim name As Variant
    Dim DebugAddRef As Boolean              '<- Debug flag (True enables debug)
    Dim fs As Object                        '<- FileSystem object
    Dim RefIdx As Long                      '<- Workbook reference index
    
    '___ Init ______________________________________________________________________________________
    DebugAddRef = False
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo reference_err
    
    '___ Get info about current workbook and the AddIn _____________________________________________
    wbName = Application.ActiveWorkbook.name
    AddInName = fs.GetBaseName(AddInFileName)
    RefType = UCase(fs.GetExtensionName(AddInFileName))
    NewFullPath = fs.GetAbsolutePathName(AddInFileName)
    AddInList = AddInName + "," + AddInProjectName
    AddInNameArray = Split(AddInList, ",")
    
    '___ Now add the reference to the workbook _____________________________________________________
    Set wb = Workbooks(wbName)
    With wb.VBProject
    
        For Each name In AddInNameArray
            
            '___ Exit if no name ___________________________________________________________________
            If (name = "") Then
                Exit For
            End If
            
            '___ See if the reference already exist in the workbook ________________________________
            '    First look for the AddInName (w/o ext) anywhere in the existing reference full path
            '    If that exist see if the path is the same
            '    If different then
            '       - remove existing reference (same as unclecking in Tools->References
            '       - and replace with new one
            '    If the same then
            '       - If AddIn is XLA then run its Workbook_Open event function
            '---------------------------------------------------------------------------------------
            For RefIdx = 1 To .References.Count
                
                If (InStr(1, UCase(.References(RefIdx).FullPath), UCase(name))) Then
                    
                    If (UCase(NewFullPath) <> UCase(.References(RefIdx).FullPath)) Then
                        '___ Debug message _________________________________________________________
                        If (DebugAddRef) Then
                            Call TheExec.ErrorLogMessage("Updating Add-In: " + AddInName + vbCrLf + _
                                                         "New Path: " + NewFullPath + vbCrLf + _
                                                         "Old Path: " + .References(RefIdx).FullPath)
                        End If
                        
                        On Error GoTo RemoveRefError
                        
                        '___ Remove the reference and if XLA close the workbook _____________________
                        .References.Remove .References(RefIdx)
                        
                        If (RefType = "XLA") Then
                            '___ Debug message ______________________________________________________
                            If (DebugAddRef) Then
                                Call TheExec.ErrorLogMessage("Closing XLA File from VB Editor " + AddInName)
                            End If
                            
                            Workbooks(AddInName + ".xla").Close
                        End If
                        
                    '___ Reference already exist with same path - run XLA workbook_open _____________
                    Else
                        '___ Debug message __________________________________________________________
                        If (DebugAddRef) Then
                            Call TheExec.ErrorLogMessage("Reference to: " + NewFullPath + _
                                                         " already exits in VBA Project: " + wbName)
                        End If
                        
                        If (RefType = "XLA") Then
                                ' Fire the Workbook_Open event________________________________________
                                ' Makes sure it is executed even if loading from .xls
                                ' Ignore error incase it does not have Workbook_Open
                                '---------------------------------------------------------------------
                                On Error Resume Next
                                Application.Run "'" & AddInName + ".xla" & "'!thisworkbook.workbook_open"
                        End If
                        
                        '___ If it already existed with same path then done __________________________
                        Exit Function
                       
                    End If
                    
                    Exit For
                    
                End If      '<- If reference existed with same name
                
            Next RefIdx     '<- Check the next workbook reference
            
        Next name           '<- Check for the optional project
        
        '___ If a new path to AddIn the add the reference from the new path _________________________
        On Error GoTo AddFromFileErr
        If (DebugAddRef) Then
            Call TheExec.ErrorLogMessage("Adding a Reference to: " + NewFullPath + " to VBProject: " + wbName)
        End If
        .References.AddFromFile NewFullPath
 
        '___ Iff XLA AddIn then call its Workbook_Open (ignore error if it does not exist) ___________
        On Error Resume Next
        If (RefType = "XLA") Then Application.Run "'" & AddInName + ".xla" & "'!thisworkbook.workbook_open"
            
    End With        '<- Workbook
 
    Exit Function
 
 
'___ Error handling ___________________________________________________________________________________
reference_err:
    Call TheExec.ErrorLogMessage("In Function: " + "AddReference()" + ": " + vbNewLine + vbNewLine + _
        "Error: " + CStr(Err.Number) + " : " + Err.Description + vbNewLine + vbNewLine + _
        "Could not add Reference: " + NewFullPath + vbNewLine + vbNewLine + _
        "Verify that Referenced File: " + NewFullPath + " exists" + vbNewLine + vbNewLine + _
        "May also need to check for errors within this function")
    Call TheExec.ErrorReport
    Exit Function
 
RemoveRefError:
    MsgBox ("Error Removing Existing Reference" + AddInFileName + vbCrLf + _
            CStr(Err.Number) + ":" + Err.Description)
    On Error GoTo 0
    Resume Next
    
AddFromFileErr:
    Select Case Err.Number
        Case 32813
            AddReference = 1 ' we have been already there, now it's really added
        Case Else
            AddReference = 0
            GoTo reference_err
    End Select
    On Error GoTo 0
    Resume Next   ' Resume execution at line after error.
    
ErrorClosingOldWorkBook:
    MsgBox ("Error Closing Existing WorkBook / Reference:  " + AddInName + vbCrLf + CStr(Err.Number) + ":" + Err.Description)
    Stop
    On Error GoTo 0
    Resume Next
    
End Function

This snippet took 0.01 seconds to highlight.

Back to the Entry List or Home.

Delete this entry (admin only).