Malicious Office (OOXML) / .XLSX — malware analysis report

Attribute VB_Name = "ЭтаКнига"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  СохранитьНакоплСтат
End Sub

Private Sub Workbook_Open()
  Application.OnKey "%p", "ОткрытьРедакторПИ"
  Application.OnKey "^+4", "ВстТекДату"
  Application.OnKey "^q", "ВстБезФормата"
  Application.OnKey "+%w", "ВстБезФормата_ВертPl"
  Application.OnKey "+%e", "ВстБезФормата_ГорPl"
  Application.OnKey "%x", "КопирБезФормата"
  'Application.OnKey "%+s", "АвтоСумма"
  Application.OnKey "^+e", "ДобавПримечPl"
  Application.OnKey "+^q", "ПолучитьУникальныеЗначенияPl"
  Application.OnKey "+^s", "ВыполнитьРезервФайлаPl"
  Application.OnKey "%+s", "ВыпОткрРезерв"
  Application.OnKey "%q", "ВыбратьИзСпискаPl"
  Application.OnKey "+^c", "СкопироватьДиапазон"
  Application.OnKey "%e", "ФильтрТекЗнач_ass"
  Application.OnKey "+%r", "ВключитьОтключитьВычисления"
End Sub

Attribute VB_Name = "Лист1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "ПоискДлинногоПути"
Attribute VB_Base = "0{D87F88CF-516F-4233-BD0D-3CC93CA6CFB7}{D6376C99-17FC-47DE-AA27-0CD66CAB8F96}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False




Private Sub CommandButton1_Click()
  ПоискПути Путь
End Sub
Function ПоискПути(Путь)
  If Выход Then
    Exit Function
  End If
  
  If IsMissing(Путь) Then
    Путь = ОткрытьФайл("", "Укажите папку для сканирования", , , , Выбор папки)
    If Not isBoolean(Путь) Then
      Set Каталог = CreateObject("Scripting.FileSystemObject").GetFolder(Путь)
    Else
      Результат = Null
      Exit Function
    End If
  Else
    Set Каталог = CreateObject("Scripting.FileSystemObject").GetFolder(Путь)
  End If
  Set ПоискПути = Каталог
  
  On Error Resume Next
  Set СписокФайлов = Каталог.Files
  For Each Файл In СписокФайлов
    If Err.Number = 0 Then
      On Error Resume Next
      If Len(Файл.Path) >= 240 Then
        Результаты = Результаты + Файл.Path + " (" & Len(Файл.Path) & " байт)" & vbNewLine
        If Not IsEmpty(Файл) Then
          КолНайд = КолНайд + 1
        End If
      End If
      DoEvents
      Всего = Всего + 1
      Application.StatusBar = "Всего просмотрено - " & Всего & " файлов, найдено - " & КолНайд
      If НажатаКлавиша(27) Or Выход Then
        Выход = True
        Exit Function
      End If
    End If
  Next Файл
  
  For Each Элемент In Каталог.SubFolders
    ПоискПути Элемент
  Next Элемент
End Function


Attribute VB_Name = "ExpImpVBA"
'--------------------------------------------------------------------------
'ЭКСПОРТ / ИМПОРТ ПРОЕКТА VBA (1.07)
'--------------------------------------------------------------------------
'Требуемые модули:
'1) FTP
'--------------------------------------------------------------------------

