VBA 消息框选择要附加的 XLA 文件

Question

因此，我们有一个遗留电子表格，不会很快消失。我维护了其中两个，因为有时我们需要不同的代码来导入作业。打开该工作表后，它会附加一个名为 Shipper.xla 的工作表或附加到第二个工作表 Shipper_Project.xla。

我只想在工作簿上根据作业处理两个 XLA 文件...因此在附加之前，我创建了一个 MsgBox 来询问它是否是项目作业？如果是，则附加 Shipper_Project.xla，如果否，则附加 Shipper.xla。如果我点击“是”，它可以工作，但仍然附加 Shipper.xla。

    result = MsgBox("Is This An MBS Project Job?", vbYesNo)
    If result = vbYes Then AttachXLAProject
    If result = vbNo Then AttachXLA

    Sub AttachXLAProject()
    With CreateObject("WScript.NetWork")
        If UCase(.UserDomain) = "PINNSTR" Then
            strFilePath = "\\fileserver\Utility$\Internal\ShipperProjectCode\Shipper_Project.xla"
        Else
            strFilePath = "\\OMAAC-Server\Pinnacle\Shipper\Shipper.xla"
        End If
        ActiveWorkbook.VBProject.References.AddFromFile strFilePath
    End With
End Sub

Sub AttachXLA()
    With CreateObject("WScript.NetWork")
        If UCase(.UserDomain) = "PINNSTR" Then
            strFilePath = "\\fileserver\Utility$\Internal\ShipperCode 3.0\Shipper.xla"
        Else
            strFilePath = "\\OMAAC-Server\Pinnacle\Shipper\Shipper.xla"
        End If
        ActiveWorkbook.VBProject.References.AddFromFile strFilePath
    End With
End Sub

现在，理论上，我可以将它们命名为shipper.xla，因为它们保存在文件服务器的不同部分，但我仍然需要在开始时进行选择。我尝试过 ElseIf 和 EndIf，但由于某种原因它只会让情况变得更糟。

有什么建议吗？

Answer 1

选择插件

• 确保加载项具有不同的名称。而且，他们不能被称为

  VBAProject

  。
• 如果（意外）添加了其他加载项，这也将删除它。

Private Sub Workbook_Open()
    ChooseAddin Me
End Sub

在打开的工作簿中进行测试

Sub Tester()
    ChooseAddin ThisWorkbook
End Sub

主要

Sub ChooseAddin(wb As Workbook)
    Dim Result As Long: Result = MsgBox("Is This An MBS Project Job?", vbYesNo)
    If Result = vbYes Then AttachXLAProject wb Else AttachXLA wb
End Sub

帮助

Sub AttachXLAProject(wb As Workbook)
    Dim FilePaths() As Variant: FilePaths = VBA.Array( _
        "\\fileserver\Utility$\Internal\ShipperProjectCode\Shipper_Project.xla", _
        "\\OMAAC-Server\Pinnacle\Shipper\Shipper.xla")
    AttachAddin wb, FilePaths
End Sub

Sub AttachXLA(wb As Workbook)
    Dim FilePaths() As Variant: FilePaths = VBA.Array( _
        "\\fileserver\Utility$\Internal\ShipperCode 3.0\Shipper.xla", _
        "\\OMAAC-Server\Pinnacle\Shipper\Shipper.xla")
    AttachAddin wb, FilePaths
End Sub

Sub AttachAddin(wb As Workbook, FilePaths As Variant)
    
    Dim refs As Object: Set refs = wb.VBProject.References
    
    Dim ref As Object, Index As Long, i As Long
    
    With CreateObject("WScript.NetWork")
        Index = UCase(.UserDomain) = "PINNSTR" + 1
        For i = 0 To UBound(FilePaths)
            If i = Index Then
                AddReferenceByPath wb, FilePaths(i)
            Else
                RemoveReferenceByPath wb, FilePaths(i)
            End If
        Next i
    End With

End Sub

Sub AddReferenceByPath(wb As Workbook, ByVal Path As String)
    Const PROC_TITLE As String = "Add Reference By Path"
    
    Dim refs As Object: Set refs = wb.VBProject.References
    
    Dim ref As Object
    
    For Each ref In refs
        If StrComp(ref.FullPath, Path, vbTextCompare) = 0 Then Exit Sub ' exists
    Next ref
    
    On Error GoTo ClearError
    Set ref = refs.AddFromFile(Path)

ProcExit:
    Exit Sub
ClearError:
    MsgBox "Could not add a reference to """ & Path & """!" & vbLf & vbLf _
        & "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub

Sub RemoveReferenceByPath(wb As Workbook, ByVal Path As String)
    Const PROC_TITLE As String = "Remove Reference By Path"
    
    Dim refs As Object: Set refs = wb.VBProject.References
    
    Dim ref As Object
    
    For Each ref In refs
        If StrComp(ref.FullPath, Path, vbTextCompare) = 0 Then Exit For
    Next ref
    
    If Not ref Is Nothing Then ' reference found
        On Error GoTo ClearError
        refs.Remove ref
    'Else ' reference not found
    End If

ProcExit:
    Exit Sub
ClearError:
    MsgBox "Could not remove the reference to """ & Path & """!" & vbLf & vbLf _
        & "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub