代码操作代码 导入模块

opiona

附件内含 自定义函数: 获取文件清单, 星号显示的inputboxPWD



代码操作代码.rar (29.02 KB, 下载次数: 66)

2022-8-19 20:16 上传

点击文件名下载附件

1. Sub 批量导入模块()
   
2.    
   
3.     Rem BAS  模块
   
4.     Rem FRM 窗体
   
5.     Rem CLS 类模块  但是也代表sheet内代码导出文件, 现有代码不能导入: sheet代码
   
6.    
   
7.     Rem 获取要导入的模块,窗体,类模块文件
   
8.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False, "BAS,FRM,CLS", "") '//含子文件夹；文件路径
   
9.     For I = 0 To UBound(FileArr)
   
10.         Rem 如果存在就删除
    
11.         For Each mk In ThisWorkbook.VBProject.VBComponents
    
12.             If InStr(mk.Name, GetPathFromFileName(FileArr(I), False)) > 0 Then
    
13.                 ThisWorkbook.VBProject.VBComponents.Remove mk    '//删除这个模块
    
14.                 Exit For
    
15.             End If
    
16.         Next
    
17.         Rem 插入: 模块,窗体,类模块文件
    
18.         ThisWorkbook.Application.VBE.ActiveVBProject.VBComponents.Import FileArr(I)
    
19.     Next
    
20.    
    
21. End Sub

复制代码

opiona

改成下面这样 自动判断导入文件的类型  更稳妥些

1. Sub 批量导入模块()
   
2.     Rem BAS  模块
   
3.     Rem FRM 窗体
   
4.     Rem CLS 类模块  但是也代表sheet内代码导出文件, 现有代码不能导入: sheet代码
   
5.     Rem 获取要导入的模块,窗体,类模块文件
   
6.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False, "BAS,FRM,CLS", "") '//含子文件夹；文件路径
   
7.     For I = 0 To UBound(FileArr)
   
8.         Rem 如果存在就删除
   
9.         For Each mk In ThisWorkbook.VBProject.VBComponents
   
10.             If UCase(mk.Name) = UCase(GetPathFromFileName(FileArr(I), False)) Then
    
11.                 If mk.Type = 100 Then   '//sheet内代码导出文件
    
12.                     BL = False
    
13.                 Else
    
14.                     ThisWorkbook.VBProject.VBComponents.Remove mk    '//删除这个模块
    
15.                     BL = True
    
16.                 End If
    
17.                 Exit For
    
18.             End If
    
19.         Next
    
20.         Rem 插入: 模块,窗体,类模块文件
    
21.         If BL = True Then
    
22.             ThisWorkbook.Application.VBE.ActiveVBProject.VBComponents.Import FileArr(I)
    
23.         End If
    
24.     Next
    
25. End Sub

复制代码

opiona

再次迭代一下
Sheet的导出文件  使用文本文件导入代码

1. ''
   
2. '''*********************************
   
3. '''*******  北极狐工作室出品  ******
   
4. '''*******  QQ：14885553      ******
   
5. '''*********************************
   
6. 
   
7. Sub C_批量导入模块()
   
8.     Rem BAS  模块
   
9.     Rem FRM 窗体
   
10.     Rem CLS 类模块  但是也代表sheet内代码导出文件, 现有代码不能导入: sheet代码
    
11.     Rem 获取要导入的模块,窗体,类模块文件
    
12.     FileArr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name, True, False, "BAS,FRM,CLS", "") '//含子文件夹；文件路径
    
13.     If FileArr(0) <> "" Then
    
14.         For I = 0 To UBound(FileArr)
    
15.             Rem 如果存在就删除
    
16.             For Each MK In ThisWorkbook.VBProject.VBComponents
    
17.                 Rem 正在使用的几个模块不导入
    
18.                 If MK.Name <> "FUNCTIONS" And MK.Name <> "C_导入模块" And MK.Name <> "D_导出模块" Then
    
19.                     If UCase(MK.Name) = UCase(GetPathFromFileName(FileArr(I), False)) Then
    
20.                         If MK.Type = 100 Then   '//sheet内代码导出文件
    
21.                             MK.CodeModule.DeleteLines 1, MK.CodeModule.CountOfLines   '//按行删除
    
