Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 92d55b3129989c23…

MALICIOUS

Office (OOXML)

98.3 KB Created: 2011-04-19 23:50:00 UTC Authoring application: Microsoft Office Word 12.0000 First seen: 2020-05-25
MD5: 5854193c3d628866a980b8dc1489ffcd SHA-1: 686e2c3fd06fa5d50bdff16794835dd435894706 SHA-256: 92d55b3129989c231e5992b1af05166323c722030614d8e74e111ce3778a7de4
224 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1059 Command and Scripting Interpreter T1204.002 Malicious File

The sample is an OOXML document containing VBA macros. Heuristics indicate the use of WScript.Shell and the Shell() function, which are commonly used to execute arbitrary commands. The VBA code appears to be designed to download and execute a second-stage payload, although the specific commands and URLs are obfuscated or truncated in the provided evidence. The presence of a renamed VBA project part suggests an attempt to evade detection.

Heuristics 7

  • VBA project inside OOXML medium 4 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present (project part renamed away from vbaProject.bin: word/vbaProjectSignature.bin)
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
    Private Function GetLnkTargetFile2(ByVal sLnkPath As String) As String
    Dim objShell  As Shell
    Dim objFolder As Shell32.Folder
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Dim Obj As Object
    Set Obj = CreateObject("WScript.Shell")
  • VBA project part renamed to evade filename detection high OOXML_VBA_PROJECT_RENAMED
    The VBA project is bound through the OOXML relationship/content type but its part is not named vbaProject.bin. Legitimate Office producers always emit vbaProject.bin; renaming it hides the macros from path-only scanners (observed in the SVCReady loader).
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Dim Obj As Object
    Set Obj = CreateObject("WScript.Shell")
  • VBA project carries a recognised code-signing signature info VBA_SIGNED_TRUSTED
    The VBA project is Authenticode-signed and the signer/issuer chain matches a recognised code-signing publisher or CA. Informational only — the signature is NOT yet verified to cover the current project bytes, so it does not (yet) reduce the verdict.
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://ocsp.verisign.com0 In document text (OOXML body / shared strings)
    • http://ocsp.verisign.com01In document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/markup-compatibility/2006In document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/relationshipsIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/mathIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/wordprocessingml/2006/mainIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2006/wordmlIn document text (OOXML body / shared strings)
    • https://www.verisign.com/rpaIn document text (OOXML body / shared strings)
    • http://csc3-2009-2-crl.verisign.com/CSC3-2009-2.crl0DIn document text (OOXML body / shared strings)
    • https://www.verisign.com/rpa0In document text (OOXML body / shared strings)
    • http://csc3-2009-2-aia.verisign.com/CSC3-2009-2.cer0In document text (OOXML body / shared strings)
    • https://www.verisign.com/cps0*In document text (OOXML body / shared strings)
    • http://logo.verisign.com/vslogo.gif0In document text (OOXML body / shared strings)
    • http://crl.verisign.com/pca3.crl0In document text (OOXML body / shared strings)

Extracted artifacts 3

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 47635 bytes
SHA-256: 1ab02c50094c10bf178f92da3162b8390262bace1630c478ed16ce77fa852003
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-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

Attribute VB_Name = "ConsPlusWindow"
Option Explicit
Option Compare Text

Type POINTAPI
    x As Long
    y As Long
End Type

Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
      
Private Const WM_COPYDATA = &H4A

Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2

Private Const SW_RESTORE = 9

Private Const GWLP_HINSTANCE = -6


#If VBA7 Then

Private Type COPYDATASTRUCT
    dwData As LongPtr
    cbData As Long
    lpData As LongPtr
End Type

Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As LongPtr)

Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long

Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr

Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long

#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If

Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long

Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _
    (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long

Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long

Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr

Private Declare PtrSafe Function GetModuleFileNameExA Lib "psapi.dll" _
   (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, _
      ByVal ModuleName As String, ByVal nSize As Long) As Long

#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr

#Else

Private Declare PtrSafe Function WindowFromPoint Lib "user32" _
  (ByVal x As Long, ByVal y As Long) As LongPtr
#End If

#Else

Private Type COPYDATASTRUCT
    dwData As Long
    cbData As Long
    lpData As Long
End Type

Private Declare Function SendMessage Lib "user32" Alias _
         "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
         wParam As Long, lParam As Any) As Long
         
