Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Private Sub Workbook_Open()



'To complete uninstall if fail
    Dim sTempFile As String
    sTempFile = TempFolder() & "\" & sAddInNameByApp & "DllPath.tmp"
    'Ontime foi necessário porque um bug no Excell2000 dispara o evento apesar de
    'EnableEvents=false não liberando a outra execução do Excel para fechar
    If Dir(sTempFile) <> "" Then Application.OnTime Now() + TimeValue("00:00:01"), "UnInstall"

    If XLtoEXE_IsThisWbExe() Then
        If sXLtoEXE_CmdLineReopen = "Install" Then PleaseWaitExeIndep False: PleaseWait True: Application.OnTime Now() + TimeValue("00:00:01"), "Install"
        If sXLtoEXE_CmdLineReopen = "UnInstall" Then PleaseWaitExeIndep False: PleaseWait True: Application.OnTime Now() + TimeValue("00:00:01"), "UnInstall"
    End If

    ButtonLanguage True
    ThisWorkbook.Saved = True
End Sub


Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If ActiveSheet.ProtectContents Then Application.GoTo Cells(Target.Row, 1)
End Sub


Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If ActiveSheet.ProtectContents Then Application.GoTo Cells(Target.Row, 1)
End Sub


Attribute VB_Name = "ModMyMsgBox"
Option Explicit
Public Const LOCALE_USER_DEFAULT& = &H400
Public Const LOCALE_SENGLANGUAGE = &H1001   'English name of language
Public Const LOCALE_SLANGUAGE = &H2   'localized name of language
Public Const LOCALE_SLIST = &HC         '  list item separator
Public Const LOCALE_SDECIMAL = &HE         '  decimal separator
Public Const LOCALE_STHOUSAND = &HF         '  thousand separator
Public Const LOCALE_ICOUNTRY = &H5         '  country code
Public Const LOCALE_ITIME = &H23        '  time format specifier
Public Const LOCALE_SDATE = &H1D        '  date separator
Public Const LOCALE_STIME = &H1E        '  time separator
#If VBA7 Then
    Private Declare PtrSafe Function apiGetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
    Private Declare PtrSafe Function GetVersion Lib "kernel32" () As Long
    Private Declare PtrSafe Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function apiGetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
    Private Declare Function GetVersion Lib "kernel32" () As Long
    Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128                           '  Maintenance string for PSS usage
End Type
'  dwPlatformId defines:
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
#If VBA7 Then
    Private Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
#Else
    Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
#End If

Public BotAcionado As Integer
Public IsPortg As Boolean
Public Msg1 As String
Public Msg2 As String

Public Function MyMsgBox(sPrompt As String, lBut As Long, sTitle As String, Optional Xpos As Long, Optional Ypos As Long)
    With FormMyMsgBox
        .Caption = sTitle
        .Alert_Tb = sPrompt
        .lBut = lBut
        .Email_Lb.Caption = IIf(IsPortg, "E-mail", "Email")
        .Email_Lb.ControlTipText = "orlando@cpap.com.br"
        .EmailSubj = IIf(IsPortg, "Informações sobre o ", "Information about ") & sAddInCaptByApp
        .HomePage_Lb.Caption = IIf(IsPortg, "Ajuda", "Help")
        .HomePage_Lb.ControlTipText = "http://cpap.com.br/orlando/"
        .HomePageUrl = "http://cpap.com.br/orlando/" & sAddInNameByApp & IIf(IsPortg, "Mais.asp?IdC=InstAjuda", "More.asp?IdC=InstHelp")
        .Xpos = Xpos    '* Twips 'Twips usa em COM Add-in
        .Ypos = Ypos    '* Twips
        .Show  '1   'É preciso usar em COM add-in
    End With
    Unload FormMyMsgBox
    MyMsgBox = BotAcionado
End Function

Sub MyWait(PauseSeg As Double, Optional bSleep As Boolean = True)
    Dim Start
    Start = Timer
    Do While Timer < Start + PauseSeg
        DoEvents
        If bSleep Then Sleep 1  'Com Sleep o CPU Usage cai de 100% para seus 0 ou 2% normal, mas põe o processo para dormir e deve ser evitado se for esperado alguma ação nele a partir de outro processo
    Loop
End Sub

Function gLocInfo(vType As Long) As String
    Dim vStr As String, vLng As Long
    Dim ret As Long
    vStr = String$(255, 0)
    vLng = 255 - 1
    ret = apiGetLocaleInfo(LOCALE_USER_DEFAULT, vType, vStr, vLng)
    If ret <> 0 Then
        gLocInfo = Left$(vStr, ret - 1)
    End If
End Function

Function SendEMailByURL(oCtrl As Object, EmailUrl As String, Subj As String, Msg As String, bCtrlError As Boolean) As Boolean
    Dim URL As String
    Dim ret As Long

    Err.Clear
    If Not oCtrl Is Nothing Then
        If oCtrl.MousePointer = fmMousePointerHourGlass Then Exit Function
        oCtrl.MousePointer = fmMousePointerHourGlass
        oCtrl.ForeColor = &H80FF&
        DoEvents
    End If

    If Subj <> "" Then                                     'Indica para montar uma URL para email
        If appHostApp.Name = "Microsoft Excel" Or appHostApp.Name = "Microsoft Word" Then _
 appHostApp.StatusBar = IIf(IsPortg, "Preparando E-mail. Aguarde...", "Preparing Email. Wait...")

        '& in Hex
        Subj = MyReplace(Subj, "&", "%26")
        Msg = MyReplace(Msg, "&", "%26")

        'Spaces in Hex
        Subj = MyReplace(Subj, " ", "%20")
        Msg = MyReplace(Msg, " ", "%20")

        'CRLF in Hex
        Msg = MyReplace(Msg, vbCrLf, "%0D%0A")

        URL = "mailto:" & EmailUrl & "?subject=" & Subj & "&body=" & Msg

        'Launch Start command with URL (Falha no Win2000)
        'Ret = Shell(Left("Start " & URL, 460), vbHide)
    Else
        URL = EmailUrl
    End If

    If Not bCtrlError And InStr(1, URL, "#") = 0 Then
        'A vantagem do ShellExecute é que no método FollowHyperlink a lingua do Navegador não é enviada
        'e tem que ter documento aberto. Vou usar FollowHyperlink só quando precisar controlar erro e
        'se houver bookmark
        ShellExecute 0&, vbNullString, Left(URL, 457), vbNullString, vbNullString, vbNormalFocus
    Else
        Dim sBookmark As String
        If InStr(1, URL, "#") = 0 Then
            sBookmark = ""
        Else
            sBookmark = Mid(URL, InStr(1, URL, "#"))
            URL = Left(URL, InStr(1, URL, "#") - 1)
        End If

        On Error Resume Next
        Select Case appHostApp.Name
        Case "Microsoft Excel"
            If appHostApp.ActiveWorkbook Is Nothing Then appHostApp.Workbooks.Add
            appHostApp.ActiveWorkbook.FollowHyperlink Left(URL, 457), sBookmark, True       'DifAppMet
        Case "Microsoft Word"
            If appHostApp.ActiveDocument Is Nothing Then appHostApp.Documents.Add
            appHostApp.ActiveDocument.FollowHyperlink Left(URL, 457), sBookmark, True
        Case "Microsoft PowerPoint"
            If appHostApp.ActivePresentation Is Nothing Then appHostApp.Presentations.Add
            appHostApp.ActivePresentation.FollowHyperlink Left(URL, 457), sBookmark, True
        Case "Microsoft Access"
            appHostApp.FollowHyperlink Left(URL, 457), sBookmark, True
        End Select
    End If
    If Err.Number = 0 Then MyWait 10
    If Subj <> "" And (appHostApp.Name = "Microsoft Excel" Or appHostApp.Name = "Microsoft Word") Then _
 appHostApp.StatusBar = False

    If Err.Number <> 0 Then MsgBox Err.Description
    If Not oCtrl Is Nothing Then oCtrl.MousePointer = fmMousePointerCustom
    SendEMailByURL = Err.Number = 0
    Err.Clear
End Function

Function MyReplace(vText As String, vTxtFind As String, vTxtRep As String)
'Word 6.0 VBA doesn't have Replace function
    Dim lPos As Long
    lPos = 1 - Len(vTxtRep)
vStart:
    lPos = InStr(lPos + Len(vTxtRep), vText, vTxtFind)
    If lPos = 0 Or vTxtFind = "" Then
        MyReplace = vText
        Exit Function
    End If
    vText = Left(vText, lPos - 1) & vTxtRep & Right(vText, Len(vText) - lPos - Len(vTxtFind) + 1)
    GoTo vStart
End Function

Function MySplit(ByVal sString As String, Optional sDelim As String, Optional lLimit As Long = -1, Optional bCompare As Long = 0) As Variant
'Excel 97 and Word6 haven't Split function
    Dim sSplitArr() As String
    Dim lPos As Long
    Dim i As Long
    Dim R As Long

    If sString = "" Or lLimit = 0 Then
        MySplit = Array()
        Exit Function
    End If

    If sDelim = "" Then
        ReDim Preserve sSplitArr(i)
        sSplitArr(i) = sString
    Else
        lPos = InStr(1, sString, sDelim, bCompare)
        If lPos = 0 Then
            ReDim Preserve sSplitArr(i)
            sSplitArr(i) = sString
        Else
            R = 2
            Do
                ReDim Preserve sSplitArr(i)
                If R > 1 Then
                    sSplitArr(i) = Left(sString, lPos - 1)
                    sString = Mid(sString, lPos + Len(sDelim))
                Else
                    sSplitArr(i) = sString
                    sString = ""
                End If
                lPos = InStr(1, sString, sDelim, bCompare)
                R = R - 1 - 1 * (lPos > 0)
                If lLimit <> -1 And i = lLimit - 1 Then
                    sSplitArr(i) = sSplitArr(i) & IIf(R > 0, sDelim & sString, "")
                    Exit Do
                End If
                i = i + 1
            Loop While R > 0
        End If
    End If
    MySplit = sSplitArr
End Function

Function EmlMsg() As String
    Dim WinVer As String
    Dim AppVer As String
    EmlMsg = ""
    EmlMsg = EmlMsg & IIf(IsPortg, "Prezado", "Dear") & " Orlando,"
    EmlMsg = EmlMsg & vbCrLf & vbCrLf
    EmlMsg = EmlMsg & IIf(IsPortg, "Gostaria...", "I would like...")
    EmlMsg = EmlMsg & vbCrLf & vbCrLf & vbCrLf & vbCrLf
    EmlMsg = EmlMsg & IIf(IsPortg, "Atenciosamente,", "Regards,") & vbCrLf & vbCrLf & vbCrLf

    EmlMsg = EmlMsg & "___" & vbCrLf
    EmlMsg = EmlMsg & GetWinUserName & vbCrLf    'O acc e pp não tem appHostApp.UserName e Win user me parece mais

    Select Case appHostApp.Name
    Case "Microsoft Excel"
        WinVer = appHostApp.OperatingSystem & " " & gLocInfo(LOCALE_SLANGUAGE)  'DifAppMet
    Case "Microsoft Word"
        WinVer = appHostApp.System.OperatingSystem & " " & gLocInfo(LOCALE_SLANGUAGE)
    Case "Microsoft PowerPoint"
        WinVer = appHostApp.OperatingSystem & " " & gLocInfo(LOCALE_SLANGUAGE)
    Case "Microsoft Access"
        WinVer = GetOperatingSystem & " " & gLocInfo(LOCALE_SLANGUAGE)
    End Select

    AppVer = gLocInfo(LOCALE_ICOUNTRY)
    AppVer = IIf(AppVer = 1, "English", IIf(AppVer = 55, "Português", "Language " & AppVer))
    AppVer = appHostApp.Name & " " & dHostAppVer & " (" & AppVer & ")"
    EmlMsg = EmlMsg & WinVer & vbCrLf
    EmlMsg = EmlMsg & AppVer & vbCrLf
End Function

Public Function GetOperatingSystem() As String
    Dim Ver As Long, WinVer As Long
    Ver = GetVersion()
    WinVer = Ver And &HFFFF&
    'retrieve the windows version
    GetOperatingSystem = "Windows " & Format((WinVer Mod 256) + ((WinVer \ 256) / 100), "Fixed")
End Function

Function GetWinUserName() As String
    Dim vStr As String, ret As Long, lpName As String
    vStr = String$(255, 0)
    ret = WNetGetUser(lpName, vStr, 255)
    If ret = 0 Then GetWinUserName = Left$(vStr, InStr(vStr, Chr(0)) - 1)
End Function

Public Function IsWinNTVista() As Boolean    'Vista e Win7 se distinguem apenas apenas em dwMinorVersion, 0 e 1.
    Dim ThisOS As OSVERSIONINFO
    ThisOS.dwOSVersionInfoSize = Len(ThisOS)
    GetVersionEx ThisOS
    IsWinNTVista = (ThisOS.dwPlatformId = VER_PLATFORM_WIN32_NT) And (ThisOS.dwMajorVersion = 6) And (ThisOS.dwMinorVersion = 0)
End Function

Public Function IsWinNT7() As Boolean    'Vista e Win7 se distinguem apenas apenas em dwMinorVersion, 0 e 1.
    Dim ThisOS As OSVERSIONINFO
    ThisOS.dwOSVersionInfoSize = Len(ThisOS)
    GetVersionEx ThisOS
    IsWinNT7 = (ThisOS.dwPlatformId = VER_PLATFORM_WIN32_NT) And (ThisOS.dwMajorVersion = 6) And (ThisOS.dwMinorVersion = 1)
End Function



Attribute VB_Name = "Mod4DllRegServer"
'Obtive no VB NG mas tenho dois outros que também funcionam
#If VBA7 Then
    Private Declare PtrSafe Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As LongPtr
    Private Declare PtrSafe Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As LongPtr, ByVal lStartAddress As LongPtr, ByVal lParameter As LongPtr, ByVal lCreationFlags As Long, lThreadId As Long) As LongPtr
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, ByVal lMilliseconds As Long) As Long
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lProcName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetExitCodeThread Lib "kernel32" (ByVal hThread As LongPtr, lExitCode As Long) As Long
    Private Declare PtrSafe Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long)
#Else
    Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long
    Private Declare Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadId As Long) As Long
    Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long
    Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long)
#End If

'Purpose   :    This function registers and Unregisters OLE components
'Inputs    :    sFilePath                       The path to the DLL/OCX or ActiveX EXE
'               bRegister                       If True Registers the control, else unregisters control
'Outputs   :    Returns True if successful
'Author    :    Andrewb
'Date      :    04/09/2000
'Notes     :    This effectively replaces RegSvr32.exe by loading the library and
'               calling the register or unregister functions exposed by all OLE components.
'Revisions :    Updated to include code for registering ActiveX Exes.

Function RegisterServer(sFilePath As String, Optional bRegister As Boolean = True) As Boolean
    #If VBA7 Then
        Dim lLibAddress As LongPtr
        Dim lProcAddress As LongPtr
        Dim lThread As LongPtr
    #Else
        Dim lLibAddress As Long
        Dim lProcAddress As Long
        Dim lThread As Long
    #End If
    Dim lThreadId As Long
    Dim lSuccess As Long
    Dim lExitCode As Long
    Dim sRegister As String
    Const clMaxTimeWait As Long = 20000    'Wait 20 secs for register to complete

    On Error GoTo ExitFunc
    If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then
        'File exists
        If UCase$(Right$(sFilePath, 3)) = "EXE" Then
            'Register/Unregister ActiveX EXE
            If bRegister Then
                'Register EXE
                Shell sFilePath & " /REGSERVER", vbHide
            Else
                'Unregister ActiveX EXE
                Shell sFilePath & " /UNREGSERVER", vbHide
            End If
            RegisterServer = True
        Else
            'Register/Unregister DLL
            If bRegister Then
                sRegister = "DllRegisterServer"
            Else
                sRegister = "DllUnregisterServer"
            End If

            'Load library into current process
            lLibAddress = LoadLibraryA(sFilePath)

            If lLibAddress Then
                'Get address of the DLL function
                lProcAddress = GetProcAddress(lLibAddress, sRegister)

                If lProcAddress Then
                    'Found interface, make call to component
                    lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThreadId)
                    If lThread Then
                        'Created thread
                        lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0)
                        If Not lSuccess Then
                            'Failed to register, close thread
                            Call GetExitCodeThread(lThread, lExitCode)
                            Call ExitThread(lExitCode)
                            RegisterServer = False
                        Else
                            'Register control
                            RegisterServer = True
                            Call CloseHandle(lThread)
                        End If
                    End If
                Else
                    'Object doesn't expose OLE interface
                    FreeLibrary lLibAddress
                End If
                Call FreeLibrary(lLibAddress)
            End If
        End If
    End If
ExitFunc:
    On Error GoTo 0
End Function