22.                             BL = False
    
23.                         Else
    
24.                             ThisWorkbook.VBProject.VBComponents.Remove MK    '//删除这个模块
    
25.                             BL = True
    
26.                         End If
    
27.                         Exit For
    
28.                     End If
    
29.                 End If
    
30.             Next
    
31.             
    
32.             If BL = True Then
    
33.                 Rem 直接导入: 模块,窗体,类模块文件
    
34.                 ThisWorkbook.Application.VBE.ActiveVBProject.VBComponents.Import FileArr(I)
    
35.             Else
    
36.                 Rem  sheet代码的导出文件 用文本文件打开  去掉不需要的内容
    
37.                 '''VERSION 1.0 CLASS
    
38.                 '''BEGIN
    
39.                 '''  MultiUse = -1  'True
    
40.                 '''End
    
41.                 '''Attribute VB_Name = "Sheet1"
    
42.                 '''Attribute VB_GlobalNameSpace = False
    
43.                 '''Attribute VB_Creatable = False
    
44.                 '''Attribute VB_PredeclaredId = True
    
45.                 '''Attribute VB_Exposed = True
    
46.                 '''
    
47.                 '''Sub A()
    
48.                 '''MsgBox "OK"
    
49.                 '''End Sub
    
50.                
    
51.                 Rem  目前办法比较Low
    
52.                 StrText = ""
    
53.                 BLB = FASLE '//判断  BEGIN 段落
    
54.                 INTX = 0
    
55.                 INTY = -1
    
56.                 Open FileArr(I) For Input As #1 ' 以只读的方式打开文件，参考open方法的帮助
    
57.                 Do While Not EOF(1) ' 循环至文件尾。
    
58.                     Line Input #1, TextLine ' 读入一行数据并将其赋予某变量
    
59.                     BLA = FASLE  '//是否需要此行
    
60.                     INTX = INTX + 1  '//记录第几行  为对比END 所在行做准备
    
61.                     TextLine = Trim(TextLine)
    
62.                     If InStr(TextLine, "VERSION ") <> 1 Then
    
63.                         If InStr(TextLine, "Attribute ") <> 1 Then
    
64.                             If InStr(TextLine, "BEGIN") = 1 Then BLB = True  '//判断  BEGIN 段落开始
    
65.                             If BLB = True And InStr(TextLine, "END") = 1 Then
    
66.                                 BLB = FASLE '//判断  BEGIN 段落结束
    
67.                                 INTY = INTX   '//记录END 所在行
    
68.                             End If
    
69.                             If BLB = FASLE Then
    
70.                                 Rem 是正文, 如果有BEGIN  则要在END之下
    
71.                                 If INTX > INTY Then BLA = True
    
72.                             End If
    
73.                         End If
    
74.                     End If
    
75.                     If BLA = True Then
    
76.                         If StrText <> "" Then StrText = StrText & vbCrLf
    
77.                         StrText = StrText & TextLine
    
78.                     End If
    
79.                 Loop
    
80.                 Close #1 ' 关闭文件。
    
81.                
    
82.                 MK.CodeModule.AddFromString StrText  '//插入代码
    
83.             End If
    
84.         Next
    
85.         MsgBox "OK"
    
86.     Else
    
87.         MsgBox "未发现 导入文件"
    
88.     End If
    
89.    
    
90. End Sub

复制代码

morpheus126

opiona 发表于 2022-8-20 09:29
改成下面这样 自动判断导入文件的类型  更稳妥些

您好，感谢分享
请问其中有一句
“现有代码不能导入: sheet代码”
这句注释是什么意思？谢谢

opiona

morpheus126 发表于 2022-8-25 09:49
您好，感谢分享
请问其中有一句
“现有代码不能导入: sheet代码”

sheet代码

就是写在工作表 代码区域内的代码
可以导出,但是不能直接导入
最新版的 是以文本的形式写进去的

morpheus126

opiona 发表于 2022-8-25 10:28
sheet代码

就是写在工作表 代码区域内的代码

懂了，感谢大师指教

gaolzhen

拜读了，
.感谢分享！！！！！

rrxfw

牛牛牛，看看