Dim Ri As Double
 
Public Function Rand() As Single
  Ri = Ri * (1.241 + (Ri > 983732.3)) + 1.737
  Rand = Ri - Int(Ri)
End Function
 
Public Sub RandInit(ByVal R As Single)
  Ri = R
End Sub

Option Explicit
 
Public Sub Fill(Ar() As Long, ByVal X As Long, ByVal Y As Long, ByVal Col As Long)
  Dim dX As Long, dY As Long
  Dim bCol As Long
  Dim pX() As Long, pY() As Long
  Dim Ptr As Long, Cnt(1) As Long
  Dim C As Long, n As Long
 
  bCol = Ar(X, Y)
  If bCol = Col Then Exit Sub
  dX = UBound(Ar(), 1) + 1
  dY = UBound(Ar(), 2) + 1
  ReDim pX((dX + dY) * 4, 1)
  ReDim pY((dX + dY) * 4, 1)
  
  Cnt(Ptr) = 1
  pX(0, Ptr) = X
  pY(0, Ptr) = Y
  Do
    C = 0
    For n = 0 To Cnt(Ptr) - 1
      If pX(n, Ptr) < dX - 1 Then
        If Ar(pX(n, Ptr) + 1, pY(n, Ptr)) = bCol Then
          pX(C, 1 - Ptr) = pX(n, Ptr) + 1
          pY(C, 1 - Ptr) = pY(n, Ptr)
          Ar(pX(C, 1 - Ptr), pY(C, 1 - Ptr)) = Col
          C = C + 1
        End If
      End If
      If pY(n, Ptr) < dY - 1 Then
        If Ar(pX(n, Ptr), pY(n, Ptr) + 1) = bCol Then
          pX(C, 1 - Ptr) = pX(n, Ptr)
          pY(C, 1 - Ptr) = pY(n, Ptr) + 1
          Ar(pX(C, 1 - Ptr), pY(C, 1 - Ptr)) = Col
          C = C + 1
        End If
      End If
      If pX(n, Ptr) > 0 Then
        If Ar(pX(n, Ptr) - 1, pY(n, Ptr)) = bCol Then
          pX(C, 1 - Ptr) = pX(n, Ptr) - 1
          pY(C, 1 - Ptr) = pY(n, Ptr)
          Ar(pX(C, 1 - Ptr), pY(C, 1 - Ptr)) = Col
          C = C + 1
        End If
      End If
      If pY(n, Ptr) > 0 Then
        If Ar(pX(n, Ptr), pY(n, Ptr) - 1) = bCol Then
          pX(C, 1 - Ptr) = pX(n, Ptr)
          pY(C, 1 - Ptr) = pY(n, Ptr) - 1
          Ar(pX(C, 1 - Ptr), pY(C, 1 - Ptr)) = Col
          C = C + 1
        End If
      End If
    Next n
    If C = 0 Then Exit Do
    Ptr = 1 - Ptr
    Cnt(Ptr) = C
  Loop
End Sub

Option Explicit
Option Base 0
 
Public Enum PTR
    [_]
End Enum
 
Private Declare Function GetMem1 Lib "msvbvm60" ( _
                         ByRef Source As Any, _
                         ByRef Dest As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                         ByRef Source As Any, _
                         ByRef Dest As Any) As Long
Private Declare Function GetMemPtr Lib "msvbvm60" Alias "GetMem4" ( _
                         ByRef Source As Any, _
                         ByRef Dest As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" ( _
                         ByRef Source As Any, _
                         ByRef Dest As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" ( _
                         ByRef lpString As Any) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" ( _
                         ByRef psz As Any, _
                         ByVal lSize As Long) As String
 