'Copies a block of memory from one location to another.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
         (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal nDirection As Long) As Long

Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
    (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long
    
Private Declare Function CloseHandle Lib "kernel32" _
   (ByVal Handle As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" _
  (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, _
      ByVal dwProcId As Long) As Long

Private Declare Function GetModuleFileNameExA Lib "psapi.dll" _
   (ByVal hProcess As Long, ByVal hModule As Long, _
      ByVal ModuleName As String, ByVal nSize As Long) As Long
      
Private Declare Function WindowFromPoint Lib "user32" _
  (ByVal x As Long, ByVal y As Long) As Long

#End If

#If Win64 Then

' Copies a POINTAPI into a LongLong.  For an API requiring a ByVal POINTAPI parameter,
' this LongLong can be passed in instead.  Example API's include WindowFromPoint,
' ChildWindowFromPoint, ChildWindowFromPointEx, DragDetect, and MenuItemFromPoint.
Private Function PointToLongLong(point As POINTAPI) As LongLong
    Dim ll As LongLong
    Dim cbLongLong As LongPtr
    
    cbLongLong = LenB(ll)
    
    ' make sure the contents will fit
    If LenB(point) = cbLongLong Then
        CopyMemory ll, point, cbLongLong
    End If
    
    PointToLongLong = ll
End Function

#End If

#If VBA7 Then
Public Function FindWordWindow() As LongPtr
    FindWordWindow = FindWordWindow3()
End Function
#Else
Public Function FindWordWindow() As Long
    FindWordWindow = FindWordWindow3()
End Function
#End If

#If VBA7 Then
Private Function FindWordWindow3() As LongPtr
    
    Dim lTop As Long
    Dim lLeft As Long
    Dim lWidth As Long
    Dim lHeight As Long
    
    If Application.Windows.Count > 0 Then
        Dim wnd As Window
        Set wnd = Application.ActiveWindow
        
        lTop = wnd.Top
        lLeft = wnd.Left
        lWidth = wnd.Width
        lHeight = wnd.Height
    Else
        lTop = Application.Top
        lLeft = Application.Left
        lWidth = Application.Width
        lHeight = Application.Height
    End If
    
    Dim p As POINTAPI
    
    p.x = lLeft + CLng(lWidth / 2)
    p.y = lTop + CLng(lHeight / 2)
    
    Dim hwnd As LongPtr
#If Win64 Then
    hwnd = WindowFromPoint(PointToLongLong(p))
#Else
    hwnd = WindowFromPoint(p.x, p.y)
#End If
    
    'теперь пойдем наверх до окна верхнего уровня
    Dim hwndParent As LongPtr
    hwndParent = GetParent(hwnd)

    ' получаем окно верхнего уровня
    While (hwndParent <> 0)
        hwnd = hwndParent
        hwndParent = GetParent(hwnd)
    Wend
    
    FindWordWindow3 = hwnd
    
End Function
#Else
Private Function FindWordWindow3() As Long
    
    Dim lTop As Long
    Dim lLeft As Long
    Dim lWidth As Long
    Dim lHeight As Long
    
    If Application.Windows.Count > 0 Then
        Dim wnd As Window
        Set wnd = Application.ActiveWindow
        
        lTop = wnd.Top
        lLeft = wnd.Left
        lWidth = wnd.Width
        lHeight = wnd.Height
    Else
        lTop = Application.Top
        lLeft = Application.Left
        lWidth = Application.Width
        lHeight = Application.Height
    End If
    
    Dim p As POINTAPI
    
    p.x = lLeft + CLng(lWidth / 2)
    p.y = lTop + CLng(lHeight / 2)
    
    Dim hwnd As Long
    hwnd = WindowFromPoint(p.x, p.y)
    
    'теперь пойдем наверх до окна верхнего уровня
     Dim hwndParent
    hwndParent = GetParent(hwnd)

    ' получаем окно верхнего уровня
    While (hwndParent <> 0)
        hwnd = hwndParent
        hwndParent = GetParent(hwnd)
    Wend
    
    FindWordWindow3 = hwnd
    
End Function
#End If

#If VBA7 Then
Private Function FindWindowByClassNameAndModulePath(ByVal strClassName As String, ByVal modulePath As String) As LongPtr

    Dim CurrWnd As LongPtr
    Dim hWndCP As LongPtr
    Dim hwndParent As LongPtr

#Else
Private Function FindWindowByClassNameAndModulePath(ByVal strClassName As String, ByVal modulePath As String) As Long

    Dim CurrWnd As Long
    Dim hWndCP As Long
    Dim hwndParent As Long
#End If

    Dim Length As Long
    Dim wndClassName As String
    
    ' берем первое окно
    CurrWnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
    
    ' перебираем окна
    While CurrWnd <> 0
        
        ' определяем класс окна
        Length = 250
        wndClassName = Space(Length + 1)
        Length = GetClassName(CurrWnd, wndClassName, Length + 1)
        wndClassName = Left(wndClassName, Length)
        
        If Length > 0 Then
            'получили класс
            'сравниваем с нашим
            If strClassName = wndClassName Then
                hWndCP = CurrWnd
                
                hwndParent = GetParent(hWndCP)
    
                ' получаем окно верхнего уровня
                While (hwndParent <> 0)
                    hWndCP = hwndParent
                    hwndParent = GetParent(hWndCP)
                Wend
                
                ' проверяем путь к модулю
                If ValidateWndModulePath(hWndCP, modulePath) Then
                    FindWindowByClassNameAndModulePath = hWndCP
                    Exit Function
                End If
                
            End If
        End If
        
        CurrWnd = GetWindow(CurrWnd, GW_HWNDNEXT)
    Wend
    
    FindWindowByClassNameAndModulePath = 0
End Function

#If VBA7 Then
Function GetConsPlusWindow(ByVal consExePath As String) As LongPtr
#Else
Function GetConsPlusWindow(ByVal consExePath As String) As Long
#End If

    GetConsPlusWindow = FindWindowByClassNameAndModulePath("ConsultantPlusMainWnd", consExePath)
    Exit Function
End Function

#If VBA7 Then
Sub ActivateConsPlusWindow(hwnd As LongPtr)
#Else
Sub ActivateConsPlusWindow(hwnd As Long)
#End If
    If IsIconic(hwnd) <> 0 Then
        ShowWindow hwnd, SW_RESTORE
    End If
    
    SetForegroundWindow hwnd
End Sub

#If VBA7 Then
Sub SendConsPlusSearchMessage(hwnd As LongPtr, ByVal searchText As String)
#Else
Sub SendConsPlusSearchMessage(hwnd As Long, ByVal searchText As String)
#End If

    Dim Buf() As Byte
    
    Buf = searchText & vbNullChar
    
    Dim cds As COPYDATASTRUCT
    
    cds.dwData = 4 ' Сначала пробуем UNICODE
    cds.cbData = Len(searchText) * 2
    cds.lpData = VarPtr(Buf(0))
    
    
#If VBA7 Then
    Dim res As LongPtr
#Else
    Dim res As Long
#End If
    
    res = SendMessage(hwnd, WM_COPYDATA, 0, cds)

    If res = 0 Then
        
        Dim a$
        a$ = searchText 'переводим строку из UNICODE в char-ы
        
        ReDim Buf(Len(a$) + 1)
        
        ' Copy the string into a byte array, converting it to ASCII
        Call CopyMemory(Buf(1), ByVal a$, Len(a$))

        cds.dwData = 3 ' Теперь пробуем char-ы
        cds.cbData = Len(a$)
        cds.lpData = VarPtr(Buf(1))

        res = SendMessage(hwnd, WM_COPYDATA, 0, cds)

    End If

End Sub

#If VBA7 Then
Private Function ValidateWndModulePath(ByVal hwnd As LongPtr, ByVal modulePath As String) As Boolean
#Else
Private Function ValidateWndModulePath(ByVal hwnd As Long, ByVal modulePath As String) As Boolean
#End If

    Dim strWndModulePath As String
    
    strWndModulePath = GetWndModulePath(hwnd)
    
    If Len(strWndModulePath) = 0 Then
        ValidateWndModulePath = False
        Exit Function
    End If
    
    Dim fso As New FileSystemObject
    
    Dim strWndModuleDir As String
    Dim strModuleDir As String
    
    strWndModuleDir = fso.GetFile(strWndModulePath).ParentFolder.Path
    strModuleDir = fso.GetFile(modulePath).ParentFolder.Path
    
    'сравниваем папки
    If strWndModuleDir = strModuleDir Then
        ValidateWndModulePath = True
        Exit Function
    End If
    
    ValidateWndModulePath = False
End Function

#If VBA7 Then

Private Function GetWndModulePath(ByVal hwnd As LongPtr) As String
    
    Dim hInst As LongPtr
    hInst = GetWindowLongPtr(hwnd, GWLP_HINSTANCE)
    
    Dim procID As Long
    GetWindowThreadProcessId hwnd, procID
    
    Dim hProc As LongPtr
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, procID)
    
    Dim strWndModulePath As String
    
    Dim Length As Long
    
    Length = 1000
    strWndModulePath = Space(Length + 1)
    Length = GetModuleFileNameExA(hProc, 0, strWndModulePath, Length)
    strWndModulePath = Left(strWndModulePath, Length)
    
    CloseHandle hProc
    
    GetWndModulePath = strWndModulePath
End Function

#Else

Private Function GetWndModulePath(ByVal hwnd As Long) As String
    Dim hInst As Long
    
    hInst = GetWindowLong(hwnd, GWLP_HINSTANCE)
    
    Dim procID As Long
    GetWindowThreadProcessId hwnd, procID
    
    Dim hProc As Long
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, procID)
    
    Dim strWndModulePath As String
    
    Dim Length As Long
    
    Length = 1000
    strWndModulePath = Space(Length + 1)
    Length = GetModuleFileNameExA(hProc, 0, strWndModulePath, Length)
    strWndModulePath = Left(strWndModulePath, Length)
    
    CloseHandle hProc
    
    GetWndModulePath = strWndModulePath