Sub RegisterServerShell32(sFilePath As String, Optional bRegister As Boolean = True)
'No Office 64-bit não aceita instalar, mas pode ser preciso desinstalar se tiver sido instalado
'antes, infelizmente, ao unregistrar via API, falha em LoadLibraryA(sFilePath) mesmo sFilPath
'esteja correto. Entao tentar aqui via shell RegSvr32 em vez da função RegisterServer
    If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then
        If bRegister Then
            Shell "RegSvr32.exe /s """ & sFilePath & """"
        Else
            Shell "RegSvr32.exe /u /s """ & sFilePath & """"
        End If
        MyWait 5
    End If
End Sub

Attribute VB_Name = "Mod2RegEdit"
Option Explicit

Public Const REG_SZ As Long = &H1
Public Const REG_DWORD As Long = &H4
Public Const REG_BINARY As Long = &H3

Public Const HKEY_CLASSES_ROOT As Long = &H80000000
Public Const HKEY_CURRENT_USER As Long = &H80000001
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_USERS As Long = &H80000003

Public Const KEY_ALL_ACCESS As Long = &H3F
Private Const KEY_QUERY_VALUE As Long = &H1
Public Const REG_OPTION_NON_VOLATILE As Long = 0

Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_NO_MORE_ITEMS = 259

Public Type SECURITY_ATTRIBUTES
    nLength As Long
    #If VBA7 Then
    lpSecurityDescriptor As LongPtr
    #Else
    lpSecurityDescriptor As Long
    #End If
    bInheritHandle As Long
End Type

#If VBA7 Then
    Public Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
    Public Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As LongPtr, lpdwDisposition As Long) As Long
    Public Declare PtrSafe Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As LongPtr, ByVal lpSubKey As String) As Long
    Public Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As LongPtr, ByVal lpValueName As String) As Long
    Private Declare PtrSafe Function RegQueryValueExStr Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare PtrSafe Function RegQueryValueExLng Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, ByRef lpType As Long, lpData As Long, ByRef lpcbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare PtrSafe Function RegQueryValueExByt Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, ByRef lpType As Long, lpData As Byte, ByRef lpcbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Public Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
    Private Declare PtrSafe Function RegSetValueExStr Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare PtrSafe Function RegSetValueExLng Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Long, ByVal cbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare PtrSafe Function RegSetValueExByt Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Byte, ByVal cbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
#Else
    Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
    Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
    Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Private Declare Function RegQueryValueExStr Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long                                      'Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare Function RegQueryValueExLng Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, lpData As Long, ByRef lpcbData As Long) As Long                                      'Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare Function RegQueryValueExByt Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, lpData As Byte, ByRef lpcbData As Long) As Long                                      'Note that if you declare the lpData parameter as String, you must pass it By Value.
    Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Private Declare Function RegSetValueExStr Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long                                  ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare Function RegSetValueExLng Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Long, ByVal cbData As Long) As Long                                  ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare Function RegSetValueExByt Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Byte, ByVal cbData As Long) As Long                                  ' Note that if you declare the lpData parameter as String, you must pass it By Value.
#End If

Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
#If VBA7 Then
    Private Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As LongPtr, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
    Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As LongPtr, lpType As Long, lpData As String, lpcbData As Long) As Long
#Else
    Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
    Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long                                            'Note that if you declare the lpData parameter as String, you must pass it By Value.
#End If

Sub FileExtAssociation(sExt As String, sAppName As String, sAppFullNameFile As String)
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
        Dim OpenKeyHdl As Long
    #End If
    Dim lRet As Long
    Dim SecurAttr As SECURITY_ATTRIBUTES

    'Create root extension subkey (.xxx)
    If GetRegValue(HKEY_CLASSES_ROOT, sExt, "", False) = "Error" Then
        RegCreateKeyEx HKEY_CLASSES_ROOT, sExt, _
                       0&, vbNullString, REG_OPTION_NON_VOLATILE, _
                       KEY_ALL_ACCESS, SecurAttr, OpenKeyHdl, lRet
        RegCloseKey OpenKeyHdl
    End If

    'Create root Application subkey about file extension (AppNameFile subkey)
    If GetRegValue(HKEY_CLASSES_ROOT, sAppName & "File\shell\open\command", "", False) = "Error" Then
        RegCreateKeyEx HKEY_CLASSES_ROOT, sAppName & "File\shell\open\command", _
                       0&, vbNullString, REG_OPTION_NON_VOLATILE, _
                       KEY_ALL_ACCESS, SecurAttr, OpenKeyHdl, lRet
        RegCloseKey OpenKeyHdl
    End If

    'Set open command value at AppNameFile subkey
    SetKeyValue HKEY_CLASSES_ROOT, sAppName & "File\shell\open\command", "", REG_SZ, """" & sAppFullNameFile & """" & " %1"

    'Define a description for the extension file as default value at AppNameFile subkey.
    SetKeyValue HKEY_CLASSES_ROOT, sAppName & "File", "", REG_SZ, sAppName & " File"

    'Set default value at extension subkey to look for commands at AppNameFile subkey
    SetKeyValue HKEY_CLASSES_ROOT, sExt, "", REG_SZ, sAppName & "File"

End Sub

#If VBA7 Then
Function SetValueEx(ByVal hKey As LongPtr, sValueName As String, lType As Long, vlpData As Variant) As Long
#Else
Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vlpData As Variant) As Long
#End If
#If VBA7 Then
    Dim OpenKeyHdl As LongPtr
#Else
    Dim OpenKeyHdl As Long
#End If


Dim blpData() As Byte
Dim llpData As Long
Dim slpData As String

Select Case lType
Case REG_BINARY
    blpData = vlpData
    SetValueEx = RegSetValueExStr(hKey, _
                                  sValueName, _
                                  0&, _
                                  lType, _
                                  blpData(0), _
                                  UBound(blpData) - LBound(blpData) - 1)

Case REG_SZ
    slpData = vlpData & Chr$(0)
    SetValueEx = RegSetValueExStr(hKey, _
                                  sValueName, _
                                  0&, _
                                  lType, _
                                  slpData, _
                                  Len(slpData))

Case REG_DWORD
    llpData = vlpData
    SetValueEx = RegSetValueExLng(hKey, _
                                  sValueName, _
                                  0&, _
                                  lType, _
                                  llpData, _
                                  4)
End Select
End Function

Sub SetKeyValue(lKey As Long, sSubKey As String, _
                sValueName As String, lType As Long, vValue As Variant)
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
        Dim OpenKeyHdl As Long
    #End If

    'open the key
    RegOpenKeyEx lKey, sSubKey, 0, KEY_ALL_ACCESS, OpenKeyHdl

    'Set the value
    SetValueEx OpenKeyHdl, sValueName, lType, vValue

    'Close the key
    RegCloseKey OpenKeyHdl

End Sub

'Get Registry Value, Arguments:
'1 - Reg Key (Ex.: HKEY_LOCAL_MACHINE),
'2 - Reg SubKey (Ex.: "Software\Microsoft\Windows\CurrentVersion"),
'3 - Name of Value (Ex.:"ProgramFilesDir" or "" for default)
'4 - Convert to text like written in reg files (*.reg)
Function GetRegValue(lKey As Long, sSubKey As String, sValueName As String, ConvRegText)
    Dim sRet As String * 255  'Fixed-length strings
    Dim lRet As Long
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
        Dim OpenKeyHdl As Long
    #End If
    Dim lType As Long
    Dim lLen As Long
    Dim sDataRet As String
    Dim lDataRet As Long
    Dim abDataRet() As Byte
    Dim i As Integer
    Dim BrkLine As Long

    lRet = RegOpenKeyEx(lKey, sSubKey, 0, KEY_QUERY_VALUE, OpenKeyHdl)

    lRet = RegQueryValueExLng(OpenKeyHdl, sValueName, 0&, lType, 0&, lLen)
    If lRet And lRet <> ERROR_MORE_DATA Then
        RegCloseKey OpenKeyHdl
        GetRegValue = "Error"
        Exit Function
    End If

    Select Case lType
    Case REG_DWORD
        lRet = RegQueryValueExLng(OpenKeyHdl, sValueName, _
                                  0&, lType, lDataRet, lLen)
        GetRegValue = CLng(lDataRet)

        If ConvRegText Then GetRegValue = """" & IIf(sValueName = "", "@", sValueName) & """=dword:" & Left("00000000", 8 - Len(Hex(GetRegValue))) & Hex(GetRegValue)

    Case REG_SZ
        sDataRet = String$(lLen - 1, 0)
        lRet = RegQueryValueExStr(OpenKeyHdl, sValueName, _
                                  0&, lType, sDataRet, lLen)
        GetRegValue = sDataRet

        If ConvRegText Then GetRegValue = """" & IIf(sValueName = "", "@", sValueName) & """=" & GetRegValue

    Case Else   'REG_BINARY and others
        ReDim abDataRet(lLen)
        lRet = RegQueryValueExByt(OpenKeyHdl, sValueName, _
                                  0&, lType, abDataRet(0), lLen)
        GetRegValue = abDataRet

        If ConvRegText Then
            If lType = REG_BINARY Then
                GetRegValue = """" & IIf(sValueName = "", "@", sValueName) & """=hex:"
                sDataRet = String$(lLen, 0)
                lRet = RegQueryValueExStr(OpenKeyHdl, sValueName, 0&, lType, sDataRet, lLen)
                BrkLine = Len(GetRegValue)
                For i = 1 To lLen
                    If BrkLine >= 77 Then
                        BrkLine = 2
                        GetRegValue = GetRegValue & "\" & Chr(10) & "  "
                    End If
                    GetRegValue = GetRegValue _
                                & IIf(Len(Hex(Asc(Mid(sDataRet, i, 1)))) = 1, "0", "") _
                                & Hex(Asc(Mid(sDataRet, i, 1))) & ","
                    BrkLine = BrkLine + 3
                Next
            Else
                If ConvRegText Then GetRegValue = """" & IIf(sValueName = "", "@", sValueName) & """=" & GetRegValue
            End If
        End If
    End Select
    RegCloseKey OpenKeyHdl
End Function

Function fRegEnumKey(lKey As Long, sSubKey As String, bEnumKeys As Boolean, bEnumValues As Boolean)
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
        Dim OpenKeyHdl As Long
    #End If
    Dim lCount As Long
    Dim sNameRet As String
    Dim lLenNameRet As Long
    Dim sDataRet As String
    Dim lLenDataRet As Long
    Dim fRetArr() As String
    Dim ft As FILETIME

    ReDim fRetArr(1, 0)

    If bEnumKeys Then    'Enumerate the keys
        If RegOpenKeyEx(lKey, sSubKey, 0, KEY_ALL_ACCESS, OpenKeyHdl) = 0 Then     'Open key
            lLenNameRet = 255: sNameRet = String$(255, 0)    'Buffering
            Do While RegEnumKeyEx(OpenKeyHdl, lCount, sNameRet, lLenNameRet, ByVal 0&, vbNullString, ByVal 0&, ft) <> ERROR_NO_MORE_ITEMS    'Enumerate the keys
                If lCount > 0 Then ReDim Preserve fRetArr(1, UBound(fRetArr, 2) + 1)
                fRetArr(0, UBound(fRetArr, 2)) = Left$(sNameRet, lLenNameRet)
                lCount = lCount + 1    'Next key
                sNameRet = String$(255, 0)
                lLenNameRet = 255
            Loop
            RegCloseKey OpenKeyHdl    'Close key
        Else
            fRegEnumKey = False    'Error when opening Key
            Exit Function
        End If
    End If

    If bEnumValues Then    'Enumerate the values
        lCount = 0
        If RegOpenKeyEx(lKey, sSubKey, 0, KEY_ALL_ACCESS, OpenKeyHdl) = 0 Then     'Open key
            lLenNameRet = 255: lLenDataRet = 255: sNameRet = String$(255, 0): sDataRet = String$(255, 0)    'Buffering
            Do While RegEnumValue(OpenKeyHdl, lCount, sNameRet, lLenNameRet, 0, ByVal 0&, ByVal sDataRet, lLenDataRet) <> ERROR_NO_MORE_ITEMS
                If fRetArr(0, UBound(fRetArr, 2)) <> "" Then ReDim Preserve fRetArr(1, UBound(fRetArr, 2) + 1)
                fRetArr(0, UBound(fRetArr, 2)) = Left$(sNameRet, lLenNameRet)
                fRetArr(1, UBound(fRetArr, 2)) = Left$(sDataRet, lLenDataRet - 1)
                lCount = lCount + 1    'Next key
                lLenNameRet = 255: lLenDataRet = 255: sNameRet = String$(255, 0): sDataRet = String$(255, 0)
            Loop
            RegCloseKey OpenKeyHdl    'Close key
        Else
            fRegEnumKey = False    'Error when opening Key
            Exit Function
        End If
    End If

    fRegEnumKey = fRetArr
End Function

Attribute VB_Name = "Mod1ConstByUtility"
Option Explicit

'==== Utility Const List. To other Office app, change Excel and Xl is sufficent. To other utility, change Calendar
Public Const sAddInNameByApp As String = "ExcelSpellNumber"    'AppUtilityNameInt
Public Const sAddInCaptByApp As String = "Popup SpellNumber for Excel"    'UtilityNameExt for App in En
Public Const sAddInCaptByAppPt As String = "Extenso Popup para Excel"    'UtilityNameExt para App em Pt
Public Const sDLLProgId As String = "AddInXlSpellNumber.ExcelDesigner"    'AddInXlUtilityNameInt.AppDesigner
Public Const sAppTarget As String = "Excel"    'Useful when installing to other Office app and not Excel

Public Const sCOMAddInFileName As String = "ExcelSpellNumber.dll"
Public Const sAddInFileName As String = ""    'ExcelSpellNumber.xla"    'XLA, DOT, PPA, MDB... Note! An xla with same name go listed in AttachFileNames, but has only fSpellMumber sheet function. It can be the Excel Add-in complete but it is not.
Public Const sEXEAddInFileName As String = "ExcelSpellNumberLoadExe.xla"    'XLA, DOT, PPA, MDB...
Public Const AttachFileNames As String = "ExcelSpellNumberHotKey.xla;ExcelSpellNumberClick.wav;ExcelSpellNumber.ini;ExcelSpellNumber.xlam;ExcelSpellNumber.xla"            'Attached in installer and created while running
Public Const AttachFileNamesEXEAddIn As String = "ExcelSpellNumber.exe"    'Attached in installer and created while running in exe
Public Const AttachFileNames64bit As String = "ExcelSpellNumber.exe.manifest;FM20.DLL;FM20ENU.DLL"    'Attached in installer and created while running in 64bit
Public Const AttachFileNamesComm As String = "FM20.DLL;FM20ENU.DLL"    'Attached files that are commom with another utilities or version

Public Const sOfficeVerReqMin As String = "9.0"     'Office Version required to Install - Min
Public Const sOfficeVerReqMax As String = "16.0"     'Office Version required to Install - Max
Public Const sAppVerReqToRun As String = ""    'Excel 12 (2007) or Excel 14 (2010)"    'Application Versions required to run utility. Let empty if Office riquired to install is sufficiente

Public Const sSuccessMsg As String = "Do not forget! The ''SpellNumber'' command will be available on Sheet Mouse Rigth-click Menu when you restart the Excel."
Public Const sSuccessMsgPt As String = "Não se esqueça! O comando ''Extenso'' estará disponível no Menu de Atalho de Clique Direito na planilha (Menu de Contexto) ao reiniciar o Excel."

Public Const lIsPortg As Long = 2    '0-Detect  1-Always portugues 2-Never Portuguese(always English) Useful to atend Extenso and SpellNumber for specic lang


Attribute VB_Name = "Mod1Uninstall"
Option Explicit
Dim sTempFile As String
Dim bCloseReOpenExcel As Boolean
Dim sFileAddInNameToUnByReg As String    'Alem de indicar o path e name do adding, é um flag para unregistra o Add-in para todos via register (mesmo só um é necessário para limpar a chave Addin manager) xxxxx
Dim bReopenedToDelDll As Boolean    'Para, se tiver uninstall dll, não tentar desregistrar possivel adding registrado por falha