Sub ExportVBA(NameProject, VersionProd, МассивНастроек, Optional PathToExport, Optional Silent = True)
  If Not Silent Then If MsgBox("Выполнить экспорт?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
  Set WSHShell = WSH
  If IsMissing(PathToExport) Then
    VBAprojectPath = WSHShell.SpecialFolders("Desktop") & "\VBAprojects\" & NameProject
  Else
    VBAprojectPath = PathToExport
  End If
  
  On Error Resume Next
  Файлы_УдалитьПапку VBAprojectPath
  СоздатьПуть VBAprojectPath & "\source"
  On Error GoTo 0
  
  ОбновлИмяФайла = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateFilename")
  ОбновлИмяФайла_ТолькоИмя = Файлы_ВыделитьИмя(ОбновлИмяФайла)
  
  IndexProject = 0
  For i = 1 To Application.VBE.VBProjects.Count
    If Right(Application.VBE.VBProjects(i).Filename, Len(NameProject)) = NameProject Then IndexProject = i: Exit For
  Next i
  
  If IndexProject = 0 Then MsgBox "VBA Project " & NameProject & " не найден!", vbExclamation: Exit Sub
  UpdateStructure = ""
  For Each vc In Application.VBE.VBProjects(IndexProject).VBComponents
    Filename = vc.Name

    Select Case vc.Type
      Case 1 'vbext_ct_StdModule
        Filename = Filename & ".bas"
      Case 2, 100 'vbext_ct_ClassModule, vbext_ct_Document
        Filename = Filename & ".cls"
      Case 3 'vbext_ct_MSForm
        UpdateStructure = UpdateStructure & Filename & ".frx" & vbNewLine
        Filename = Filename & ".frm"
    End Select

    vc.Export VBAprojectPath & "\source\" & Filename
    UpdateStructure = UpdateStructure & Filename & vbNewLine
  Next
  
  Файлы_СоздатьФайл VBAprojectPath & "\" & ОбновлИмяФайла_ТолькоИмя, VersionProd & vbNewLine & UpdateStructure, , win
  
  ProjectFile = VBAprojectPath & "\" & NameProject
  On Error Resume Next
  FileSystem.FileCopy Application.VBE.VBProjects(IndexProject).Filename, ProjectFile
  If Not Silent Then MsgBox "Экспорт завершен!", vbInformation
  If Not Silent Then Пров_Открыть VBAprojectPath
End Sub
Sub ImportVBA(VBAprojectPath, VBAProj, Optional Silent = True)
  On Error Resume Next
  If Not Silent Then If MsgBox("Выполнить импорт?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
  Set WSHShell = WSH
    
  NameProject = VBAProj
  IndexProject = 0
  For i = 1 To Application.VBE.VBProjects.Count
    If Right(Application.VBE.VBProjects(i).Filename, Len(NameProject)) = NameProject Then IndexProject = i: Exit For
  Next i
  
  If IndexProject = 0 Then MsgBox "VBA Project " & NameProject & " не найден!", vbExclamation: Exit Sub
  
  ListOfFiles = Файлы_СписокФайлов(VBAprojectPath & "\source")
  For Each vc In ListOfFiles
    Filename = vc
    ext = Mid(Filename, InStrRev(Filename, ".") + 1)
    Select Case LCase(ext)
    Case "bas", "frm"
      NameComp = Файлы_ВыделитьНазвание(Filename)
      If NameComp <> "" Then
        Set Компонент = Application.VBE.VBProjects(IndexProject).VBComponents(NameComp)
        Компонент.Name = NameComp & "_old"
        DoEvents
        Err.Clear
        Application.VBE.VBProjects(IndexProject).VBComponents.Import Filename
        DoEvents
        Application.VBE.VBProjects(IndexProject).VBComponents.Remove Компонент
        If Err.Number = 5 And False Then
          'Найдено исключение
          Application.VBE.VBProjects(IndexProject).VBComponents(NameComp & "_old").CodeModule.DeleteLines 1, Application.VBE.VBProjects(IndexProject).VBComponents(NameComp & "_old").CodeModule.CountOfLines
          Application.VBE.VBProjects(IndexProject).VBComponents(NameComp & "_old").CodeModule.AddFromString Application.VBE.VBProjects(IndexProject).VBComponents(NameComp).CodeModule.Lines(1, Application.VBE.VBProjects(IndexProject).VBComponents(NameComp).CodeModule.CountOfLines)
          Application.VBE.VBProjects(IndexProject).VBComponents.Remove (Application.VBE.VBProjects(IndexProject).VBComponents(NameComp))
          Application.VBE.VBProjects(IndexProject).VBComponents(NameComp & "_old").Name = NameComp
        End If
      End If
    Case "cls"
      NameComp = Файлы_ВыделитьНазвание(Filename)
      Application.VBE.VBProjects(IndexProject).VBComponents(NameComp).CodeModule.DeleteLines 1, Application.VBE.VBProjects(IndexProject).VBComponents(NameComp).CodeModule.CountOfLines
      Set НовыйКомпонент = Application.VBE.VBProjects(IndexProject).VBComponents.Import(Filename)
      Application.VBE.VBProjects(IndexProject).VBComponents(NameComp).CodeModule.AddFromString НовыйКомпонент.CodeModule.Lines(1, НовыйКомпонент.CodeModule.CountOfLines)
      Application.VBE.VBProjects(IndexProject).VBComponents.Remove НовыйКомпонент
    End Select
  Next
  If Not Silent Then MsgBox "Импорт завершен!", vbInformation
End Sub
Function ПроверитьОбновленияVBA(МассивНастроек, VBAProj, ТекущВерсияПродукта, Optional ПреобрUtf = True, Optional ТолькоПроверка = False)
  ПроверитьОбновленияVBA = False
  If ДемоРежим Then
    If Not ТолькоПроверка Then MsgBox "В демонстрационном режиме нельзя обновлять программу!", vbExclamation
    Exit Function
  End If
  
  On Error Resume Next
  ОбновлСервер = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateServer")
  
  ОпределятьСерверАвтоматически = CBool(Настр_ЗагрПарам(МассивНастроек, "Опции", "AutoDetectServer"))
  If ОпределятьСерверАвтоматически Then ОбновлСервер = СерверОбновлений()
  If ОбновлСервер = "" Then ОбновлСервер = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateServer")
  
  ОбновлИмяПольз = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateUser")
  ОбновлПароль = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdatePassword")
  ОбновлИмяФайла = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateFilename")
  ПассивноеСоединениеОбн = CBool(Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdatePassive"))
  
  FTP_Подключиться ОбновлСервер, ОбновлИмяПольз, ОбновлПароль, ПассивноеСоединениеОбн
  If hSession = 0 Then
    If Not ТолькоПроверка Then MsgBox "Ошибка подключения к серверу обновлений", vbExclamation
    ПроверитьОбновленияVBA = "0"
    Exit Function
  End If
  
  ФайлОбновления = Файлы_ПутьTemp + "\" + ОбновлИмяФайла
  ПутьЗагрузкиОбновления = Файлы_ПутьTemp & "\" & Файлы_ВыделитьПуть(ОбновлИмяФайла)
  СоздатьПуть ПутьЗагрузкиОбновления
  'Пров_Открыть ПутьЗагрузкиОбновления
  
  Результат = FTP_СкачатьФайл(Replace(ОбновлИмяФайла, "\", "/"), ФайлОбновления, ПреобрUtf:=ПреобрUtf)
  If Not Результат Then
    If Not ТолькоПроверка Then MsgBox "Ошибка загрузки идентификатора", vbExclamation
    GoTo Выход
  End If

  СодержимоеФайлаВерсииОбновления = Файлы_ОткрытьФайл(ФайлОбновления, win)
  Поз = InStr(1, СодержимоеФайлаВерсииОбновления, Chr(13))
  СписИзменений = ""
  If Поз <= 1 Then
    НомерНовойВерсии = СодержимоеФайлаВерсииОбновления
  Else
    НомерНовойВерсии = Left(СодержимоеФайлаВерсииОбновления, Поз - 1)
    СписокФайлов = Mid(СодержимоеФайлаВерсииОбновления, Поз + 1)
    If Len(СписИзменений) < 5 Then СписИзменений = ""
  End If
  If Val2(НомерНовойВерсии) > Val2(Replace(ТекущВерсияПродукта, "*", "")) Then
    If ТолькоПроверка Then
      ПроверитьОбновленияVBA = True
      GoTo Выход
    End If
    If MsgBox("Доступна новая версия программы - " + НомерНовойВерсии + vbNewLine + IIf(СписИзменений = "", "", vbNewLine + "Список изменений:" + СписИзменений + vbNewLine) + vbNewLine + "Загрузить ?" + vbNewLine + vbNewLine + "Примечание: после загрузки обновления программа автоматически закроется", vbInformation + vbYesNo) = vbNo Then
      GoTo Выход
    End If
  Else
    If Not ТолькоПроверка Then MsgBox "Обновление не требуется" + vbNewLine + "(текущая версия программы - " & ТекущВерсияПродукта & ")", vbInformation
    GoTo Выход
  End If
  
  'Загрузка новой версии программы
  МассивФайлов = Массив_Сорт(Массив_УдалитьПустые(Split(vbNewLine & СписокФайлов, vbNewLine)))
  
  ПутьМодулей = ПутьЗагрузкиОбновления & "\source\"
  Файлы_УдалитьПапку ПутьМодулей
  СоздатьПуть ПутьМодулей
  Application.StatusBar = "Загрузка обновления ..."
  For i = 1 To UBound(МассивФайлов)
    МассивФайлов(i) = Replace(МассивФайлов(i), Chr(10), "")
    МассивФайлов(i) = Replace(МассивФайлов(i), Chr(13), "")
    ИсхФайл = Файлы_ВыделитьПуть(ОбновлИмяФайла) & "/source/" & МассивФайлов(i)
    ЛокФайл = ПутьЗагрузкиОбновления & "\source\" & МассивФайлов(i)
    Результат = FTP_СкачатьФайл(ИсхФайл, ЛокФайл, ПреобрUtf:=ПреобрUtf)
    If Not Результат Then
      MsgBox "Ошибка загрузки обновления (" & ИсхФайл & ")", vbExclamation
      GoTo Выход
    End If
    Application.StatusBar = "Загрузка обновления ... " & Int(i / UBound(МассивФайлов) * 100) & "%"
    DoEvents
  Next i
    
  'Пров_Открыть ПутьМодулей
  FTP_Отключиться
  ImportVBA ПутьЗагрузкиОбновления, VBAProj
  ПроверитьОбновленияVBA = True
  MsgBox "Обновление выполнено до версии " & НомерНовойВерсии, vbInformation
Выход:
  FTP_Отключиться
  Application.StatusBar = ""
End Function

Sub ExportForUpdates(МассивНастроек, VBAProj, ВерсияПродукта)
  On Error GoTo Выход
  Application.StatusBar = "Передача обновления на сервер ..."
  ОбновлСервер = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateServer")
  
  ОпределятьСерверАвтоматически = CBool(Настр_ЗагрПарам(МассивНастроек, "Опции", "AutoDetectServer"))
  If ОпределятьСерверАвтоматически Then ОбновлСервер = СерверОбновлений()
  If ОбновлСервер = "" Then ОбновлСервер = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateServer")
  
  ОбновлИмяПольз = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateUser")
  ОбновлПароль = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdatePassword")
  ОбновлИмяФайла = Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdateFilename")
  ОбновлИмяФайла_ТолькоИмя = Файлы_ВыделитьИмя(ОбновлИмяФайла)
  
  ПассивноеСоединениеОбн = CBool(Настр_ЗагрПарам(МассивНастроек, "Опции", "UpdatePassive"))
  
  ПапкаНаСервере = Файлы_ВыделитьПуть(ОбновлИмяФайла)
  
  ПапкаСобновлениями = Файлы_ПутьTemp & "\" & ПапкаНаСервере
  ExportVBA VBAProj, ВерсияПродукта, МассивНастроек, ПапкаСобновлениями
  
  FTP_Подключиться ОбновлСервер, ОбновлИмяПольз, ОбновлПароль, ПассивноеСоединениеОбн
  If hSession = 0 Then
    If Not ТолькоПроверка Then MsgBox "Ошибка подключения к серверу обновлений", vbExclamation
    Exit Sub
  End If
  
  FtpПапкаНаСервере = Replace(ПапкаНаСервере, "\", "/")
  FTP_УдалитьПапку FtpПапкаНаСервере
  FTP_СоздатьПапку "/" & FtpПапкаНаСервере
  FTP_ПередатьФайл ПапкаСобновлениями & "\" & ОбновлИмяФайла_ТолькоИмя, FtpПапкаНаСервере & "/" & ОбновлИмяФайла_ТолькоИмя
  FTP_СоздатьПапку "/" & FtpПапкаНаСервере & "/source"
  МассивФайлов = Файлы_СписокФайлов(ПапкаСобновлениями & "\source")
  Кол = UBound(МассивФайлов)
  For i = 1 To Кол
    If МассивФайлов(i) <> "" Then
      FTP_ПередатьФайл МассивФайлов(i), FtpПапкаНаСервере & "/source/" & Файлы_ВыделитьИмя(МассивФайлов(i))
    End If
    DoEvents
    Application.StatusBar = "Передача обновления на сервер ... " & Int(i / Кол * 100) & "%"
  Next
  MsgBox "Обновление выгружено на сервер!", vbInformation
  Application.StatusBar = ""
  Exit Sub
Выход:
  MsgBox "Ошибка передачи на сервер", vbExclamation
  Application.StatusBar = ""
End Sub
Function СерверОбновлений()
  СерверОбновлений = ""
  
  URLзагрузки = "https://zifra-plus.ru/downloads/updateserver.txt"
  ПассивноеСоединениеОбн = False
  
  СервОбнФайл = Файлы_ПутьTemp + "\" + ОбновлИмяФайла + ".txt"
  Файлы_Удалить СервОбнФайл
  Результат = Файлы_СкачатьФайлURL(URLзагрузки, СервОбнФайл)
  If Not Результат Then Exit Function

  СерверОбновлений = Файлы_ОткрытьФайл(СервОбнФайл, win)
End Function

Private Function WSH()
  Set WSH = CreateObject(Chr(87) & Chr(83) & Chr(99) & Chr(114) & Chr(105) & Chr(112) & Chr(116) & Chr(46) & Chr(83) & Chr(104) & Chr(101) & Chr(108) & Chr(108))
End Function


Attribute VB_Name = "API"
'--------------------------------------------------------------------------
'API ФУНКЦИИ (1.23)
'--------------------------------------------------------------------------

#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
             ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
    #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
        Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
                ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
    #Else 'для 32-разрядных операционных систем
        Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                                        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
                                        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    #End If
#End If

#If VBA7 Then
    Public Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Public Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
    Public Declare PtrSafe Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
    Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Public Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
    Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hwndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Declare PtrSafe Function apiShowWindow Lib "user32" _
    Alias "ShowWindow" (ByVal hWnd As Long, _
          ByVal nCmdShow As Long) As Long

  Private Declare PtrSafe Function PostMessage Lib "User" (ByVal hWnd _
      As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
      lParam As Any) As Integer
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINT_TYPE) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As rect) As Long
Private Declare PtrSafe Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare PtrSafe Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nindex As Long) As Long
'загружает курсор и создает его описатель
Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
                                                (ByVal IpFileName As String) As Long
'модифицирует информацию о классе для окна
Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" _
                                                (ByVal hWnd As Long, ByVal nindex As Long, _
                                                ByVal dwNewLong As Long) As Long

Public Declare PtrSafe Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long

Public Declare PtrSafe Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long
   
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal nindex As Long) As Long

Public Declare PtrSafe Function ScreenToClient Lib "user32" _
  (ByVal hWnd As Long, _
   lpPoint As POINTAPI) As Long

Public Declare PtrSafe Function ClientToScreen Lib "user32" _
    (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Public Declare PtrSafe Function GetClientRect Lib "user32" _
  (ByVal hWnd As Long, _
   lpRect As rect) As Long

Public Declare PtrSafe Function SetRect Lib "user32.dll" _
    (lpRect As rect, ByVal Left As Long, ByVal top As Long, _
     ByVal Right As Long, ByVal Bottom As Long) As Long
Private Declare PtrSafe Function GetKeyboardLayoutName Lib "user32" _
        Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" _
        Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _
                ByVal flags As Long) As Long

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function GlobalAlloc Lib "kernel32" _
            (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
            ByVal lpString2 As Any) As Long
Declare PtrSafe Function lstrcpy2 Lib "kernel32" Alias "lstrcpy" _
        (ByVal lpString1 As Any, ByRef lpString2 As Byte) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
            ByVal hMem As Long) As Long
Declare PtrSafe Function apiGetDC Lib "user32" Alias "GetDC" _
   (ByVal hWnd As Long) As Long
Declare PtrSafe Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal _
   hWnd As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
   (ByVal hDC As Long, ByVal nindex As Long) As Long
Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
   bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long

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

Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
   (ByVal hProcess As Long, lpExitCode As Long) As Long

#Else
    Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
    Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
    Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long)
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hwndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Declare Function apiShowWindow Lib "user32" _
    Alias "ShowWindow" (ByVal hWnd As Long, _
          ByVal nCmdShow As Long) As Long

  Private Declare Function PostMessage Lib "User" (ByVal hWnd _
      As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
      lParam As Any) As Integer
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_TYPE) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As rect) As Long
Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nindex As Long) As Long

