VBA程序也玩自动升级

admin

最近用VBA帮公司其他部门的同事写了一个数据管理的小工具，让他们以前每天要花1、2个钟头处理的工作现在10几分钟就搞定，还不容易出错，博得不少喝彩。终于，这些个家伙们提出越来越多新的要求，一会要求导出的报表增加这个项目，一会要求增加那个功能。倒是难不倒咱，很快修改了窗体代码，然而他们却连导入窗体都不会操作，还得跑到他们电脑前去（办公室可不在一起呀，一次两次就算了，可却经常发生，又不好意思拒绝，几经尝试，终于找到了一个解决办法：
4 U; F7 {" _  b* b: T% V  }+ }1 e. u 为了好看，也为了防止误操作，所有他们可见的界面都是窗体，每次要求修改的东西也都是通过修改窗体代码完成的，那么，在工具上加上个自动升级功能，每次我写好新窗体后，导出到共享盘上，文件自动查找有没有新窗体文件存在，有，则先删除原来的窗体，再导入新窗体（要求同名），不就搞定了吗？不多说了，上代码：

1. 
   
2. Sub 升级()
   ) b$ y+ F# _/ n& y
3. Application.ScreenUpdating = False
   $ w$ w6 u/ Q$ W- n; Y
4. On Error Resume Next
   # F8 X, t, l* S: i' x. X& |
5.    Dim pw$
   
6. '因为要用代码操作窗体需要先解开VBA工程密码（无密码就不用了），先解开：
   # U) H! \0 K- s6 Q
7.    pw = "1234" 'VBA工程密码
   
8.    If ThisWorkbook.VBProject.Protection = vbext_pp_locked Then
   
9.      Application.VBE.CommandBars(1).Controls("工具(T)").Controls("VBAProject 属性(&E)...").Execute
     m; F( e* @+ g6 z* Q
10.      Application.SendKeys pw & "{ENTER}{ENTER}"
    
11.      DoEvents
    ) v2 j; s7 M5 \( v- E8 J! u
12.    End If
    
13. 
    2 N. V. u! B' ^7 n! \; Y
14. '还要求工具（T）-宏（M）-安全性（M）-可靠发行商（T）-勾选了“信任对于VB项目的访问（V），就别手工了，自动来：
    & v. Q% ~& c- G" {! j/ N1 w0 |
15.    Dim Chgset As Boolean
    ( s6 q1 ?% P5 \4 t
16.    '陷阱测试，VBProject.Protection在这儿并无实际的意义
    # U5 m; i; B, ?& Q4 D# x
17.    Debug.Print ThisWorkbook.VBProject.Protection
    / L: J2 n8 d; J  S; W7 |+ A# u& l
18.    If Err.Number = 1004 Then
    
19.      Err.Clear
    
20.      Application.SendKeys "%TMS%T%V{ENTER}"
    " k( m& h1 o) s! z6 ^+ B
21. Chgset = True
    8 s' k$ U0 W. H' a  w
22. DoEvents
    1 X9 Z$ Z! N( d2 Q5 X+ l
23.    End If
    
24.    '执行升级操作：
    
25. Dim vbCmp As VBComponent
    9 z, R4 R6 i! C3 ^  A& A+ u% H" j2 E
26. Dim fname As String
    8 I7 ~2 i9 A4 F, F; e) {. ~
27.    For Each vbCmp In ThisWorkbook.VBProject.VBComponents
    % @+ }" u, N. {9 Z9 d* r$ O  S6 Y
28.      If vbCmp.Type = vbext_ct_MSForm Then 'ThisWorkbook.VBProject.VBComponents.Remove vbCmp
    
29.      fname = vbCmp.Name
    ( {3 z) {6 `  q+ _+ B& b
30.      If Dir("共享路径" & fname & ".frm") <> "" Then
    - l0 k  T  \5 L7 Z4 m- I
31.      Application.VBE.ActiveVBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(fname)
    
32.      Application.VBE.ActiveVBProject.VBComponents.Import "共享路径"  & fname & ".frm"
    
33.      End If
    
34.      End If
    & ]. T. W) ^, u. Q% x9 i# A1 Y7 _
35.    Next vbCmp
    " ~, T4 y" j. b4 }% {7 g: H
36.    MsgBox "升级完成"
    8 @% H- c+ E9 f( P
37.    
    2 @9 v9 [  o& S$ [
38.    '操作完成后还原操作前的状态
    
39. Application.ScreenUpdating = True
    - s7 s) f4 h, Y2 v/ V' q& K4 A2 J
40. If Chgset Then Application.SendKeys "%TMS%T%V{ENTER}"
    
41. End Sub
    

复制代码

当然了，这里是直接开始升级了，如果需要，加上个升级文件是否存在的判断也行。