Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "SMQ"
Const ISWKEY As String = "AutoQuotes"
Sub ToggleAutoQuotes()
Select Case AutoQuoteStatus
Case True: DisableAutoQuote
Case Else: ActivateAutoQuote
End Select
End Sub
Sub ActivateAutoQuote()
On Error Resume Next
SetEnvironment
DisableAutoQuote
Dim sKbd As String: sKbd = GetCurKeyboardName
Dim iKey1 As Integer: iKey1 = GetDefKey(sKbd, 1)
Dim iKey2 As Integer: iKey2 = GetDefKey(sKbd, 2)
AssignKey "InsertDoubleQuote", iKey1
AssignKey "InsertSingleQuote", iKey2
SaveSetting ISWREG, ISWKEY, "Enabled", "1"
SaveSetting ISWREG, ISWKEY, "Key1", iKey1
SaveSetting ISWREG, ISWKEY, "Key2", iKey2
SaveSetting ISWREG, "Keyboard", "Name", sKbd
CleanEnvironment
End Sub
Sub DisableAutoQuote()
On Error Resume Next
SetEnvironment
Dim iKey1 As Integer: iKey1 = Val(GetSetting(ISWREG, ISWKEY, "Key1"))
Dim iKey2 As Integer: iKey2 = Val(GetSetting(ISWREG, ISWKEY, "Key2"))
FindKey(iKey1).Clear
FindKey(iKey2).Clear
SaveSetting ISWREG, ISWKEY, "Enabled", "0"
DeleteSetting ISWREG, ISWKEY, "Key1"
DeleteSetting ISWREG, ISWKEY, "Key2"
CleanEnvironment
End Sub
Function AutoQuoteStatus()
AutoQuoteStatus = (Val(GetSetting(ISWREG, ISWKEY, "Enabled")) <> 0)
End Function
Sub InsertSingleQuotePair()
With Selection
    .Collapse Direction:=wdCollapseEnd
    .TypeText fSingleQuoteOpen
    .TypeText fSingleQuoteClose
    .MoveLeft Unit:=wdCharacter, count:=Len(fSingleQuoteOpen)
End With
End Sub
Sub InsertDoubleQuotePair()
With Selection
    .Collapse Direction:=wdCollapseEnd
    .TypeText fDoubleQuoteOpen
    .TypeText fDoubleQuoteClose
    .MoveLeft Unit:=wdCharacter, count:=Len(fDoubleQuoteOpen)
End With
End Sub
Sub InsertSingleQuote()
If Not FormattingAllowed Then Beep: Exit Sub
Dim CurAsc As Long, CanMove As Integer
With Selection
    If Options.AutoFormatAsYouTypeReplaceQuotes = False Then
        .TypeText "'"
        Exit Sub
    End If
    If .Type = wdSelectionIP Then
        CanMove = .MoveLeft
        If CanMove = 0 Then
            .TypeText fSingleQuoteOpen
        Else
            CurAsc = AscW(.Text)
            .MoveRight
            Select Case CurAsc
            Case Is <= 32, 34, 145, 146, 40, 91, 123, 61, 60, 62 '   "‘’([{=<>
                .TypeText fSingleQuoteOpen
            Case Else
                .TypeText fSingleQuoteClose
            End Select
        End If
    Else
        Select Case Trim(.Text)
        Case "", Chr(13): Beep: Exit Sub
        Case Else: End Select
        While Right(.Text, 1) = " "
            .MoveEnd Unit:=wdCharacter, count:=-1
        Wend
        While Right(.Text, 1) = Chr(13)
            .MoveEnd Unit:=wdCharacter, count:=-1
        Wend
        If .Type = wdSelectionIP Then .Words(1).Select
        .InsertBefore fSingleQuoteOpen
        .InsertAfter fSingleQuoteClose
    End If
End With
End Sub
Sub InsertDoubleQuote()
'If Not FormattingAllowed Then Beep: Exit Sub
Dim CurAsc As Long, CanMove As Integer
With Selection
    If Options.AutoFormatAsYouTypeReplaceQuotes = False Then
        .TypeText Chr(34)
        Exit Sub
    End If
    If .Type = wdSelectionIP Then
        CanMove = .MoveLeft
        If CanMove = 0 Then
            .TypeText fDoubleQuoteOpen
        Else
            CurAsc = AscW(.Text)
            .MoveRight
            Select Case CurAsc
            Case Is <= 32, 34, 147, 148, 40, 91, 123, 61, 60, 62 '   "“”([{=<>
                .TypeText fDoubleQuoteOpen
            Case Else
                .TypeText fDoubleQuoteClose
            End Select
        End If
    Else
        Select Case Trim(.Text)
        Case "", Chr(13): Beep: Exit Sub
        Case Else: End Select
        While Right(.Text, 1) = " "
            .MoveEnd Unit:=wdCharacter, count:=-1
        Wend
        While Right(.Text, 1) = Chr(13)
            .MoveEnd Unit:=wdCharacter, count:=-1
        Wend
        If .Type = wdSelectionIP Then .Words(1).Select
        .InsertBefore fDoubleQuoteOpen
        .InsertAfter fDoubleQuoteClose
    End If
