Option Explicit
'/////////////////////////////////////////////////
'// Модуль для изменения обоев на рабочем столе //
'// Copyright (c) 01.08.2023 by HackerVlad      //
'// e-mail: vladislavpeshkov@yandex.ru          //
'// Версия 3.0                                  //
'/////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function SystemParametersInfoW Lib "user32" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpszIID As Long, iid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32" (rclsid As Any, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As Any, ByVal ppv As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal addr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal dlen As Long)
Private Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsW" (ByVal pszPath As Long) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const UPDATEINIFILE = &H1
Private Const CLSCTX_INPROC_SERVER  As Long = 1
Private Const CLSID_ActiveDesktop   As String = "{75048700-EF1F-11D0-9888-006097DEACF9}"
Private Const IID_ActiveDesktop     As String = "{F490EB00-1240-11D1-9888-006097DEACF9}"
 
Private Type GUID
    data1                   As Long
    data2                   As Integer
    data3                   As Integer
    data4(7)                As Byte
End Type
 
Private Type IActiveDesktop
    ' IUnknown
    QueryInterface          As Long
    AddRef                  As Long
    Release                 As Long
    ' IActiveDesktop
    ApplyChanges            As Long
    GetWallpaper            As Long
    SetWallpaper            As Long
    GetWallpaperOptions     As Long
    SetWallpaperOptions     As Long
    GetPattern              As Long
    SetPattern              As Long
    GetDesktopItemOptions   As Long
    SetDesktopItemOptions   As Long
    AddDesktopItem          As Long
    AddDesktopItemWithUI    As Long
    ModifyDesktopItem       As Long
    RemoveDesktopItem       As Long
    GetDesktopItemCount     As Long
    GetDesktopItem          As Long
    GetDesktopItemByID      As Long
    GenerateDesktopItemHtml As Long
    AddUrl                  As Long
    GetDesktopItemBySource  As Long
End Type
 
Private Enum AD_APPLY
    AD_APPLY_SAVE = &H1
    AD_APPLY_HTMLGEN = &H2
    AD_APPLY_REFRESH = &H4
    AD_APPLY_ALL = &H7
    AD_APPLY_FORCE = &H8
    AD_APPLY_BUFFERED_REFRESH = &H10
    AD_APPLY_DYNAMICREFRESH = &H20
End Enum
 
' Универсальная функция изменения обоев на рабочем столе
Public Function SetWallpaperUniversal(ByVal FileName As String) As Boolean
    If IsFileAPI(StrPtr(FileName)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    If SetWallpaper(FileName) = False Then
        If ActiveDesktopSetWallpaper(FileName) = True Then
            SetWallpaperUniversal = True
        End If
    Else
        SetWallpaperUniversal = True
    End If
End Function
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfoW(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function
 
' Изменение обоев на рабочем столе с помощью интерфейса IActiveDesktop
Public Function ActiveDesktopSetWallpaper(ByVal strFile As String) As Boolean
    Dim vtbl            As IActiveDesktop
    Dim vtblptr         As Long
    Dim classid         As GUID
    Dim iid             As GUID
    Dim obj             As Long
    Dim hRes            As Long
    
    If IsFileAPI(StrPtr(strFile)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    ' CLSID (BSTR) to CLSID (GUID)
    hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
    If hRes <> 0 Then
        Exit Function
    End If
    
    ' IID (BSTR) to IID (GUID)
    hRes = IIDFromString(StrPtr(IID_ActiveDesktop), iid)
    If hRes <> 0 Then
        Exit Function
    End If
    
    ' Создать экземпляр IActiveDesktop
    ' (Set IActiveDesktop = New IActiveDesktop)
    hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
    If hRes <> 0 Then
        Exit Function
    End If
    
    GetMem4 ByVal obj, vtblptr
    RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
    
    ' IActiveDesktop::SetWallpaper
    ' Первым параметром всегда является указатель на объект
    ' Возвращаемое значение всегда должно быть HRESULT (0 = S_OK)
    hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
    If hRes = 0 Then
        ActiveDesktopSetWallpaper = True
    End If
    
    ' IActiveDesktop::ApplyChanges
    hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE)
    
    ' Освободить память
    ' (Set IActiveDesktop = Nothing)
    CallPointer vtbl.Release, obj
End Function
 
Private Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long
    Dim btASM(&HEC00& - 1)  As Byte
    Dim pASM                As Long
    Dim i                   As Integer
    
    pASM = VarPtr(btASM(0))
    
    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX
    
    For i = UBound(params) To 0 Step -1
        AddPush pASM, CLng(params(i))   ' PUSH dword
    Next
    
    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET
    
    CallPointer = CallWindowProcA(VarPtr(btASM(0)), 0, 0, 0, 0)
End Function
 
Private Sub AddPush(pASM As Long, lng As Long)
    AddByte pASM, &H68
    AddLong pASM, lng
End Sub
 
Private Sub AddCall(pASM As Long, addr As Long)
    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub
 
Private Sub AddLong(pASM As Long, lng As Long)
    GetMem4 lng, ByVal pASM
    pASM = pASM + 4
End Sub
 
Private Sub AddByte(pASM As Long, bt As Byte)
    GetMem1 bt, ByVal pASM
    pASM = pASM + 1
End Sub

Option Explicit
' *----------------------------------------*
' | Программа PixelingNT                   |
' | Версия 1.0                             |
' | Copyright (c) 26.09.2023 by HackerVlad |
' | e-mail: vladislavpeshkov@ya.ru         |
' *----------------------------------------*
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As OLE_HANDLE) As OLE_HANDLE
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As OLE_HANDLE, ByVal hDC As OLE_HANDLE) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As OLE_HANDLE, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef Point As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
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
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetMem1 Lib "msvbvm60" (ByVal Src As Long, Dst As Any) As Long
 
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Dim ScreenX As Long
Dim ScreenY As Long
Dim Stopped As Boolean
Dim MouseXY As POINTAPI
 
Private Function APIColor2HtmlColor(APIColor As Long) As String
    Dim colorR As Byte
    Dim colorG As Byte
    Dim colorB As Byte
    
    GetMem1 VarPtr(APIColor), colorR
    GetMem1 VarPtr(APIColor) + 1, colorG
    GetMem1 VarPtr(APIColor) + 2, colorB
    
    APIColor2HtmlColor = "#" & IIf(Len(Hex(colorR)) = 2, Hex(colorR), "0" & Hex(colorR)) & IIf(Len(Hex(colorG)) = 2, Hex(colorG), "0" & Hex(colorG)) & IIf(Len(Hex(colorB)) = 2, Hex(colorB), "0" & Hex(colorB))
End Function
 
Private Sub Form_Click()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
       .SetText Label1.Caption
       .PutInClipboard
    End With
End Sub
 
Private Sub Form_Load()
    WindowTopMost hwnd, True
    PositionWindow hwnd, mRightBottom
    
    ScreenX = (Screen.Width / Screen.TwipsPerPixelX)
    ScreenY = (Screen.Height / Screen.TwipsPerPixelY)
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim GetColor As Long
    Dim LabelString As String
    
    GetColor = Me.Point(x, y)
    
    If x <> 255 And y <> 255 And (x Mod 16) <> 0 And (y Mod 16) <> 0 Then
        LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
        
        If Label1.Caption <> LabelString Then
            Label1.Caption = LabelString
        End If
    End If
End Sub
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        Unload Me
    End If
End Sub
 
Private Sub Label1_Click()
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Label1_DblClick()
    PositionWindow hwnd, mRightBottom
End Sub
 
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call ReleaseCapture
    Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Timer1_Timer()
    Dim hDC As OLE_HANDLE
    Dim tPT As POINTAPI
    Dim mouseX As Long
    Dim mouseY As Long
    Dim lN As Long
    
    If Stopped = False Then
        GetCursorPos tPT
        
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Label1.Caption = tPT.x & " x " & tPT.y
            hDC = GetDC(0)
            
            If hDC Then
                If (tPT.x - 8) >= 0 Then
                    If tPT.x >= ScreenX - 8 Then
                        Me.Cls
                        mouseX = ScreenX - 8
                    Else
                        mouseX = tPT.x - 8
                    End If
                End If
                If (tPT.y - 8) >= 0 Then
                    If tPT.y > ScreenY - 8 Then
                        Me.Cls
                        mouseY = ScreenY - 8
                    Else
                        mouseY = tPT.y - 8
                    End If
                End If
                
                StretchBlt Me.hDC, 0, 0, 256, 256, hDC, mouseX, mouseY, 16, 16, vbSrcCopy
                
                ReleaseDC 0, hDC
                Me.Refresh
            End If
        End If
    End If
End Sub
 