End Function
#End If

Attribute VB_Name = "ContextMenu"
Option Explicit

#If VBA7 Then

Private Declare PtrSafe Function MessageBoxW Lib "user32" _
    (ByVal hwnd As LongPtr, lpText As Any, lpCaption As Any, ByVal wType As Long) As Long

Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" _
    (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, _
    ByVal cchMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long 'ByVal lpWideCharStr As String

Private Declare PtrSafe Function ShellExecuteW Lib "shell32.dll" _
    (ByVal hwnd As LongPtr, lpOperation As Any, lpFile As Any, _
     lpParameters As Any, lpDirectory As Any, _
     ByVal nShowCmd As Long) As LongPtr


#Else

Private Declare Function MessageBoxW Lib "user32" _
     (ByVal hwnd As Long, Prompt As Any, Title As Any, ByVal Buttons As Long) As Long

Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
  ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, _
  ByVal cbMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long

Private Declare Function ShellExecuteW Lib "shell32.dll" _
    (ByVal hwnd As Long, lpOperation As Any, lpFile As Any, _
     lpParameters As Any, lpDirectory As Any, _
     ByVal nShowCmd As Long) As Long

#End If

Private Const SW_SHOWNORMAL = 1

Function LoadString(str As String) As String
    Dim Buf() As Byte, sBuf As String
    Dim cSize As Long
    Dim retval As Long

    cSize = Len(str)
    ReDim Buf(cSize * 2)
    
    retval = MultiByteToWideChar(1251, 0, str, cSize, Buf(0), cSize)

    LoadString = Left(Buf, retval)
End Function
    
'Обработчик кнопки Что это?
Sub WhatIsIt()
    SconsMsg LoadString("Этот инструмент позволяет искать в системе КонсультантПлюс непосредственно из документа Word. ") & _
        LoadString("Существует два способа сделать это:") & vbCr & _
        LoadString("1. Ввести запрос в текстовое поле и нажать кнопку поиска") & vbCr & _
        LoadString("2. Выделить нужный текст и, после вызова контекстного меню, выбрать пункт ""Найти в КонсультантПлюс""") & vbCr & _
        vbCr & _
        LoadString("Версия: ") & Version.GetVersion()
End Sub

'Обработчик кнопки Выбрать систему для поиска...
Public Sub ChooseSystem()
    On Error GoTo errorHandler

    Dim filePath As String
    
    'читаем параметр из реестра
    filePath = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "UserSearchPath")
    
    If Len(filePath) = 0 Then
        filePath = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "SearchPath")
    End If
    
    'запрашиваему пользователя путь к cons.exe
    ChooseSystemForm.FilePathTextBox.text = filePath
    ChooseSystemForm.Show
    
    filePath = ChooseSystemForm.filePath
    
    If Len(filePath) = 0 Then
        'пользователь отказался от ввода
        Exit Sub
    End If
    
    'пишем параметр в реестр
    System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "UserSearchPath") = filePath
    
    Exit Sub