' // Get list of VB6 object methods
Public Property Get ListOfMethods( _
                    ByVal cObj As Object) As String()
    Dim sRet()      As String
    Dim lIndex      As Long
    Dim lCount      As Long
    Dim pObjInfo    As PTR
    Dim pPubDesc    As PTR
    Dim pPrivDesc   As PTR
    Dim pMembers    As PTR
    Dim pMethDesc   As PTR
    Dim pVtbl       As PTR
    Dim lMethods    As Long
    Dim pNames      As PTR
    Dim pName       As PTR
    Dim lMethOffset As Long
    Dim lPropCount  As Long
    Dim lFlags      As Long
    
    GetMemPtr ByVal ObjPtr(cObj), pVtbl
    GetMemPtr ByVal pVtbl - 4, pObjInfo
    GetMemPtr ByVal pObjInfo + &H18, pPubDesc
    GetMemPtr ByVal pObjInfo + &HC, pPrivDesc
    GetMemPtr ByVal pPubDesc + &H20, pNames
    
    If pPrivDesc = 0 Then
        Exit Property
    End If
    
    GetMemPtr ByVal pPrivDesc + &H18, pMembers
    GetMem2 ByVal pPubDesc + &H1C, lMethods
    
    If lMethods = 0 Then
        Exit Property
    End If
 
    For lIndex = 0 To lMethods - 1
        
        GetMemPtr ByVal pMembers, pMethDesc
 
        If pMethDesc Then
            
            GetMem2 ByVal pMethDesc + 2, lMethOffset
            
            If lMethOffset And 1 Then
                
                lMethOffset = lMethOffset And -2
                
                GetMemPtr ByVal pNames + lIndex * Len(pName), pName
                
                If lCount Then
                    If lCount > UBound(sRet) Then
                        ReDim Preserve sRet(lCount + 10)
                    End If
                Else
                    ReDim sRet(9)
                End If
                
                sRet(lCount) = SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))
                
                lCount = lCount + 1
                
            End If
 
        End If
        
        pMembers = pMembers + 4
        
    Next
    
    GetMem2 ByVal pPrivDesc + &H10, lPropCount
    GetMemPtr ByVal pPrivDesc + &H20, pMembers
    
    For lIndex = 0 To lPropCount - 1
        
        GetMemPtr ByVal pMembers, pMethDesc
        
        If pMethDesc Then
            
            GetMem2 ByVal pMethDesc + &H10, lFlags
            
            If lFlags And 2 Then
                
                GetMemPtr ByVal pMethDesc, pName
                GetMem2 ByVal pMethDesc + &H12, lMethOffset
                
                If lCount Then
                    If lCount > UBound(sRet) Then
                        ReDim Preserve sRet(lCount + 10)
                    End If
                Else
                    ReDim sRet(9)
                End If
                
                sRet(lCount) = SysAllocStringByteLen(ByVal pName, lstrlenA(ByVal pName))
                
                lCount = lCount + 1
                
            End If
            
        End If
        
        pMembers = pMembers + 4
        
    Next
    
    If lCount Then
        ReDim Preserve sRet(lCount - 1)
    End If
    
    ListOfMethods = sRet
    
End Property

Option Explicit
 
Private Const AreYouABasicInstance  As String = "{0B6C9465-D082-11CF-8B4F-00A0C90F2704}"
 
Private Declare Function vbaCheckType Lib "msvbvm60" Alias "__vbaCheckType" (ByVal pObj As Any, ByRef pIID As Any) As Boolean
Private Declare Function IIDFromString Lib "ole32" (ByRef lpsz As Any, ByRef lpiid As Any) As Long
 
Private Sub Form_Load()
    Dim bIID(15)    As Byte
    
    IIDFromString ByVal StrPtr(AreYouABasicInstance), bIID(0)
 
    If vbaCheckType(Me, bIID(0)) Then
        MsgBox "VB obj"
    End If
    
End Sub

' //
' // Debug redirect
' // by The trick
' //
 
Option Explicit
 
Private Enum PTR
    [_]
End Enum
 
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As PTR) As PTR
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 Function ReplaceDebugObject( _
                 ByVal pObj As PTR) As PTR
    Static s_pCurObject As PTR
    Dim hVBA        As PTR
    Dim pNTHdr      As PTR
    Dim pStart      As PTR
    Dim pEnd        As PTR
    Dim cSign       As Currency
    Dim lLength     As Long
    Dim lOldProtect As Long
    
    If s_pCurObject = 0 Then
    
        hVBA = GetModuleHandle(StrPtr("vba6"))
        If hVBA = 0 Then Exit Function
    
        GetMem4 ByVal hVBA + &H3C, pNTHdr
        pNTHdr = pNTHdr + hVBA
        
        GetMem4 ByVal pNTHdr + &H12C, pStart
        pStart = pStart + hVBA
        
        GetMem4 ByVal pNTHdr + &H128, lLength
        pEnd = pStart + lLength - 8
        
        Do While pStart <= pEnd
            
            GetMem8 ByVal pStart, cSign
            
            If cSign = 511398171365990.4051@ Then
            
                GetMemPtr ByVal pStart + &H11, pStart
                GetMemPtr ByVal pStart + &H44, pStart
                GetMemPtr ByVal pStart + &H1, s_pCurObject
                Exit Do
                
            End If
            
            pStart = pStart + 1
            
        Loop
 
    End If
    
    If s_pCurObject = 0 Then
        Err.Raise 51
    End If
    
    GetMemPtr ByVal s_pCurObject, ReplaceDebugObject
    PutMemPtr ByVal s_pCurObject, pObj
    
End Function
 
Private Sub Form_Load()
    Dim pOriginal   As PTR
    
    Me.AutoRedraw = True
    
    pOriginal = ReplaceDebugObject(ObjPtr(Me))
    
    Debug.Print "test"
    Debug.Print "Hello", "world", Spc(10); "1234"; Tab(3); "vb6"
 
    ReplaceDebugObject pOriginal
    
End Sub

Option Explicit
 
Private Declare Function allmul Lib "ntdll" _
                         Alias "_allmul" ( _
                         ByVal cMultiplicand As Currency, _
                         ByVal cMultiplier As Currency) As Currency
Private Declare Function alldiv Lib "ntdll" _
                         Alias "_alldiv" ( _
                         ByVal cDivident As Currency, _
                         ByVal cDivisor As Currency) As Currency
                         
Private Sub Form_Load()
    Debug.Print alldiv(5, 0.08) ' // 50000 / 800 = 62
    Debug.Print allmul(500, 8)  ' // 5000000 * 80000 = 400000000000
End Sub

' //
' // CHashTable.cls - hash table with string keys
' // The trick, 2023
' //
 
Option Explicit
Option Base 0
 
Private Const HASH_SIZE As Long = 587
 
Private Type tHashPointer
    lHash   As Long
    lIndex  As Long
End Type
 
Private Type tHashItem
    vValue      As Variant
    sKey        As String
    lNext       As Long
    lPrevEnum   As Long
    lNextEnum   As Long
End Type
 
Private Declare Function CharLowerBuff Lib "user32" _
                         Alias "CharLowerBuffW" ( _
                         ByVal lpsz As Long, _
                         ByVal cchLength As Long) As Long
Private Declare Sub HashData Lib "shlwapi" ( _
                    ByRef pbData As Any, _
                    ByVal cbData As Long, _
                    ByRef pbHash As Any, _
                    ByVal cbHash As Long)
 
Private m_tItems()          As tHashItem
Private m_bCaseInsensitive  As Boolean
Private m_lCount            As Long
Private m_lFirstFree        As Long
Private m_lFirstItem        As Long
Private m_lLastItem         As Long
 
Public Property Get CaseInsensitive() As Boolean
    CaseInsensitive = m_bCaseInsensitive
End Property
 
Public Property Let CaseInsensitive( _
                    ByVal bValue As Boolean)
    
    If m_lCount Then
        Err.Raise 5
    End If
    
    m_bCaseInsensitive = bValue
    
End Property
 
Public Function Exists( _
                ByRef sKey As String) As Boolean
    Exists = FindItem(sKey).lIndex <> -1
End Function
 
Public Property Get Item( _
                    ByRef sKey As String) As Variant
    Dim tPointer    As tHashPointer
    
    tPointer = FindItem(sKey)
    
    If tPointer.lIndex = -1 Then
        Item = Empty
    Else
        If IsObject(m_tItems(tPointer.lIndex).vValue) Then
            Set Item = m_tItems(tPointer.lIndex).vValue
        Else
             Item = m_tItems(tPointer.lIndex).vValue
        End If
    End If
 
End Property
 
Public Property Let Item( _
                    ByRef sKey As String, _
                    ByVal vValue As Variant)
    Dim tPointer    As tHashPointer
    
    tPointer = FindItem(sKey)
 
    If IsEmpty(vValue) Then
        If tPointer.lIndex = -1 Then
            Exit Property
        Else
            DeleteItem sKey
        End If
    Else
    
        If tPointer.lIndex = -1 Then
            tPointer = AddItem(sKey)
        End If
        
        m_tItems(tPointer.lIndex).vValue = vValue
        
    End If
    
End Property
 
