VBA卸载加载宏与DLL加载及卸除

jdwang1000

曾于2012/11/11访问过gengsai 的帖子[求助]VBA可以完全卸载加载宏

当时依该帖内容作了部分修改后可以完全卸载加载宏

现将我的作法发表于此希望能提供需要者参考附件内含  

1.  Install_2003_cn.xls （未加锁可自行参阅程式码）

2.  Uninstall_Lunar_03_cn.xls （未加锁可自行参阅程式码）

3.  Lunar_24_V1.4_03.dll

4.  Lunar_24_V1.4_03.xla

VBA.rar (218.03 KB, 下载次数: 214)

2013-8-30 20:44 上传

点击文件名下载附件

此加载宏档是农历函数加载成功后简介如下 ：

本转换函数具有许多参数可供使用


Lunar(Year,Month,Day,Type)
Year --- 年 -5000 ~ 5000 (为了要适用 1900/01/01 以前的日期所以区分为 年 月 日 三项
Month --- 月
Day --- 日
Type --- 输出类型 可省略 (内定为0)


Type = 0   或省略 ( =Lunar(2012,4,20)  或 Lunar(2012,4,20,)  或 Lunar(2012,4,20,0)    三十 )
Type = 1   月日 ( =Lunar(2012,6,14,1)     闰四月(小) 廿五 )
Type = 20   月日国定假日 ( =Lunar(2012,6,23,20)    五月(大) 初五 端午节 )
Type = 21   月日农历节日 ( =Lunar(2012,2,23,21)    二月(小)初二 龙头节  )
. . . . . .. .. . .  .. .. .

此农历函数更详细的说明可参考 http://club.excelhome.net/thread-819194-1-1.html

以下将先列出安装档程式模块内容(Install_2003_cn.xls)

二楼及三楼为卸载加载宏与卸除 dll 作法

1. Option Explicit
   
2. Sub DynamicAddin()
   
3.     Dim WB, addX, Notice_Str
   
4.     Dim strFilename As String
   
5.     Dim strAddInName As String, Reg_Str As String
   
6.     Dim Re_Install As Boolean
   
7.     Dim Install_Num As Byte, Ans As Byte
   
8.       
   
9.     Notice_Str = Range("F6:H8")
   
10.     Re_Install = True
    
11.     Install_Num = 0
    
12.     On Error GoTo Err_Static
    
13.     Do While (Re_Install And Install_Num < 3)
    
14.         MsgBox Notice_Str(1, 1) & _
    
15.                     Chr(10) & Chr(10) & Chr(10) & Space(16) & Notice_Str(1, 2)
    
16.         Shell "cmd.exe /c md C:\Lunar_24_V1.4_03"
    
17.         Application.Wait (Now + TimeValue("0:00:01"))
    
18.         If Not FileExist("C:\Lunar_24_V1.4\Lunar_24_V1.4_03.dll") Then
    
19.             Reg_Str = Application.ThisWorkbook.Path & "\Lunar_24_V1.4_03.DLL"
    
20.             FileCopy Reg_Str, "C:\Lunar_24_V1.4_03\Lunar_24_V1.4_03.DLL"        ' err -- 53
    
21.         End If
    
22.         Ans = MsgBox(Space(7) & "再次确认是否为系统管理员身分进行安装" & _
    
23.                     Chr(10) & Chr(10) & Chr(10) & "一般使用者无法有效注册 Lunar_24_V1.4_03.DLL " & _
    
24.                     Chr(10) & Chr(10) & Chr(10) & Space(24) & "将导致所有安装无效 !! ", 260, "JW 管理员身份确认")
    
25.         If Ans = 7 Then
    
26.             MsgBox Space(8) & "即将退出 Lunar_24_V1.4_03 安装程序" & _
    
27.                     Chr(10) & Chr(10) & Chr(10) & Space(4) & "请取得系统管理员身分后再进行此安装 !!"
    
28.             Exit Sub
    
29.         End If
    
30.             
    
31.         Reg_Str = "cmd.exe /c regsvr32  /s  C:\Lunar_24_V1.4_03\Lunar_24_V1.4_03.DLL"
    
32.         Shell Reg_Str
    
33.         Application.Wait (Now + TimeValue("0:00:01"))
    
34.         If Not FileExist("C:\Lunar_24_V1.4_03\Lunar_24_V1.4_03.xla") Then
    
35.             Reg_Str = Application.ThisWorkbook.Path & "\Lunar_24_V1.4_03.xla"
    
36.             FileCopy Reg_Str, "C:\Lunar_24_V1.4_03\Lunar_24_V1.4_03.xla"        ' err -- 53
    
37.         End If
    
38.         strAddInName = "Lunar_24_V1.4_03"
    
39.         strFilename = "C:\Lunar_24_V1.4_03\Lunar_24_V1.4_03.xla"
    
40.         Set addX = AddIns.Add(Filename:=strFilename, CopyFile:=True)        ' err -- 1004
    
41.         addX.Installed = True   '        ' err -- 424
    
42.         Install_Num = Install_Num + 1
    
43.         If Err = 0 Then Re_Install = False
    
44.     Loop
    
45.     If addX.Installed Then
    
46.         MsgBox Space(44) & Notice_Str(1, 3) & Chr(10) & Chr(10) & Chr(10) & Notice_Str(3, 1)
    
47.         For Each WB In Workbooks
    
48.             If WB.Name <> ThisWorkbook.Name Then WB.Close True
    
49.         Next
    
50.         ThisWorkbook.Saved = True
    
51.         Excel.Application.Quit
    
52.         Exit Sub
    
53.     End If
    
54. Err_Static:
    
55.     Select Case Err
    
56.         Case 53
    
57.             MsgBox "Lunar_24_V1.4_03.DLL or Lunar_24_V1.4_03.xla" & _
    
58.                 Chr(10) & Chr(10) & Chr(10) & _
    
59.                 "无法复制到 C:\Lunar_24_V1.4_03 文件夹" & _
    
60.                  Chr(10) & Chr(10) & Chr(10) & _
    
61.                 "请确认以上二档与本 Install_2003.xls 在同一文件夹内"
    
62.         Case 424
    
63.             MsgBox "加载宏 Lunar_24_V1.4_03.xla 无法正常安装 !!"
    
64.         Case 1004
    
65.             MsgBox "加载宏 Lunar_24_V1.4_03.xla 无法正确引用 !!"
    
66.     End Select
    
67. End Sub
    
68. 
    
69. 
    
70. Function FileExist(strPath As String) As Boolean
    
71.     FileExist = (Dir(strPath, vbNormal + vbHidden + vbReadOnly) <> "")
    
72. End Function
    
73. 
    
74. 
    
75. Function FolderExist(strPath As String) As Boolean
    
76.     FolderExist = (Dir(strPath, vbDirectory + vbHidden) <> "")
    
77. End Function
    

复制代码

2

jdwang1000

卸载加载宏的程式码如下

1.  活页簿事件 Workbook_BeforeClose(Cancel As Boolean)

此程序主要因 dll 档案因处于使用中无法经由一次的 Uninstall 程序删除而做此提示处理

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Dim WB
   
3.     On Error GoTo Msg1
   
4.     Set My_Folder = CreateObject("scripting.filesystemobject")
   
5.     If FolderExist("C:\Lunar_24_V1.4_03*") Then
   
6.         My_Folder.deletefolder "C:\Lunar_24_V1.4_03", True  'err 76
   
7.     ElseIf FolderExist("C:\Lunar_24_V1.4_*") Then
   
8.         My_Folder.deletefolder "C:\Lunar_24_V1.4", True  'err 76
   
9.     End If
   
10.     Exit Sub
    
11. Msg1:
    
12.     If FolderExist("C:\Lunar_24_V1.*") Then
    
13.         MsgBox "Lunar_24_V1.??.dll   档案因处于使用中尚未删除 !!" & _
    
14.                 Chr(10) & Chr(10) & Chr(10) & _
    
15.                 " EXCEL 关闭后须再执行一次 UnInstall_Lunar.xlsm " & _
    
16.                 Chr(10) & Chr(10) & Chr(10) & _
    
17.                  "      按下确定按钮后将关闭 EXCEL"
    
18.     Else
    
19.         MsgBox "您未曾安装过 Lunar 农历函数 , 不须执行此 UnInstall_Lunar.xlsm !!"
    
20.     End If
    
21. End Sub
    
22. 
    

复制代码

jdwang1000

2. Uninstall_Lunar_03_cn.xls  模块程式码 DelMyAddins() 如下

1. Option Explicit
   
2. 
   
3. Sub DelMyAddins()   ' VBA 卸除 Lunar* 加载宏及 DLL
   
4.     Dim Addin_Num As Integer, I As Integer, j As Integer, K As Integer
   
5.     Dim My_Folder As Object
   
6.     Dim Lunar_ComAddin, Lunar_Addin, WB
   
7.    
   
8.     On Error Resume Next
   
9.     If FolderExist("C:\Lunar_24_V1.*") Then
   
10.        j = 1
    
11.    
    
12.        '查出目标加载宏在列表中的位置并卸除加载宏
    
13.       
    
14.        For I = 1 To Application.AddIns.Count
    
15.            If Application.AddIns(I).FullName Like "*Lunar_24_V1.*" Then
    
16.                Application.AddIns(I).Installed = False    '卸除加载宏
    
17.                Kill Application.AddIns(I).FullName
    
18.                If j > 1 Then
    
19.                    For K = 1 To j - 1
    
20.                        Application.SendKeys ("{down}"), False
    
21.                    Next
    
22.                End If
    
23.                Application.SendKeys ("{BACKSPACE}"), False
    
24.                Application.SendKeys ("{enter}")
    
25.                Application.SendKeys ("{enter}")
    
26.                Application.SendKeys ("{numlock}")
    
27.                Application.Dialogs(321).Show   ' 同 --> Application.Dialogs(xlDialogAddinManager).Show
    
28.                DoEvents
    
29.                Exit For
    
30.            End If
    
31.            j = j + 1
    
32.        Next
    
33.       
    
34.        '查出 DLL 在列表中的位置并卸除 DLL
    
35.        For Each Lunar_ComAddin In Application.COMAddIns
    
36.            If Lunar_ComAddin.Description Like "*Lunar_24_V1.*" Then
    
37.                Lunar_ComAddin.Connect = False '关闭 Lunar_24_V1.??? Dll 载入项
    
38.                Shell "cmd.exe /c regsvr32  /u  C:\Lunar_24_V1.4_03" & Lunar_ComAddin.Description
    
39.            End If
    
40.        Next
    
41.       
    
42.        MsgBox "已完全清除 Lunar_24_V1.?? 函数 , 按下确定按钮后将关闭 EXCEL !!"
    
43.     End If
    
44.     For Each WB In Workbooks
    
45.         If WB.Name <> ThisWorkbook.Name Then WB.Close True
    
46.     Next
    
47.     ThisWorkbook.Saved = True
    
48.     Excel.Application.Quit
    
49. End Sub
    
50. 
    
51. 
    
52. Function FileExist(strPath As String) As Boolean
    
53.     FileExist = (Dir(strPath, vbNormal + vbHidden + vbReadOnly) <> "")
    
54. End Function
    
55. 
    
56. 
    
57. Function FolderExist(strPath As String) As Boolean
    
58.     FolderExist = (Dir(strPath, vbDirectory + vbHidden) <> "")
    
59. End Function
    

复制代码

要完全清除加载宏及 dll 档以此方式经由重复执行二次的 Uninstall 即可达到目的

sfsfsfsf

留个记号！！！

wqfzqgk

可能近期能用着，做个记录

鄂龙蒙

学习资料，收藏了，谢谢！！！

sunny_8848

多谢分享，一直找不到完全卸载DLL的方法，看能否解决这个疑难问题

jininglin

你开发、分享的关于excel农历计算的插件”Lunar_24_V1.4_03.dll“很好用。但是现在打开excel就提示错误，不能用了。提示要更新最新版本，你更新的，可以在哪里拿到呢。

jdwang1000

jininglin 发表于 2015-3-4 11:40
你开发、分享的关于excel农历计算的插件”Lunar_24_V1.4_03.dll“很好用。但是现在打开excel就提示错误，不 ...

For Excel 2007 ~ 2013

農曆函數壓縮檔 [ Lunar_V1.65.rar  286.58 KB ] 下載連結如下

http://www.mediafire.com/download/wy25e07ikl5oo35/Lunar_V1.65.rar


For Excel 2003

Excel 2003 版本農曆函數壓縮檔 [ Lunar_V1.65 _2003.rar 234.22 KB ] 下載連結如下

http://www.mediafire.com/downloa ... nar_V1.65+_2003.rar

liucqa

jdwang1000 发表于 2015-4-9 13:51
For Excel 2007 ~ 2013

農曆函數壓縮檔 [ Lunar_V1.65.rar  286.58 KB ] 下載連結如下

Lunar_V1.65.rar (286.58 KB, 下载次数: 52)

2015-4-9 19:07 上传

点击文件名下载附件

Lunar_V1.65 _2003.rar (234.22 KB, 下载次数: 42)

2015-4-9 19:07 上传

点击文件名下载附件

附件下载困难，转载一下