End With
End Sub
Function fDoubleQuoteOpen()
Select Case Selection.LanguageID
Case wdPolish, wdBulgarian, wdRomanian, wdSerbianCyrillic, wdSerbianLatin, wdGerman, wdSwissGerman
    fDoubleQuoteOpen = QuoteChar(1, 1)
Case wdDutch, wdItalian, wdSpanish, wdFinnish, wdSwedish, wdDanish, wdNorwegianBokmol, wdNorwegianNynorsk, wdTurkish, wdSpanishModernSort, wdBelgianDutch, wdIcelandic, wdMexicanSpanish, wdPortuguese, wdSwissItalian, wdBrazilianPortuguese
    fDoubleQuoteOpen = QuoteChar(2, 1)
Case wdGreek, wdRussian, wdFrench, wdCatalan, wdBasque, wdBelgianFrench, wdFrenchCanadian, wdEstonian, wdLatvian, wdMacedonian, wdSwissFrench, wdUkrainian, wdByelorussian
    fDoubleQuoteOpen = QuoteChar(3, 1)
Case wdHungarian, wdSlovenian
    fDoubleQuoteOpen = QuoteChar(4, 1)
Case Else
    fDoubleQuoteOpen = QuoteChar(5, 1)
End Select
End Function
Function fDoubleQuoteClose()
Select Case Selection.LanguageID
Case wdPolish, wdBulgarian, wdRomanian, wdSerbianCyrillic, wdSerbianLatin, wdGerman, wdSwissGerman
    fDoubleQuoteClose = QuoteChar(1, 2)
Case wdDutch, wdItalian, wdSpanish, wdFinnish, wdSwedish, wdDanish, wdNorwegianBokmol, wdNorwegianNynorsk, wdTurkish, wdSpanishModernSort, wdBelgianDutch, wdIcelandic, wdMexicanSpanish, wdPortuguese, wdSwissItalian, wdBrazilianPortuguese
    fDoubleQuoteClose = QuoteChar(2, 2)
Case wdGreek, wdRussian, wdFrench, wdCatalan, wdBasque, wdBelgianFrench, wdFrenchCanadian, wdEstonian, wdLatvian, wdMacedonian, wdSwissFrench, wdUkrainian, wdByelorussian
    fDoubleQuoteClose = QuoteChar(3, 2)
Case wdHungarian, wdSlovenian
    fDoubleQuoteClose = QuoteChar(4, 2)
Case Else
    fDoubleQuoteClose = QuoteChar(5, 2)
End Select
End Function
Function fSingleQuoteOpen()
Select Case Selection.LanguageID
Case wdFinnish, wdSwedish, wdHungarian, wdDanish
    fSingleQuoteOpen = QuoteChar(11, 1)
Case Else
    fSingleQuoteOpen = QuoteChar(12, 1)
End Select
End Function
Function fSingleQuoteClose()
Select Case Selection.LanguageID
Case wdFinnish, wdSwedish, wdHungarian, wdDanish
    fSingleQuoteClose = QuoteChar(11, 2)
Case Else
    fSingleQuoteClose = QuoteChar(12, 2)
End Select
End Function
Function QuoteChar(ByVal iGroup As Integer, iOpen As Integer)
Select Case iGroup
' 1-5: double quotes
Case 1:     QuoteChar = Choose(iOpen, Chr(132), Chr(148)) '   „   "
Case 2:     QuoteChar = Choose(iOpen, Chr(148), Chr(148)) '   "   "
Case 3:     QuoteChar = Choose(iOpen, Chr(171) & " ", " " & Chr(187)) '   «   »
Case 4:     QuoteChar = Choose(iOpen, Chr(187), Chr(171)) '   »   «
Case 5:     QuoteChar = Choose(iOpen, Chr(147), Chr(148)) '   "   "
' 11-12: single quotes
Case 11:    QuoteChar = Choose(iOpen, Chr(146), Chr(146)) '   '   '
Case 12:    QuoteChar = Choose(iOpen, Chr(145), Chr(146)) '   '   '
Case Else: End Select
End Function


Attribute VB_Name = "ToyLib"
Declare Function CreateDirectory Lib "Kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long
Dim st As SYSTEMTIME, LCID As Long
Public Const strREG_OFFICE_TOYS_WORD As String = "Software\VB and VBA Program Settings\Merlot\Office Toys\Word"
Public Const NAVREG As String = "Merlot\Office Toys\Navigator"
Public Const PRNREG As String = "Merlot\Office Toys\Word\Printers"
Dim DefTarget As String
Dim dwPrinterIndex As Integer
Public rgstrKeyNames() As String
Public iTotalNumKeys As Integer
'Public SelectPrinterMode As Integer
Public hWndSortList As Long
Public OptionMode As Integer
Public HelpBalloon As Object    'Assistant object

Public Function WordEnvironment()
On Error Resume Next
If Selection.Information(wdInWordMail) > 0 Then
    temp = 3
Else
    Dim OpusHwnd As Long: OpusHwnd = FindWindowByTitle(0, Application.Caption)
    temp = _
        1 * Abs((FindWindowByClassName("OpusApp", 0) = OpusHwnd)) + _
        2 * Abs((FindWindowByClassName("BinderFrame", 0) = OpusHwnd)) + _
        3 * Abs((FindWindowByClassName("rctrl_renwnd32", 0)) = OpusHwnd)