Public Property Set Item( _
                    ByRef sKey As String, _
                    ByVal vValue As Variant)
    Dim tPointer    As tHashPointer
    
    tPointer = FindItem(sKey)
 
    If IsEmpty(vValue) Then
        If tPointer.lIndex = -1 Then
            Exit Property
        Else
            DeleteItem sKey
        End If
    Else
    
        If tPointer.lIndex = -1 Then
            tPointer = AddItem(sKey)
        End If
        
        Set m_tItems(tPointer.lIndex).vValue = vValue
        
    End If
    
End Property
 
Public Property Get Count() As Long
    Count = m_lCount
End Property
 
Public Sub Clear()
    Dim lIndex  As Long
    
    ReDim m_tItems(HASH_SIZE - 1)
    
    For lIndex = 0 To HASH_SIZE - 1
    
        m_tItems(lIndex).lNext = -1
        m_tItems(lIndex).lNextEnum = -1
        m_tItems(lIndex).lPrevEnum = -1
        
    Next
    
    m_lFirstFree = HASH_SIZE
    m_lFirstItem = -1
    m_lLastItem = -1
    m_lCount = 0
    
End Sub
 
Public Property Get Items() As Variant
    Dim lIndex      As Long
    Dim lItemIndex  As Long
    Dim vRet()      As Variant
    
    If m_lCount Then
        
        ReDim vRet(m_lCount - 1)
        
        lItemIndex = m_lFirstItem
        
        For lIndex = 0 To m_lCount - 1
        
            If IsObject(m_tItems(lItemIndex).vValue) Then
                Set vRet(lIndex) = m_tItems(lItemIndex).vValue
            Else
                vRet(lIndex) = m_tItems(lItemIndex).vValue
            End If
            
            lItemIndex = m_tItems(lItemIndex).lNextEnum
            
        Next
        
        Items = vRet
        
    Else
        Items = Split("")
    End If
    
End Property
 
Public Property Get Keys() As String()
    Dim lIndex      As Long
    Dim lItemIndex  As Long
    Dim sRet()      As String
    
    If m_lCount Then
        
        ReDim sRet(m_lCount - 1)
        
        lItemIndex = m_lFirstItem
        
        For lIndex = 0 To m_lCount - 1
        
            sRet(lIndex) = m_tItems(lItemIndex).sKey
            lItemIndex = m_tItems(lItemIndex).lNextEnum
            
        Next
    
    End If
    
    Keys = sRet
    
End Property
 
Public Function CalculateHash( _
                ByVal sKey As String) As Long
    Dim lHash   As Long
    
    If m_bCaseInsensitive Then
        CharLowerBuff StrPtr(sKey), Len(sKey)
    End If
    
    HashData ByVal StrPtr(sKey), LenB(sKey), lHash, Len(lHash)
    
    CalculateHash = (lHash And &H7FFFFFFF) Mod HASH_SIZE
    
End Function
 