errorHandler:
    SconsErrMsg "Ошибка: " & err.Description
End Sub

'Поиск выделенного текста в КонсультантПлюс
Public Sub DoConsPlusSearch()
    
    On Error GoTo errorHandler
    
    If Not IsActiveDocument() Then
        SconsErrMsg LoadString("Для поиска в КонсультантПлюс должен быть открыт документ")
        Exit Sub
    End If
    
    Dim selectedText As String
    selectedText = GetSelectedText()
    
    'проверяем выделенный текст
    If Not IsTextAcceptedForSearch(selectedText) Then
        SconsErrMsg LoadString("Выделите текст для поиска")
        Exit Sub
    End If
    
    ExecuteSearch selectedText
    
    Exit Sub
    
errorHandler:
    SconsErrMsg LoadString("Ошибка: ") & err.Description
End Sub

'переход в КонсультантПлюс
Sub ActivateConsPlus()
    On Error GoTo errorHandler
    
    Dim consExePath As String
    consExePath = GetConsExePath()
    
    If Len(consExePath) = 0 Then
        Exit Sub
    End If
    
    'ищем открытое окно КонсультантПлюс
#If VBA7 Then
    Dim consPlusWnd As LongPtr
#Else
    Dim consPlusWnd As Long
#End If
    consPlusWnd = GetConsPlusWindow(consExePath)
    
    If consPlusWnd <> 0 Then
        'есть окно, активизируем его
        ActivateConsPlusWindow (consPlusWnd)
    Else
        'не нашли окно, запускаем КонсультантПлюс
        ShellRunConsPlus consExePath, ""
    End If
    
    Exit Sub
    