Sub UnInstall()
    IsPortg = IIf(lIsPortg = 0, Application.LanguageSettings.LanguageID(msoLanguageIDUI) = 1046 Or Application.LanguageSettings.LanguageID(msoLanguageIDUI) = 2070, lIsPortg = 1)    'Application.International(xlCountryCode) = 55
    Set appHostApp = Application
    dHostAppVer = Val(Application.Version)
    AddInTitle = "Orlando's " & sAddInNameByApp
    sStartupPath = Application.StartupPath

    sTempFile = TempFolder() & "\" & sAddInNameByApp & "DllPath.tmp"

    PleaseWait False
    If Dir(sTempFile) = "" And sXLtoEXE_CmdLineReopen <> "UnInstall" Then
        If IsPortg Then
            Msg1 = "Será verificada a existência de uma instalação anterior e, em seguida, ela será devidamente removida. OK?"
            Msg2 = sAddInCaptByAppPt & " - DesInstalar"
        Else
            Msg1 = "It will be verified a previous installation and, after that, it will be duly removed. OK?"
            Msg2 = sAddInCaptByApp & " - UnInstall"
        End If
        If MyMsgBox(Msg1, 2, Msg2) = 2 Then Exit Sub
        PleaseWait True: If fExitEXEAddIn Then If fExitEXEAddIn Then Err.Raise vbObjectError + 1, "UnInstall", "Cannot stop " & AttachFileNamesEXEAddIn & " running!"
    Else
        PleaseWaitExeIndep False: PleaseWait True: bReopenedToDelDll = True
        MyWait 2    'To give time to other eventual instance of sAppTarget closes
    End If

    'Antes verificar se tem privilegio de admin para desregistrar DLL, se não, reopen asking
    If IsInstallAsCOMAddin And Not HasAdminPrivilege Then CloseReOpenExcelToUnregDLL: Exit Sub

    If UnInstallAsCOMAddIn Then
        If UnInstallAsAddIn Then
            VerifRestDisabledItems
            If IsPortg Then
                Msg1 = "Arquivos e comando do " & sAddInCaptByAppPt & " foram removidos."
                Msg2 = sAddInCaptByAppPt & " - DesInstalação Concluída"
            Else
                Msg1 = sAddInCaptByApp & " files and command were removed."
                Msg2 = sAddInCaptByApp & " - UnInstall Finished"
            End If
            If MyMsgBox(Msg1, 1, Msg2) = 1 Then
                ThisWorkbook.Saved = True
                If sFileAddInNameToUnByReg = "" Or bReopenedToDelDll Then
                    Application.Quit
                Else
                    UnInstallAddIn_AllViaReg sFileAddInNameToUnByReg, 0    'primeiro fazer a partir desta instância para que a seguinte logue no registro já limpo. Isso foi necessário no Excel 2010 em XP para ficar total limpo, inclusive Add-in Manager.
                    CloseReOpenExcelToDelDLL "'UnInstallAddIn_AllViaReg """ & sFileAddInNameToUnByReg & """,""" & fGetApp_hWnd & """'"       'Se houver mais de um Excel registrado, unregistrer o Add-in para todos via register xxxxx
                End If
            End If
        End If
    Else
        If bCloseReOpenExcel Then
            bCloseReOpenExcel = False
            If sAppTarget = "Excel" Then
                If HasAdminPrivilege Then CloseReOpenExcelToDelDLL "UnInstall" Else CloseReOpenExcelToUnregDLL    'Abrir outra instância é melhor que reopen mas precisa ter direito admin
            Else
                'Não é necessário o Excel está fechado pra remover a dll e sim o sAppTarget, bastando ReTry imediatamente.
                'Mantive o mesmo esquema, pois se falhar na próxima tentativa já vai completando a desinstalação
                ' CloseAllAccess True    'Qure retorne True or False, retenta pode ser que dê certo nesta execução mesmo
                UnInstall
            End If
        End If
    End If
End Sub

Private Function UnInstallAsCOMAddIn() As Boolean
    Dim sGuid As String
    Dim sDllPath As String

    PathInst = GetRegValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion", "ProgramFilesDir", False)
    If PathInst = "Error" Then PathInst = GetRegValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion", "ProgramFilesDir", False)
    If PathInst = "Error" Or Len(PathInst) < 5 Then PathInst = "C:"
    PathInst = PathInst & "\OrlandoApp"

    If IsInstallAsCOMAddin Then    'Uninstall from reg saving info in tmp file, close aplic, reopen, and then recall to delete the files
        'Get Dll Path on register
        sGuid = GetRegValue(HKEY_CLASSES_ROOT, sDLLProgId & "\Clsid", "", False)
        sDllPath = GetRegValue(HKEY_CLASSES_ROOT, "CLSID\" & sGuid & "\InprocServer32", "", False)

        'Se for Office 64-bits e como a instalação só pode ter sido feita pelo 32-bit então a pasta
        'deve ser detectada via Wow6432Node no registro e o unregister irá ser feito via RegSvr32.exe.
        'Exceto isto, nada foi alterado no codigo de uninstall pra 32-bit.
        If Not (Len(sDllPath) > 0 And Len(Dir(sDllPath))) > 0 And IsOffice64_bit Then
            sDllPath = GetRegValue(HKEY_CLASSES_ROOT, "Wow6432Node\CLSID\" & sGuid & "\InprocServer32", "", False)
        End If

        Dim sDllPathPct    'Se a dll registrada não for encontrada ou estiver inacessível, usar a do pacote. Isto é só para desregistrar, o processo continua como se sDllPath existisse inclusive reopen
        If Not (Len(sDllPath) > 0 And Len(Dir(sDllPath))) > 0 Then
            sDllPathPct = ThisWorkbook.Path & "\" & sCOMAddInFileName
            If Not (Len(sDllPathPct) > 0 And Len(Dir(sDllPathPct))) > 0 Then sDllPathPct = ""
        End If

        PathTemp = ThisWorkbook.Path: If Not InstallMSAddnDrDLL Then Exit Function   'To register/unregister COM, requires MSAddnDr.DLL, then verify and install if need. A priori isto só seria necessário em uma tenhativa de instalação de uma versão anterior que normalmente não pode acontecer, pois os antigos não rodam no 2013. Fica aqui em teste ou por segurança.

        If Not IsOffice64_bit Then
            RegisterServer IIf(sDllPathPct = "", sDllPath, sDllPathPct), False
        Else
            RegisterServerShell32 IIf(sDllPathPct = "", sDllPath, sDllPathPct), False
        End If

        'Se a dll registrada falhar ainda por algum outro motivo falhar, corrompida por exemplo,
        'tenta usar a do pacote se ainda não foi usada
        MyWait 1
        If IsInstallAsCOMAddin And sDllPathPct = "" Then   'Conferir
            sDllPathPct = ThisWorkbook.Path & "\" & sCOMAddInFileName
            If Not (Len(sDllPathPct) > 0 And Len(Dir(sDllPathPct))) > 0 Then sDllPathPct = ""
            If sDllPathPct <> "" Then
                If Not IsOffice64_bit Then
                    RegisterServer IIf(sDllPathPct = "", sDllPath, sDllPathPct), False
                Else
                    RegisterServerShell32 IIf(sDllPathPct = "", sDllPath, sDllPathPct), False
                End If
                MyWait 1
            End If
        End If

        If IsInstallAsCOMAddin Then    'Conferir novamente
            If IsPortg Then
                Msg1 = "Ao desregistrar a DLL no Windows." & vbCrLf & vbCrLf & _
                       "Obs.: No Windows XP e Vista, somente usuários com plenos direitos administrativos podem instalar e desinstalar COM add-ins, mas, se tentar instalar sem direitos, não vai causar nenhum problema maior, simplesmente não vai instalar."
                Msg2 = sAddInCaptByAppPt & " - Falha!"
            Else
                Msg1 = "When unregister the DLL on Windows." & vbCrLf & vbCrLf & _
                       "Note: In Windows XP and Vista, only users with full administrative rights can install and uninstall COM add-ins; however if you try to install without rights, this won't cause any major problems, it simply won't install."
                Msg2 = sAddInCaptByApp & " - Fail!"
            End If
            MyMsgBox Msg1, 1, Msg2
            PleaseWait False
            Exit Function
        End If

        'Delete local machine subkey for AddIn is used for All Win User
        If Not GetRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office\" & sAppTarget & "\Addins\" & sDLLProgId, "LoadBehavior", False) = "Error" Then _
 RegDeleteKey HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office\" & sAppTarget & "\Addins\" & sDLLProgId

        sDllPath = MyReplace(UCase(sDllPath), UCase("\" & sCOMAddInFileName), "")

        If Dir(sDllPath & "\LembreteDirProj.txt") <> "" Then sDllPath = PathInst    'Avoid to delete in folder project

        Open sTempFile For Output As #1
        Write #1, sDllPath
        Close #1
        bCloseReOpenExcel = True    'Para Quit Excel fora da função, pois não sai quando perde o foco
        Exit Function
    Else
        'Get Dll Path on temp file
        If Dir(sTempFile) <> "" Then
            Open sTempFile For Input As #1
            Input #1, sDllPath
            Close #1
        Else
            sDllPath = PathInst
        End If

        'Delete files and folder
        Dim i As Double
        Do
            i = i + 1
            MyWait i
            On Error Resume Next
            If Dir(PathInst & "\" & sCOMAddInFileName) <> "" Then Kill PathInst & "\" & sCOMAddInFileName
            If Dir(sDllPath & "\" & sCOMAddInFileName) <> "" Then Kill sDllPath & "\" & sCOMAddInFileName
        Loop While Err.Number <> 0 And i < 5
        If Err.Number = 0 Then
            For Each Fn In Split(AttachFileNames, ";")
                If Dir(PathInst & "\" & Fn) <> "" Then Kill PathInst & "\" & Fn
                If Dir(sDllPath & "\" & Fn) <> "" Then Kill sDllPath & "\" & Fn
            Next
            If Dir(PathInst & "\*.*") = "" And Dir(PathInst, vbDirectory) <> "" Then RmDir PathInst
            If Dir(sTempFile) <> "" Then Kill sTempFile
            PleaseWait False
        Else
            PleaseWait False
            'Antes verificar se não é falta de privilegio de admin para deletar DLL em pastas protegidas, se não, reopen asking. Isso acontece quando a DLL foi desregistrada por outros meios e não deletou os arquivo ou até por falha aqui.
            If Not HasAdminPrivilege Then bCloseReOpenExcel = True: Exit Function

            If IsPortg Then
                Msg1 = "Acesso não permitido. Feche todas as janelas do " & sAppTarget & " e depois tente novamente." _
                     & vbCrLf & vbCrLf & "Veja ainda se seus direitos de acessos são suficientes para excluir arquivos na pasta " & IIf(Dir(PathInst & "\" & sCOMAddInFileName) <> "", PathInst, sDllPath) & "."
                Msg2 = sAddInCaptByAppPt & " - Impossível Excluir!"
            Else
                Msg1 = "Access denied. Close all " & sAppTarget & " windows and then try again." _
                     & vbCrLf & vbCrLf & "See still if your access rights are sufficient to delete files in " & IIf(Dir(PathInst & "\" & sCOMAddInFileName) <> "", PathInst, sDllPath) & " folder."
                Msg2 = sAddInCaptByApp & " - Impossible to Delete!"
            End If
            MyMsgBox Msg1, 1, Msg2
            Exit Function
        End If
    End If
    UnInstallAsCOMAddIn = True
End Function

Private Function UnInstallAsAddIn() As Boolean
    Dim PathInst As String
    Dim ad As AddIn

    UnInstallAsAddIn = True
    If sAddInFileName = "" And sEXEAddInFileName = "" Then Exit Function

    PathInst = ""
    For Each ad In AddIns
        If ad.Name = sAddInFileName Or ad.Name = sEXEAddInFileName Then
            PathInst = ad.Path: sFileAddInNameToUnByReg = ad.FullName
            Exit For
        End If
    Next

    On Error Resume Next

…