Private Sub DeleteItem( _
            ByRef sKey As String)
    Dim lHash       As Long
    Dim lIndex      As Long
    Dim lNextIndex  As Long
    Dim lPrevIndex  As Long
    Dim eComp       As VbCompareMethod
    
    lHash = CalculateHash(sKey)
    
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
    
    lIndex = lHash
    lPrevIndex = -1
    
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
    
        lPrevIndex = lIndex
        lIndex = m_tItems(lIndex).lNext
        If lIndex = -1 Then Exit Sub    ' // Not found
        
    Loop
 
    If lPrevIndex = -1 Then
        
        ' // In main hash table
        lNextIndex = m_tItems(lIndex).lNext
 
        If lNextIndex <> -1 Then
            
            ' // Move next collision to main table
            m_tItems(lIndex).sKey = m_tItems(lNextIndex).sKey
            
            If IsObject(m_tItems(lNextIndex).vValue) Then
                Set m_tItems(lIndex).vValue = m_tItems(lNextIndex).vValue
            Else
                m_tItems(lIndex).vValue = m_tItems(lNextIndex).vValue
            End If
            
            If m_tItems(lIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
            End If
            
            If m_tItems(lIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
            End If
            
            If m_tItems(lNextIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lNextIndex).lPrevEnum).lNextEnum = lIndex
            End If
            
            If m_tItems(lNextIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lNextIndex).lNextEnum).lPrevEnum = lIndex
            End If
            
            If m_lFirstItem = lNextIndex Then
                m_lFirstItem = lIndex
            ElseIf m_lFirstItem = lIndex Then
                If m_tItems(lIndex).lNextEnum <> lNextIndex Then
                    m_lFirstItem = m_tItems(lIndex).lNextEnum
                End If
            End If
            
            If m_lLastItem = lNextIndex Then
                m_lLastItem = lIndex
            ElseIf m_lLastItem = lIndex Then
                If m_tItems(lIndex).lPrevEnum <> lNextIndex Then
                    m_lLastItem = m_tItems(lIndex).lPrevEnum
                End If
            End If
            
            m_tItems(lIndex).lNextEnum = m_tItems(lNextIndex).lNextEnum
            m_tItems(lIndex).lPrevEnum = m_tItems(lNextIndex).lPrevEnum
            m_tItems(lIndex).lNext = m_tItems(lNextIndex).lNext
            
            DeallocItem lNextIndex
            
        Else
            
            If m_lFirstItem = lIndex Then
                m_lFirstItem = m_tItems(lIndex).lNextEnum
            End If
            
            If m_lLastItem = lIndex Then
                m_lLastItem = m_tItems(lIndex).lPrevEnum
            End If
            
            If m_tItems(lIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
            End If
            
            If m_tItems(lIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
            End If
 
            m_tItems(lIndex).sKey = vbNullString
            m_tItems(lIndex).vValue = Empty
            m_tItems(lIndex).lNext = -1
            m_tItems(lIndex).lNextEnum = -1
            m_tItems(lIndex).lPrevEnum = -1
            
        End If
 
    Else
        
        m_tItems(lPrevIndex).lNext = m_tItems(lIndex).lNext
        
        If m_lFirstItem = lIndex Then
            m_lFirstItem = m_tItems(lIndex).lNextEnum
        End If
        
        If m_lLastItem = lIndex Then
            m_lLastItem = m_tItems(lIndex).lPrevEnum
        End If
            
        If m_tItems(lIndex).lNextEnum <> -1 Then
            m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
        End If
        
        If m_tItems(lIndex).lPrevEnum <> -1 Then
            m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
        End If
        
        DeallocItem lIndex
        
    End If
    
    m_lCount = m_lCount - 1
    
End Sub
 
Private Function AddItem( _
                 ByRef sKey As String) As tHashPointer
    Dim lIndex      As Long
    Dim lNewIndex   As Long
    Dim eComp       As VbCompareMethod
    
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
    
    lIndex = CalculateHash(sKey)
    
    AddItem.lHash = lIndex
    
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
        If m_tItems(lIndex).lNext = -1 Then
            
            If lIndex = AddItem.lHash And Len(m_tItems(lIndex).sKey) = 0 Then
                lNewIndex = lIndex
            Else
                lNewIndex = AllocItem
                m_tItems(lIndex).lNext = lNewIndex
            End If
            
            m_tItems(lNewIndex).sKey = sKey
            m_tItems(lNewIndex).lNext = -1
            m_tItems(lNewIndex).lNextEnum = -1
            
            If m_lFirstItem = -1 Then
                m_lFirstItem = lNewIndex
            End If
            
            m_tItems(lNewIndex).lPrevEnum = m_lLastItem
            
            If m_lLastItem <> -1 Then
                m_tItems(m_lLastItem).lNextEnum = lNewIndex
            End If
            
            m_lLastItem = lNewIndex
            
            lIndex = lNewIndex
            
            m_lCount = m_lCount + 1
            
            Exit Do
            
        Else
            lIndex = m_tItems(lIndex).lNext
        End If
    Loop
    
    AddItem.lIndex = lIndex
    
End Function
 
Private Function FindItem( _
                 ByRef sKey As String) As tHashPointer
    Dim lIndex  As Long
    Dim eComp   As VbCompareMethod
    
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
    
    lIndex = CalculateHash(sKey)
    
    FindItem.lHash = lIndex
    
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
        lIndex = m_tItems(lIndex).lNext
        If lIndex = -1 Then Exit Do
    Loop
    
    FindItem.lIndex = lIndex
    
End Function
 
Private Sub DeallocItem( _
            ByVal lIndex As Long)
                
    m_tItems(lIndex).sKey = vbNullString
    m_tItems(lIndex).vValue = Empty
    m_tItems(lIndex).lNext = m_lFirstFree
    m_tItems(lIndex).lNextEnum = -1
    m_tItems(lIndex).lPrevEnum = -1
    
    m_lFirstFree = lIndex
                
End Sub
 
Private Function AllocItem() As Long
    Dim lIndex      As Long
    Dim lCurSize    As Long
    
    If m_lFirstFree > UBound(m_tItems) Then
        
        lCurSize = (UBound(m_tItems) + 1)
        ReDim Preserve m_tItems(lCurSize * 2 - 1)
        
        For lIndex = lCurSize To UBound(m_tItems)
        
            m_tItems(lIndex).lNext = lIndex + 1
            m_tItems(lIndex).lNextEnum = -1
            m_tItems(lIndex).lPrevEnum = -1
            
        Next
        
    End If
    
    AllocItem = m_lFirstFree
    m_lFirstFree = m_tItems(m_lFirstFree).lNext
    
End Function
 
Private Sub Class_Initialize()
 
    Clear
    m_bCaseInsensitive = True
    
End Sub

' //
' // Get calling procedure name
' // The result executable should be compiled with debug symbols
' // by The trick 2022
' //
 
Option Explicit
Option Base 0
 
Private Enum PTR    ' // Alias (thanks OlimilO1402)
    [_]
End Enum
 
Private Const MAX_SYM_NAME                                  As Long = 2000
Private Const MAX_PATH                                      As Long = 260
Private Const SIZEOF_SYMBOL_INFO                            As Long = 88
Private Const GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS        As Long = 4
Private Const GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT  As Long = 2
 
Private Type SYMBOL_INFO
    SizeOfStruct            As Long
    TypeIndex               As Long
    Reserved(1)             As Currency
    Index                   As Long
    Size                    As Long
    ModBase                 As Currency
    Flags                   As Long
    lPad0                   As Long
    Value                   As Currency
    Address                 As Currency
    Register                As Long
    Scope                   As Long
    Tag                     As Long
    NameLen                 As Long
    MaxNameLen              As Long
    iName(MAX_SYM_NAME - 1) As Integer
End Type
 
Private Declare Function SymInitialize Lib "dbghelp" _
                         Alias "SymInitializeW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal UserSearchPath As Any, _
                         ByVal fInvadeProcess As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" _
                         Alias "SymFromAddrW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal Address As Currency, _
                         ByRef Displacement As Currency, _
                         ByRef Symbol As SYMBOL_INFO) As Long
Private Declare Function SymLoadModuleEx Lib "dbghelp" _
                         Alias "SymLoadModuleExW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal hFile As OLE_HANDLE, _
                         ByVal ImageName As PTR, _
                         ByVal ModuleName As PTR, _
                         ByVal BaseOfDll As Currency, _
                         ByVal DllSize As Long, _
                         ByRef Data As Any, _
                         ByVal Flags As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" _
                         Alias "GetModuleFileNameW" ( _
                         ByVal hModule As Long, _
                         ByVal lpFileName As PTR, _
                         ByVal nSize As Long) As Long
Private Declare Function GetModuleHandleEx Lib "kernel32" _
                         Alias "GetModuleHandleExW" ( _
                         ByVal dwFlags As Long, _
                         ByVal lpModuleName As PTR, _
                         ByRef phModule As Any) As Long
Private Declare Function SysAllocString Lib "oleaut32" ( _
                         ByRef pOlechar As Any) As Long
Private Declare Function EbSetMode Lib "vba6" ( _
                         ByVal Mode As Long) As Long
Private Declare Function EbGetCallstackCount Lib "vba6" ( _
                         ByRef lCount As Long) As Long
Private Declare Function EbGetCallstackFunction Lib "vba6" ( _
                         ByVal lIndex As Long, _
                         ByVal pProject As PTR, _
                         ByVal pModule As PTR, _
                         ByVal pFunction As PTR, _
                         ByRef lRet As Long) As Long
Private Declare Function RtlCaptureStackBackTrace Lib "kernel32" ( _
                         ByVal FramesToSkip As Long, _
                         ByVal FramesToCapture As Long, _
                         ByRef BackTrace As Any, _
                         ByRef BackTraceHash As Any) As Integer
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pRetVal As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
                    Alias "PutMem4" ( _
                    ByRef pAddr As Any, _
                    ByVal pNewVal As PTR)
 
Private m_bInintialized As Boolean
 
Public Function GetCallStack() As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    Dim lIndex      As Long
    Dim pAddr()     As PTR
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            For lIndex = 1 To lStackCount - 1
                If EbGetCallstackFunction(lIndex, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                
                    GetCallStack = GetCallStack & sModule & "::" & sFunction & vbNewLine
                    sProject = vbNullString
                    sModule = vbNullString
                    sFunction = vbNullString
                    
                End If
            Next
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    ReDim pAddr(31)
    
    lStackCount = RtlCaptureStackBackTrace(1, UBound(pAddr) + 1, pAddr(0), ByVal 0&)
    
    For lIndex = 0 To UBound(pAddr)
    
        GetMem4 pAddr(lIndex), cAddr
    
        If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) Then
            
            PutMemPtr ByVal VarPtr(sFunction), SysAllocString(tSymInfo.iName(0))
            GetCallStack = GetCallStack & sFunction & vbNewLine
            sFunction = vbNullString
            
        Else
            
            GetCallStack = GetCallStack & "<unknown>" & vbNewLine
            
        End If
 
    Next
    
End Function
 
Public Function GetCallingProcName( _
                Optional ByVal lReserved As Long) As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            If lStackCount > 1 Then
                If EbGetCallstackFunction(1, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                    GetCallingProcName = sModule & "::" & sFunction
                End If
            End If
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    GetMem4 ByVal VarPtr(lReserved) - 4, cAddr
    
    If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) = 0 Then
        Exit Function
    End If
    
    PutMemPtr ByVal VarPtr(GetCallingProcName), SysAllocString(tSymInfo.iName(0))
    
End Function
 
Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function
 
Private Function GetExecutableName() As String
    Dim sRet    As String
    Dim lSize   As Long
    Dim hMod    As PTR
    
    If GetModuleHandleEx(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS Or GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, _
                         AddressOf GetCallingProcName, hMod) = 0 Then
        Exit Function
    End If
    
    sRet = Space$(MAX_PATH)
    lSize = GetModuleFileName(hMod, StrPtr(sRet), Len(sRet))
    
    If lSize Then
        GetExecutableName = Left$(sRet, lSize)
    End If
 
End Function

Option Explicit
 
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
 
Private Const CF_UNICODETEXT    As Long = 13&
Private Const CF_LOCALE         As Long = 16
Private Const GMEM_MOVEABLE     As Long = &H2&
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
 
Dim LenClipboardA As Long
Dim LenClipboardW As Long
Dim EffortClipboardA As String
Dim EffortClipboardW As String
 
Private Function wAppPath() As String
    If Right$(App.Path, 1) = "\" Then
        wAppPath = Mid(App.Path, 1, Len(App.Path) - 1)
    Else
        wAppPath = App.Path
    End If
End Function
 
' Получить буфер в уникоде
Private Function GetClipboardW() As String
    On Error GoTo ErrorHandler
    
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GetClipboardData(CF_UNICODETEXT)
        If hMem Then
            Size = GlobalSize(hMem)
            If Size Then
                txt = Space$(Size \ 2 - 1)
                ptr = GlobalLock(hMem)
                lstrcpyn ByVal StrPtr(txt), ByVal ptr, Size
                GlobalUnlock hMem
                GetClipboardW = txt
            End If
        End If
        CloseClipboard
    End If
    Exit Function
ErrorHandler:
    'Debug.Print "GetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Function
 
' Записать уникодную строку в буфер
Private Sub SetClipboardW(sText As String)
    On Error GoTo ErrorHandler
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GlobalAlloc(GMEM_MOVEABLE, 4)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                GetMem4 &H419, ByVal ptr
                GlobalUnlock hMem
                SetClipboardData CF_LOCALE, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        hMem = GlobalAlloc(GMEM_MOVEABLE, LenB(sText) + 2)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                lstrcpyn ptr, StrPtr(sText), LenB(sText)
                ZeroMemory ByVal (StrPtr(sText) + LenB(sText)), 2&
                GlobalUnlock hMem
                SetClipboardData CF_UNICODETEXT, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        CloseClipboard
    End If
    Exit Sub
ErrorHandler:
    'Debug.Print "SetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Sub
 
' Возьмём символы а-я, А-Я, ёЁ с кодами от 192 до 255 а так же 184 и 168
' Определить содержит ли буфер CF_UNICODETEXT кракозяблики символы а-я, А-Я, ёЁ
Private Function IsCrabsString(str As String) As Boolean
    Dim i As Integer
    
    For i = 192 To 255
        If InStr(1, str, ChrW(i)) > 0 Then
            IsCrabsString = True
            Exit Function ' Для ускорения
        End If
    Next
    
    If InStr(1, str, ChrW(184)) > 0 Then IsCrabsString = True
    If InStr(1, str, ChrW(168)) > 0 Then IsCrabsString = True
End Function
 
Private Function IsQuestionString(str As String) As Boolean
    str = Replace(str, " ", "")
    
    If str = "?" Or str = "??" Or str = "???" Or str = "????" Or str = "?????" Then
        IsQuestionString = True
        Exit Function ' Для ускорения
    End If
    If Len(str) > 5 Then ' Если 6 вопросительных знаков вподряд и более
        If Mid(str, 1, 6) = "??????" Then
            IsQuestionString = True
            Exit Function ' Для ускорения
        End If
    End If
    If InStr(1, str, "?????") Then
        IsQuestionString = True
    End If
End Function
 
Private Sub ClipboardPath()
    On Error Resume Next
    
    Dim ClipboardA As String
    Dim ClipboardW As String
    
    ClipboardA = Clipboard.GetText
    ClipboardW = GetClipboardW
    
    If LenClipboardW <> Len(ClipboardW) Then ' Выполнять код, только если буфер изменился
        LenClipboardW = Len(ClipboardW)
                
        If Len(ClipboardW) > 0 Then
            If IsCrabsString(ClipboardW) = True Then ' Буфер содержит кракозяблики
                SetClipboardW ClipboardA ' Исправить буфер (засунуть в CF_UNICODETEXT правильную строку взятую из CF_TEXT)
                sndPlaySound wAppPath & "\FixingClipboard.wav", SND_ASYNC Or SND_NODEFAULT
                EffortClipboardW = Mid(ClipboardA, 1, 8)
                Exit Sub ' Для ускорения
            End If
        End If
    Else ' Если количество символов всё-таки одинаковое
        If Len(ClipboardW) > 0 And LenClipboardW > 0 Then
            LenClipboardW = Len(ClipboardW)
            
            If EffortClipboardW <> vbNullString Then
                If Mid(ClipboardW, 1, 8) <> EffortClipboardW Then ' Выполнять код, только если реально буфер изменился
                    If IsCrabsString(ClipboardW) = True Then ' Буфер содержит кракозяблики
                        SetClipboardW ClipboardA ' Исправить буфер (засунуть в CF_UNICODETEXT правильную строку взятую из CF_TEXT)
                        sndPlaySound wAppPath & "\FixingClipboard.wav", SND_ASYNC Or SND_NODEFAULT
                        EffortClipboardW = Mid(ClipboardA, 1, 8)
                        Exit Sub ' Для ускорения
                    End If
                End If
            End If
        End If
    End If
    
    If LenClipboardA <> Len(ClipboardA) Then ' Выполнять код, только если буфер изменился
        LenClipboardA = Len(ClipboardA)
        
        If Len(ClipboardA) > 0 Then
            If IsQuestionString(ClipboardA) = True Then
                Clipboard.SetText ClipboardW ' Исправить буфер (засунуть в CF_TEXT правильную строку взятую из CF_UNICODETEXT)
                sndPlaySound wAppPath & "\FixingClipboard.wav", SND_ASYNC Or SND_NODEFAULT
                EffortClipboardA = Mid(ClipboardW, 1, 8)
            End If
        End If
    Else ' Если количество символов всё-таки одинаковое
        If Len(ClipboardA) > 0 And LenClipboardA > 0 Then
            LenClipboardA = Len(ClipboardA)
            
            If EffortClipboardA <> vbNullString Then
                If Mid(ClipboardA, 1, 8) <> EffortClipboardA Then ' Выполнять код, только если реально буфер изменился
                    If IsQuestionString(ClipboardA) = True Then
                        Clipboard.SetText ClipboardW ' Исправить буфер (засунуть в CF_TEXT правильную строку взятую из CF_UNICODETEXT)
                        sndPlaySound wAppPath & "\FixingClipboard.wav", SND_ASYNC Or SND_NODEFAULT
                        EffortClipboardA = Mid(ClipboardW, 1, 8)
                    End If
                End If
            End If
        End If
    End If
End Sub
 
Private Sub Form_Load()
    Me.Hide
    App.TaskVisible = False
    
    If App.PrevInstance = True Then
        Unload Me
        End
    End If
End Sub
 
Private Sub Timer1_Timer()
    ClipboardPath
End Sub

Option Explicit
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 ReleaseCapture Lib "user32" () As Long
 
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call ReleaseCapture
    Call SendMessage(Command1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub