Malicious Office (OLE) — malware analysis report

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

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

Private Type POINT
    x As Long
    y As Long
End Type
      
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

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 GetDesktopWindow Lib "user32" () 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 GetWindowText Lib "user32" Alias "GetWindowTextA" _
    (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private Declare Function FindWindowA Lib "user32" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
Private Declare Function FindWindowW Lib "user32" _
    (lpClassName As Any, lpWindowName As Any) As Long
    
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" _
    (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize 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
      
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16

Public Function FindWordWindow() As Long
    
    FindWordWindow = FindWordWindow3()
    
End Function

'Public Function FindWordWindow1() As Long
'    Dim bClass() As Byte
'    bClass = "OpusApp" + vbNullChar
'
'    Dim bCaption() As Byte
'    bCaption = Application.Caption + vbNullChar
'
'    FindWordWindow1 = FindWindowW(bClass(0), bCaption(0))
'
'End Function
'
'Public Function FindWordWindow2() As Long
'
'    FindWordWindow2 = FindWindowA("OpusApp", vbNullString)
'
'End Function

Public 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 POINT
    
    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

Public Function FindWindowByCaption(strCaption As String) As Long

    '***************************************
    '*  Находит окно в заголовке которого  *
    '*  есть заданная строка               *
    '***************************************
    Dim CurrWnd As Long
    Dim length As Long
    Dim TaskName As String
    Dim parent As Long
    
    CurrWnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
    While CurrWnd <> 0
        parent = GetParent(CurrWnd)
        
        length = GetWindowTextLength(CurrWnd)
        TaskName = Space(length + 1)
        length = GetWindowText(CurrWnd, TaskName, length + 1)
        TaskName = Left(TaskName, Len(TaskName) - 1)
        
        If length > 0 Then
            TaskName = LCase(TaskName)
            If InStr(1, TaskName, strCaption, vbTextCompare) = 1 Then
                Dim hWndCP
                hWndCP = CurrWnd
                
                Dim hwndParent
                hwndParent = GetParent(hWndCP)
    
                While (hwndParent <> 0)
                    hWndCP = hwndParent
                    hwndParent = GetParent(hWndCP)
                Wend
            
                FindWindowByCaption = hWndCP
                Exit Function
            End If
        End If
        
        CurrWnd = GetWindow(CurrWnd, GW_HWNDNEXT)
    Wend
    
    FindWindowByCaption = 0
End Function

Public Function FindWindowByClassNameAndModulePath(ByVal strClassName As String, ByVal modulePath As String) As Long

    Dim CurrWnd As Long
    Dim length As Long
    Dim wndClassName As String
    Dim parent As Long
    
    ' берем первое окно
    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
                Dim hWndCP
                hWndCP = CurrWnd
                
                Dim hwndParent
                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

Function GetConsPlusWindow(ByVal consExePath As String) As Long
    'GetConsPlusWindow = FindWindow("ConsultantPlusMainWnd", vbNullString) 'FindWindowByString("консультантплюс")
    GetConsPlusWindow = FindWindowByClassNameAndModulePath("ConsultantPlusMainWnd", consExePath) '"ConsultantPlusMainWnd"
    Exit Function
End Function

Sub ActivateConsPlusWindow(hWnd As Long)

    If IsIconic(hWnd) <> 0 Then
        ShowWindow hWnd, SW_RESTORE
    End If
    
    SetForegroundWindow hWnd
End Sub

Sub SendConsPlusSearchMessage(hWnd As Long, ByVal searchText As String)

    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))
    
    Dim res As Long
    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

Private Function ValidateWndModulePath(ByVal hWnd As Long, ByVal modulePath As String) As Boolean
    
    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

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

Attribute VB_Name = "ContextMenu"
Option Explicit
     
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

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

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

'Обработчик кнопки Убрать эту панель?
Public Sub HidePanel()
    
    On Error GoTo errorHandler

    Dim ourCombo As CommandBarComboBox
    Set ourCombo = SearchCombo.FindOurSearchCombo()
    
    ourCombo.parent.Visible = False

    SconsMsg LoadString("Вы отключили панель поиска в КонсультантПлюс! Для того чтобы она вновь появилась, " & _
        "необходимо щелкнуть правой кнопкой мыши на панели инструментов и в появившемся меню включить " & _
        "флажок ""Поиск в КонсультантПлюс""")

    Exit Sub

errorHandler:
    SconsErrMsg LoadString("Ошибка: ") & err.Description
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
    
    'ищем открытое окно КонсультантПлюс
    Dim consPlusWnd As Long
    consPlusWnd = GetConsPlusWindow(consExePath)
    
    If consPlusWnd <> 0 Then
        'есть окно, активизируем его
        ActivateConsPlusWindow (consPlusWnd)
    Else
        'не нашли окно, запускаем КонсультантПлюс
        ShellRunConsPlus consExePath, ""
    End If
    
    Exit Sub
    