errorHandler:
    SconsErrMsg LoadString("Ошибка: ") & err.Description
End Sub

Private Function IsActiveDocument() As Boolean
    IsActiveDocument = Application.Documents.Count > 0
End Function

Private Function GetSelectedText() As String
    Dim selRange As Range
    Set selRange = Selection.Range.Duplicate
    
    If Selection.Type = wdSelectionIP Then
    selRange.Expand wdWord
    End If
    
    If selRange.Font.Hidden = CLng(True) Then
        selRange.TextRetrievalMode.IncludeHiddenText = True
    Else
        selRange.TextRetrievalMode.IncludeHiddenText = False
    End If
    
    GetSelectedText = Trim(selRange.text)
End Function

Private Function IsTextAcceptedForSearch(ByVal str As String) As Boolean
    Dim strLen As Long
    strLen = Len(str)
    
    Dim i As Long
    
    For i = 1 To strLen
        Dim c As String
        c = Mid(str, i, 1)
        
        If (AscW(c) >= AscW(LoadString("a")) And AscW(c) <= AscW(LoadString("z"))) Or _
           (AscW(c) >= AscW(LoadString("A")) And AscW(c) <= AscW(LoadString("Z"))) Or _
           (AscW(c) >= AscW(LoadString("а")) And AscW(c) <= AscW(LoadString("я"))) Or _
           (AscW(c) >= AscW(LoadString("А")) And AscW(c) <= AscW(LoadString("Я"))) Or _
           (AscW(c) >= AscW(LoadString("0")) And AscW(c) <= AscW(LoadString("9"))) Or _
           AscW(c) = AscW(LoadString("ё")) Or AscW(c) = AscW(LoadString("Ё")) Then
           IsTextAcceptedForSearch = True
           Exit Function
        End If
    Next
    
    IsTextAcceptedForSearch = False