Private Sub Timer2_Timer()
    Dim tPT As POINTAPI
    Dim lN  As Long
    
    GetCursorPos tPT
    
    If GetAsyncKeyState(17) And GetAsyncKeyState(91) Or GetAsyncKeyState(17) And GetAsyncKeyState(92) Then
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Timer3.Enabled = True
            Timer2.Enabled = False
            
            Stopped = Not (Stopped)
            Timer1.Enabled = Not (Timer1.Enabled)
            
            If Stopped = True Then
                MouseXY = tPT
                Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
                
                For lN = 0 To 15
                    Me.Line (0, lN * 16)-Step(256, 0), vbBlack
                    Me.Line (lN * 16, 0)-Step(0, 256), vbBlack
                Next
                
                Me.Line (255, 0)-(255, 255), vbBlack
                Me.Line (0, 255)-(256, 255), vbBlack
            End If
            
            Exit Sub
        End If
    End If
    
    If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
        If Stopped = True Then
            Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
        End If
    End If
End Sub
 
Private Sub Timer3_Timer()
    Timer3.Enabled = False
    Timer2.Enabled = True
End Sub

Option Explicit
Private Declare Function WTSEnumerateProcesses Lib "wtsapi32.dll" Alias "WTSEnumerateProcessesW" (ByVal hServer As Long, ByVal Reserved As Long, ByVal Version As Long, ppProcessInfo As Long, pCount As Long) As Long
Private Declare Function WTSFreeMemory Lib "wtsapi32.dll" (ByVal pMemory As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal ptr As Long, ByVal Value As Long)
Private Declare Function ConvertSidToStringSid Lib "advapi32.dll" Alias "ConvertSidToStringSidW" (ByVal lpSid As Long, lpString As Long) As Long
Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidW" (ByVal lpSystemName As Long, ByVal sid As Long, ByVal name As Long, cbName As Long, ByVal ReferencedDomainName As Long, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
 
Private Const WTS_CURRENT_SERVER_HANDLE = 0
Private Const MAX_PATH As Long = 260
 
Private Type WTS_PROCESS_INFO
    SessionId As Long
    ProcessId As Long
    pProcessName As Long
    pUserSid As Long
End Type
 
Private Sub Command1_Click()
    Dim ppProcessInfo As Long
    Dim pCount As Long
    Dim WTS As WTS_PROCESS_INFO
    Dim ProcessName As String
    Dim pVoid As Long
    Dim i As Long
    Dim lpString As Long
    Dim StringSid As String
    Dim lpszDomain As String, lpszUsername As String
    Dim cbDomain As Long, cbUsername As Long
    Dim peUse As Long
    Dim AddLookupAccountSid As Boolean
    
    If List1.ListCount > 0 Then List1.Clear
    If List2.ListCount > 0 Then List2.Clear
    If List3.ListCount > 0 Then List3.Clear
    If List4.ListCount > 0 Then List4.Clear
    
    If WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0, 1, ppProcessInfo, pCount) > 0 Then
        pVoid = ppProcessInfo
        
        For i = 0 To pCount - 1
            CopyMemory WTS, pVoid, LenB(WTS)
            StringSid = ""
            
            If WTS.ProcessId > 0 Then
                PutMem4 VarPtr(ProcessName), SysAllocStringLen(0, lstrlen(WTS.pProcessName))
                lstrcpy StrPtr(ProcessName), WTS.pProcessName
                AddLookupAccountSid = False
                
                If ConvertSidToStringSid(WTS.pUserSid, lpString) > 0 Then
                    PutMem4 VarPtr(StringSid), SysAllocStringLen(0, lstrlen(lpString))
                    lstrcpy StrPtr(StringSid), lpString
                    LocalFree lpString
                    
                    cbDomain = MAX_PATH
                    cbUsername = MAX_PATH
                    PutMem4 VarPtr(lpszDomain), SysAllocStringLen(0, MAX_PATH)
                    PutMem4 VarPtr(lpszUsername), SysAllocStringLen(0, MAX_PATH)
                    
                    If LookupAccountSid(ByVal 0&, WTS.pUserSid, StrPtr(lpszUsername), cbUsername, StrPtr(lpszDomain), cbDomain, peUse) > 0 Then
                        lpszDomain = Left$(lpszDomain, cbDomain)
                        lpszUsername = Left$(lpszUsername, cbUsername)
                        AddLookupAccountSid = True
                    End If
                End If
                
                List1.AddItem WTS.ProcessId & "    " & WTS.SessionId
                List2.AddItem ProcessName
                List3.AddItem StringSid
                If AddLookupAccountSid = True Then
                    List4.AddItem lpszDomain & "\" & lpszUsername
                Else
                    List4.AddItem "<Unknown>\<Unknown>"
                End If
            End If
            
            pVoid = pVoid + LenB(WTS)
        Next
        
        WTSFreeMemory ppProcessInfo
    End If
    
    List1.Selected(0) = True
    List1.SetFocus
End Sub
 
Private Sub List1_Click()
    List2.Selected(List1.ListIndex) = True
    List3.Selected(List1.ListIndex) = True
    List4.Selected(List1.ListIndex) = True
End Sub
 
Private Sub List2_Click()
    List1.Selected(List2.ListIndex) = True
    List3.Selected(List2.ListIndex) = True
    List4.Selected(List2.ListIndex) = True
End Sub
 
Private Sub List3_Click()
    List1.Selected(List3.ListIndex) = True
    List2.Selected(List3.ListIndex) = True
    List4.Selected(List3.ListIndex) = True
End Sub
 
Private Sub List4_Click()
    List1.Selected(List4.ListIndex) = True
    List2.Selected(List4.ListIndex) = True
    List3.Selected(List4.ListIndex) = True
End Sub

Option Explicit
' *----------------------------------------*
' | Программа PixelingNT                   |
' | Версия 1.1                             |
' | Copyright (c) 10.10.2023 by HackerVlad |
' | e-mail: vladislavpeshkov@ya.ru         |
' *----------------------------------------*
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As OLE_HANDLE) As OLE_HANDLE
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As OLE_HANDLE, ByVal hDC As OLE_HANDLE) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As OLE_HANDLE, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef Point As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
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
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetMem1 Lib "msvbvm60" (ByVal Src As Long, Dst As Any) As Long
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) 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 Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const ABS_AUTOHIDE = &H1
Private Const ABS_ONTOP = &H2
Private Const ABM_GETSTATE = &H4
Private Const ABM_GETTASKBARPOS = &H5
Private Const HWND_TOPMOST = -1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long
End Type
 
Dim ScreenX As Long
Dim ScreenY As Long
Dim Stopped As Boolean
Dim MouseXY As POINTAPI
 
Private Function APIColor2HtmlColor(APIColor As Long) As String
    Dim colorR As Byte
    Dim colorG As Byte
    Dim colorB As Byte
    
    GetMem1 VarPtr(APIColor), colorR
    GetMem1 VarPtr(APIColor) + 1, colorG
    GetMem1 VarPtr(APIColor) + 2, colorB
    
    APIColor2HtmlColor = "#" & IIf(Len(Hex(colorR)) = 2, Hex(colorR), "0" & Hex(colorR)) & IIf(Len(Hex(colorG)) = 2, Hex(colorG), "0" & Hex(colorG)) & IIf(Len(Hex(colorB)) = 2, Hex(colorB), "0" & Hex(colorB))
End Function
 
Private Sub Form_Click()
    Dim PutSetText As String
    
    PutSetText = Label1.Caption
    
    If Len(PutSetText) > 0 Then
        PutSetText = Replace(PutSetText, "&&H", "&H")
        
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .SetText PutSetText
           .PutInClipboard
        End With
    End If
End Sub
 
Private Sub Form_Load()
    Dim ABD As APPBARDATA, Ret As Long
    Dim hPanel As Integer
    Dim gPanel As Integer
    
    ScreenX = (Screen.Width / Screen.TwipsPerPixelX)
    ScreenY = (Screen.Height / Screen.TwipsPerPixelY)
    
    ' Предотвратить растягивание формы в других DPI
    If IsScreenZoom > 100 Then
        Me.Width = 256 * Screen.TwipsPerPixelX
        Me.Height = 273 * Screen.TwipsPerPixelY
        Label1.Top = 256
        Label1.Left = 0
        Label1.Width = 256
        Label1.Height = Me.Height - Label1.Top
        Label1.Font = GetSystemFontName(MessageFont)
        
        If IsScreenZoom > 120 Then
            Label1.FontSize = 7
        Else
            Label1.FontSize = 9
        End If
    End If
    
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
    
    ' Математические расчёты для центрирования формы в правом нижнем углу экрана, в соответствии с таскбаром
    SHAppBarMessage ABM_GETTASKBARPOS, ABD
    Ret = SHAppBarMessage(ABM_GETSTATE, ABD)
    If Trim(Str(ABD.rc.Top)) > 0 Then hPanel = (Trim(Str(ABD.rc.Bottom)) - Trim(Str(ABD.rc.Top))) * Screen.TwipsPerPixelX
    If Trim(Str(ABD.rc.Left)) > 0 Then gPanel = (Trim(Str(ABD.rc.Right)) - Trim(Str(ABD.rc.Left))) * Screen.TwipsPerPixelX
    
    Me.Left = Screen.Width - Me.Width - gPanel
    Me.Top = Screen.Height - Me.Height - hPanel
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim GetColor As Long
    Dim LabelString As String
    
    GetColor = Me.Point(x, y)
    
    If Stopped = True Then
        If x <> 255 And y <> 255 And (x Mod 16) <> 0 And (y Mod 16) <> 0 Then
            LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
            
            If Label1.Caption <> LabelString Then
                Label1.Caption = LabelString
            End If
        End If
    Else
        LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
        
        If Label1.Caption <> LabelString Then
            Label1.Caption = LabelString
        End If
    End If
