使用VBA将VBA模块从Access项目导出到Excel项目

Posted 2021-04-19

我的任务是创建一个基于VBA的系统，允许我将部门特定的文档注释代码插入到基于VBA的程序中，然后稍后提取这些日期。该程序通过将2个VBA模块临时插入目标项目来完成此操作。然后运行包含的函数。这个功能正常，并且使用VBA插入/提取注释。

但是，我发现自己因为基于访问的插入项目将模块插入基于excel的项目而感到茫然。我一直在使用这个函数将模块导入目标访问项目：

Public Function InsertVADER(strTestPath As String, ProgramType As String) As Boolean
'//Insert VADER into the target program
On Error GoTo errjordan

Dim obj As AccessObject '//Create instance of Access Application object.

If ProgramType = "Access" Then


    ''//Transfer Modules to target project.

    For Each obj In CurrentProject.AllModules
       DoCmd.TransferDatabase acExport, "Microsoft Access", strTestPath, acModule, obj.Name, obj.Name & "_TMP", False
    Next obj

    '//Set and open target project
    Set appAccess = CreateObject("Access.Application")
    appAccess.OpenCurrentDatabase strTestPath, False

    '//SEt to visible. If the project has an auto exec that will usurp this project. You will
    appAccess.Visible = True


    '//Open the vader module. If there is an auto run macro this will cause it to show
    appAccess.DoCmd.OpenModule ("VADER_TMP")
ElseIf ProgramType = "Excel" Then
    '//Run Excel routine
    For Each obj In CurrentProject.AllModules
       'DoCmd.TransferDatabase acExport, "Microsoft Excel", strTestPath, acModule, obj.Name, obj.Name & "_TMP", False

    Next obj





End If


'//Indicate function sucess
InsertVADER = True

Exit Function   'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
errjordan:

If Err.Number = 2501 Then
    MsgBox "Project cannot be locked for viewing. Please unlock and save project before using this tool"
    Err.Clear
    InsertVADER = False
ElseIf Err.Number = 29045 Or Err.Number = 7866 Then
    MsgBox "This file is not compatible with VADER. Please convert the project to a useable format before using this tool."
    Err.Clear
    InsertVADER = False
Else
    Err.Raise Err.Number
End If


End Function

StrtestPath传递目标项目的文件路径，programtype指定我选择的项目类型。两者都设置在外部项目中。

是否有基于VBA的解决方案，允许我：

1. 将CurrentProject.allModules定义的模块从access导入到目标Excel项目中 运行后从目标Excel项目中删除模块

答案

感谢@chrisneilsen评论中提供的链接，我提出了一个解决方案，可以完成我们的目标。解决方案是在excel项目中创建一个空白的模块，然后将位于访问模块中的VBE行作为字符串导入到这个新的Excel模块中。

这是代码片段，以防其他人遇到此问题：

Dim vbProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim codemod As VBIDE.CodeModule

Public Function InsertVADER(strTargetPath As String, ProgramType As String, strRunFunction As String) As Boolean
if programtype = "Excel" then
    '//Run Excel routine. This version is slightly more complex as the module cannot be transfered from Access to excel as a singluar object

    '//Create an instance of an Excel application object
    Set appExcel = CreateObject("Excel.Application")

    '//Open the target workbook
    appExcel.workbooks.Open (strTargetPath)
    appExcel.Visible = True

    '//If there is an on load item for excel then it will need
    Set vbProj = appExcel.ActiveWorkbook.VBProject

RetryEX:        '//If the project is locked you will exit the error capture here for excel


    Debug.Print appExcel.VBE.VBProjects(1).VBComponents.Count

    '//Add modules to the excel project
    Set VBComp = vbProj.VBComponents.Add(vbext_ct_StdModule)
        VBComp.Name = "VADER_TMP"

    Set VBComp = vbProj.VBComponents("VADER_TMP")
    Set codemod = VBComp.CodeModule

    '//Capture the code in the VADER modules located in this project
    Dim strVADER As String

    LoopCount = 1
    lngLineCount = 1
    Do Until lngLineCount > Application.VBE.VBProjects(1).VBComponents("VADER").CodeModule.CountOfLines
        strVADER = strVADER & Application.VBE.VBProjects(1).VBComponents("VADER").CodeModule.Lines(lngLineCount, 1) & vbNewLine

        lngLineCount = lngLineCount + 1
    Loop

    '//Insert the captured VADER code into the Excel module
    codemod.InsertLines 1, strVADER

    '//Do the same thing with runVADER
    Set VBComp = vbProj.VBComponents.Add(vbext_ct_StdModule)
        VBComp.Name = "runVADER_TMP"

    Set VBComp = vbProj.VBComponents("runVADER_TMP")
    Set codemod = VBComp.CodeModule

    strVADER = vbNullString
    LoopCount = 1
    lngLineCount = 1
    Do Until lngLineCount > Application.VBE.VBProjects(1).VBComponents("runVADER").CodeModule.CountOfLines
        strVADER = strVADER & Application.VBE.VBProjects(1).VBComponents("runVADER").CodeModule.Lines(lngLineCount, 1) & vbNewLine

        lngLineCount = lngLineCount + 1
    Loop

    codemod.InsertLines 1, strVADER

    '//Call the function
    appExcel.Run strRunFunction

End If


'//Indicate function sucess
InsertVADER = True

Exit Function   'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
errjordan:

'//Captured error

If Err.Number = 2501 Then
    '//An access project locked for viewing
    MsgBox "Project cannot be locked for viewing. Please unlock the project and then press OK."
    Err.Clear
    Resume Next

ElseIf Err.Number = 50289 Then
    '//An excel document locked for viewing
    MsgBox "Workbook cannot be locked for viewing. Please unlock the project and then press OK."
    Err.Clear
    GoTo RetryEX

ElseIf Err.Number = 29045 Or Err.Number = 7866 Then
    '//Not excel or access
    MsgBox "This file is not compatible with VADER. Please convert the project to a useable format before using this tool."
    Err.Clear
Else
    '//Some other error!
    Err.Raise Err.Number
End If

InsertVADER = False '//If I'm here pass a failure code

End Function

删除仍然非常类似于访问：

Public Function RemoveVADER(strTargetPath As String, ProgramType As String)
'//Remove VADER from the project
    '//Target path is not used in the function but has been left in in case of future issues/expandability

If ProgramType = "Access" Then
    Set vbcom = appAccess.VBE.ActiveVBProject.VBComponents
    vbcom.Remove VBComponent:=vbcom.Item("VADER_TMP")
    vbcom.Remove VBComponent:=vbcom.Item("runVADER_TMP")

    '//Close the target program and save changes
    appAccess.Quit acQuitSaveAll

ElseIf ProgramType = "Excel" Then
    Set vbProj = appExcel.ActiveWorkbook.VBProject
    Set VBComp = vbProj.VBComponents("VADER_TMP")
    vbProj.VBComponents.Remove VBComp
    Set VBComp = vbProj.VBComponents("runVADER_TMP")
    vbProj.VBComponents.Remove VBComp

    '//Close the target program and save changes
    appExcel.ActiveWorkbook.Save
    appExcel.Quit
End If

End Function