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
Private Sub Workbook_Open()
  ' CreateShortCutMenu
  ' Application.Visible = False
   
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

Attribute VB_Name = "Mod1CreateShortCut"
Public Const vStr As Long = 255
Public Const REG_BINARY = 3&
Public Const REG_DWORD = 4&
#If VBA7 Then
    Declare PtrSafe Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As Long
    Declare PtrSafe Function RegQueryValueEx 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.
    Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
#Else
    Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Declare Function RegQueryValueEx 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.
    Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002

#If VBA7 Then
    Private Declare PtrSafe Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As LongPtr, ByVal lpSubKey As String) As Long
    Private Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As LongPtr, ByVal lpValueName As String) As Long
#Else
    Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
    Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
#End If


#If VBA7 Then
    Public Declare PtrSafe Function GetKeyState32 Lib "user32" Alias "GetKeyState" (ByVal nVirtKey As Long) As Integer
    Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Public Declare Function GetKeyState32 Lib "user32" Alias "GetKeyState" (ByVal vKey As Integer) As Integer
    Public Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Public Const AddInTitle As String = "Orlando's Create ShortCut"
#If VBA7 Then
    Public App_hWnd As LongPtr
#Else
    Public App_hWnd As Long
#End If
#If VBA7 Then
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
#Else
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Private Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1
#If VBA7 Then
    Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#Else
    Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#End If
Public Const LOCALE_USER_DEFAULT& = &H400
Public Const LOCALE_SENGLANGUAGE = &H1001   'English name of language
Public Const LOCALE_SLANGUAGE = &H2   'localized name of language
#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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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 CreateShortCut.xla", "Information about CreateShortCut.xla")
        .HomePage_Lb.Caption = IIf(IsPortg, "Ajuda", "Help")
        .HomePage_Lb.ControlTipText = "http://cpap.com.br/orlando/"
        .HomePageUrl = "http://cpap.com.br/orlando/" & IIf(IsPortg, "CreateShortCutMais.asp?IdC=Ajuda", "CreateShortCutMore.asp?IdC=Help")
        .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)
    Dim Start
    Start = Timer
    Do
        DoEvents
        Sleep 1    'Com isso o CPU Usage cai de 100% para seus 0 ou 2% normal
    Loop While Timer < Start + PauseSeg
End Sub

Function gLocInfo(vType As Long) As String
    Dim vLoc As Long
    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