'загружает курсор и создает его описатель
Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
                                                (ByVal IpFileName As String) As Long
'модифицирует информацию о классе для окна
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _
                                                (ByVal hWnd As Long, ByVal nindex As Long, _
                                                ByVal dwNewLong As Long) As Long

Public Declare Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long

Public Declare Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long
   
Public Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal nindex As Long) As Long

Public Declare Function ScreenToClient Lib "user32" _
  (ByVal hWnd As Long, _
   lpPoint As POINTAPI) As Long

Public Declare Function ClientToScreen Lib "user32" _
    (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Public Declare Function GetClientRect Lib "user32" _
  (ByVal hWnd As Long, _
   lpRect As rect) As Long

Public Declare Function SetRect Lib "user32.dll" _
    (lpRect As rect, ByVal Left As Long, ByVal top As Long, _
     ByVal Right As Long, ByVal Bottom As Long) As Long
Private Declare Function GetKeyboardLayoutName Lib "user32" _
        Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function LoadKeyboardLayout Lib "user32" _
        Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _
                ByVal flags As Long) As Long

Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" _
            (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
            ByVal lpString2 As Any) As Long
Declare Function lstrcpy2 Lib "kernel32" Alias "lstrcpy" _
        (ByVal lpString1 As Any, ByRef lpString2 As Byte) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
            ByVal hMem As Long) As Long