End If
If Err Then temp = 0
WordEnvironment = temp
End Function
Public Function AssistantInstalled(ShowMsg As Boolean)
On Error Resume Next
test = Assistant.Visible
If Err <> 0 Then
    If ShowMsg = True Then
        getcommonstrings
        MsgBox commonstr(2), vbCritical, OffToy
    End If
    AssistantInstalled = False
Else
    AssistantInstalled = True
End If
End Function
Public Function GetPath(sCaption As String)
On Error GoTo Oops
Dim LenBuffer As Long, Buffer As String
Buffer = Space(260)
LenBuffer = Len(Buffer)
Call BrowseForFolder(sCaption, Buffer, LenBuffer)
Oops:
Select Case Err
Case 48, 49
    getcommonstrings
    n = WizMsg(commonstr(1), 0, "", True)
Case Else: End Select
GetPath = Trim(Buffer)
End Function
Public Sub GetRegKeyNames(hKey, aSection)
'aSection = strREG_OFFICE_TOYS_WORD & "\" & aSection
iTotalNumKeys = 0
Dim hr As Long
Dim hSubKey As Long
Dim lpKeyName As String, strKeyName As String
Dim strKey As String
Dim cbKeyName As Long
Dim dwKeyIndex As Long
Dim lRet As Long, iLenKeyName As Integer
hr = RegOpenKey(hKey, aSection, hSubKey)
If hr <> ERROR_SUCCESS Then Exit Sub
cbKeyName = 256
dwKeyIndex = 0
On Error Resume Next
lRet = ERROR_SUCCESS
While (lRet = ERROR_SUCCESS)
    lpKeyName = String$(cbKeyName, 0)
    lRet = RegEnumKey(hSubKey, dwKeyIndex, lpKeyName, cbKeyName)
    If lRet <> ERROR_SUCCESS Then GoTo LEndLocalKeys
    iLenKeyName = InStr(lpKeyName, Chr$(0))
    If (iLenKeyName > 1) Then 'no name
        strKeyName = Left$(lpKeyName, iLenKeyName - 1)
        If Len(strKeyName) <> 0 Then 'if valid name, add to list
            If (iTotalNumKeys Mod 10) = 0 Then _
                ReDim Preserve rgstrKeyNames(iTotalNumKeys + 10)
            rgstrKeyNames(iTotalNumKeys) = Trim(strKeyName)
            iTotalNumKeys = iTotalNumKeys + 1
        End If
    End If
    dwKeyIndex = dwKeyIndex + 1
Wend
LEndLocalKeys:
If iTotalNumKeys > 0 Then
    SelectionSort rgstrKeyNames, 0, iTotalNumKeys - 1
End If
RegCloseKey (hSubKey)
End Sub
Public Sub TipHandler(Switch, TipStr)
If Not AssistantInstalled(True) Then Exit Sub
getcommonstrings
Select Case Switch
Case True
    Set HelpBalloon = Assistant.NewBalloon
    With HelpBalloon
        .Heading = commonstr(0)
        .Icon = msoIconTip
        .Animation = msoAnimationGetAttentionMajor
        .Button = msoButtonSetNone
        .Mode = msoModeAutoDown
        .Text = TipStr
        .Show
    End With
    Assistant.Visible = 1
Case Else
  HelpBalloon.Close
End Select
End Sub
Public Function fShiftState()
fShiftState = _
    (Abs(GetKeyState(16) < 0) * 1) + _
    (Abs(GetKeyState(17) < 0) * 2) + _
    (Abs(GetKeyState(18) < 0) * 4)
End Function
Public Function DocHasEnvelope()
On Error Resume Next
test = ActiveDocument.Envelope.FeedSource
DocHasEnvelope = (Err = 0)
End Function
Public Sub FreezeScreen(Switch)
LockWindowUpdate (GetDesktopWindow * Abs(Switch <> 0))
End Sub
Public Function CleanFileName(fName)
Dim test As String: test = fName
If Left(test, 1) = Chr(34) Then test = Mid(test, 2, Len(test) - 2)
If Right(test, 1) = "\" Then test = Left(test, Len(test) - 1)
CleanFileName = test
End Function
Public Function fnDocExtension()
fnDocExtension = sFileNameInfo(ActiveDocument.Name, 3)
End Function
Function ProofingAllowed()
On Error Resume Next
If Documents.count > 0 Then
    ProofingAllowed = (FormattingAllowed = True And Left(Languages(ActiveDocument.Characters(1).LanguageID).NameLocal, 1) <> "(")
End If
If Err Then ProofingAllowed = False
End Function
Public Function FormattingAllowed()
On Error Resume Next
FormattingAllowed = CommandValid(253)
End Function

Sub NetConnect()
n = WNetConnectionDialog(GetDesktopWindow, 1)
End Sub

Sub PrinterConnect()
n = WNetConnectionDialog(GetDesktopWindow, 2)
End Sub

Sub NetDisconnect()
n = WNetDisconnectDialog(GetDesktopWindow, 1)
End Sub