errorHandler:
    SconsErrMsg LoadString("Ошибка: ") & err.Description
End Sub

Private Sub SetTemplateSaved()
    Dim templ As Template
    For Each templ In Application.Templates
        If templ.Name = "scons.dot" Then
            templ.Saved = True
        End If
    Next
End Sub

Private Sub DoConsPlusSearchCmdBar()

    On Error GoTo errorHandler

    Dim ourCombo As CommandBarComboBox
    Set ourCombo = SearchCombo.FindOurSearchCombo()

    Dim enteredText As String
    enteredText = Trim(ourCombo.Text)
    
    If Len(enteredText) = 0 Then
        SconsErrMsg LoadString("Для поиска в КонсультантПлюс введите запрос и нажмите клавишу ""Enter""")
        Exit Sub
    End If
    
    UpdateMRU ourCombo
    SetTemplateSaved

    ExecuteSearch enteredText

    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

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

    Dim hwndConsPlus As Long
    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 = "SearchCombo"
Option Explicit

Public Declare Function OutputDebugStringA Lib "kernel32" (ByVal lpOutputString As String) As Long

Public Const OurComboTag = "CPSearchComboBox"

Function FindOurSearchCombo() As CommandBarComboBox
    Set FindOurSearchCombo = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=OurComboTag)
End Function

Sub UpdateMRU(ourCombo As CommandBarComboBox)
    If (ourCombo.ListIndex = 1) Then
        'уже выбран первый элемент
        Exit Sub
    End If
    
    Dim strText As String
    strText = ourCombo.Text
    
    If (ourCombo.ListIndex = 0) Then
        'текста нет в списке - добавляем
        ourCombo.AddItem strText, 1
        ourCombo.ListIndex = 1
        
        'ограничение на количество элементов в списке
        While ourCombo.ListCount > 20
            ourCombo.RemoveItem (ourCombo.ListCount)
        Wend
    Else
        'текст есть в списке, но он не на первом месте
        
        ourCombo.RemoveItem ourCombo.ListIndex
        
        ourCombo.AddItem strText, 1
        ourCombo.ListIndex = 1
    End If
    
End Sub

Sub SaveTextToList(ourCombo As CommandBarComboBox, strText As String)
    
    'Dim ttt As String
    'ttt = ourCombo.Text
    
    If (ourCombo.ListIndex <> 0) Then
        'в списке комбобокса что-то выбрано
        
        'определяем выбранный в комбобоксе текст
        Dim txt As String
        txt = ourCombo.List(ourCombo.ListIndex)
        
        If (txt = strText) Then
            'текст в эдитке совпадает с выбранном текстом, это бывает когда руками начинают набирать значение
            'ниже специально перепроставляется номер выделенной позиции, т.к. иначе комбобокс про него забывает
            ourCombo.ListIndex = ourCombo.ListIndex
        End If
        
        Exit Sub
    End If
    
    If Len(strText) = 0 Then
        'пустой текст не сохраняем в список
        Exit Sub
    End If
    
    ourCombo.AddItem strText
    ourCombo.ListIndex = ourCombo.ListCount
End Sub

Attribute VB_Name = "UICreator"
Option Explicit

Public Const OurCommandBarName = "Поиск в КонсультантПлюс"

Public Sub CreateUI()
    CreateAllButtons
    CreateToolBar
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"
    DeleteButton "Lists"
    DeleteButton "Table Headings"
    DeleteButton "Table Lists"
    DeleteButton "Table Text"
    DeleteButton "Linked Text"
    DeleteButton "Spelling"
    DeleteButton "Grammar"
    DeleteButton "Grammar (2)"
    DeleteButton "Hyperlink Context Menu"
    DeleteButton "Table Cells"
    DeleteButton "Endnotes"
    DeleteButton "Footnotes"
    DeleteButton "Comment"
End Sub

Private Sub CreateButton(cmdBarName As String)
    
    Dim contextBar As CommandBar
    Set contextBar = CommandBars.Item(cmdBarName)
    
    Const strButtonName As String = "Найти в КонсультантПлюс"
    
    Dim ourButton As CommandBarButton
    
    On Error Resume Next
    Set ourButton = contextBar.Controls.Item(strButtonName)
    On Error GoTo 0
    
    If (ourButton Is Nothing) Then
        
        Application.CustomizationContext = ActiveDocument
        
        'создаем
        Set ourButton = contextBar.Controls.Add(msoControlButton)
        ourButton.Caption = strButtonName
        
        ourButton.Style = msoButtonIconAndCaption
        
        ourButton.OnAction = "ContextMenu.DoConsPlusSearch"
        
        ourButton.Picture = GetManButtonPicture()
        ourButton.BeginGroup = True
        
    End If
