Option Explicit
Option Compare Text
Sub fixAddinPathInRegistry()
Const HKEY_CURRENT_USER As Long = &H80000001
Dim objRegistry As Object
Dim strComputer As String
Dim rPath As String, s$, s1$, s2$
Dim arrEntryNames(), arrValueTypes(), arrSubkeys()
Dim strAsk, addin, APPDATA$, p$
Dim FSO As Object, a, i, i2, v, root As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
strComputer = ".": root = HKEY_CURRENT_USER
Set objRegistry = Interaction.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
For Each i In Array("12.0", "14.0", "15.0", "16.0")
GoSub p1: GoSub p
GoSub p2: GoSub p
GoSub p3: GoSub o
Next
APPDATA = Environ("APPDATA") & "\Microsoft\Addins"
i = Application.Version: GoSub p1
For Each i In Application.AddIns
If i.Installed Then
p = i.FullName: s1 = i.Name
If FSO.FileExists(p) Then
s2 = s2 & IIf(s2 = "", "", vbLf) & " " & p
If i.Path = APPDATA Then
objRegistry.setStringValue root, rPath, s1, ""
Else
objRegistry.setStringValue root, rPath, p, ""
End If
Else
s = s & IIf(s = "", "", vbLf) & " " & p
objRegistry.DeleteValue root, rPath, s1
objRegistry.DeleteValue root, rPath, p
End If
End If
Next
E:
MsgBox IIf(s = "", _
"Hoan thanh!" & vbNewLine & _
"Khong tim thay Path can xoa!", _
" Da xoa các Path:" & _
s) & vbNewLine & vbNewLine & _
IIf(s2 = "", "Khong tim thay Path can fix!", _
" Da fix các Path:" & _
s2), Title:="Xoa & fix path Add-in Registry"
Exit Sub
p1:
rPath = "Software\Microsoft\Office\" & i & "\Excel\Add-in Manager"
Return
p2:
rPath = "Software\Microsoft\Office\" & i & "\Excel\AddInLoadTimes"
Return
p3:
rPath = "Software\Microsoft\Office\" & i & "\Excel\Options"
Return
p:
objRegistry.EnumValues root, rPath, arrEntryNames, arrValueTypes
If IsNull(arrEntryNames) Then Return
For Each strAsk In arrEntryNames
v = strAsk
If v Like "*:\*" Then
If v Like """*""" Then v = Mid$(v, 2, Len(v) - 2)
If v Like "file:///*" Then v = Mid$(v, 9)
If FSO.FileExists(v) Then
Else
s = s & IIf(s = "", "", vbLf) & " " & strAsk
objRegistry.DeleteValue root, rPath, strAsk
' For Each addin In Application.AddIns
' If addin.Installed = False Then
' If strAsk = addin.Path & "\" & addin.Name Then
' objRegistry.DeleteValue root, rPath, strAsk
' End If
' End If
' Next
End If
End If
Next
Return
o:
objRegistry.EnumValues root, rPath, arrEntryNames, arrValueTypes
If IsNull(arrEntryNames) Then Return
For Each strAsk In arrEntryNames
If strAsk Like "Open#*" Or strAsk = "Open" Then
objRegistry.getstringvalue root, rPath, strAsk, v
If v Like "*:\*" Then
If v Like """*""" Then v = Mid$(v, 2, Len(v) - 2)
If v Like "file:///*" Then v = Mid$(v, 9)
If FSO.FileExists(v) Then
Else
s = s & IIf(s = "", "", vbLf) & " " & v
objRegistry.DeleteValue root, rPath, strAsk
End If
End If
End If
Next
Return
End Sub