Sub PrinterDisconnect()
n = WNetDisconnectDialog(GetDesktopWindow, 2)
End Sub

Public Sub SetDocProp(sName, vValue, iType)
If DocPropExists(sName) Then KillDocProp (sName)
ActiveDocument.CustomDocumentProperties.Add _
    Name:=sName, LinkToContent:=False, Value:=vValue, _
    Type:=iType
End Sub
Public Sub KillDocProp(sName)
On Error Resume Next
ActiveDocument.CustomDocumentProperties(sName).Delete
End Sub
Public Function GetDocProp(sName)
If DocPropExists(sName) Then
    GetDocProp = ActiveDocument.CustomDocumentProperties(sName).Value
End If
End Function
Public Function DocPropExists(sName)
On Error GoTo Oops
test = ActiveDocument.CustomDocumentProperties(sName).Value
Oops:
DocPropExists = (Err = 0)
End Function
Public Function AutoTextExists(sName)
On Error Resume Next
test1 = NormalTemplate.AutoTextEntries(sName).Value
test2 = ActiveDocument.AttachedTemplate.AutoTextEntries(sName).Value
AutoTextExists = ((test1 <> "") Or (test2 <> ""))
End Function

Public Function DirExist(Path)
If Left(LCase(Path), 7) = "file://" Then
    Path = Mid(Path, 8)
ElseIf Left(LCase(Path), 5) = "file:" Then
    Path = Mid(Path, 6)
End If
On Error Resume Next
Dim test As Integer: test = GetAttr(Path)
DirExist = ((Err = 0) And ((test And vbDirectory) <> 0))

End Function
Public Function ShellFolder(Fldr)
ShellFolder = System.PrivateProfileString("", _
    "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", Fldr)
End Function
Public Function DocHasName(Optional ByVal sDocName As String) As Boolean
On Error Resume Next
If Documents.count = 0 Then
    DocHasName = False
Else
    If sDocName = vbNullString Then
        DocHasName = (ActiveDocument.Path <> vbNullString)
    Else
        DocHasName = (Documents(sDocName).Path <> vbNullString)
    End If
End If
If Err Then DocHasName = False
End Function
Public Function FileExists(fName)
On Error Resume Next
test = GetAttr(fName)
FileExists = (Err <> 53) And (Err <> 76) And (Err <> 52)
End Function
Public Function CleanPath(FullPath)
If Len(FullPath) = 3 Then
    CleanPath = FullPath