End Sub

Private Sub CreateToolBar()

    Application.CustomizationContext = ActiveDocument
    
    Dim cmdBar As CommandBar
    Set cmdBar = CommandBars.Add(OurCommandBarName, msoBarTop, False, False)
    
    'кнопка перехода в КП
    Dim ourButton As CommandBarButton
    Set ourButton = cmdBar.Controls.Add(msoControlButton)
    
    ourButton.Caption = "Открыть КонсультантПлюс"
    ourButton.Style = msoButtonIcon
    ourButton.OnAction = "ContextMenu.ActivateConsPlus"
    ourButton.Picture = GetManButtonPicture()
    ourButton.Tag = "OpenConsultantPlusButton"
    
    '----------------------
    'Выпадающее меню
    CreatePopup cmdBar.Controls
    
    '----------------------
    'комбобокс для поисковых запросов
    Dim ourCombo As CommandBarComboBox
    Set ourCombo = cmdBar.Controls.Add(msoControlComboBox)

    ourCombo.Tag = SearchCombo.OurComboTag

    ourCombo.Caption = "Найти в КонсультантПлюс"
    ourCombo.Style = msoComboNormal

    ourCombo.TooltipText = "Введите текст для поиска в системе КонсультантПлюс и нажмите Enter"
    ourCombo.Width = 250
    ourCombo.OnAction = "ContextMenu.DoConsPlusSearchCmdBar"
    ourCombo.Enabled = True
    'ourCombo.BeginGroup = True

    '----------------------
    'кнопка поиска введенного текста
    'Dim ourCmdButton As CommandBarButton
    'Set ourCmdButton = cmdBar.Controls.Add(msoControlButton)

    'ourCmdButton.Caption = "Найти"
    'ourCmdButton.TooltipText = "Найти в КонсультантПлюс"
    'ourCmdButton.Style = msoButtonIconAndCaption
    'ourCmdButton.Picture = GetSearchButtonPicture()
    'ourCmdButton.Mask = GetSearchButtonPictureMask()
    'ourCmdButton.OnAction = "ContextMenu.DoConsPlusSearchCmdBar"
    
    cmdBar.Visible = True
End Sub

Private Sub CreatePopup(Controls As CommandBarControls)

    Dim ourPopup As CommandBarPopup
    Set ourPopup = Controls.Add(Type:=msoControlPopup, Temporary:=False)
    
    ourPopup.Caption = "КонсультантПлюс"
    
    'Открыть К+
    Dim ourGotoKPButton As CommandBarButton
    Set ourGotoKPButton = ourPopup.Controls.Add(msoControlButton)
    
    ourGotoKPButton.Caption = "Открыть КонсультантПлюс"
    ourGotoKPButton.Style = msoButtonCaption
    ourGotoKPButton.OnAction = "ContextMenu.ActivateConsPlus"
    
    'Как работать с этой панелью
    Dim ourInfoButton As CommandBarButton
    Set ourInfoButton = ourPopup.Controls.Add(msoControlButton)
    
    ourInfoButton.Caption = "Как работать с этой панелью?"
    ourInfoButton.Style = msoButtonCaption
    ourInfoButton.OnAction = "ContextMenu.WhatIsIt"
    
    'Выбрать систему для поиска...
    Dim ourChooseSystemButton As CommandBarButton
    Set ourChooseSystemButton = ourPopup.Controls.Add(msoControlButton)
    
    ourChooseSystemButton.Caption = "Выбрать систему для поиска..."
    ourChooseSystemButton.Style = msoButtonCaption
    ourChooseSystemButton.OnAction = "ContextMenu.ChooseSystem"
    ourChooseSystemButton.BeginGroup = True
    
    'Убрать эту панель
    Dim ourHideButton As CommandBarButton
    Set ourHideButton = ourPopup.Controls.Add(msoControlButton)
    
    ourHideButton.Caption = "Убрать эту панель"
    ourHideButton.Style = msoButtonCaption
    ourHideButton.OnAction = "ContextMenu.HidePanel"
    ourHideButton.BeginGroup = True
    
End Sub

Private Sub DeleteButton(cmdBarName As String)
    Dim contextBar As CommandBar
    Set contextBar = CommandBars.Item(cmdBarName)
    
    Const strButtonName As String = "КонсультантПлюс"
    
    On Error Resume Next
…