End Sub
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        Unload Me
    End If
End Sub
 
Private Sub Label1_Click()
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Label1_DblClick()
    Dim ABD As APPBARDATA, Ret As Long
    Dim hPanel As Integer
    Dim gPanel As Integer
    
    ' Математические расчёты для центрирования формы в правом нижнем углу экрана, в соответствии с таскбаром
    SHAppBarMessage ABM_GETTASKBARPOS, ABD
    Ret = SHAppBarMessage(ABM_GETSTATE, ABD)
    If Trim(Str(ABD.rc.Top)) > 0 Then hPanel = (Trim(Str(ABD.rc.Bottom)) - Trim(Str(ABD.rc.Top))) * Screen.TwipsPerPixelX
    If Trim(Str(ABD.rc.Left)) > 0 Then gPanel = (Trim(Str(ABD.rc.Right)) - Trim(Str(ABD.rc.Left))) * Screen.TwipsPerPixelX
    
    Me.Left = Screen.Width - Me.Width - gPanel
    Me.Top = Screen.Height - Me.Height - hPanel
End Sub
 
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call ReleaseCapture
    Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Timer1_Timer()
    Dim hDC As OLE_HANDLE
    Dim tPT As POINTAPI
    Dim mouseX As Long
    Dim mouseY As Long
    Dim lN As Long
    
    If Stopped = False Then
        GetCursorPos tPT
        
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Label1.Caption = tPT.x & " x " & tPT.y
            hDC = GetDC(0)
            
            If hDC Then
                If (tPT.x - 8) >= 0 Then
                    If tPT.x >= ScreenX - 8 Then
                        Me.Cls
                        mouseX = ScreenX - 8
                    Else
                        mouseX = tPT.x - 8
                    End If
                End If
                If (tPT.y - 8) >= 0 Then
                    If tPT.y > ScreenY - 8 Then
                        Me.Cls
                        mouseY = ScreenY - 8
                    Else
                        mouseY = tPT.y - 8
                    End If
                End If
                
                StretchBlt Me.hDC, 0, 0, 256, 256, hDC, mouseX, mouseY, 16, 16, vbSrcCopy
                
                ReleaseDC 0, hDC
                Me.Refresh
            End If
        End If
    End If
End Sub
 
Private Sub Timer2_Timer()
    Dim tPT As POINTAPI
    Dim lN  As Long
    
    GetCursorPos tPT
    
    If GetAsyncKeyState(17) And GetAsyncKeyState(91) Or GetAsyncKeyState(17) And GetAsyncKeyState(92) Then
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Timer3.Enabled = True
            Timer2.Enabled = False
            
            Stopped = Not (Stopped)
            Timer1.Enabled = Not (Timer1.Enabled)
            
            If Stopped = True Then
                MouseXY = tPT
                Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
                
                For lN = 0 To 15
                    Me.Line (0, lN * 16)-Step(256, 0), vbBlack
                    Me.Line (lN * 16, 0)-Step(0, 256), vbBlack
                Next
                
                Me.Line (255, 0)-(255, 255), vbBlack
                Me.Line (0, 255)-(256, 255), vbBlack
            End If
            
            Exit Sub
        End If
    End If
    
    If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
        If Stopped = True Then
            Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
        End If
    End If
End Sub
 
Private Sub Timer3_Timer()
    Timer3.Enabled = False
    Timer2.Enabled = True
End Sub

Option Explicit
Private Declare Function GetCursorInfo Lib "user32" (ByRef pci As CURSORINFO) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private Declare Function GetObjectW Lib "gdi32" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Private Type CURSORINFO
    cbSize          As Long
    Flags           As Long
    hCursor         As Long
    ptPosX          As Long
    ptPosY          As Long
End Type
 
Private Type ICONINFO
    fIcon           As Long
    xHotspot        As Long
    yHotspot        As Long
    hbmMask         As Long
    hbmColor        As Long
End Type
 
Private Type BITMAP
    bmType          As Long
    bmWidth         As Long
    bmHeight        As Long
    bmWidthBytes    As Long
    bmPlanes        As Integer
    bmBitsPixel     As Integer
    bmBits          As Long
End Type
 
Public Sub GetMouseCursorHeight(SizeHeight As Integer, HotY As Integer)
    Dim tCurInfo As CURSORINFO
    
    ' If there is no mouse cursor, these should be 0
    SizeHeight = 0
    HotY = 0
    
    tCurInfo.cbSize = Len(tCurInfo)
    GetCursorInfo tCurInfo
    
    If tCurInfo.Flags = 1 And CBool(tCurInfo.hCursor) Then
        ' In case we can't figure out the dimensions, this is a best guess
        SizeHeight = 19
        
        Dim tICONINFO As ICONINFO
        
        If GetIconInfo(tCurInfo.hCursor, tICONINFO) Then
            Dim bm As BITMAP
            
            If GetObjectW(tICONINFO.hbmMask, Len(bm), bm) <> 0 Then
                ' Extract the bitmap bits
                Dim max As Long
                Dim curMask() As Byte
                
                max = bm.bmWidth * bm.bmHeight / 8
                ReDim curMask(max * 2 - 1) ' Enough space for the mask and the xor mask
                
                ' bm.bmWidthBytes = UBound(curMask)
                If GetBitmapBits(tICONINFO.hbmMask, UBound(curMask), curMask(0)) <> 0 Then
                    Dim hasXORMask As Byte
                    Dim Empt As Boolean
                    Dim bottom As Long
                    
                    If tICONINFO.hbmColor Then
                    
                    Else
                        ' if no color bitmap, then the hbmMask is a double height bitmap
                        ' with the cursor and the mask stacked.
                        hasXORMask = 1
                        max = max / 2
                    End If
                    
                    ' Go through the bitmap looking for the bottom of the image and/or mask
                    Empt = True
                    bottom = max
                    bottom = bottom - 1
                    
                    Do While bottom >= 0
                        If curMask(bottom) <> &HFF Or (hasXORMask And (curMask(bottom + max) <> 0)) Then
                            Empt = False
                            Exit Do
                        End If
                        
                        bottom = bottom - 1
                    Loop
                    
                    If Empt = False Then
                        ' Go through the bitmap looking for the top of the image and/or mask
                        Dim top As Long
                        Dim byteWidth As Long
                        
                        For top = 0 To max - 1
                            If curMask(top) <> &HFF Or (hasXORMask And (curMask(top + max) <> 0)) Then Exit For
                        Next
                        
                        ' byteWidth = bytes per row AND bytes per vertical pixel
                        byteWidth = bm.bmWidth / 8
                        bottom = bottom / byteWidth
                        top = top / byteWidth
                        
                        SizeHeight = bottom - top + 1
                        HotY = tICONINFO.yHotspot - top
                    Else
                        ' (Final value) We didn't find anything in the bitmap.
                        ' So, we'll make a guess with the information that we have.
                        ' Note: This seems to happen on I-Beams and Cross-hairs -- cursors that
                        ' are all inverted. Strangely, their hbmColor is non-null.
                        SizeHeight = bm.bmHeight
                        HotY = tICONINFO.yHotspot
                    End If
                End If
                
                DeleteObject tICONINFO.hbmMask
            End If
        End If
    End If
End Sub

Option Explicit
'////////////////////////////////////////////
'// Модуль создания уникодного InputBox'а  //
'// Copyright (c) 15.11.2023 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.0                             //
'////////////////////////////////////////////
 
Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Const EVENT_OBJECT_SHOW As Long = &H8002&
Private Const WM_COMMAND = &H111
Private Const IDOK = 1
Private Const WM_GETTEXT As Long = &HD
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_SETTEXT = &HC
Private Const EM_SETSEL = &HB1
 
Dim hEvent As Long
Dim HandleDialogWindow As Long
Dim HandleEdit As Long
Dim Subclassed As Long
Dim InputText As String
Dim TitleCaption As String
Dim DialogPrompt As String
Dim TextDefault As String
Dim once As Boolean
 
Public Function InputBoxW(ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String) As String
    InputText = vbNullString
    HandleDialogWindow = 0
    Subclassed = 0
    HandleEdit = 0
    hEvent = 0
    once = False
    
    DialogPrompt = strPrompt
    TitleCaption = strTitle
    TextDefault = strDefault
    
    hEvent = SetWinEventHook(EVENT_OBJECT_SHOW, EVENT_OBJECT_SHOW, 0, AddressOf WinEventProc, 0, App.ThreadID, 0) ' Устанавливаем хук на создание окон в системе
    InputBox strPrompt, vbNullString ' Вызвать классический InputBox
    
    RemoveWindowSubclass Subclassed, AddressOf WndProc, 0 ' Снять субклассирование
    If hEvent > 0 Then UnhookWinEvent hEvent
    
    InputBoxW = InputText
End Function
 
' Функция вызывается при создании окна
Private Sub WinEventProc(ByVal hWinEventHook As Long, ByVal dwEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
    Dim cls As String
    Dim sLn As Long
    Dim hwndStatic As Long
    
    cls = Space(256)
    
    ' Получаем имя класса окна
    sLn = GetClassName(hwnd, StrPtr(cls), Len(cls))
    
    If sLn Then
        cls = Left(cls, sLn)
        
        If StrComp(cls, "Edit", vbTextCompare) = 0 Then
            HandleEdit = hwnd ' Запомнить hwnd текстового поля
        End If
        
        If cls = "#32770" Then ' Если класс этого окна это диалоговое окно
            HandleDialogWindow = hwnd ' Запомнить hwnd диалогового окна
            
            If once = False Then ' На всякий случай, чтобы код выполнялся только один раз
                hwndStatic = FindWindowEx(hwnd, ByVal 0&, "Static", vbNullString) ' Найти Static
                If Len(TitleCaption) = 0 Then TitleCaption = App.Title
                
                ' Установить заголовок окна с поддержкой уникода (SendMessage не работает в этом случае)
                DefWindowProcW hwnd, WM_SETTEXT, 0, StrPtr(TitleCaption)
                
                ' Установить заголовок окна с поддержкой уникода (а вот здесь SendMessage уже работает почему-то)
                SendMessage hwndStatic, WM_SETTEXT, 0, StrPtr(DialogPrompt)
                
                If Len(TextDefault) > 0 Then
                    SendMessage HandleEdit, WM_SETTEXT, 0, StrPtr(TextDefault) ' Установить текст по умолчанию в текстовом поле
                    SendMessage HandleEdit, EM_SETSEL, 0, -1 ' Выделить всё в текстовом поле
                End If
                
                once = True
            End If
            
            If HandleEdit > 0 And HandleDialogWindow > 0 Then
                ' Снять хук, если мы получили оба значения и HandleDialogWindow и HandleEdit
                If hEvent > 0 Then ' Только единожды
                    UnhookWinEvent hEvent
                    hEvent = 0
                End If
            End If
            
            If Subclassed = 0 Then
                Subclassed = SetWindowSubclass(HandleDialogWindow, AddressOf WndProc, 0&)
            End If
        End If
    End If
End Sub
 
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Dim bProcessed As Boolean
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_COMMAND
            If wParam = IDOK Then ' Событие которое обрабатывается при нажатии ОК
                InputText = Space$(256)
                TextLen = SendMessage(HandleEdit, WM_GETTEXTLENGTH, 0, 0)
                SendMessage HandleEdit, WM_GETTEXT, TextLen + 1, StrPtr(InputText)
                InputText = Left$(InputText, TextLen)
            End If
    End Select
    
    If Not bProcessed Then
        WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    End If
End Function

Option Explicit
'////////////////////////////////////////////
'// Модуль создания уникодного InputBox'а  //
'// Copyright (c) 16.11.2023 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.1                             //
'////////////////////////////////////////////
 
Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Const EVENT_OBJECT_CREATE As Long = &H8000&
Private Const WM_COMMAND = &H111
Private Const IDOK = 1
Private Const WM_GETTEXT As Long = &HD
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_SETTEXT = &HC
Private Const EM_SETSEL = &HB1
Private Const WM_SHOWWINDOW As Long = &H18
 
Dim hEvent As Long
Dim HandleDialogWindow As Long
Dim HandleStatic As Long
Dim HandleEdit As Long
Dim Subclassed As Long
Dim InputText As String
Dim TitleCaption As String
Dim DialogPrompt As String
Dim TextDefault As String
 
Public Function InputBoxW(ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String) As String
    InputText = vbNullString
    HandleDialogWindow = 0
    HandleStatic = 0
    Subclassed = 0
    HandleEdit = 0
    hEvent = 0
    
    DialogPrompt = strPrompt
    TitleCaption = strTitle
    TextDefault = strDefault
    
    hEvent = SetWinEventHook(EVENT_OBJECT_CREATE, EVENT_OBJECT_CREATE, 0, AddressOf WinEventProc, 0, App.ThreadID, 0) ' Устанавливаем хук на создание окон в системе
    InputBox strPrompt, vbNullString ' Вызвать классический InputBox
    
    RemoveWindowSubclass Subclassed, AddressOf WndProc, 0 ' Снять субклассирование
    If hEvent > 0 Then UnhookWinEvent hEvent
    
    InputBoxW = InputText
End Function
 
' Функция вызывается при создании окна
Private Sub WinEventProc(ByVal hWinEventHook As Long, ByVal dwEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
    Dim cls As String
    Dim sLn As Long
    
    cls = Space(256)
    
    ' Получаем имя класса окна
    sLn = GetClassName(hwnd, StrPtr(cls), Len(cls))
    
    If sLn Then
        cls = Left(cls, sLn)
        
        If HandleDialogWindow = 0 Then
            If cls = "#32770" Then ' Если класс это диалоговое окно
                HandleDialogWindow = hwnd ' Запомнить hwnd диалогового окна
                
                If Subclassed = 0 Then
                    Subclassed = SetWindowSubclass(HandleDialogWindow, AddressOf WndProc, 0&)
                End If
            End If
        End If
        
        If HandleStatic = 0 Then
            If StrComp(cls, "Static", vbTextCompare) = 0 Then
                HandleStatic = hwnd
            End If
        End If
        
        If HandleEdit = 0 Then
            If StrComp(cls, "Edit", vbTextCompare) = 0 Then
                HandleEdit = hwnd ' Запомнить hwnd текстового поля
            End If
        End If
        
        If HandleDialogWindow > 0 And HandleStatic > 0 And HandleEdit > 0 Then
            If hEvent > 0 Then ' Только единожды
                UnhookWinEvent hEvent ' Снять хук
                hEvent = 0
            End If
        End If
    End If
End Sub
 
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Dim bProcessed As Boolean
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_SHOWWINDOW
            If Len(TitleCaption) = 0 Then TitleCaption = App.Title
            SetWindowText HandleDialogWindow, StrPtr(TitleCaption)
            
            SendMessage HandleStatic, WM_SETTEXT, 0, StrPtr(DialogPrompt)
            
            If Len(TextDefault) > 0 Then
                SendMessage HandleEdit, WM_SETTEXT, 0, StrPtr(TextDefault) ' Установить текст по умолчанию в текстовом поле
                SendMessage HandleEdit, EM_SETSEL, 0, -1 ' Выделить всё в текстовом поле
            End If
        
        Case WM_COMMAND
            If wParam = IDOK Then ' Событие которое обрабатывается при нажатии ОК
                InputText = Space$(256)
                TextLen = SendMessage(HandleEdit, WM_GETTEXTLENGTH, 0, 0)
                SendMessage HandleEdit, WM_GETTEXT, TextLen + 1, StrPtr(InputText)
                InputText = Left$(InputText, TextLen)
            End If
    End Select
    
    If Not bProcessed Then
        WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    End If
End Function

' ***  Модифицированная функция BrowseForFolder. Получает на вход следующие аргументы:
' ***
' ***  hWnd_Owner        - hWnd вызывающего объекта
' ***  sPrompt           - текст подсказки
' ***  InitDir           - начальная папка обзора (если не задана, то "Мой компьютер")
' ***  ChangeSize        - увеличивать ли размер диалога; если "да", то надо указать RatioX и RatioY
' ***  RatioX            - во сколько раз увеличивать ширину диалога (принимается во внимание, если ChangeSize = True)
' ***  RatioY            - во сколько раз увеличивать высоту диалога (принимается во внимание, если ChangeSize = True)
' ***  CenterOnScreen    - центрировать ли диалог на экране
' ***  ShowEditBox       - показывать ли адресную строку
' ***  ShowNewFoldButton - показывать ли кнопку создания новой папки
' ***  OnlyDisks         - показывать только диски моего компьютера
' ***  fileMasks         - файловые маски, разделённые символом ";" (*.doc; *.txt и т.п.)
' ***                      если эта строка задана, то папку можно выбрать только если она
' ***                      содержит файлы, удовлетворяющие заданным маскам)
' ***  DialogTitle       - пользовательский заголовок диалога
' ***  TopMost           - если = True, то диалог будет поверх всех открытых окон
' ***  SetFocusTreeView  - если = True, то фокус по умолчанию переходит на дерево каталогов
Public Function BrowseForFolder(ByVal hWnd_Owner As Long, ByVal sPrompt As String, Optional ByVal InitDir As String, Optional ByVal ChangeSize As Boolean, Optional ByVal RatioX As Double = 1, Optional ByVal RatioY As Double = 1, Optional ByVal CenterOnScreen As Boolean, Optional ByVal ShowEditBox As Boolean, Optional ByVal ShowNewFoldButton As Boolean, Optional ByVal OnlyDisks As Boolean, Optional ByRef fileMasks As String, Optional ByVal DialogTitle As String, Optional ByVal TopMost As Boolean, Optional ByVal SetFocusTreeView As Boolean) As String
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BROWSEINFO
    Dim WhatBr As Long
    Dim lItemIDList As ItemIDList
    
    bff_DialogTitle = DialogTitle
    bff_ChangeSize = ChangeSize
    bff_RatioX = RatioX
    bff_RatioY = RatioY
    bff_CenterOnScreen = CenterOnScreen
    bff_TopMost = TopMost
    bff_NewBoy = False
    
    If ShowEditBox = True Then
        WhatBr = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT Or BIF_EDITBOX Or BIF_VALIDATE
    Else
        WhatBr = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT Or BIF_VALIDATE
    End If
    
    bff_CreatedDirictory = ""
    bff_ShowNewFoldButton = ShowNewFoldButton
    bff_ShowEditTextBox = ShowEditBox
    bff_SetFocusTreeView = SetFocusTreeView
    
RestartDialog:
    bff_hwndSysTreeView32 = 0
    bff_WidthStatic = 0
    bff_HwndStatic = 0
    bff_Subclassed = 0
    
    If Len(InitDir) > 0 Then
        bff_CurrentDirectory = InitDir & vbNullChar
    Else
        bff_CurrentDirectory = vbNullString
    End If
    
    If Len(fileMasks) > 0 Then
        bff_FileMasks = Split(fileMasks, ";")
    Else
        ReDim bff_FileMasks(0 To 0)
        bff_FileMasks(0) = vbNullString
    End If
    
    With udtBI
        If OnlyDisks = True Then
            SHGetSpecialFolderLocation hWnd_Owner, CSIDL_DRIVES, lItemIDList
            .pidlRoot = lItemIDList.mkid.cb
        End If
        
        .hwndOwner = hWnd_Owner
        .lpszTitle = sPrompt
        .ulFlags = WhatBr
        .lpfnCallback = FarProc(AddressOf BrowseCallbackProc)
    End With
    
    lpIDList = SHBrowseForFolder(VarPtr(udtBI))
    
    If lpIDList Then
        sPath = Space$(MAX_PATH)
        lResult = SHGetPathFromIDList(lpIDList, StrPtr(sPath))
        
        CoTaskMemFree lpIDList
    End If
    
    If bff_Subclassed Then
        RemoveWindowSubclass bff_hwndDialog, AddressOf WndProc, 0
    End If
    
    If bff_NewBoy = True Then
        GoTo RestartDialog
    End If
    
    BrowseForFolder = APIStrToVBStr(sPath)
End Function

Option Explicit
'/////////////////////////////////////////////
'// Модуль для вызова юникодного InputBox'а //
'// Copyright (c) 19.11.2023 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 2.0                              //
'/////////////////////////////////////////////
 
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamW" (ByVal hInstance As Long, ByVal lpTemplate As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function EndDialog Lib "user32" (ByVal hDlg As Long, ByVal nResult As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long) As Long
Private Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long, ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MONITORINFO) As Long
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal dwFlags As Long) As Long
 
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const ID_EDIT = 4900
Private Const ID_STATIC = 4901
Private Const ID_HELP = 4902
Private Const WM_COMMAND = &H111
Private Const WM_INITDIALOG = &H110
Private Const SW_HIDE = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const MONITOR_DEFAULTTONEAREST = &H2
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL = &HB1
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type
 
Dim InputText As String
Dim TitleText As String
Dim DefaultText As String
Dim CenterOnWorkspace As Boolean ' Аналог DS_CENTER
 
' Вызвать InputBox из msvbvm60.dll с поддеркой юникода
Public Function InputBoxW(ByVal hParent As Long, ByVal strPrompt As String, Optional ByVal strTitle As String, Optional CenterOnMonitorWorkspace As Boolean, Optional ByVal strDefault As String) As String
    Dim msvbvm60 As Long
    
    msvbvm60 = LoadLibrary(StrPtr("msvbvm60.dll"))
    
    If msvbvm60 <> 0 Then
        TitleText = strTitle
        DefaultText = strDefault
        CenterOnWorkspace = CenterOnMonitorWorkspace
        DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt) ' Тот самый заветный код, который вызывает InputBox
    End If
    
    InputBoxW = InputText
    InputText = vbNullString
    TitleText = vbNullString
    DefaultText = vbNullString
End Function
 
' Функция обработки сообщений диалогового окна
Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim NotidyCode As Long
    Dim ItemID As Long
    Dim rct As RECT
    Dim hMonitor As Long
    Dim MI As MONITORINFO
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_INITDIALOG
            If Len(TitleText) = 0 Then TitleText = App.Title
            SetWindowText hwndDlg, StrPtr(TitleText)
            
            ShowWindow GetDlgItem(hwndDlg, ID_HELP), SW_HIDE
            SetDlgItemText hwndDlg, ID_STATIC, lParam
            
            ' Определяем размеры окна
            GetWindowRect hwndDlg, rct
            
            If CenterOnWorkspace = False Then ' Стандартная центровка
                SetWindowPos hwndDlg, 0, ((Screen.Width / Screen.TwipsPerPixelX) - (rct.Right - rct.Left)) / 2, (((Screen.Height / Screen.TwipsPerPixelY) - (rct.Bottom - rct.Top)) / 2) - (rct.Bottom - rct.Top), 0, 0, SWP_NOSIZE Or SWP_NOZORDER
            Else ' Центровка по рабочей области экрана (аналог стиля DS_CENTER)
                hMonitor = MonitorFromWindow(hwndDlg, MONITOR_DEFAULTTONEAREST)
                MI.cbSize = LenB(MI)
                
                If GetMonitorInfo(hMonitor, MI) <> 0 Then
                    SetWindowPos hwndDlg, 0, ((MI.rcWork.Right - MI.rcWork.Left) - (rct.Right - rct.Left)) / 2, ((MI.rcWork.Bottom - MI.rcWork.Top) - (rct.Bottom - rct.Top)) / 2, 0, 0, SWP_NOSIZE Or SWP_NOZORDER
                End If
            End If
            
            If Len(DefaultText) > 0 Then
                SetDlgItemText hwndDlg, ID_EDIT, StrPtr(DefaultText)
                SendDlgItemMessage hwndDlg, ID_EDIT, EM_SETSEL, 0, -1
            End If
            
            DlgProc = 1
            Exit Function
        
        Case WM_COMMAND
            NotidyCode = wParam \ 65536
            ItemID = wParam And 65535
            
            If ItemID = IDOK Then
                TextLen = SendDlgItemMessage(hwndDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0)
                InputText = Space$(TextLen)
                GetDlgItemText hwndDlg, ID_EDIT, StrPtr(InputText), TextLen + 1
                
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
            
            If ItemID = IDCANCEL Then
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
    End Select
    
    DlgProc = 0
End Function

Option Explicit
Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_SETTEXT = &HC
 
Private Sub Command1_Click()
    Dim str As String
    
    str = InputBoxW(0, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), True, "Это китайский символ дружбы - " & ChrW(-29686))
    
    If Len(str) > 0 Then
        DefWindowProcW Me.hwnd, WM_SETTEXT, 0, ByVal StrPtr(Chr(34) & str & Chr(34))
    Else
        Me.Caption = "Canceled."
    End If
End Sub
 
Private Sub Command2_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(-29686) & "):")
    
    If Len(str) > 0 Then
        DefWindowProcW Me.hwnd, WM_SETTEXT, 0, ByVal StrPtr(Chr(34) & str & Chr(34))
    Else
        Me.Caption = "Canceled."
    End If
End Sub
 
Private Sub Command3_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), True, "Это китайский символ дружбы - " & ChrW(-29686))
    
    If Len(str) > 0 Then
        DefWindowProcW Me.hwnd, WM_SETTEXT, 0, ByVal StrPtr(Chr(34) & str & Chr(34))
    Else
        Me.Caption = "Canceled."
    End If
End Sub
 
Private Sub Command4_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), False, "Это китайский символ дружбы - " & ChrW(-29686))
    
    If Len(str) > 0 Then
        DefWindowProcW Me.hwnd, WM_SETTEXT, 0, ByVal StrPtr(Chr(34) & str & Chr(34))
    Else
        Me.Caption = "Canceled."
    End If
End Sub

Option Explicit
'/////////////////////////////////////////////
'// Модуль для вызова юникодного InputBox'а //
'// Copyright (c) 01.02.2024 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 2.5                              //
'/////////////////////////////////////////////
 
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamW" (ByVal hInstance As Long, ByVal lpTemplate As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function EndDialog Lib "user32" (ByVal hDlg As Long, ByVal nResult As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long) As Long
Private Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long, ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpW" (ByVal hwnd As Long, ByVal lpHelpFile As Long, ByVal wCommand As Long, ByVal dwData As Long) As Long
Private Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpW" (ByVal hwndCaller As Long, ByVal pszFile As Long, ByVal uCommand As Long, ByVal dwData As Long) As Long
 
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const ID_EDIT = 4900
Private Const ID_STATIC = 4901
Private Const ID_HELP = 4902
Private Const WM_COMMAND = &H111
Private Const WM_INITDIALOG = &H110
Private Const WM_HELP = &H53
Private Const WM_DESTROY = &H2
 
Private Const SW_HIDE = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL = &HB1
Private Const SPI_GETWORKAREA = 48
Private Const HH_DISPLAY_TOPIC = &H0
Private Const HH_HELP_CONTEXT = &HF
Private Const HELP_CONTEXT = &H1
Private Const HELP_INDEX = &H3
Private Const HELP_QUIT = &H2
 
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
 
Dim sInputText As String
Dim sTitleText As String
Dim sDefaultText As String
Dim CenterOnWorkspace As Boolean ' Аналог DS_CENTER
Dim iXPos As Integer
Dim iYPos As Integer
Dim sHelpFile As String
Dim lContext As Long
Dim IsWinHelpRunning As Boolean
 
' Вызвать InputBox из msvbvm60.dll с поддеркой юникода
Public Function InputBoxW(ByVal hParent As Long, ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String, Optional intXPos As Integer, Optional intYPos As Integer, Optional strHelpFile As String, Optional intContext As Long, Optional CenterOnMonitorWorkspace As Boolean) As String
    Dim msvbvm60 As Long
    
    msvbvm60 = LoadLibrary(StrPtr("msvbvm60.dll"))
    
    If msvbvm60 <> 0 Then
        sTitleText = strTitle
        sDefaultText = strDefault
        CenterOnWorkspace = CenterOnMonitorWorkspace
        iXPos = intXPos
        iYPos = intYPos
        sHelpFile = strHelpFile
        lContext = intContext
        IsWinHelpRunning = False
        
        DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt) ' Тот самый заветный код, который вызывает InputBox
    End If
    
    InputBoxW = sInputText
    sInputText = vbNullString
    sTitleText = vbNullString
    sDefaultText = vbNullString
    sHelpFile = vbNullString
End Function
 
' Функция обработки сообщений диалогового окна
Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim NotifyCode As Long
    Dim ItemID As Long
    Dim wndRect As RECT
    Dim rcWork As RECT
    Dim TextLen As Long
    Dim lLeft As Long
    Dim lTop As Long
    
    Select Case uMsg
        Case WM_INITDIALOG
            If Len(sTitleText) = 0 Then sTitleText = App.Title
            SetWindowText hwndDlg, StrPtr(sTitleText)
            
            If Len(sHelpFile) = 0 Then
                ShowWindow GetDlgItem(hwndDlg, ID_HELP), SW_HIDE
            End If
            
            SetDlgItemText hwndDlg, ID_STATIC, lParam
            
            ' Определяем размеры окна
            GetWindowRect hwndDlg, wndRect
            
            ' Определяем размеры рабочей области экрана
            SystemParametersInfo SPI_GETWORKAREA, 0, rcWork, 0
            
            If CenterOnWorkspace = False Then ' Стандартная центровка
                If (iXPos Or iYPos) = 0 Then
                    ' Абсолютно идеальный код выравнивания диалогового окна, в точности так же, как это делает оригинальный InputBox
                    lLeft = rcWork.iLeft + (rcWork.iRight - rcWork.iLeft - (wndRect.iRight - wndRect.iLeft)) \ 2
                    lTop = rcWork.iTop + (rcWork.iBottom - rcWork.iTop - (wndRect.iBottom - wndRect.iTop)) \ 3
                Else
                    lLeft = iXPos
                    lTop = iYPos
                End If
            Else ' Центровка по рабочей области экрана (аналог стиля DS_CENTER)
                lLeft = ((rcWork.iRight - rcWork.iLeft) - (wndRect.iRight - wndRect.iLeft)) / 2
                lTop = ((rcWork.iBottom - rcWork.iTop) - (wndRect.iBottom - wndRect.iTop)) / 2
            End If
            
            SetWindowPos hwndDlg, 0, lLeft, lTop, 0, 0, SWP_NOSIZE Or SWP_NOZORDER ' Выравнивание диалогового окна
            
            If Len(sDefaultText) > 0 Then
                SetDlgItemText hwndDlg, ID_EDIT, StrPtr(sDefaultText)
                SendDlgItemMessage hwndDlg, ID_EDIT, EM_SETSEL, 0, -1
            End If
            
            DlgProc = 1
            Exit Function
        
        Case WM_COMMAND
            NotifyCode = wParam \ 65536
            ItemID = wParam And 65535
            
            If ItemID = IDOK Then
                TextLen = SendDlgItemMessage(hwndDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0)
                sInputText = Space$(TextLen)
                GetDlgItemText hwndDlg, ID_EDIT, StrPtr(sInputText), TextLen + 1
                
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
            
            If ItemID = IDCANCEL Then
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
            
            If ItemID = ID_HELP Then
                RunHelp hwndDlg
                DlgProc = 1
                Exit Function
            End If
        
        Case WM_HELP
            RunHelp hwndDlg
            DlgProc = 1
            Exit Function
        
        Case WM_DESTROY
            If IsWinHelpRunning = True Then
                WinHelp hwndDlg, 0, HELP_QUIT, 0 ' Закрыть окно HLP справки
            End If
            
            DlgProc = 1
            Exit Function
    End Select
    
    DlgProc = 0
End Function
 
Private Sub RunHelp(ByVal hwnd As Long)
    If Len(sHelpFile) > 0 Then
        If Right$(sHelpFile, 4) = ".hlp" Then
            If lContext = 0 Then
                WinHelp hwnd, StrPtr(sHelpFile), HELP_INDEX, 0
            Else
                WinHelp hwnd, StrPtr(sHelpFile), HELP_CONTEXT, lContext
            End If
            IsWinHelpRunning = True
        Else ' CHM
            If lContext = 0 Then
                HtmlHelp hwnd, StrPtr(sHelpFile), HH_DISPLAY_TOPIC, 0
            Else
                HtmlHelp hwnd, StrPtr(sHelpFile), HH_HELP_CONTEXT, lContext
            End If
        End If
    End If
End Sub

Dim FdM()  As Single  'сила натяжения, делённая на массу
Dim P()    As Single  'позиция
Dim S()    As Single  'скорость

  For i = 1 To stLen - 1
    d = (P(i - 1) + P(i + 1)) * 0.5 - P(i)
    S(i) = S(i) + d * FdM(i)
  Next i

  For i = 1 To stLen - 1
    P(i) = P(i) + S(i)
  Next i

  For i = 1 To stLen - 1
    S(i) = S(i) * k1 + (S(i - 1) + S(i + 1)) * k2
  Next i

Option Explicit
'/////////////////////////////////////////////
'// Модуль для вызова диалога выбора файлов //
'// Copyright (c) 29.04.2024 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 1.0                              //
'/////////////////////////////////////////////
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (ByVal pOpenfilename As Long) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameW" (ByVal pOpenfilename As Long) As Long
 
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER = &H80000
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_SHAREAWARE = &H4000
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Public Enum OpenFileEnum
    OFEOpenForLoad = 1
    OFEOpenForSave = 2
End Enum
 
' Диалог выбора файлов (открыть или сохранить)
Public Function MyGetFileName(OpenMode As OpenFileEnum, DirStr As String, FileNameStr() As String, FilterMass() As String, Optional FileExt As String = "", Optional hwndOwnerArg As Long = 0, Optional ByVal DialogTitle As String) As Boolean
    Dim pOpenfilename As OPENFILENAME
    Dim N As Integer
    Dim i As Integer
    Dim x As Long
    Dim St1 As String
    Dim St2 As String
    Dim St3 As String
    
    pOpenfilename.lStructSize = Len(pOpenfilename)
    pOpenfilename.hwndOwner = hwndOwnerArg
    
    If Len(DialogTitle) > 0 Then
        pOpenfilename.lpstrTitle = DialogTitle
    End If
    
    If UBound(FilterMass, 1) = 1 Then
        N = UBound(FilterMass, 2)
        
        If N >= 0 Then
            For i = 0 To N
                If Len(FilterMass(1, i)) > 1 Then
                    If Len(FilterMass(0, i)) > 1 Then
                        St1 = St1 & (FilterMass(0, i) + vbNullChar)
                    Else
                        St1 = St1 & ("Разные файлы" + vbNullChar)
                    End If
                    
                    St1 = St1 & (FilterMass(1, i) + vbNullChar)
                End If
            Next
            
            St1 = St1 & vbNullChar & vbNullChar
        Else
            St1 = "Все файлы" & vbNullChar & "*.*" & vbNullChar & vbNullChar
        End If
    End If
    
    If FileExt <> "" Then
        pOpenfilename.lpstrDefExt = FileExt
    End If
    
    pOpenfilename.lpstrInitialDir = DirStr
    pOpenfilename.lpstrFilter = St1
    pOpenfilename.lpstrFile = LPBuff(512)
    pOpenfilename.nMaxFile = 511
    pOpenfilename.lpstrFileTitle = LPBuff(512)
    pOpenfilename.nMaxFileTitle = 511
    pOpenfilename.flags = OFN_SHAREAWARE Or OFN_LONGNAMES Or OFN_NODEREFERENCELINKS Or OFN_EXPLORER
    
    If OpenMode = OFEOpenForLoad Then
        pOpenfilename.flags = pOpenfilename.flags Or OFN_ALLOWMULTISELECT
        x = GetOpenFileName(VarPtr(pOpenfilename))
    Else
        pOpenfilename.flags = pOpenfilename.flags Or OFN_OVERWRITEPROMPT
        x = GetSaveFileName(VarPtr(pOpenfilename))
    End If
    
    If x = 1 Then
        MyGetFileName = True
        St1 = LP2VB2(pOpenfilename.lpstrFile)
        DirStr = Left(St1, pOpenfilename.nFileOffset - 1)
        N = -1
        St2 = St1
        
        Do
            St3 = MyGetLpStr(St2)
            N = N + 1
        Loop Until St2 = ""
        
        If N >= 1 Then
            ReDim FileNameStr(N - 1)
            St2 = St1
            St3 = MyGetLpStr(St2)
            
            For i = 1 To N
                FileNameStr(i - 1) = MyGetLpStr(St2)
            Next
        Else
            ReDim FileNameStr(0)
            FileNameStr(0) = Right$(St1, Len(St1) - pOpenfilename.nFileOffset)
        End If
    Else
        MyGetFileName = False
        DirStr = ""
        ReDim FileNameStr(0)
        FileNameStr(0) = ""
        '  ResErr = CommDlgExtendedError
        '  Debug.Print ResErr
    End If
End Function
 
Private Function LPBuff(N As Integer) As String
    LPBuff = String(N, vbNullChar)
End Function
 
Private Function LP2VB2(St1) As String
    LP2VB2 = Left$(St1, InStr(1, St1, vbNullChar & vbNullChar) - 1)
End Function
 
Private Function MyGetLpStr(St1 As String) As String
Dim i As Variant
i = InStr(1, St1, vbNullChar)
If IsNull(i) Then
  MyGetLpStr = ""
  St1 = ""
  Exit Function
ElseIf i = 0 Then
  MyGetLpStr = St1
  St1 = ""
  Exit Function
Else
  MyGetLpStr = Left$(St1, i - 1)
  St1 = Right$(St1, Len(St1) - i)
  Exit Function
End If
End Function

Option Explicit
'/////////////////////////////////////////////
'// Модуль для вызова диалога выбора файлов //
'// Copyright (c) 02.05.2024 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 2.0                              //
'/////////////////////////////////////////////
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (ByVal pOpenfilename As Long) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameW" (ByVal pOpenfilename As Long) As Long
 
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER = &H80000
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_SHAREAWARE = &H4000
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Public Enum OpenFileEnum
    OFEOpenForLoad = 1
    OFEOpenForSave = 2
End Enum
 
' Функция диалога выбора файлов (открыть или сохранить) возвращает путь ВСЕГДА без косой черты на конце
' Массив arrFiles является необязательным параметром и используется только при выборе множества файлов
Public Function GetDialogFileName(OpenMode As OpenFileEnum, ByVal strFilter As String, Optional ByVal hwndOwner As Long, Optional ByVal InitDir As String, Optional ByVal DialogTitle As String, Optional ByVal AllowMultiSelect As Boolean, Optional arrFiles As Variant) As String
    Dim ofn As OPENFILENAME
    Dim str As String
    Dim ret As Long
    Dim i As Long
    
    ofn.nMaxFile = 65535 ' Размер буфера, на который указывает lpstrFile, в символах. Буфер должен быть достаточно большим, чтобы хранить строку или строки пути и имени файла, включая завершающий символ NULL.
    ofn.hwndOwner = hwndOwner
    If Len(DialogTitle) > 0 Then ofn.lpstrTitle = DialogTitle
    ofn.lpstrFile = Space$(65535)
    ofn.lStructSize = LenB(ofn)
    ofn.lpstrFilter = strFilter
    If Len(InitDir) > 0 Then ofn.lpstrInitialDir = InitDir
    ofn.flags = OFN_SHAREAWARE Or OFN_LONGNAMES Or OFN_NODEREFERENCELINKS Or OFN_EXPLORER
    
    If OpenMode = OFEOpenForLoad Then
        If AllowMultiSelect = True Then ofn.flags = ofn.flags Or OFN_ALLOWMULTISELECT
        ret = GetOpenFileName(VarPtr(ofn))
    Else
        ofn.flags = ofn.flags Or OFN_OVERWRITEPROMPT
        ret = GetSaveFileName(VarPtr(ofn))
    End If
    
    If ret <> 0 Then
        If AllowMultiSelect = True And OpenMode = OFEOpenForLoad Then
            i = InStr(1, ofn.lpstrFile, vbNullChar & vbNullChar)
            If i Then ofn.lpstrFile = Left$(ofn.lpstrFile, i - 1)
            
            str = Left$(ofn.lpstrFile, ofn.nFileOffset - 1)
            
            ofn.lpstrFile = Right$(ofn.lpstrFile, Len(ofn.lpstrFile) - ofn.nFileOffset)
            arrFiles = Split(ofn.lpstrFile, vbNullChar)
            
            If Right$(str, 1) <> "\" Then
                GetDialogFileName = str
            Else
                GetDialogFileName = Left$(str, Len(str) - 1)
            End If
        Else
            i = InStr(1, ofn.lpstrFile, vbNullChar)
            If i Then GetDialogFileName = Left$(ofn.lpstrFile, i - 1)
        End If
    End If
End Function

Option Explicit
'/////////////////////////////////////////////
'// Модуль вывода текста на форме в юникоде //
'// Copyright (c) 14.05.2024 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 2.0                              //
'/////////////////////////////////////////////
 
' Декларации API...
Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As Long, ByVal lpsz As Long, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (arr() As Any) As Long
 
' Типы...
Private Type POINTAPI
   x As Long
   y As Long
End Type
 
Dim PlusY() As Long
Dim PlusHwnds() As Long
 
' Напечатать на форме текст
Public Function PrintW(PrintText As String, Optional PrintForm As Object) As Boolean
    Dim Frms As Form
    Dim hDC As Long
    Dim hwnd As Long
    Dim pt As POINTAPI
    Dim Redraw As Boolean
    Dim i As Long
    Dim Founded As Boolean
    Dim plus As Long
    
    If PrintForm Is Nothing Then
        For Each Frms In Forms
            hDC = Frms.hDC
            hwnd = Frms.hwnd
            Redraw = Frms.AutoRedraw
            Frms.AutoRedraw = True
            Exit For ' Выбирать всегда первую форму
        Next
    Else
        hDC = PrintForm.hDC
        hwnd = PrintForm.hwnd
        Redraw = PrintForm.AutoRedraw
        PrintForm.AutoRedraw = True
    End If
    
    GetTextExtentPoint32 hDC, StrPtr(PrintText), Len(PrintText), pt
    
    If SafeArrayGetDim(PlusY) > 0 Then ' Если наполнен массив
        For i = 0 To UBound(PlusHwnds)
            If PlusHwnds(i) = hwnd Then
                plus = PlusY(i)
                PlusY(i) = PlusY(i) + pt.y
                
                Founded = True
                Exit For
            End If
        Next
        
        If Founded = False Then
            ReDim Preserve PlusHwnds(UBound(PlusHwnds) + 1)
            ReDim Preserve PlusY(UBound(PlusY) + 1)
            
            PlusHwnds(UBound(PlusHwnds)) = hwnd
            PlusY(UBound(PlusY)) = pt.y
        End If
    Else
        ReDim Preserve PlusY(0)
        ReDim Preserve PlusHwnds(0)
        
        PlusY(0) = pt.y
        PlusHwnds(0) = hwnd
    End If
    
    TextOut hDC, 0, plus, StrPtr(PrintText), Len(PrintText)
    
    If PrintForm Is Nothing Then
        If Redraw = True Then Frms.Refresh
        Frms.AutoRedraw = Redraw
    Else
        If Redraw = True Then PrintForm.Refresh
        PrintForm.AutoRedraw = Redraw
    End If
    
    PrintW = True
End Function
 
' Очистить форму
Public Sub ClsW(Optional PrintForm As Object)
    Dim Frms As Form
    Dim hwnd As Long
    Dim i As Long
    
    If PrintForm Is Nothing Then
        For Each Frms In Forms
            Frms.Cls
            hwnd = Frms.hwnd
            Exit For ' Выбирать всегда первую форму
        Next
    Else
        PrintForm.Cls
        hwnd = PrintForm.hwnd
    End If
    
    If SafeArrayGetDim(PlusHwnds) > 0 Then ' Если наполнен массив
        For i = 0 To UBound(PlusHwnds)
            If PlusHwnds(i) = hwnd Then
                PlusY(i) = 0
                Exit For
            End If
        Next
    End If
End Sub

' Количество найденных символов (либо подстрок) в строке
Public Function CountSymbolFromString(ByVal str As String, ByVal SearchSymbol As String) As Long
    Dim FirstSearch As Long
    Dim SearchFromTheSymbol As Long
    Dim cnt As Long
    Dim LenSearchSymbol As Long
    
    LenSearchSymbol = Len(SearchSymbol)
    SearchFromTheSymbol = 1
    
    If Len(str) > 0 And Len(SearchSymbol) > 0 Then
        ' Очень быстрый поиск подстрок в строке
        Do
            FirstSearch = InStr(SearchFromTheSymbol, str, SearchSymbol) ' Искать нужную нам подстроку
            If FirstSearch > 0 Then
                cnt = cnt + 1
                SearchFromTheSymbol = FirstSearch + LenSearchSymbol
            End If
        Loop While FirstSearch > 0 ' Выполнять цикл до тех пор, пока будет найдена искомая подстрока
    End If
    
    CountSymbolFromString = cnt
End Function

Option Explicit
 
Private Enum PTR
    [_]
End Enum
 
Private Const PAGE_EXECUTE_READWRITE  As Long = &H40&
 
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As PTR) As PTR
Private Declare Function VirtualProtect Lib "kernel32" ( _
                         ByVal lpAddress As Long, _
                         ByVal dwSize As Long, _
                         ByVal flNewProtect As Long, _
                         ByRef lpflOldProtect As Long) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pDst As Any)
Private Declare Sub GetMemPtr Lib "msvbvm60" _
                    Alias "GetMem4" ( _
                    ByRef pAddr As Any, _
                    ByRef pDst As Any)
Private Declare Sub GetMem8 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pDst As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
                    Alias "PutMem4" ( _
                    ByRef pDst As Any, _
                    ByVal pVal As PTR)
Private Declare Sub PutMem2 Lib "msvbvm60" ( _
                    ByRef pDst As Any, _
                    ByVal iVal As Integer)
 
Private Function RemoveSystemError() As Boolean
    Dim hVB6    As PTR
    Dim pNTHdr  As PTR
    Dim pStart  As PTR
    Dim pEnd    As PTR
    Dim cSign   As Currency
    Dim lLength As Long
    Dim lProt   As Long
   
    hVB6 = GetModuleHandle(StrPtr("vba6.dll"))
    If hVB6 = 0 Then Exit Function
 
    GetMem4 ByVal hVB6 + &H3C, pNTHdr
    pNTHdr = pNTHdr + hVB6
   
    GetMem4 ByVal pNTHdr + &H104, pStart
    pStart = pStart + hVB6
   
    GetMem4 ByVal pNTHdr + &H100, lLength
    pEnd = pStart + lLength - 8
       
    Do While pStart <= pEnd
       
        GetMem8 ByVal pStart, cSign
       
        If cSign = -356375250902713.1008@ Then
 
            If VirtualProtect(pStart + &H10, 2, PAGE_EXECUTE_READWRITE, lProt) Then
           
                PutMem2 ByVal pStart + &H10, &H9090
                VirtualProtect pStart + &H10, 2, lProt, lProt
                RemoveSystemError = True
               
            End If
           
            Exit Do
           
        End If
       
        pStart = pStart + 1
       
    Loop
 
End Function

Option Explicit
'/////////////////////////////////////////////////
'// Модуль для изменения обоев на рабочем столе //
'// Copyright (c) 15.07.2024 by HackerVlad      //
'// e-mail: vladislavpeshkov@yandex.ru          //
'// Версия 3.5                                  //
'/////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function SystemParametersInfoW Lib "user32" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpszIID As Long, iid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32" (rclsid As Any, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As Any, ByVal ppv As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal addr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal dlen As Long)
Private Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsW" (ByVal pszPath As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const SPI_GETDESKWALLPAPER = 115
Private Const MAX_PATH As Long = 260
Private Const UPDATEINIFILE = &H1
Private Const CLSCTX_INPROC_SERVER  As Long = 1
Private Const CLSID_ActiveDesktop   As String = "{75048700-EF1F-11D0-9888-006097DEACF9}"
Private Const IID_ActiveDesktop     As String = "{F490EB00-1240-11D1-9888-006097DEACF9}"
 
Private Type GUID
    data1                   As Long
    data2                   As Integer
    data3                   As Integer
    data4(7)                As Byte
End Type
 
Private Type IActiveDesktop
    ' IUnknown
    QueryInterface          As Long
    AddRef                  As Long
    Release                 As Long
    ' IActiveDesktop
    ApplyChanges            As Long
    GetWallpaper            As Long
    SetWallpaper            As Long
    GetWallpaperOptions     As Long
    SetWallpaperOptions     As Long
    GetPattern              As Long
    SetPattern              As Long
    GetDesktopItemOptions   As Long
    SetDesktopItemOptions   As Long
    AddDesktopItem          As Long
    AddDesktopItemWithUI    As Long
    ModifyDesktopItem       As Long
    RemoveDesktopItem       As Long
    GetDesktopItemCount     As Long
    GetDesktopItem          As Long
    GetDesktopItemByID      As Long
    GenerateDesktopItemHtml As Long
    AddUrl                  As Long
    GetDesktopItemBySource  As Long
End Type
 
Private Enum AD_APPLY
    AD_APPLY_SAVE = &H1
    AD_APPLY_HTMLGEN = &H2
    AD_APPLY_REFRESH = &H4
    AD_APPLY_ALL = &H7
    AD_APPLY_FORCE = &H8
    AD_APPLY_BUFFERED_REFRESH = &H10
    AD_APPLY_DYNAMICREFRESH = &H20
End Enum
 
' Универсальная функция изменения обоев на рабочем столе
Public Function SetWallpaperUniversal(ByVal FileName As String) As Boolean
    If IsFileAPI(StrPtr(FileName)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    If SetWallpaper(FileName) = False Then
        If ActiveDesktopSetWallpaper(FileName) = True Then
            SetWallpaperUniversal = True
        End If
    Else
        SetWallpaperUniversal = True
    End If
End Function
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfoW(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function
 
' Получение пути и имени файла к обоям на рабочем столе
Public Function GetWallpaper() As String
    Dim RetVal As Long
    Dim str As String
    Dim lNullPos As Long
    
    str = Space$(MAX_PATH)
    
    RetVal = SystemParametersInfoW(SPI_GETDESKWALLPAPER, MAX_PATH, StrPtr(str), 0)
    
    If RetVal Then
        lNullPos = InStr(1, str, vbNullChar)
        If lNullPos Then
            str = Left$(str, lNullPos - 1)
        End If
        GetWallpaper = str
    End If
End Function
 
' Включить ActiveDesktop для того чтобы картинка на рабочем столе появлялась с красивым fade эффектом
Public Sub EnableActiveDesktop()
    Dim result As Long
    
    SendMessageTimeout FindWindow("Progman", vbNullString), &H52C, ByVal 0&, ByVal 0&, ByVal 0&, 500, result
End Sub
 
' Изменение обоев на рабочем столе с помощью интерфейса IActiveDesktop
Public Function ActiveDesktopSetWallpaper(ByVal strFile As String) As Boolean
    Dim vtbl            As IActiveDesktop
    Dim vtblptr         As Long
    Dim classid         As GUID
    Dim iid             As GUID
    Dim obj             As Long
    Dim hRes            As Long
    
    If IsFileAPI(StrPtr(strFile)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    ' CLSID (BSTR) to CLSID (GUID)
    hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
    If hRes <> 0 Then
        Exit Function
    End If
    
    ' IID (BSTR) to IID (GUID)
    hRes = IIDFromString(StrPtr(IID_ActiveDesktop), iid)
    If hRes <> 0 Then
        Exit Function
    End If
    
    ' Создать экземпляр IActiveDesktop
    ' (Set IActiveDesktop = New IActiveDesktop)
    hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
    If hRes <> 0 Then
        Exit Function
    End If
    
    GetMem4 ByVal obj, vtblptr
    RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
    
    ' IActiveDesktop::SetWallpaper
    ' Первым параметром всегда является указатель на объект
    ' Возвращаемое значение всегда должно быть HRESULT (0 = S_OK)
    hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
    If hRes = 0 Then
        ActiveDesktopSetWallpaper = True
    End If
    
    ' IActiveDesktop::ApplyChanges
    hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE Or AD_APPLY_BUFFERED_REFRESH)
    
    ' Освободить память
    ' (Set IActiveDesktop = Nothing)
    CallPointer vtbl.Release, obj
End Function
 
Private Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long
    Dim btASM(&HEC00& - 1)  As Byte
    Dim pASM                As Long
    Dim i                   As Integer
    
    pASM = VarPtr(btASM(0))
    
    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX
    
    For i = UBound(params) To 0 Step -1
        AddPush pASM, CLng(params(i))   ' PUSH dword
    Next
    
    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET
    
    CallPointer = CallWindowProcA(VarPtr(btASM(0)), 0, 0, 0, 0)
End Function
 
Private Sub AddPush(pASM As Long, lng As Long)
    AddByte pASM, &H68
    AddLong pASM, lng
End Sub
 
Private Sub AddCall(pASM As Long, addr As Long)
    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub
 
Private Sub AddLong(pASM As Long, lng As Long)
    GetMem4 lng, ByVal pASM
    pASM = pASM + 4
End Sub
 
Private Sub AddByte(pASM As Long, bt As Byte)
    GetMem1 bt, ByVal pASM
    pASM = pASM + 1
End Sub