Else
    FullPath = FinalBackSlash(FullPath, 0)
    If InStr(FullPath, "\") Then
        LastSlash = LastInstr(FullPath, "\")
        CleanPath = Mid(FullPath, LastSlash + 1)
    End If
End If
Bye:
End Function
Public Function CleanFile(FullFileName)
sep = Application.PathSeparator
On Error GoTo Bye
If (InStr(FullFileName, sep) = 0) Or _
    (InStr(FullFileName, "~") > 0) Then
    CleanFile = ""
Else
    temp = FullFileName
    While Right(temp, 1) <> sep
        temp = Left(temp, Len(temp) - 1)
    Wend
    CleanFile = Trim(Mid(FullFileName, Len(temp) + 1))
End If
Bye:
End Function

Public Function FavDotPath()
GetDefaultFolderStrings
Dim DotDir As String, temp As String
temp = Options.DefaultFilePath(wdUserTemplatesPath) & _
    Application.PathSeparator & FolderStr(0)
If Not DirExist(temp) Then MkDir temp
FavDotPath = temp
End Function

Public Function RecentPath()
RecentPath = ToyFolder(1)
End Function
Public Function EssentialPath()
EssentialPath = ToyFolder(4)
End Function
Public Function ProjectPath()
ProjectPath = ToyFolder(2)
End Function
Public Function EnvelopePath()
EnvelopePath = ToyFolder(3)
End Function
Public Function ToyFolder(Optional FldrNum As Variant)
'0=Favorites, 1=Recent, 2=Projects, 3=Envelopes, 4=Essentials
Dim ToyPath As String, temp As String
ToyPath = FinalBackSlash(Application.Options.DefaultFilePath(wdProgramPath)) & "Toys"
If Not DirExist(ToyPath) Then MkDir ToyPath
If IsMissing(FldrNum) Then
    temp = FinalBackSlash(ToyPath)
Else
    GetDefaultFolderStrings
    temp = FinalBackSlash(ToyPath) & FolderStr(FldrNum)
    If Not DirExist(temp) Then MkDir temp
End If
ToyFolder = temp
End Function
Function InRange(ByVal TestVal As Long, ByVal MinVal As Long, ByVal MaxVal As Long)
If MinVal > MaxVal Then Tmp = MinVal: MinVal = MaxVal: MaxVal = Tmp
InRange = (TestVal >= MinVal And TestVal <= MaxVal)
End Function
Public Function SetBit(ByVal iValue As Long, _
    ByVal iBitPos As Integer, ByVal Switch As Boolean)
On Error Resume Next
If iValue <= 2147483647 And InRange(iBitPos, 0, 30) Then
    SetBit = IIf(Switch = False, iValue And Not 2 ^ iBitPos, iValue Or 2 ^ iBitPos)
End If
End Function
Public Function GetBit(ByVal iValue As Long, ByVal iBitPos As Integer)
On Error Resume Next
If iValue <= 2147483647 And InRange(iBitPos, 0, 30) Then
    GetBit = Abs((iValue And 2 ^ iBitPos) <> 0)
End If
End Function
Function BoolToValue(ByVal Switch As Boolean)
BoolToValue = Abs(Switch <> 0)
End Function

Public Function NoAmpersand(Instring)
Dim test As Integer: test = InStr(Instring, "&")
Select Case test
Case 0:     NoAmpersand = Instring
Case 1:     NoAmpersand = Mid(Instring, 2)
Case Else:  NoAmpersand = Left(Instring, test - 1) & Mid(Instring, test + 1)
End Select
End Function
Public Function NoEllipsis(Instring)
Dim test As Integer: test = InStr(Instring, "...")
Select Case test
Case 0:     NoEllipsis = Instring
Case Else:  NoEllipsis = Left(Instring, test - 1)
End Select
End Function
Public Function IsWordDoc(ByVal fName As String)
IsWordDoc = (InStr(UCase(AppDocumentExtensions & ";"), "*" & _
    UCase(sFileNameInfo(fName, 3)) & ";") > 0)
End Function
Public Function AppDocumentExtensions()
Dim sExt As String, APPREG As String, temp As String
APPREG = NAVREG & "\" & Application.Name
temp = GetSetting(APPREG, "Extensions", "Documents")
If temp = "" Then
    On Error GoTo ParseErr
    temp = System.PrivateProfileString("", _
        "HKEY_CURRENT_USER\Software\Microsoft\Office\" & _
            Application.Version & _
            "\Word\Text Converters\Import\WordFormats", "Extensions")
    If temp <> "" Then
        If Right(temp, 1) <> " " Then temp = temp & " "
        While InStr(temp, " ")
            sExt = sExt & "*." & Trim(Left(temp, InStr(temp, " "))) & ";"
            temp = LTrim(Mid(temp, InStr(temp, " ") + 1))
        Wend
    Else
        sExt = "*.doc;*.dot;*.htm*;*.url;*.rtf;*.txt;"
    End If
    If InStr(UCase(sExt), "TXT") = 0 Then sExt = sExt & "*.TXT;"
ParseErr:
    If Err Then sExt = "*.doc;*.dot;*.htm*;*.url;*.rtf;*.txt;": Err.Clear
    SaveSetting APPREG, "Extensions", "Documents", LCase(sExt)
    AppDocumentExtensions = LCase(sExt)
Else
    AppDocumentExtensions = LCase(temp)
End If
End Function
Public Function AppTemplateExtensions()
Dim APPREG As String, temp As String
APPREG = NAVREG & "\" & Application.Name
temp = GetSetting(APPREG, "Extensions", "Templates")
If temp = "" Then
    temp = "*.dot;*.wiz"
    SaveSetting APPREG, "Extensions", "Templates", LCase(temp)
End If
AppTemplateExtensions = LCase(temp)
End Function
Public Function AppUserTemplatesPath()
AppUserTemplatesPath = Options.DefaultFilePath(wdUserTemplatesPath)
End Function
Public Function AppWorkGroupTemplatesPath()
AppWorkGroupTemplatesPath = Options.DefaultFilePath(wdWorkgroupTemplatesPath)
End Function

Public Function AppDocumentsPath()
AppDocumentsPath = Options.DefaultFilePath(wdDocumentsPath)
End Function
Public Function LocalCaption(ByVal id As Variant, _
    Optional ByVal NoAmp As Boolean)
On Error Resume Next
Dim Tmp As String, LCID As Long
LCID = Application.International(wdProductLanguageID)
Tmp = GetSetting(LOCALCAPTIONREG, LCID, id)
If Tmp = vbNullString Then
    Set myctrl = CommandBars.FindControl(id:=id)
    If myctrl Is Nothing Then
        Set mybar = CommandBars.Add("ToyTemp", _
            Position:=msoBarFloating)
        With mybar
            .Visible = False
            .Controls.Add id:=id
            DoEvents
            Tmp = .Controls(1).Caption
            .Delete
        End With
    Else
        Tmp = myctrl.Caption
    End If
    CleanEnvironment
    SaveSetting LOCALCAPTIONREG, LCID, id, Tmp
End If
If NoAmp = True Then Tmp = NoAmpersand(Tmp)
LocalCaption = Tmp
End Function

Public Function NotInWord(ShowMsg)
On Error Resume Next
dummy = Windows.count
NotInWord = (Err <> 0)
End Function
Public Function sWinzipPath()
temp$ = System.PrivateProfileString("", _
    "HKEY_CLASSES_ROOT\WinZip\Shell\Open\command", "")
Q = InStr(temp$, Chr$(34)): If Q > 0 Then temp$ = Left$(temp$, Q - 2)
sWinzipPath = temp$
End Function
Public Function sWinzip7Path()
On Error Resume Next
sWinzip7Path = System.PrivateProfileString("", _
    "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion" & _
    "\App Paths\wzzip.exe", "")
End Function

Public Function sNortonZipPath()
On Error Resume Next
sNortonZipPath = System.PrivateProfileString$("", _
    "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion" & _
    "\App Paths\symapcmp.exe", "")
End Function

Public Function QuoteFileName(ByVal fName As String, Switch)
If fName = "" Then GoTo Bye
temp = fName: Q$ = Chr$(34)
While Left$(temp, 1) = Q$: temp = Mid$(temp, 2): Wend
While Right$(temp, 1) = Q$: temp = Left$(temp, Len(temp) - 1): Wend
If Switch Then temp = Q$ + temp + Q$
Bye:
QuoteFileName = temp
End Function

Public Function WordLanguageVersion()
Select Case Application.International(wdProductLanguageID)
Case wdEnglishAUS, wdEnglishCanadian, wdEnglishNewZealand, wdEnglishSouthAfrica, wdEnglishUK, wdEnglishUS
    WordLanguageVersion = 1 'english
Case wdBelgianFrench, wdFrench, wdFrenchCanadian, wdSwissFrench
    WordLanguageVersion = 2 'french
Case wdGerman, wdSwissGerman
    WordLanguageVersion = 3 'german
Case wdMexicanSpanish, wdSpanish, wdSpanishModernSort
    WordLanguageVersion = 4 'spanish
Case wdBelgianDutch, wdDutch
    WordLanguageVersion = 5 'dutch
Case wdBrazilianPortuguese, wdPortuguese
    WordLanguageVersion = 6 'portuguese
Case wdDanish
    WordLanguageVersion = 7 'danish
Case wdSwedish
    WordLanguageVersion = 8 'swedish
Case wdNorwegianBokmol, wdNorwegianNynorsk
    WordLanguageVersion = 9 'norwegian
Case wdFinnish
    WordLanguageVersion = 10 'finnish
Case wdItalian, wdSwissItalian
    WordLanguageVersion = 11 'italian
Case Else
    WordLanguageVersion = 0
End Select

End Function
Public Function MakeFileName(sPath, sFile)
MakeFileName = FinalBackSlash(sPath) & sFile
End Function
Sub SetClipBoardText(ByVal Txt As String)
With New DataObject
    .SetText Txt
    .PutInClipboard
End With
End Sub
Function GetClipBoardText()
With New DataObject
    .GetFromClipboard
    GetClipBoardText = .GetText(1)
End With
End Function

Public Function LastInstr(ByVal SourceStr, ByVal SearchStr)
Dim pos%: pos = 0
Do While InStr(pos + 1, SourceStr, SearchStr)
    pos = InStr(pos + 1, SourceStr, SearchStr)
Loop
LastInstr = pos
End Function

Function GetWinDir()
Dim temp As String: temp = Space(255)
test = GetWindowsDirectory(temp, 255)
temp = Left(temp, test)
GetWinDir = FinalBackSlash(temp, True)
End Function

Function GetSysDir()
Dim temp As String: temp = Space(255)
test = GetSystemDirectory(temp, 255)
temp = Left(temp, test)
GetSysDir = FinalBackSlash(temp, True)
End Function
Public Function WizMsg(Prompt, Btns, Title, ShowIcon As Boolean)
If Title = "" Then Title = OffToy
Dim ret As Integer
If Not AssistantInstalled(False) Then GoTo ShowMsgBox
If Assistant.Visible = True Then
    Set toywiz = Assistant.NewBalloon
    With toywiz
        .Heading = Title
        .Mode = msoModeModal
        If ShowIcon = True Then .Icon = msoIconAlert
        .Text = Prompt
        Select Case Btns
        Case 0: .Button = msoButtonSetOK
        Case 1: .Button = msoButtonSetCancel
        Case 2: .Button = msoButtonSetAbortRetryIgnore
        Case 3: .Button = msoButtonSetYesNoCancel
        Case 4: .Button = msoButtonSetYesNo
        Case 5: .Button = msoButtonSetRetryCancel
        Case Else: .Button = msoButtonSetOK
        End Select
        Answer = .Show
        Select Case Answer
        Case msoBalloonButtonOK: ret = vbOK
        Case msoBalloonButtonCancel: ret = vbCancel
        Case msoBalloonButtonAbort: ret = vbAbort
        Case msoBalloonButtonRetry: ret = vbRetry
        Case msoBalloonButtonIgnore: ret = vbIgnore
        Case msoBalloonButtonYes: ret = vbYes
        Case msoBalloonButtonNo: ret = vbNo
        Case Else: ret = vbOK
        End Select
    End With
Else
ShowMsgBox:
    If ShowIcon = True Then Btns = Btns + vbExclamation
    ret = MsgBox(Prompt, Btns, Title)
End If
WizMsg = ret '1=OK, 2=Cancel, 3=Abort, 4=Retry, 5=Ignore, 6=Yes, 7=No
End Function

Function IsOfficeAppInstalled(AppClass As String)
'Office.Binder, Access.Application, Excel.Application, Outlook.Application, PowerPoint.Application
IsOfficeAppInstalled = (System.PrivateProfileString("", "HKEY_CLASSES_ROOT\" + AppClass + "\Curver", "") <> "")
End Function

Function fCreateList(Title$, Sort As Boolean)
Dim hwnd As Long: hwnd = GetActiveWindow
Dim hInst As Long, fStyle As Long
hInst = GetWindowWord(hwnd, (-6))
If Sort = 0 Then fStyle = 1073741952 Else fStyle = 1073741954
fCreateList = CreateWindow(0, "ListBox", Title$, fStyle, 0, 0, 0, 0, hwnd, 0, hInst, 0)
End Function
Public Function fGetList(Title$)
fGetList = GetListhWnd(GetActiveWindow, 0, 0, Title$)
End Function

Public Sub DeleteSorter()
End Sub
Public Sub InitSorter()
Erase sSortString()
iSortTotal = 0
End Sub
Public Sub AddToSorter(ByVal itm As String)
If (iSortTotal Mod 10) = 0 Then _
    ReDim Preserve sSortString(iSortTotal + 10)
sSortString(iSortTotal) = itm
iSortTotal = iSortTotal + 1
End Sub
Public Function GetFromSorter(ByVal idx As Integer) As String
On Error Resume Next
GetFromSorter = sSortString(idx)
End Function
Public Function GetSorterCount() As Integer
GetSorterCount = iSortTotal
End Function
Public Sub toySortArray()  '(InArray() As String)
If (iSortTotal > 0) Then
    SelectionSort sSortString, 0, iSortTotal - 1
End If
End Sub
Sub SelectionSort(values() As String, ByVal min As Long, ByVal max As Long)
Dim i As Long
Dim j As Long
Dim smallest_value As String
Dim smallest_j As Long

For i = min To max - 1
    smallest_value = values(i)
    smallest_j = i
    
    For j = i + 1 To max
        If values(j) < smallest_value Then
            smallest_value = values(j)
            smallest_j = j
        End If
    Next j
    
    If smallest_j <> i Then
        values(smallest_j) = values(i)
        values(i) = smallest_value
    End If
Next i
End Sub
Public Sub SetLocalContext(Container As String)
Container = MacroContainer
On Error Resume Next
CustomizationContext = Templates(AddinFullPath(Container))
If Err Then SetEnvironment
End Sub
Public Sub ReportError(errval As Long)
On Error Resume Next
Err.Raise errval
If Err Then n = WizMsg(Err.Description, 0, "", True)
End Sub

Public Function VbCr2()
VbCr2 = vbCr + vbCr
End Function
Public Function VbLf2()
VbLf2 = vbLf + vbLf
End Function
Public Function RightAfter$(ByVal textstring$, ByVal textfrom$)
Dim temp$, pos%
If InStr(textstring, textfrom) = 0 Then
    RightAfter = textstring
Else
    pos = InStr(textstring, textfrom) + 1
    temp = Mid(textstring, pos)
    RightAfter = temp
End If
End Function

Public Sub UpdateDocExtensions()
If Documents.count = 0 Then Exit Sub
If DocHasName = False Then Exit Sub
On Error GoTo Bye
Dim APPREG As String, temp As String, REGKEY As String, RegVal As String
temp = "*" & LCase(fnDocExtension)
APPREG = NAVREG & "\" & Application.Name
Select Case ActiveDocument.Type
Case wdTypeTemplate:    REGKEY = "Templates"
Case Else:              REGKEY = "Documents"
End Select
RegVal = GetSetting(APPREG, "Extensions", REGKEY)
If Right(RegVal, 1) <> ";" Then RegVal = RegVal & ";"
If InStr(RegVal, temp) = 0 Then
    RegVal = RegVal & temp & ";"
    SaveSetting APPREG, "Extensions", REGKEY, LCase(RegVal)
End If
Bye:
End Sub
Sub SetEnvironment()
CustomizationContext = Templates(MacroContainer.Path + _
    Application.PathSeparator + MacroContainer)
End Sub

Sub CleanEnvironment()
CleanToyModules
End Sub

Function CommandValid(ByVal CmdNum As Long)
On Error Resume Next
CommandValid = CommandBars.FindControl(id:=CmdNum).Enabled
If Err Then CommandValid = False
End Function

Sub TranslateControl(iType As Integer, sTag As String, sCaption As String)
On Error Resume Next
SetEnvironment
Set myControl = CommandBars.FindControl(Type:=iType, Tag:=sTag)
If myControl Is Nothing Then GoTo Bye
myControl.Caption = sCaption
Bye:
CleanEnvironment
End Sub

Public Function CleanCurPrinter()
On Error Resume Next
Dim CurPrn As String: CurPrn = Application.ActivePrinter
If CurPrn = vbNullString Then Exit Function
If iTotalNumPrinters = 0 Then GetAllPrinters
If iTotalNumPrinters = 0 Then Exit Function
For i = iTotalNumPrinters - 1 To 0 Step -1
    If InStr(CurPrn, rgstrPrinterNames(i)) Then
        CleanCurPrinter = rgstrPrinterNames(i)
        Exit For
    End If
Next
End Function
Function GetCurKeyboardName()
Const KL_NAMELENGTH = 9
Dim buff As String * KL_NAMELENGTH
n = GetKeyboardLayoutName(buff)
GetCurKeyboardName = Left(buff, KL_NAMELENGTH - 1)
End Function
Function GetDefKey(ByVal kb As String, ByVal idx As Integer) As Integer
'idx values 1=dblquote, 2=snglquote, 3=slash, 4=equal, 5=1, 6=2, 7=3
Select Case LCase(kb)
Case "00000809" 'British
    GetDefKey = Choose(idx, 306, 192, 191, 187, 49, 50, 51)
Case "00000807" 'Swiss German
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case "00000409" 'United States
    GetDefKey = Choose(idx, 478, 222, 191, 187, 49, 50, 51)
Case "00000c0a" 'Spanish, Basque, Catalan
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case "0000040c" 'French
    GetDefKey = Choose(idx, 51, 52, 447, 187, 305, 306, 307)
Case "00000407" 'German, German Austrian
    GetDefKey = Choose(idx, 306, 447, 311, 304, 49, 50, 51)
Case "00000414" 'Norwegian
    GetDefKey = Choose(idx, 306, 191, 311, 304, 49, 50, 51)
Case "00000413" 'Dutch
    GetDefKey = Choose(idx, 306, 304, 219, 445, 49, 50, 51)
Case "0000041d" 'Swedish
    GetDefKey = Choose(idx, 306, 191, 311, 304, 49, 50, 51)
Case "00000405" 'Czech
    GetDefKey = Choose(idx, 442, 476, 475, 189, 305, 306, 307)
Case "00000406" 'Danish
    GetDefKey = Choose(idx, 306, 191, 311, 304, 49, 50, 51)
Case "00000813" 'Belgian Dutch
    GetDefKey = Choose(idx, 306, 304, 219, 445, 49, 50, 51)
Case "00001009" 'Canadian Multilingual
    GetDefKey = Choose(idx, 306, 444, 1727, 187, 49, 50, 51)
Case "00001809" 'Irish
    GetDefKey = Choose(idx, 306, 192, 191, 187, 49, 50, 51)
Case "0000040b" 'Finnish
    GetDefKey = Choose(idx, 306, 191, 311, 304, 49, 50, 51)
Case "0000080c" 'Belgian French
    GetDefKey = Choose(idx, 51, 52, 447, 187, 305, 306, 307)
Case "00000c0c" 'French Canadian
    GetDefKey = Choose(idx, 306, 444, 307, 187, 49, 50, 51)
Case "0000100c" 'Swiss French
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case "00000816" 'Portuguese
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case "00000416" 'Brazilian Portuguese
    GetDefKey = Choose(idx, 476, 478, 191, 187, 49, 50, 51)
Case "0000040f" 'Icelandic
    GetDefKey = Choose(idx, 306, 186, 311, 304, 49, 50, 51)
Case "0000040e" 'Hungarian
    GetDefKey = Choose(idx, 306, 305, 310, 311, 49, 50, 51)
Case "00000408" 'Greek
    GetDefKey = Choose(idx, 478, 222, 191, 187, 49, 50, 51)
Case "00000424" 'Slovenian
    GetDefKey = Choose(idx, 306, 189, 311, 304, 49, 50, 51)
Case "00000419" 'Russian
    GetDefKey = Choose(idx, 306, 1758, 476, 187, 49, 50, 51)
Case "00000410" 'Italian, Swiss Italian
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case "00000415" 'Polish
    GetDefKey = Choose(idx, 306, 187, 311, 304, 49, 50, 51)
Case "00002c0a" 'Latin American
    GetDefKey = Choose(idx, 306, 219, 311, 304, 49, 50, 51)
Case Else
    kb = GetCurKeyboardName
    Dim Tmp As String
    Select Case idx
    Case 1  'double quote
        GetDefKey = Val(GetSetting(ISWREG, kb, "DoubleQuoteKey"))
    Case 2  'single quote
        GetDefKey = Val(GetSetting(ISWREG, kb, "SingleQuoteKey"))
    Case 3  'slash
        GetDefKey = Val(GetSetting(ISWREG, kb, "SlashKey"))
    Case 4  'equal
        GetDefKey = Val(GetSetting(ISWREG, kb, "EqualsKey"))
    Case 5  '1
        Tmp = Val(GetSetting(ISWREG, kb, "OneKey"))
        If Tmp = vbNullString Then
            GetDefKey = GetKeyInfoFromUser(kb, 1)
        Else
            GetDefKey = Tmp
        End If
    Case 6  '2
        Tmp = Val(GetSetting(ISWREG, kb, "TwoKey"))
        If Tmp = vbNullString Then
            GetDefKey = GetKeyInfoFromUser(kb, 2)
        Else
            GetDefKey = Tmp
        End If
    Case 7  '3
        Tmp = Val(GetSetting(ISWREG, kb, "ThreeKey"))
        If Tmp = vbNullString Then
            GetDefKey = GetKeyInfoFromUser(kb, 3)
        Else
            GetDefKey = Tmp
        End If
    Case Else
    End Select
End Select
End Function
Function GetKeyInfoFromUser(ByVal kb As String, char As Integer)
GetIntelliSwitchStrings
Dim Tmp As Integer, regk As String
n = WizMsg(DlgStr(80) + VbLf2 + Space(10) + Str(char) + VbLf2 + DlgStr(81) + vbCr + DlgStr(82), 4, toyapp, True)
Select Case n
Case 6:     Tmp = 256 + 48 + char   'yes
…