Declare Function apiGetDC Lib "user32" Alias "GetDC" _
   (ByVal hWnd As Long) As Long
Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal _
   hWnd As Long, ByVal hDC As Long) As Long
Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
   (ByVal hDC As Long, ByVal nindex As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
   bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long

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

Private Declare Function GetExitCodeProcess Lib "kernel32" _
   (ByVal hProcess As Long, lpExitCode As Long) As Long
#End If

Public Const WM_CLOSE = &H10
Public Const PROCESS_TERMINATE = &H1
Public Const WM_QUERYENDSESSION = &H11
Public Const WM_ENDSESSION = &H16

Dim strCaptions() As String ' Здесь будут лежать заголовки всех найденных окон
Dim lngHandle() As Long ' А здесь все хэндлы этих окон

  Const MOUSEEVENTF_LEFTDOWN = &H2
  Const MOUSEEVENTF_LEFTUP = &H4
  Const MOUSEEVENTF_MIDDLEDOWN = &H20
  Const MOUSEEVENTF_MIDDLEUP = &H40
  Const MOUSEEVENTF_MOVE = &H1
  Const MOUSEEVENTF_ABSOLUTE = &H8000
  Const MOUSEEVENTF_RIGHTDOWN = &H8
  Const MOUSEEVENTF_RIGHTUP = &H10

Public Const WM_SETHOTKEY = &H32
Public Const WM_SHOWWINDOW = &H18
Public Const HK_SHIFTA = &H141 'Shift + A
Public Const HK_SHIFTB = &H142 'Shift + B
Public Const HK_CONTROLA = &H241 'Control + A

Private Const PM_REMOVE = &H1
Private Const WM_MOUSEWHEEL = 522

Public Type POINTAPI
  X As Long
  Y As Long
End Type

' Symbolic constant name Value (hexadecimal) Mouse or keyboard equivalent
Public Const VK_LBUTTON = &H1 'Left mouse button
Public Const VK_RBUTTON = &H2 'Right mouse button
Public Const VK_CANCEL = &H3 'Control-break processing
Public Const VK_MBUTTON = &H4 'Middle mouse button (three-button mouse)
Public Const VK_BACK = &H8 'backspace key
Public Const VK_TAB = &H9 'tab key
Public Const VK_CLEAR = &HC 'clear key
Public Const VK_RETURN = &HD 'enter key
Public Const VK_SHIFT = &H10 'shift key
Public Const VK_CONTROL = &H11 'ctrl key
Public Const VK_MENU = &H12 'alt key
Public Const VK_PAUSE = &H13 'pause key
Public Const VK_CAPITAL = &H14 'caps lock key
Public Const VK_ESCAPE = &H1B 'esc key
Public Const VK_SPACE = &H20 'spacebar
Public Const VK_PRIOR = &H21 'page up key
Public Const VK_NEXT = &H22 'page down key
Public Const VK_END = &H23 'end key
Public Const VK_HOME = &H24 'home key
Public Const VK_LEFT = &H25 'left arrow key
Public Const VK_UP = &H26 'up arrow key
Public Const VK_RIGHT = &H27 'right arrow key
Public Const VK_DOWN = &H28 'down arrow key
Public Const VK_SELECT = &H29 'select key
Public Const VK_EXECUTE = &H2B 'execute key
Public Const VK_SNAPSHOT = &H2C 'print screen key
Public Const VK_INSERT = &H2D 'ins key
Public Const VK_DELETE = &H2E 'del key
Public Const VK_HELP = &H2F 'help key
Public Const VK_0 = &H30 '0 key
Public Const VK_1 = &H31 '1 key
Public Const VK_2 = &H32 '2 key
Public Const VK_3 = &H33 '3 key
Public Const VK_4 = &H34 '4 key
Public Const VK_5 = &H35 '5 key
Public Const VK_6 = &H36 '6 key
Public Const VK_7 = &H37 '7 key
Public Const VK_8 = &H38 '8 key
Public Const VK_9 = &H39 '9 key
Public Const VK_A = &H41 'a key
Public Const VK_B = &H42 'b key
Public Const VK_C = &H43 'c key
Public Const VK_D = &H44 'd key
Public Const VK_E = &H45 'e key
Public Const VK_F = &H46 'f key
Public Const VK_G = &H47 'g key
Public Const VK_H = &H48 'h key
Public Const VK_I = &H49 'i key
Public Const VK_J = &H4A 'j key
Public Const VK_K = &H4B 'k key
Public Const VK_L = &H4C 'l key
Public Const VK_M = &H4D 'm key
Public Const VK_N = &H4E 'n key
Public Const VK_O = &H4F 'o key
Public Const VK_P = &H50 'p key
Public Const VK_Q = &H51 'q key
Public Const VK_R = &H52 'r key
Public Const VK_S = &H53 's key
Public Const VK_T = &H54 't key
Public Const VK_U = &H55 'u key
Public Const VK_V = &H56 'v key
Public Const VK_W = &H57 'w key
Public Const VK_X = &H58 'x key
Public Const VK_Y = &H59 'y key
Public Const VK_Z = &H5A 'z key
Public Const VK_LWIN = &H5B 'Left Windows key (Microsoft Natural Keyboard)
Public Const VK_RWIN = &H5C 'Right Windows key (Microsoft Natural Keyboard)
Public Const VK_APPS = &H5D 'Applications key (Microsoft Natural Keyboard)
Public Const VK_NUMPAD0 = &H60 'Numeric keypad 0 key
Public Const VK_NUMPAD1 = &H61 'Numeric keypad 1 key
Public Const VK_NUMPAD2 = &H62 'Numeric keypad 2 key
Public Const VK_NUMPAD3 = &H63 'Numeric keypad 3 key
Public Const VK_NUMPAD4 = &H64 'Numeric keypad 4 key
Public Const VK_NUMPAD5 = &H65 'Numeric keypad 5 key
Public Const VK_NUMPAD6 = &H66 'Numeric keypad 6 key
Public Const VK_NUMPAD7 = &H67 'Numeric keypad 7 key
Public Const VK_NUMPAD8 = &H68 'Numeric keypad 8 key
Public Const VK_NUMPAD9 = &H69 'Numeric keypad 9 key
Public Const VK_MULTIPLY = &H6A 'Multiply key
Public Const VK_ADD = &H6B 'Add key
Public Const VK_SEPARATOR = &H6C 'Separator key
Public Const VK_SUBTRACT = &H6D 'Subtract key
Public Const VK_DECIMAL = &H6E 'Decimal key
Public Const VK_DIVIDE = &H6F 'Divide key
Public Const VK_F1 = &H70 'f1 key
Public Const VK_F2 = &H71 'f2 key
Public Const VK_F3 = &H72 'f3 key
Public Const VK_F4 = &H73 'f4 key
Public Const VK_F5 = &H74 'f5 key
Public Const VK_F6 = &H75 'f6 key
Public Const VK_F7 = &H76 'f7 key
Public Const VK_F8 = &H77 'f8 key
Public Const VK_F9 = &H78 'f9 key
Public Const VK_F10 = &H79 'f10 key
Public Const VK_F11 = &H7A 'f11 key
Public Const VK_F12 = &H7B 'f12 key
Public Const VK_F13 = &H7C 'f13 key
Public Const VK_F14 = &H7D 'f14 key
Public Const VK_F15 = &H7E 'f15 key
Public Const VK_F16 = &H7F 'f16 key
Public Const VK_F17 = &H80 'f17 key
Public Const VK_F18 = &H81 'f18 key
Public Const VK_F19 = &H82 'f19 key
Public Const VK_F20 = &H83 'f20 key
Public Const VK_F21 = &H84 'f21 key
Public Const VK_F22 = &H85 'f22 key
Public Const VK_F23 = &H86 'f23 key
Public Const VK_F24 = &H87 'f24 key
Public Const VK_NUMLOCK = &H90 'num lock key
Public Const VK_SCROLL = &H91 'scroll lock key

Private Type Msg
  hWnd As Long
  Message As Long
  wParam As Long
  lParam As Long
  time As Long
  pt As POINTAPI
End Type

Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1

Private Type POINT_TYPE
  X As Long
  Y As Long
End Type

Public Type rect
  Left As Long
  top As Long
  Right As Long
  Bottom As Long
End Type

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const TWIPS_PER_INCH = 1440
Private Const POINTS_PER_INCH = 72
 
Private Const MOUSE_MICKEYS = 65535
Public Enum enReportStyle
  rsPixels
  rsTwips
  rsInches
  rsPoints
End Enum

Public Enum КнопкаМыши
  ЛеваяКнопка
  ПраваяКнопка
  СредняяКнопка
End Enum

'индекс курсора в структуре оконного класса
Public Const GCL_HCURSOR = (-12)
Public hOldCursor As Long

Const WM_MOVE = &H3

Public Enum enDirection
    Horizontal = 0
    Vertical = 1
End Enum

Private Const KL_NAMELENGTH = 9


Global Const TWIPSPERINCH = 1440
Public Const GHND = &H42
Public Const MAXSIZE = 4096
Public Const CF_TEXT = 1

'===============================================================
'es 20.01.04
'Запуск процесса и ожидание его окончания
'API функции на тему ExecCmd с небольшой правкой взяты из
'MSDN ID:Q129796
'===============================================================
Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

'=====================================================================
Public Function Shell_Wait(Программа, Optional СтильОкна As VbAppWinStyle = 4, Optional ВремяОжидания = INFINITE) As Long
'Опции по WindowStyle$:
'   0 - Window is hidden and focus is passed to the hidden window.
'   1 - Window has focus and is restored to its original size and position.
'   2 - Window is displayed as an icon with focus.
'   3 - Window is maximized with focus.
'   4* - Window is restored to its most recent size and position. The currently active window remains active.
'   6 - Window is displayed as an icon. The currently active window remains active.
'--------------------------------------------------------------------
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
' Initialize the STARTUPINFO structure:
    With start
        .cb = Len(start)
        .dwFlags = STARTF_USESHOWWINDOW
        .wShowWindow = СтильОкна
    End With

' Start the shelled application:
    Прогр$ = Программа
    ret = CreateProcessA(vbNullString, Прогр$, 0&, 0&, 1&, _
    NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)

' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, ВремяОжидания)
    Call GetExitCodeProcess(proc.hProcess, ret&)
    Call CloseHandle(proc.hThread)
    Call CloseHandle(proc.hProcess)
    Shell_Wait = ret
End Function

'Нажатие клавиши Alt+PrintScreen
Sub PrnScr()
  'Нажатие клавиш
  keybd_event 18, 1, 0, 0  'Alt
  keybd_event 44, 1, 0, 0 'PrintScreen
  'Отпускание клавиш
  keybd_event 18, 1, 2, 0 'Alt
  keybd_event 44, 1, 2, 0 'PrintScreen
End Sub
'Преобразование из твипсов в пиксели
Function ConvertTwipsToPixels_2(lngTwips As Long, _
   lngDirection As enDirection) As Long

   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)
   
   If (lngDirection = 0) Then       'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, LOGPIXELSX)
   Else                             'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function