End Function

Public Sub SconsMsg(ByVal s As String)
    'MsgBox s, vbOKOnly, "Поиск в КонсультантПлюс"
    
    Dim bArrayS() As Byte
    bArrayS = s & vbNullChar
    
    Dim bArrayT() As Byte
    bArrayT = LoadString("Поиск в КонсультантПлюс") & vbNullChar
    
    MessageBoxW FindWordWindow(), bArrayS(0), bArrayT(0), vbOKOnly
    
End Sub

Public Sub SconsErrMsg(ByVal s As String)
    'MsgBox s, vbOKOnly + vbExclamation, "Поиск в КонсультантПлюс"
    
    Dim bArrayS() As Byte
    bArrayS = s & vbNullChar
    
    Dim bArrayT() As Byte
    bArrayT = LoadString("Поиск в КонсультантПлюс") & vbNullChar
    
    MessageBoxW FindWordWindow(), bArrayS(0), bArrayT(0), vbOKOnly + vbExclamation
    
End Sub


Public Sub ExecuteSearch(ByVal searchedText As String)
    
    Dim consExePath As String
    consExePath = GetConsExePath()
    
    If Len(consExePath) = 0 Then
        Exit Sub
    End If
    
    If Len(searchedText) > 500 Then
        SconsErrMsg LoadString("Задан слишком длинный фрагмент для поиска в КонсультантПлюс!")
        Exit Sub
    End If
    
    'сначала пробуем послать сообщение окну КонсультантПлюс
    If Not SendSearchMessage(consExePath, searchedText) Then
        ShellRunConsPlus consExePath, searchedText
    End If
End Sub

Private Function SendSearchMessage(ByVal consExePath As String, ByVal searchedText As String) As Boolean

#If VBA7 Then
    Dim hwndConsPlus As LongPtr
#Else
    Dim hwndConsPlus As Long
#End If

    hwndConsPlus = GetConsPlusWindow(consExePath)
    
    If hwndConsPlus = 0 Then
        SendSearchMessage = False
        Exit Function
    End If
    
    ActivateConsPlusWindow hwndConsPlus
    
    SendConsPlusSearchMessage hwndConsPlus, searchedText
    
    SendSearchMessage = True
End Function

' получить путь к cons.exe, при необходимости спросить у пользователя
Private Function GetConsExePath() As String
    
    'HKEY_CURRENT_USER\Software\ConsultantPlus\SearchPath
    'HKEY_CURRENT_USER\Software\ConsultantPlus\UserSearchPath
    
    'сначала определяем путь к cons.exe
    Dim strPath As String
    
    'читаем параметр реестра UserSearchPath
    strPath = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "UserSearchPath")
    
    If Len(strPath) = 0 Then
        'читаем параметр реестра SearchPath
        strPath = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "SearchPath")
    End If
    
    If Len(strPath) = 0 Then
        
        'нет ни одного параметра в реестре
        
        'просим пользователя указать систему
        ChooseSystemForm.FilePathTextBox.text = ""
        ChooseSystemForm.Show
        
        strPath = ChooseSystemForm.filePath
    
        If Len(strPath) = 0 Then
            'пользователь отказался от ввода пути к cons.exe
            Exit Function
        End If

        'пишем параметр в реестр
        System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "UserSearchPath") = strPath
    End If

    'проверяем, что файл есть
    Dim fso As New FileSystemObject
    
    If Not (fso.FileExists(strPath)) Then
        'файла cons.exe нет по указанному пути
        'сообщаем об этом пользователю
        SystemIsAbsentForm.SetPathForMessage strPath
        SystemIsAbsentForm.Show
        
        If Len(SystemIsAbsentForm.m_filePath) = 0 Then
            'пользователь отказался от продолжения
            Exit Function
        End If
    
        strPath = SystemIsAbsentForm.m_filePath
    
        'пишем параметр в реестр
        System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "UserSearchPath") = strPath
    End If
    
    GetConsExePath = strPath