Sub SendEMailByURL(Email As String, Subj As String, Msg As String)
    Dim URL As String
    Dim Ret As Long
    Application.StatusBar = IIf(IsPortg, "Preparando Email. 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:" & Email & "?subject=" & Subj & "&body=" & Msg

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

    ThisWorkbook.FollowHyperlink Left(URL, 457), , True
    MyWait 10
    Application.StatusBar = False
End Sub

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
    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 & Application.UserName & vbCrLf

    Dim WinVer As String
    Dim AppVer As String
    WinVer = Application.OperatingSystem & " " & gLocInfo(LOCALE_SLANGUAGE)
    AppVer = Application.International(xlCountryCode)
    AppVer = IIf(AppVer = 1, "English", IIf(AppVer = 55, "Português", "Language " & AppVer))
    AppVer = Application.Name & " " & Application.Version & " (" & AppVer & ")"
    EmlMsg = EmlMsg & WinVer & vbCrLf
    EmlMsg = EmlMsg & AppVer & vbCrLf
End Function


Function TempFolder() As String
'Get Temp Folder
   Dim fctRet As Long
   TempFolder = String$(255, 0)
   fctRet = GetTempPath(255, TempFolder)
   If fctRet <> 0 Then
      TempFolder = Left(TempFolder, fctRet)
      If Right(TempFolder, 1) = "\" Then TempFolder = Left(TempFolder, Len(TempFolder) - 1)
   Else
      TempFolder = ""
   End If
End Function

Public Function BrowseFolder(szDialogTitle As String, hWnd As Variant) As String
   Dim X As Long, bi As BROWSEINFO, dwIList As Long
   Dim szPath As String, wPos As Integer

   With bi
      .hOwner = hWnd 'hWndAccessApp
      .lpszTitle = szDialogTitle
      .ulFlags = BIF_RETURNONLYFSDIRS
   End With

   dwIList = SHBrowseForFolder(bi)
   szPath = Space$(512)
   X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

   If X Then
      wPos = InStr(szPath, Chr(0))
      BrowseFolder = Left$(szPath, wPos - 1)
   Else
      BrowseFolder = ""
   End If
End Function

Sub aa()
   Dim strFolderName As String
   GetApp_hWnd
   strFolderName = BrowseFolder("What Folder you want to select?", App_hWnd)
End Sub



Public Sub CreateShortCut(NameShortCut As String, _
      Optional PathWorkbook As String, _
      Optional PathIcoFile As String, _
      Optional Exclusive As Boolean = True, _
      Optional CmdLineArgument As String, _
      Optional PathExcelExe As String)
   Dim DashPos1 As Integer
   Dim DashPos2 As Integer
   Dim PathStartProg As String
   Dim vFolder As String
   Dim PathTemp As String
   Dim PathShortCutExe As String
   Dim ScrUp As Boolean
   Dim i As Integer

   If Left(NameShortCut, 1) = "\" Then NameShortCut = Mid(NameShortCut, 2, 500)
   If InStr(1, NameShortCut, "\") = 0 Then NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Desktop") & "\" & NameShortCut
   If InStr(1, NameShortCut, "\") > 0 And InStr(1, NameShortCut, ":") = 0 Then
      DashPos1 = 0
      DashPos2 = InStr(DashPos1 + 1, NameShortCut, "\")
      PathStartProg = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Programs")
      While DashPos2 > 0
         vFolder = Mid(NameShortCut, 1, DashPos2 - 1)
         If Dir(PathStartProg & "\" & vFolder, vbDirectory) = "" Then MkDir PathStartProg & "\" & vFolder
         DashPos1 = DashPos2
         DashPos2 = InStr(DashPos1 + 1, NameShortCut, "\")
      Wend
      NameShortCut = PathStartProg & "\" & NameShortCut
   End If
   If PathExcelExe = "" Then PathExcelExe = Application.Path
   If Right(PathExcelExe, 1) = "\" Then PathExcelExe = Left(PathExcelExe, Len(PathExcelExe) - 1)

   'First try to do by WScript if it presents
   Dim vName As String, vTarget As String, vArg As String, vIco As String
   vName = NameShortCut & ".lnk"
   If Exclusive Then
      vTarget = PathExcelExe & "\EXCEL.EXE"
      vArg = CmdLineArgument & IIf(PathWorkbook = "", "", " " & """" & PathWorkbook & """")
   Else
      vTarget = """" & PathWorkbook & """"
      vArg = CmdLineArgument
   End If
   vIco = PathIcoFile
   If CreateShortCutWScript(vName, vTarget, vArg, vIco) Then Exit Sub
   'Para testar shortcut dos basta comentar a linha acima

   'Second try to do by Shortcut.exe
   PathTemp = TempFolder()
   If Right(PathTemp, 1) = "\" Then PathTemp = Left(PathTemp, Len(PathTemp) - 1)
   PathShortCutExe = PathTemp

   'Extraindo Pacote
   Application.DisplayAlerts = False
   ThisWorkbook.Sheets(1).OLEObjects("ShortCutDos").Verb Verb:=xlPrimary
   Application.DisplayAlerts = True
   MyWait 5

   'Conferindo extraçمo
   Do While Dir(PathTemp & "\shortcut.exe") = ""
      MyWait 1
      i = i + 1
      If i > 40 Then
         MyMsgBox IIf(IsPortg, "Ao extrair arquivos para a pasta " & PathTemp & ".", "When extract files to " & PathTemp & " folder."), 1, IIf(IsPortg, "Falha!", "Fail!")
         Exit Sub
      End If
   Loop

   'Creating Shortcut
   Shell PathShortCutExe & "\SHORTCUT.EXE -f -t """ & vTarget & """ -n """ & vName & ""
   MyWait 2

   'Adding command line argument
   If CmdLineArgument <> "" Or PathWorkbook <> "" Then
      If Exclusive Then
         vArg = " -a " & """" & CmdLineArgument & IIf(PathWorkbook = "", "", " " & """""""" & PathWorkbook & """""""") & """"
      Else
         If CmdLineArgument <> "" Then
            vArg = " -a " & """" & CmdLineArgument & """"
         Else
            vArg = ""
         End If
      End If
      Shell PathShortCutExe & "\SHORTCUT.EXE -c -n """ & vName & """" & vArg
      MyWait 2
   End If

   'Adding Icone
   If PathIcoFile <> "" Then
      vIco = " -i " & """" & PathIcoFile & """"
      Shell PathShortCutExe & "\SHORTCUT.EXE -c -n """ & vName & """" & vIco
      MyWait 5
   End If
   On Error Resume Next
   Kill PathTemp & "\shortcut.exe"
   ThisWorkbook.Saved = True
End Sub

Private Function CreateShortCutWScript(vName As String, vTarget As String, vArg As String, vIco As String)
   Dim wsh As Object
   Dim oShortcut As Object
   Dim DirP As String
   Dim fs

   On Error GoTo ErrorHandler
   vName = Application.WorksheetFunction.Substitute(vName, """", "")
   vTarget = Application.WorksheetFunction.Substitute(vTarget, """", "")

   DirP = ThisWorkbook.Path
   If InStr(1, Left(vName, 3), "\") = 0 Then vName = DirP & "\" & vName & ".lnk"
   Set fs = CreateObject("Scripting.FileSystemObject")
   If fs.fileexists(vName) Then fs.DeleteFile vName, True

   vTarget = Application.WorksheetFunction.Substitute(vTarget, """", "")
   Set wsh = CreateObject("WScript.Shell")
   Set oShortcut = wsh.CreateShortCut(vName)
   With oShortcut
      If vTarget <> "" Then .TargetPath = vTarget
      If vArg <> "" Then .Arguments = vArg
      '.WorkingDirectory = "c:\xx"
      '.WindowStyle = 4
      If vIco <> "" Then .IconLocation = vIco
      .Save
   End With
   Set wsh = Nothing
   CreateShortCutWScript = True
   Exit Function
ErrorHandler:
   CreateShortCutWScript = False
End Function

'ThisWorkbook.Sheets(1).Shapes("ShortCutDos").Visible = False


Public Sub CreateShortCutMenu()
    IsPortg = Application.International(xlCountryCode) = 55
    If Val(Application.Version) > 11 + 1 + 2 + 1 + 1 Then
        Msg1 = IIf(IsPortg, "Nova versمo do Excel desconhecida para esta versمo do CreateShortCut.xla! Clique no link Ajuda, logo abaixo, para baixar uma nova versمo compatيvel.", _
                "New Excel version unknown to this CreateShortCut.xla version! Click Help link, soon below, to download a new compatible version.")
        Msg2 = AddInTitle & IIf(IsPortg, " - Falha!", " - Fail!")
        MyMsgBox Msg1, 1, Msg2
    Else
        FormShortCut.Show
    End If
    If Not ShiftDown Then ThisWorkbook.Close False
End Sub

Public Function ShiftDown()
'Verif. se shift estل pressionada
   ShiftDown = (GetKeyState32(16) < 0)
End Function

Sub ThisOnDesktop()
   Dim NameShortCut As String
   Dim CmdLineArgument As String
   Dim PathIcoFile As String
   Dim PathWorkbook As String
   IsPortg = Application.International(xlCountryCode) = 55
   NameShortCut = IIf(IsPortg, "Atalho para ", "Shortcut to ") & ThisWorkbook.Name
   PathWorkbook = ThisWorkbook.FullName
   PathIcoFile = ThisWorkbook.Path & "\CreateShortCut.ico"
   'CmdLineArgument = "/automation"
   CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, False
End Sub

Sub GetApp_hWnd()
    Dim sClassByVer As String
    If Val(Application.Version) > 9 Then App_hWnd = Application.hWnd
    If App_hWnd = 0 Then sClassByVer = "XLMain"
    If App_hWnd = 0 And sClassByVer <> "" Then
        On Error Resume Next
        If Application.Windows.Count > 0 Then
            App_hWnd = FindWindowA(sClassByVer, Application.Caption & " - " & Application.ActiveWindow.Caption)
            If App_hWnd = 0 Then App_hWnd = FindWindowA(sClassByVer, Application.ActiveWindow.Caption & " - " & Application.Caption)
        End If
        If App_hWnd = 0 Then App_hWnd = FindWindowA(sClassByVer, Application.Caption)
        If App_hWnd = 0 Then App_hWnd = FindWindowA(sClassByVer, vbNullString)    'KB288902 informa ClassNames até o 2007
        Err.Clear
    End If
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)
Function GetRegValue(Key As Long, SubKey As String, ValueName As String) As String
   Dim RetStr As String * vStr   'Fixed-length strings
   Dim fctRet As Long
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
      Dim OpenKeyHdl As Long
    #End If
   Dim vType As Long
   Dim vLen As Long
   Dim i As Integer

   GetRegValue = "Error"
   vLen = vStr
   fctRet = RegOpenKey(Key, SubKey, OpenKeyHdl)
   If fctRet <> 0 Then Exit Function

   fctRet = RegQueryValueEx(OpenKeyHdl, ValueName, 0&, vType, RetStr, vLen)
   RegCloseKey OpenKeyHdl
   If fctRet <> 0 Then Exit Function

   If vType = REG_BINARY Then
      GetRegValue = ""
      For i = 1 To vLen
         GetRegValue = GetRegValue _
               & IIf(Len(Hex(Asc(Mid(RetStr, i, 1)))) = 1, "0", "") _
               & Hex(Asc(Mid(RetStr, i, 1))) & " "
      Next
      Exit Function
   End If

   If vType = REG_DWORD Then
      GetRegValue = "0x"
      For i = 4 To 1 Step -1
         GetRegValue = GetRegValue _
               & IIf(Len(Hex(Asc(Mid(RetStr, i, 1)))) = 1, "0", "") _
               & Hex(Asc(Mid(RetStr, i, 1)))
      Next
      Exit Function
   End If

   GetRegValue = Left(RetStr, vLen - 1)
End Function

Private Sub TestGet()
'Teste 1 Outlook Journal
   MsgBox GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Shared Tools\Outlook\Journaling\Microsoft Excel", "Enabled")
   'Teste 2 Calendar
   MsgBox GetRegValue(HKEY_CLASSES_ROOT, "MSCAL.Calendar", "")
   'Teste 2 Resoluçمo do vيdeo
   MsgBox Application.WorksheetFunction.Clean(GetRegValue(HKEY_LOCAL_MACHINE, "Config\0001\Display\Settings", "Resolution"))
   'Teste 3 Pastas padrُes
   MsgBox GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Desktop")
   MsgBox GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Programs")
   MsgBox GetRegValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion", "ProgramFilesDir")
   MsgBox GetRegValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion", "ProgramFilesPath")
   MsgBox GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Favorites")
   MsgBox GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Start Menu")
End Sub

Sub DeleteKey(Key As Long, SubKey As String)
   Call RegDeleteKey(Key, SubKey)
End Sub

Sub DeleteKeyValue(Key As Long, SubKey As String, ValueName As String)
    #If VBA7 Then
        Dim OpenKeyHdl As LongPtr
    #Else
      Dim OpenKeyHdl As Long
    #End If
   Dim fctRet As Long
   fctRet = RegOpenKey(Key, SubKey, OpenKeyHdl)
   If fctRet <> 0 Then Exit Sub
   Call RegDeleteValue(OpenKeyHdl, ValueName)
   RegCloseKey OpenKeyHdl
End Sub



Attribute VB_Name = "Mod5GetTempDir"
Option Explicit


Attribute VB_Name = "Mod3GetRegValue"
Option Explicit




Attribute VB_Name = "Mod4BrowseFolder"
Option Explicit
'---Posted by Dev Ashish--
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'Code courtesy of
'Terry Kreft


Attribute VB_Name = "Mod2Others"
Option Explicit


Attribute VB_Name = "FormShortCut"
Attribute VB_Base = "0{6C6B79E8-340D-4869-A81A-42C4AAB9E92B}{3941B38D-6892-4711-9CF6-6FC768D4B679}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
#If VBA7 Then
    Dim Form_hWnd1 As LongPtr
#Else
    Dim Form_hWnd1 As Long
#End If

Private Sub UserForm_Initialize()
    Dim wb As Workbook
    Dim IconFile As String

    If IsPortg Then
        Caption = "Criador de Atalho XL no Windows®"
        Workbook_Fr.Caption = "Arquivo XL Aberto:"
        ShortCut_Fr.Caption = "Atalho a criar para o arquivo XL acima:"
        ShortCutName_Lb.Caption = "Nome:"
        CreateOn_Fr.Caption = "Criar Em:"
        Desktop_ChB.Caption = "ءrea de Trabalho"
        StartMenu_ChB.Caption = "Menu Iniciar na Subpasta Programas:"
        AnyWhere_ChB.Caption = "Qualquer Local Em:"
        Exclusive_ChB.Caption = "Abrir sempre em uma nova execuçمo do Excel      "
        Argument_Lb.Caption = "Argumento Opcional de Comando de Linha:"
        Icon_Lb.Caption = "حcone:"
        Create_Bt.Caption = "Criar"
        Exit_Bt.Caption = "Sair"
        Email_Lb.Caption = "E-mail"
        Email_Lb.ControlTipText = "info95100@gmail.com"
        HomePage_Lb.Caption = "Ajuda"
        HomePage_Lb.ControlTipText = "http://cpap.com.br/orlando/"
    End If
    Email_Lb.Left = Width - Email_Lb.Width - (Width - InsideWidth) - 4     'Email_Lb.Left = Width - Email_Lb.Width - 8

    For Each wb In Workbooks
        Workbook_Cb.AddItem (wb.Name)
    Next
    Workbook_Cb.AddItem (ThisWorkbook.Name)
    Workbook_Cb.AddItem ("")

    StartMenu_Cb.AddItem (IIf(IsPortg, "MeuAplicativo", "MyApplication"))
    StartMenu_Cb.AddItem (IIf(IsPortg, "<Raiz da Pasta Programas>", "<Root Programs Folder>"))
    StartMenu_Cb.AddItem (IIf(IsPortg, "<Raiz da Pasta Menu Iniciar>", "<Root Start Menu Folder>"))
    StartMenu_Cb.AddItem ("")
    StartMenu_Cb.ListIndex = 0

    Anywhere_Tb.Value = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Favorites")

    Argument_Cb.AddItem ("/Automation")
    IconFile = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 3) & "ico"
    If Dir(IconFile) <> "" Then Icon_Tb.Value = IconFile
    
    'Get form handle
    Form_hWnd1 = FindWindowA("ThunderDFrame", Caption)
    If Form_hWnd1 = 0 Then Form_hWnd1 = FindWindowA(vbNullString, Caption)
End Sub

Private Sub Workbook_Cb_Change()
   If Workbook_Cb.Value = "" Then Exit Sub
   If Workbooks(Workbook_Cb.Value).Path = "" Then
      Msg1 = IIf(IsPortg, "Impossيvel criar atalho para uma pasta de trabalho ainda nمo salva!", "Impossible to create a shortcut for an unsaved workbook!")
      Msg2 = IIf(IsPortg, "Pasta de Trabalho ainda nمo Salva!", "Workbook Was Not Saved Yet!")
      MyMsgBox Msg1, 1, Msg2
      Workbook_Cb.Value = ""
      ShortCutName_Tb.Value = ""
      Exit Sub
   End If
   ShortCutName_Tb.Value = IIf(IsPortg, "Atalho para ", "Shortcut to ") & Workbook_Cb.Value
End Sub

Private Sub AnyWherePath_Lb_Click()
   Dim strFolderName
   strFolderName = BrowseFolder(IIf(IsPortg, "Que pasta você deseja selecionar?", "What folder do you want to select?"), Form_hWnd1)
   If strFolderName = "" Then Exit Sub
   Anywhere_Tb.Value = strFolderName
End Sub

Private Sub IconOpen_Lb_Click()
   Dim vFileName
   vFileName = Application.GetOpenFilename(IIf(IsPortg, "حcones (*.ico;*.cur),*.ico;*.cur", "Icons (*.ico;*.cur),*.ico;*.cur"), , IIf(IsPortg, "Selecionar Arquivos de حcone", "Select Icon File"))
   If vFileName = False Then Exit Sub
   Icon_Tb.Value = vFileName
End Sub


Private Sub Create_Bt_Click()
   Dim NameShortCut As String
   Dim CmdLineArgument As String
   Dim PathIcoFile As String
   Dim PathWorkbook As String
   Dim InstDesktop As Boolean
   Dim InstStartMenu As Boolean
   Dim InstAnyWhere As Boolean

   If Workbook_Cb.Value = "" Then
      Msg1 = IIf(IsPortg, "Informe uma Pasta de Trabalho salva para criar o atalho para mesma!", "Inform a saved Workbook to create shortcut for it!")
      Msg2 = IIf(IsPortg, "Pasta de Trabalho Vazia!", "Empty Workbook!")
      MyMsgBox Msg1, 1, Msg2
      Exit Sub
   End If
   PathWorkbook = Workbooks(Workbook_Cb.Value).FullName

   If Not (Desktop_ChB.Value Or StartMenu_ChB.Value Or AnyWhere_ChB.Value) Then
      Msg1 = IIf(IsPortg, "Informe um local para criar o atalho!", "Inform a place to create the shortcut!")
      Msg2 = IIf(IsPortg, "Local Indefinido!", "Undefined Place!")
      MyMsgBox Msg1, 1, Msg2
      Exit Sub
   End If

   CmdLineArgument = Argument_Cb.Value
   PathIcoFile = Icon_Tb.Value
   If Dir(PathIcoFile) = "" Then
      Msg1 = IIf(IsPortg, "O arquivo para o يcone nمo foi encontrado!", "The icon file wasn't found!")
      Msg2 = IIf(IsPortg, "Falha!", "Fail!")
      MyMsgBox Msg1, 1, Msg2
      Exit Sub
   End If

   If Desktop_ChB.Value Then
      NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Desktop")
      NameShortCut = NameShortCut & "\" & ShortCutName_Tb.Value
      If Dir(NameShortCut & ".lnk") <> "" Then
         Msg1 = IIf(IsPortg, "O atalho com o nome " & NameShortCut & " jل existe. Substituir?", "The shortcut with the name " & NameShortCut & " already exists. Replace?")
         Msg2 = IIf(IsPortg, "Substituir", "Replace")
         If MyMsgBox(Msg1, 2, Msg2) = 1 Then
            CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
            If Err.Number = 0 Then InstDesktop = True
         End If
      Else
         CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
         If Err.Number = 0 Then InstDesktop = True
      End If
   End If

   If StartMenu_ChB.Value Then
      If StartMenu_Cb.Value = "" Then
         NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Programs")
      Else
         NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Programs") & "\" & StartMenu_Cb.Value
      End If
      If StartMenu_Cb.Value = IIf(IsPortg, "<Raiz da Pasta Programas>", "<Root Programs Folder>") Then NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Programs")
      If StartMenu_Cb.Value = IIf(IsPortg, "<Raiz da Pasta Menu Iniciar>", "<Root Start Menu Folder>") Then NameShortCut = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Start Menu")

      If Dir(NameShortCut, vbDirectory) = "" Then
         Msg1 = IIf(IsPortg, "A pasta " & NameShortCut & " nمo existe. Criar?", "The " & NameShortCut & " folder don't exist. Create?")
         Msg2 = IIf(IsPortg, "Criar Pasta", "Create Folder")
         If MyMsgBox(Msg1, 2, Msg2) = 1 Then
            On Error Resume Next
            MkDir NameShortCut
            If Err.Number <> 0 Then
               Msg1 = Err.Description
               Msg2 = IIf(IsPortg, "Falha!", "Fail!")
               MyMsgBox Msg1, 1, Msg2
               GoTo AnyWhere
            End If
         Else
            GoTo AnyWhere
         End If
      End If

      NameShortCut = NameShortCut & "\" & ShortCutName_Tb.Value
      If Dir(NameShortCut & ".lnk") <> "" Then
         Msg1 = IIf(IsPortg, "O atalho com o nome " & NameShortCut & " jل existe. Substituir?", "The shortcut with the name " & NameShortCut & " already exists. Replace?")
         Msg2 = IIf(IsPortg, "Substituir", "Replace")
         If MyMsgBox(Msg1, 2, Msg2) = 1 Then
            CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
            If Err.Number = 0 Then InstStartMenu = True
         End If
      Else
         CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
         If Err.Number = 0 Then InstStartMenu = True
      End If
   End If

AnyWhere:
   If AnyWhere_ChB.Value Then
      NameShortCut = Anywhere_Tb.Value
      If Dir(NameShortCut, vbDirectory) = "" And NameShortCut <> GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Favorites") Then
         Msg1 = IIf(IsPortg, "A pasta " & NameShortCut & " nمo existe. Criar?", "The " & NameShortCut & " folder don't exist. Create?")
         Msg2 = IIf(IsPortg, "Criar Pasta", "Create Folder")
         If MyMsgBox(Msg1, 2, Msg2) = 2 Then
            On Error Resume Next
            MkDir NameShortCut
            If Err.Number <> 0 Then
               Msg1 = Err.Description
               Msg2 = IIf(IsPortg, "Falha!", "Fail!")
               MyMsgBox Msg1, 1, Msg2
               GoTo Fim
            End If
         Else
            GoTo Fim
         End If
      End If

      NameShortCut = NameShortCut & "\" & ShortCutName_Tb.Value
      If Dir(NameShortCut & ".lnk") <> "" Then
         Msg1 = IIf(IsPortg, "O atalho com o nome " & NameShortCut & " jل existe. Substituir?", "The shortcut with the name " & NameShortCut & " already exists. Replace?")
         Msg2 = IIf(IsPortg, "Substituir", "Replace")
         If MyMsgBox(Msg1, 2, Msg2) = 1 Then
            CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
            If Err.Number = 0 Then InstAnyWhere = True
         End If
      Else
         CreateShortCut NameShortCut, PathWorkbook, PathIcoFile, Exclusive_ChB.Value, CmdLineArgument
         If Err.Number = 0 Then InstAnyWhere = True
      End If
   End If
Fim:
   If IsPortg Then
      Msg1 = "- Na ءrea de Trabalho: " & IIf(InstDesktop, "OK", "Nمo") & Chr(10) & Chr(10)
      Msg1 = Msg1 & "- No Menu Iniciar: " & IIf(InstStartMenu, "OK", "Nمo") & Chr(10) & Chr(10)
      Msg1 = Msg1 & "- Em " & IIf(InstAnyWhere, NameShortCut, "outro local") & ": " & IIf(InstAnyWhere, "OK", "Nمo")
      Msg2 = "Atalhos Criados - Relatَrio Final"
   Else
      Msg1 = "- At Desktop: " & IIf(InstDesktop, "OK", "Not") & Chr(10) & Chr(10)
      Msg1 = Msg1 & "- At Start Menu: " & IIf(InstStartMenu, "OK", "Not") & Chr(10) & Chr(10)
      Msg1 = Msg1 & "- At " & IIf(InstAnyWhere, NameShortCut, "Anywhere") & ": " & IIf(InstAnyWhere, "OK", "Not")
      Msg2 = "Created ShortCuts - Final Report"
   End If
   MyMsgBox Msg1, 1, Msg2
End Sub

Private Sub Exit_Bt_Click()
   Unload Me
End Sub

Private Sub Email_Lb_Click()
   If Email_Lb.MousePointer = fmMousePointerHourGlass Then Exit Sub
   Email_Lb.MousePointer = fmMousePointerHourGlass
   Email_Lb.ForeColor = &H80FF&
   SendEMailByURL "orlando@cpap.com.br", IIf(IsPortg, "Informaçُes sobre o CreateShortCut.xla", "Information about the CreateShortCut.xla"), EmlMsg
   Email_Lb.MousePointer = fmMousePointerCustom
End Sub

Private Sub HomePage_Lb_Click()
   If HomePage_Lb.MousePointer = fmMousePointerHourGlass Then Exit Sub
   HomePage_Lb.MousePointer = fmMousePointerHourGlass
   HomePage_Lb.ForeColor = &H80FF&
  
   'A vantagem do Shell é poder acionar Start(Dos) oculto (Falha no Win2000)
   'Shell "Start http://cpap.com.br/orlando/", vbHide
   'MyWait 10

   On Error Resume Next
   ThisWorkbook.FollowHyperlink "http://cpap.com.br/orlando/" & IIf(IsPortg, "CreateShortCutMais.asp?IdC=Ajuda", "CreateShortCutMore.asp?IdC=Help"), , True
   If Err.Number <> 0 Then MsgBox Err.Description
   
   HomePage_Lb.MousePointer = fmMousePointerCustom
End Sub

Attribute VB_Name = "ModMyMsgBox"
Option Explicit

Attribute VB_Name = "FormMyMsgBox"
Attribute VB_Base = "0{52C5E1F2-7A4F-4382-9BC0-652F32B4AA11}{5E8A22CC-E3FA-49FD-A800-386AB01402EC}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Public EmailSubj As String
Public HomePageUrl As String
Public lBut As Long
Public Xpos As Long
Public Ypos As Long

Private Sub HomePage_Lb_Click()
    If HomePage_Lb.MousePointer = fmMousePointerHourGlass Then Exit Sub
    HomePage_Lb.MousePointer = fmMousePointerHourGlass
    HomePage_Lb.ForeColor = &H80FF&
    On Error Resume Next
    ThisWorkbook.FollowHyperlink HomePageUrl, , True
    If Err.Number <> 0 Then MsgBox Err.Description
    HomePage_Lb.MousePointer = fmMousePointerCustom
End Sub

Private Sub Email_Lb_Click()
    If Email_Lb.MousePointer = fmMousePointerHourGlass Then Exit Sub
    Email_Lb.MousePointer = fmMousePointerHourGlass
    Email_Lb.ForeColor = &H80FF&
    SendEMailByURL Email_Lb.ControlTipText, EmailSubj, EmlMsg
    Email_Lb.MousePointer = fmMousePointerCustom
End Sub

Private Sub OK_Bt_Click()
    BotAcionado = 1
    Hide
End Sub

Private Sub Cancel_Bt_Click()
    BotAcionado = 2
    Hide
End Sub

Private Sub Ignore_Bt_Click()
    BotAcionado = 3
    Hide
End Sub

Private Sub UserForm_Activate()
    Dim CountLines As Long
    Dim Lins
    Dim l As Long

    With Alert_Tb
        .Width = 284
        'Lins = Split(.Text, vbCrLf)
        Lins = MySplit(.Text, vbCrLf)
        For l = 0 To UBound(Lins)
            CountLines = CountLines + 1 + Int(Len(Lins(l)) / 75)
        Next
        .Height = (1 + CountLines) * 12
        If .Height > 16 * 12 Then
            .Height = 15 * 12
            .SpecialEffect = fmSpecialEffectSunken
            .SetFocus
            .SelStart = 0
        End If
    End With

    Icon_Lb.Caption = IIf(lBut <> 1, "?", "i")
    Cancel_Bt.Visible = lBut <> 1
    Ignore_Bt.Visible = lBut = 3

    OK_Bt.Caption = IIf(lBut = 3, IIf(IsPortg, "Sim", "Yes"), "OK")
    Cancel_Bt.Caption = IIf(lBut = 3, IIf(IsPortg, "Nمo", "No"), IIf(IsPortg, "Cancelar", "Cancel"))
    Ignore_Bt.Caption = IIf(IsPortg, "Ignorar", "Ignore")

    OK_Bt.Top = Alert_Tb.Top + Alert_Tb.Height + 5
    Cancel_Bt.Top = OK_Bt.Top
    Ignore_Bt.Top = OK_Bt.Top
    HomePage_Lb.Top = OK_Bt.Top + 7.5
    Email_Lb.Top = HomePage_Lb.Top
    Email_Lb.Left = Width - Email_Lb.Width - (Width - InsideWidth) - 4      'Email_Lb.Left = Width - Email_Lb.Width - 8 'Em COM add-in é preciso transformar width e height em Twips
    Height = (HomePage_Lb.Top + OK_Bt.Height) + (Height - InsideHeight) - 1       'Height = HomePage_Lb.Top + OK_Bt.Height + (Height - InsideHeight - (Width - InsideWidth) / 2) + 2    'Entre parentese: altura da barra de tيtulo(caption)

    If lBut = 1 Then OK_Bt.Left = 135
    If lBut = 2 Then OK_Bt.Left = 90: Cancel_Bt.Left = 180
    If Xpos <> 0 Then Left = Xpos
    If Ypos <> 0 Then Top = Ypos
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then BotAcionado = IIf(Cancel_Bt.Visible, 2, 1)
End Sub