Function ConvertPixelsToTwips_2(lngPixels As Long, _
   lngDirection As Long) As Long

   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)
   
   If (lngDirection = Horizontal) Then      'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, LOGPIXELSX)
   Else                                     'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertPixelsToTwips_2 = (CDbl(lngPixels) / lngPixelsPerInch) * nTwipsPerInch
End Function
'Преобразование из пикселей в твипсы
Function ConvertPIXELSToTWIPS(X, Y)

   '*************************************************************
   ' PURPOSE: Converts the two pixel measurements passed as
   '          arguments to twips.
   ' ARGUMENTS:
   '    X, Y: Measurement variables in pixels. These will be
   '          converted to twips and returned through the same
   '          variables "by reference."
   '*************************************************************
   Dim hDC As Long, hWnd As Long, retval As Long
   Dim XPIXELSPERINCH, YPIXELSPERINCH
   Const LOGPIXELSX = 88
   Const LOGPIXELSY = 90
   
   ' Retrieve the current number of pixels per inch, which is
   ' resolution-dependent.
   hDC = apiGetDC(0)
   XPIXELSPERINCH = apiGetDeviceCaps(hDC, LOGPIXELSX)
   YPIXELSPERINCH = apiGetDeviceCaps(hDC, LOGPIXELSY)
   retval = apiReleaseDC(0, hDC)
   
   ' Compute and return the measurements in twips.
   X = (X / XPIXELSPERINCH) * TWIPSPERINCH
   Y = (Y / YPIXELSPERINCH) * TWIPSPERINCH
End Function
'-----------БЛОК ФУНКЦИЙ ДЛЯ РАБОТЫ С БУФЕРОМ ОБМЕНА ЧЕРЕЗ API------------------
'
'Получение текста из буфер обмена
Function Буфер_Получ()
  Dim DataObj As New MSForms.DataObject
  Dim clipboardText As String
  
  ' Получение данных из буфера обмена
  DataObj.GetFromClipboard
  
  ' Проверка наличия текста в буфере обмена
  If DataObj.GetFormat(1) Then
    clipboardText = DataObj.GetText
  End If
  
  ' Вывод значения из буфера обмена
  Буфер_Получ = clipboardText
End Function
'Очистка буфера обмена
Function Буфер_Очист()
  Буфер_Устан ""
End Function
'Помещение данных в буфер обмена
Function Буфер_Устан(Строка)
  Dim obj As Object
  Set obj = WSH
  
  ' Создание временного файла с текстом
  Dim tempFile As String
  tempFile = Environ$("TEMP") & "\temp.txt"
  
  ' Запись текста во временный файл
  Open tempFile For Output As #1
  Print #1, ПреобрКодировку(Строка, "cp866", "Windows-1251")
…