End Function

' запустить КонсультантПлюс из командной строки с поиском
Private Sub ShellRunConsPlus(ByVal consExePath As String, ByVal searchedText As String)
    
    Dim fso As New FileSystemObject
    Dim strWrkDir As String
    strWrkDir = fso.GetFile(consExePath).ParentFolder.Path
    
    Dim escapedText As String
    'заменяем кавычки на двойные
    escapedText = Replace(searchedText, """", """""")
    
    Dim strParams As String
    strParams = vbNullString
    
    If (Len(searchedText) > 0) Then
        strParams = """/SPLUS=" & escapedText & """"
    End If
    
    Dim bOperation() As Byte
    bOperation = "open" & vbNullChar
    
    Dim bFile() As Byte
    bFile = consExePath & vbNullChar
    
    Dim bParams() As Byte
    bParams = strParams & vbNullChar
    
    Dim bDir() As Byte
    bDir = strWrkDir & vbNullChar
    
    Dim retval
    retval = ShellExecuteW(0, bOperation(0), bFile(0), bParams(0), bDir(0), SW_SHOWNORMAL)
    
    Exit Sub
End Sub

Attribute VB_Name = "RibbonCallbacks"
Option Explicit

Private strEditText As String
Private strTabHomeEditText As String
Private myRibbonUI As IRibbonUI

Private bTabHomeGroupVisible As Boolean

' (компонент: customUI, атрибут: onLoad), 2007
Sub OnUILoad(ribbon As IRibbonUI)
    Set myRibbonUI = ribbon
    bTabHomeGroupVisible = ReadReg_TabHomeGroupVisible()
End Sub

'TabHome_ConsPlusGroup (компонент: group, атрибут: getVisible), 2007
Sub TabHome_ConsPlusGroup_getVisivle(control As IRibbonControl, ByRef visible)
    visible = bTabHomeGroupVisible
End Sub

'ConsPlusActivate (компонент: button, атрибут: onAction), 2007
Sub ConsPlusActivate_OnAction(control As IRibbonControl)
    ContextMenu.ActivateConsPlus
End Sub

'TabHome_ConsPlusFindEdit (компонент: editBox, атрибут: onChange), 2007
Sub TabHome_ConsPlusFindEdit_OnChange(control As IRibbonControl, text As String)
    strTabHomeEditText = text
End Sub

'ConsPlusFindEdit (компонент: editBox, атрибут: onChange), 2007
Sub ConsPlusFindEdit_OnChange(control As IRibbonControl, text As String)
    strEditText = text
End Sub

'TabHome_ConsPlusFindEdited (компонент: button, атрибут: onAction), 2007
Sub TabHome_ConsPlusFindEdited_OnAction(control As IRibbonControl)
    If Len(strTabHomeEditText) = 0 Then
        SconsMsg LoadString("Введите текст для поиска")
        Exit Sub
    End If

    ContextMenu.ExecuteSearch strTabHomeEditText
End Sub

'ConsPlusFindEdited (компонент: button, атрибут: onAction), 2007
Sub ConsPlusFindEdited_OnAction(control As IRibbonControl)
    If Len(strEditText) = 0 Then
        SconsMsg LoadString("Введите текст для поиска")
        Exit Sub
    End If

    ContextMenu.ExecuteSearch strEditText
End Sub

'TabHome_ConsPlusInfo (компонент: button, атрибут: onAction), 2007
'ConsPlusInfo (компонент: button, атрибут: onAction), 2007
Sub ConsPlusInfo_OnAction(control As IRibbonControl)
    ContextMenu.WhatIsIt
End Sub

'TabHome_ConsPlusChooseSystem (компонент: button, атрибут: onAction), 2007
'ConsPlusChooseSystem (компонент: button, атрибут: onAction), 2007
Sub TabHome_ConsPlusChooseSystem_OnAction(control As IRibbonControl)
    ContextMenu.ChooseSystem
End Sub

'TabHome_ConsPlusGroupHide (компонент: button, атрибут: onAction), 2007
Sub TabHome_ConsPlusGroupHide_OnAction(control As IRibbonControl)
    
    bTabHomeGroupVisible = False
    
    'сохраняем новое значение в реестр
    WriteReg_TabHomeGroupVisible False
    
    myRibbonUI.Invalidate

    ContextMenu.SconsMsg LoadString("Вы убрали поиск в КонсультантПлюс с главной вкладки! Для того, чтобы он вновь там появился, необходимо на вкладке ""КонсультантПлюс"" в меню включить опцию ""Отображать на главной вкладке""")
