VBA程序也玩自动升级

xgy0214dxy

必须收藏了，顶一下，无所不能

songzi2000

老师，能否上附件呀，我在电脑运行说我未定义，另个我也想向你学习窗体，你一定做的很了不起

7473v6575ba

好好研究一下!如果改进到无线的模式就可以大有作为了！

jylgnlygjs

收藏，谢谢分享。

917067811

学习  收藏

sunny_8848

多谢分享，不知道网络自动升级该怎样写代码？

z00128284

收藏了。不错，蛮有意思的

phipe

谢谢分享，好厉害。

jygzcj

1. Sub 升级()
   
2. 
   
3. Application.ScreenUpdating = False
   
4. On Error Resume Next
   
5. 
   
6. Dim Chgset As Boolean
   
7. Debug.Print ThisWorkbook.VBProject.Protection
   
8. If Err.Number = 1004 Then
   
9.     Err.Clear
   
10.     Application.SendKeys "%TMS%T%V{ENTER}"
    
11.     Chgset = True
    
12.     DoEvents
    
13. End If
    
14. 
    
15. Dim d1 As New Scripting.Dictionary
    
16. Dim d2 As New Scripting.Dictionary
    
17. Dim Str$, bb$
    
18. Dim StrFileName$
    
19. 
    
20. Str = ThisWorkbook.Path & ""
    
21. 
    
22. StrFileName = Dir(Str & "*.bas")
    
23. Do While StrFileName <> ""
    
24.    StrFileName = Left(StrFileName, Len(StrFileName) - 4)
    
25.    d1(StrFileName) = StrFileName
    
26.    StrFileName = Dir
    
27. Loop
    
28. 
    
29. StrFileName = Dir(Str & "*.frm")
    
30. Do While StrFileName <> ""
    
31.     StrFileName = Left(StrFileName, Len(StrFileName) - 4)
    
32.     d2(StrFileName) = StrFileName
    
33.     StrFileName = Dir
    
34. Loop
    
35. 
    
36. For Each vbCmp In ThisWorkbook.VBProject.VBComponents
    
37.   '工作表类型type 100
    
38.   '模块类型type 1
    
39.     If vbCmp.Type = 1 Then
    
40.             If d1.Exists(vbCmp.Name) Then
    
41.                 bb = vbCmp.Name
    
42.                 ThisWorkbook.VBProject.VBComponents.Remove vbCmp
    
43.                 ThisWorkbook.VBProject.VBComponents.Import Str & bb & ".bas"
    
44.             End If
    
45.         ElseIf vbCmp.Type = 3 Then
    
46.             If d2.Exists(vbCmp.Name) Then
    
47.                 bb = vbCmp.Name
    
48.                 ThisWorkbook.VBProject.VBComponents.Remove vbCmp
    
49.                 ThisWorkbook.VBProject.VBComponents.Import Str & bb & ".Frm"
    
50.             End If
    
51.                
    
52.     End If
    
53. Next vbCmp
    
54.    
    
55.     If Chgset Then Application.SendKeys "%TMS%T%V{ENTER}"
    
56.     Application.ScreenUpdating = True
    
57. End Sub
    

复制代码

13610865084

高大上 赞一个先