End Sub

'ConsPlusGroupShow (компонент: button, атрибут: onAction), 2007
Sub ConsPlusGroupShow_OnAction(control As IRibbonControl)

    bTabHomeGroupVisible = True
    
    'сохраняем новое значение в реестр
    WriteReg_TabHomeGroupVisible True
    
    myRibbonUI.Invalidate
End Sub

'ConsPlusGroupVisibleCheckBox (компонент: checkBox, атрибут: getPressed), 2007
Sub ConsPlusGroupVisibleCheckBox_getPressed(control As IRibbonControl, ByRef pressed)
    pressed = bTabHomeGroupVisible
End Sub

'TabHome_ConsPlusGroupVisibleCheckBox (компонент: checkBox, атрибут: onAction), 2007
Sub ConsPlusGroupVisibleCheckBox_OnAction(control As IRibbonControl, pressed As Boolean)
    
    bTabHomeGroupVisible = pressed
    
    'сохраняем новое значение в реестр
    WriteReg_TabHomeGroupVisible pressed
    
    myRibbonUI.Invalidate
End Sub

'чтение параметра из реестра
Private Function ReadReg_TabHomeGroupVisible() As Boolean
    Dim strVisible As String
    strVisible = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "SconsDotmGroupVisible")
    
    If strVisible = "False" Then
        ReadReg_TabHomeGroupVisible = False
    Else
        ReadReg_TabHomeGroupVisible = True
    End If
End Function

'запись параметра в реестр
Private Function WriteReg_TabHomeGroupVisible(val As Boolean)
    Dim strVisible As String
    If val Then
        strVisible = "True"
    Else
        strVisible = "False"
    End If
    
    System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\ConsultantPlus", "SconsDotmGroupVisible") = strVisible
End Function

Attribute VB_Name = "UICreator"
Option Explicit

Public Sub CreateUI()
    CreateAllButtons
End Sub

'----------------------------------------------------
' методы создания кнопок и панелей
'----------------------------------------------------
Private Sub CreateAllButtons()
    CreateButton "Text"
    CreateButton "Headings"
    CreateButton "Linked Headings"
    CreateButton "Lists"
    CreateButton "Table Headings"
    CreateButton "Table Lists"
    CreateButton "Table Text"
    CreateButton "Linked Text"
    CreateButton "Spelling"
    CreateButton "Grammar"
    CreateButton "Grammar (2)"
    CreateButton "Hyperlink Context Menu"
    CreateButton "Table Cells"
    CreateButton "Endnotes"
    CreateButton "Footnotes"
    CreateButton "Comment"
End Sub

Private Sub DeleteAllButtons()
    DeleteButton "Text"
    DeleteButton "Headings"
    DeleteButton "Linked Headings"
…
vbaProject_00.bin vba-project OOXML VBA project: word/vbaProject.bin 176128 bytes
SHA-256: 18382c2fb367693a2ec39a47148a03ab6afe3662ff4ff34bd242cb00a06e33fc
vbaProject_01.bin vba-project OOXML VBA project: word/vbaProjectSignature.bin 5399 bytes
SHA-256: 1cb4d764b5961d7cf3924269ef4131595731258e253ac211da7a33537acfd19d

Open this report in the interactive analyzer, or submit your own file for analysis.