Private Declare Function Initialize Lib "VBPng.dll" () As Long
Private Declare Sub Uninitialize Lib "VBPng.dll" ()
 
Private Sub Form_Initialize()
 
    If Initialize() = 0 Then
        MsgBox "Unable to initialize png dll", vbCritical
    End If
    
End Sub
 
Private Sub Form_Terminate()
    Uninitialize
End Sub

' // Create a new thread
Public Function vbCreateThread(ByVal lpThreadAttributes As Long, _
                               ByVal dwStackSize As Long, _
                               ByVal lpStartAddress As Long, _
                               ByVal lpParameter As Long, _
                               ByVal dwCreationFlags As Long, _
                               ByRef lpThreadId As Long, _
                               Optional ByVal bIDEInSameThread As Boolean = True) As Long

' // This function is used in compiled form
Public Function CallbackProc( _
                ByVal lThreadId As Long, _
                ByVal sKey As String, _
                ByVal fTimeFromLastTick As Single) As Long
    ' // Init runtime and call CallBackProc_user with VarPtr(lThreadId) parameter
    InitCurrentThreadAndCallFunction AddressOf CallBackProc_user, VarPtr(lThreadId), CallbackProc
End Function
 
' // Callback function is called by runtime/window proc (in IDE)
Public Function CallBackProc_user( _
                ByRef tParam As tCallbackParams) As Long
 
End Function

Public Sub CallBack(ByVal vRet As Variant)

' // Execution command process
Function ExecuteProcess() As Boolean
    Dim index       As Long:                Dim bItem       As BinExecListItem
    Dim pPath       As Long:                Dim pErrMsg     As Long
    Dim shInfo      As SHELLEXECUTEINFO:    Dim pTempString As Long
    Dim pItem       As Long:                Dim status      As Long
 
    ' // Set pointer and size
    shInfo.cbSize = Len(shInfo)
    pItem = pExecutesTable
    
    ' // Go thru all items
    For index = 0 To ProjectDesc.execListDescriptor.dwNumberOfItems - 1
    
        ' // Copy item
        CopyMemory bItem, ByVal pItem, ProjectDesc.execListDescriptor.dwSizeOfItem
        
        ' // Set pointer to next item
        pItem = pItem + ProjectDesc.execListDescriptor.dwSizeOfItem
        
        ' // Normalize path
        pPath = NormalizePath(pStringsTable + bItem.ofstFileName, 0)
        
        ' // Fill SHELLEXECUTEINFO
        shInfo.lpFile = pPath
        shInfo.lpParameters = pStringsTable + bItem.ofstParameters
        shInfo.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
        shInfo.nShow = SW_SHOWDEFAULT
        
        ' // Performing...
        status = ShellExecuteEx(shInfo)
        
        ' // If error occurs show notification (retry, abort, ignore)
        Do Until status
            
            If pErrMsg Then SysFreeString pErrMsg: pErrMsg = 0
            
            ' // Ignore error
            If bItem.dwFlags And EF_IGNOREERROR Then
                Exit Do
            End If
                        
            pTempString = GetString(MID_ERROREXECUTELINE)
            pErrMsg = StrCat(pTempString, pPath)
            
            SysFreeString pTempString: pTempString = 0
            
            Select Case MessageBox(0, pErrMsg, 0, MB_ICONERROR Or MB_SYSTEMMODAL Or MB_CANCELTRYCONTINUE)
            Case MESSAGEBOXRETURN.IDCONTINUE: Exit Do
            Case MESSAGEBOXRETURN.IDTRYAGAIN
            Case Else: GoTo CleanUp
            End Select
 
            status = ShellExecuteEx(shInfo)
            
        Loop
        
        ' // Wait for process terminaton
        WaitForSingleObject shInfo.hProcess, INFINITE
        CloseHandle shInfo.hProcess
        
    Next
    
    ' // Success
    ExecuteProcess = True
    
CleanUp:
 
    If pTempString Then SysFreeString pTempString
    If pErrMsg Then SysFreeString pErrMsg
    If pPath Then SysFreeString pPath
    
End Function

' // Run exe from project in memory
Function RunProcess() As Boolean
    Dim bItem       As BinStorageListItem:  Dim Length      As Long
    Dim pFileData   As Long
    
    ' // Get descriptor of executable file
    CopyMemory bItem, ByVal pStoragesTable + ProjectDesc.storageDescriptor.dwSizeOfItem * _
                      ProjectDesc.storageDescriptor.iExecutableIndex, Len(bItem)
    
 
    ' // Alloc memory within top memory addresses
    pFileData = VirtualAlloc(ByVal 0&, bItem.dwSizeOfFile, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE)
    If pFileData = 0 Then Exit Function
    
    ' // Copy raw exe file to this memory
    CopyMemory ByVal pFileData, ByVal pFilesTable + bItem.ofstBeginOfData, bItem.dwSizeOfFile
    
    ' // Free decompressed project data
    HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pProjectData
    pProjectData = 0
    
    ' // Run exe from memory
    RunExeFromMemory pFileData, bItem.dwFlags And FF_IGNOREERROR
    
    ' ----------------------------------------------------
    ' // An error occurs
    ' // Clean memory
    
    VirtualFree ByVal pFileData, 0, MEM_RELEASE
    
    ' // If ignore error then success
    If bItem.dwFlags And FF_IGNOREERROR Then RunProcess = True
    
End Function

' // Run EXE file by memory address
Function RunExeFromMemory( _
                ByVal pExeData As Long, _
                ByVal IgnoreError As Boolean) As Boolean
    Dim Length  As Long:    Dim pCode       As Long
    Dim pszMsg  As Long:    Dim pMsgTable   As Long
    Dim index   As Long:    Dim pCurMsg     As Long
    
    ' // Get size of shellcode
    Length = GetAddr(AddressOf ENDSHELLLOADER) - GetAddr(AddressOf BEGINSHELLLOADER)
    
    ' // Alloc memory within top addresses
    pCode = VirtualAlloc(ByVal 0&, Length, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    
    ' // Copy shellcode to allocated memory
    CopyMemory ByVal pCode, ByVal GetAddr(AddressOf BEGINSHELLLOADER), Length
    
    ' // Initialization of shellcode
    If Not InitShellLoader(pCode) Then GoTo CleanUp
    
    ' // Splice CallLoader function in order to call shellcode
    Splice AddressOf CallLoader, pCode + GetAddr(AddressOf LoadExeFromMemory) - GetAddr(AddressOf BEGINSHELLLOADER)
    
    ' // Check ignore errors
    If Not IgnoreError Then
        
        ' // Alloc memory for messages table
        pMsgTable = VirtualAlloc(ByVal 0&, 1024, MEM_TOP_DOWN Or MEM_COMMIT, PAGE_READWRITE)
        If pMsgTable = 0 Then GoTo CleanUp
        
        ' // Skip pointers
        pCurMsg = pMsgTable + EM_END * 4
        
        For index = 0 To EM_END - 1
        
            ' // Load message string
            pszMsg = GetString(MSG_LOADER_ERROR + index)
            If pszMsg = 0 Then GoTo CleanUp
            
            Length = SysStringLen(pszMsg)
 
            lstrcpyn ByVal pCurMsg, ByVal pszMsg, Length + 1
            
            ' // Store pointer
            CopyMemory ByVal pMsgTable + index * 4, pCurMsg, Len(pCurMsg)
            
            ' // Next message offset
            pCurMsg = pCurMsg + (Length + 1) * 2
            
            SysFreeString pszMsg
            
        Next
        
    End If
    
    ' // Call shellcode
    CallLoader pExeData, pCode, pMsgTable
    
CleanUp:
    
    If pMsgTable Then
        VirtualFree ByVal pMsgTable, 0, MEM_RELEASE
    End If
    
    If pCode Then
        VirtualFree ByVal pCode, 0, MEM_RELEASE
    End If
    
End Function

' // Shellcode initialization
Function InitShellLoader( _
                 ByVal pShellCode As Long) As Boolean
    Dim hLib    As Long:        Dim sName   As Long
    Dim sFunc   As Long:        Dim lpAddr  As Long
    Dim libIdx  As Long:        Dim fncIdx  As Long
    Dim libName As MessagesID:  Dim fncName As MessagesID
    Dim fncSpc  As Long:        Dim splAddr As Long
    
    ' // +----------------------------------------------------------------+
    ' // |                  Fixing of API addresses                       |
    ' // +----------------------------------------------------------------+
    ' // | In order to call api function from shellcode i use splicing of |
    ' // |    our VB functions and redirect call to corresponding api.    |
    ' // |     I did same in the code that injects to other process.      |
    ' // +----------------------------------------------------------------+
    
    splAddr = GetAddr(AddressOf tVirtualAlloc) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode
    
    ' // Get size in bytes between stub functions
    fncSpc = GetAddr(AddressOf tVirtualProtect) - GetAddr(AddressOf tVirtualAlloc)
 
    ' // Use 3 library: kernel32, ntdll и user32
    For libIdx = 0 To 2
    
        ' // Get number of imported functions depending on library
        Select Case libIdx
        Case 0: libName = API_LIB_KERNEL32: fncIdx = 13
        Case 1: libName = API_LIB_NTDLL:    fncIdx = 1
        Case 2: libName = API_LIB_USER32:   fncIdx = 1
        End Select
        
        ' // Get library name from resources
        sName = GetString(libName): If sName = 0 Then Exit Function
        
        ' // Get module handle
        hLib = GetModuleHandle(ByVal sName): If hLib = 0 Then Exit Function
        SysFreeString sName
        
        ' // Go thru functions
        Do While fncIdx
        
            libName = libName + 1
            ' // Get function name
            sName = GetString(libName): If sName = 0 Then Exit Function
            
            ' // Because of GetProcAddress works with ANSI string translate it to ANSI
            sFunc = ToAnsi(sName): If sFunc = 0 Then Exit Function
            
            ' // Get function address
            lpAddr = GetProcAddress(hLib, sFunc)
            SysFreeString sName: SysFreeString sFunc
            
            ' // Error
            If lpAddr = 0 Then Exit Function
            
            ' // Splice stub
            Splice splAddr, lpAddr
            
            ' // Next stub
            splAddr = splAddr + fncSpc
            fncIdx = fncIdx - 1
            
        Loop
        
    Next
    
    ' // Modify CallByPointer
    lpAddr = GetAddr(AddressOf CallByPointer) - GetAddr(AddressOf BEGINSHELLLOADER) + pShellCode
    
    ' // pop eax    - 0x58
    ' // pop ecx    - 0x59
    ' // push eax   - 0x50
    ' // jmp ecx    - 0xFFE1
    
    CopyMemory ByVal lpAddr, &HFF505958, 4
    CopyMemory ByVal lpAddr + 4, &HE1, 1
 
    ' // Success
    InitShellLoader = True
    
End Function
 
' // Splice function
Sub Splice( _
            ByVal Func As Long, _
            ByVal NewAddr As Long)
    ' // Set memory permissions
    VirtualProtect ByVal Func, 5, PAGE_EXECUTE_READWRITE, 0
    CopyMemory ByVal Func, &HE9, 1                      ' // JMP
    CopyMemory ByVal Func + 1, NewAddr - Func - 5, 4    ' // Relative address
End Sub

' // Parse exe in memory
Function LoadExeFromMemory( _
                 ByVal pRawData As Long, _
                 ByVal pMyBaseAddress As Long, _
                 ByVal pErrMsgTable As Long) As Boolean
    Dim NtHdr   As IMAGE_NT_HEADERS
    Dim pBase   As Long
    Dim index   As Long
    Dim iError  As ERROR_MESSAGES
    Dim pszMsg  As Long
    
    ' // Get IMAGE_NT_HEADERS
    If GetImageNtHeaders(pRawData, NtHdr) = 0 Then
        iError = EM_UNABLE_TO_GET_NT_HEADERS
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Check flags
    If NtHdr.FileHeader.Machine <> IMAGE_FILE_MACHINE_I386 Or _
       (NtHdr.FileHeader.Characteristics And IMAGE_FILE_EXECUTABLE_IMAGE) = 0 Or _
       (NtHdr.FileHeader.Characteristics And IMAGE_FILE_32BIT_MACHINE) = 0 Then Exit Function
 
    ' // Release main EXE memory. After that main exe is unloaded from memory.
    ZwUnmapViewOfSection GetCurrentProcess(), GetModuleHandle(ByVal 0&)
 
    ' // Reserve memory for EXE
    iError = ReserveMemory(pRawData, pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Place data
    iError = ProcessSectionsAndHeaders(pRawData, pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Update new base address
    iError = UpdateNewBaseAddress(pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Import table processing
    iError = ProcessImportTable(pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Relocations processing
    iError = ProcessRelocations(pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Set the memory attributes
    iError = SetMemoryPermissions(pBase)
    If iError Then
        EndProcess pErrMsgTable, iError
        Exit Function
    End If
    
    ' // Release error message table
    If pErrMsgTable Then
        tVirtualFree pErrMsgTable, 0, MEM_RELEASE
    End If
    
    ' // Call entry point
    CallByPointer NtHdr.OptionalHeader.AddressOfEntryPoint + pBase
    
    ' // End process
    EndProcess
    
End Function

' // Reserve memory for EXE
Function ReserveMemory( _
                 ByVal pRawExeData As Long, _
                 ByRef pBase As Long) As ERROR_MESSAGES
    Dim NtHdr       As IMAGE_NT_HEADERS
    Dim pLocBase    As Long
    
    If GetImageNtHeaders(pRawExeData, NtHdr) = 0 Then
        ReserveMemory = EM_UNABLE_TO_GET_NT_HEADERS
        Exit Function
    End If
    
    ' // Reserve memory for EXE
    pLocBase = tVirtualAlloc(ByVal NtHdr.OptionalHeader.ImageBase, _
                          NtHdr.OptionalHeader.SizeOfImage, _
                          MEM_RESERVE, PAGE_EXECUTE_READWRITE)
    If pLocBase = 0 Then
        
        ' // If relocation information not found error
        If NtHdr.FileHeader.Characteristics And IMAGE_FILE_RELOCS_STRIPPED Then
        
            ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY
            Exit Function
            
        Else
            ' // Reserve memory in other region
            pLocBase = tVirtualAlloc(ByVal 0&, NtHdr.OptionalHeader.SizeOfImage, _
                                 MEM_RESERVE, PAGE_EXECUTE_READWRITE)
            
            If pLocBase = 0 Then
            
                ReserveMemory = EM_UNABLE_TO_ALLOCATE_MEMORY
                Exit Function
                
            End If
 
        End If
        
    End If
    
    pBase = pLocBase
    
End Function

' // Allocate memory for sections and copy them data to there
Function ProcessSectionsAndHeaders( _
                 ByVal pRawExeData As Long, _
                 ByVal pBase As Long) As ERROR_MESSAGES
 
    Dim iSec    As Long
    Dim pNtHdr  As Long
    Dim NtHdr   As IMAGE_NT_HEADERS
    Dim sec     As IMAGE_SECTION_HEADER
    Dim lpSec   As Long
    Dim pData   As Long
    
    pNtHdr = GetImageNtHeaders(pRawExeData, NtHdr)
    If pNtHdr = 0 Then
        ProcessSectionsAndHeaders = EM_UNABLE_TO_GET_NT_HEADERS
        Exit Function
    End If
    
    ' // Alloc memory for headers
    pData = tVirtualAlloc(ByVal pBase, NtHdr.OptionalHeader.SizeOfHeaders, MEM_COMMIT, PAGE_READWRITE)
    If pData = 0 Then
        ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY
        Exit Function
    End If
    
    ' // Copy headers
    tCopyMemory pData, pRawExeData, NtHdr.OptionalHeader.SizeOfHeaders
    
    ' // Get address of beginnig of sections headers
    pData = pNtHdr + Len(NtHdr.Signature) + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader
    
    ' // Go thru sections
    For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1
    
        ' // Copy section descriptor
        tCopyMemory IntPtr(sec.SectionName(0)), pData, Len(sec)
        
        ' // Alloc memory for section
        lpSec = tVirtualAlloc(sec.VirtualAddress + pBase, sec.VirtualSize, MEM_COMMIT, PAGE_READWRITE)
        If lpSec = 0 Then
            ProcessSectionsAndHeaders = EM_UNABLE_TO_ALLOCATE_MEMORY
            Exit Function
        End If
        
        ' If there is initialized data
        If sec.SizeOfRawData Then
        
            ' // Take into account  file alignment
            If sec.SizeOfRawData > sec.VirtualSize Then sec.SizeOfRawData = sec.VirtualSize
            
            ' // Copy initialized data to section
            tCopyMemory lpSec, pRawExeData + sec.PointerToRawData, sec.SizeOfRawData
            lpSec = lpSec + sec.SizeOfRawData
            sec.VirtualSize = sec.VirtualSize - sec.SizeOfRawData
            
        End If
 
        ' // Fill remain part with zero
        tFillMemory lpSec, sec.VirtualSize, 0
        
        ' // Next section
        pData = pData + Len(sec)
        
    Next
    
End Function

Type PEB
    NotUsed                         As Long
    Mutant                          As Long
    ImageBaseAddress                As Long
    LoaderData                      As Long ' // Pointer to PEB_LDR_DATA
    ProcessParameters               As Long
    ' // ....
End Type

Type PEB_LDR_DATA
    Length                          As Long
    Initialized                     As Long
    SsHandle                        As Long
    InLoadOrderModuleList           As LIST_ENTRY
    InMemoryOrderModuleList         As LIST_ENTRY
    InInitializationOrderModuleList As LIST_ENTRY
End Type

Type LDR_MODULE
    InLoadOrderModuleList           As LIST_ENTRY
    InMemoryOrderModuleList         As LIST_ENTRY
    InInitOrderModuleList           As LIST_ENTRY
    BaseAddress                     As Long
    EntryPoint                      As Long
    SizeOfImage                     As Long
    FullDllName                     As UNICODE_STRING
    BaseDllName                     As UNICODE_STRING
    Flags                           As Long
    LoadCount                       As Integer
    TlsIndex                        As Integer
    HashTableEntry                  As LIST_ENTRY
    TimeDateStamp                   As Long
End Type

Type PROCESS_BASIC_INFORMATION
    ExitStatus                      As Long
    PebBaseAddress                  As Long
    AffinityMask                    As Long
    BasePriority                    As Long
    UniqueProcessId                 As Long
    InheritedFromUniqueProcessId    As Long
End Type

Function UpdateNewBaseAddress( _
                 ByVal pBase As Long) As ERROR_MESSAGES
    Dim pPBI    As Long:                        Dim PBIlen  As Long
    Dim PBI     As PROCESS_BASIC_INFORMATION:   Dim cPEB    As PEB
    Dim ntstat  As Long
    Dim ldrData As PEB_LDR_DATA
    Dim ldrMod  As LDR_MODULE
    
    ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, IntPtr(PBI.ExitStatus), Len(PBI), PBIlen)
    
    Do While ntstat = STATUS_INFO_LENGTH_MISMATCH
        
        PBIlen = PBIlen * 2
        
        If pPBI Then
            tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI
        End If
        
        pPBI = tHeapAlloc(tGetProcessHeap(), HEAP_NO_SERIALIZE, PBIlen)
        ntstat = tNtQueryInformationProcess(tGetCurrentProcess(), ProcessBasicInformation, pPBI, PBIlen, PBIlen)
        
    Loop
    
    If ntstat <> STATUS_SUCCESS Then
        UpdateNewBaseAddress = EM_PROCESS_INFORMATION_NOT_FOUND
        GoTo CleanUp
    End If
    
    If pPBI Then
        ' // Copy to PROCESS_BASIC_INFORMATION
        tCopyMemory IntPtr(PBI.ExitStatus), pPBI, Len(PBI)
    End If
 
    ' // Get PEB
    tCopyMemory IntPtr(cPEB.NotUsed), PBI.PebBaseAddress, Len(cPEB)
    
    ' // Modify image base
    cPEB.ImageBaseAddress = pBase
    
    ' // Restore PEB
    tCopyMemory PBI.PebBaseAddress, IntPtr(cPEB.NotUsed), Len(cPEB)
    
    ' // Fix base address in PEB_LDR_DATA list
    tCopyMemory IntPtr(ldrData.Length), cPEB.LoaderData, Len(ldrData)
    
    ' // Get first element
    tCopyMemory IntPtr(ldrMod.InLoadOrderModuleList.Flink), ldrData.InLoadOrderModuleList.Flink, Len(ldrMod)
    
    ' // Fix base
    ldrMod.BaseAddress = pBase
    
    ' // Restore
    tCopyMemory ldrData.InLoadOrderModuleList.Flink, IntPtr(ldrMod.InLoadOrderModuleList.Flink), Len(ldrMod)
    
CleanUp:
    
    ' // Free memory
    If pPBI Then
        tHeapFree tGetProcessHeap(), HEAP_NO_SERIALIZE, pPBI
    End If
    
End Function

Type IMAGE_IMPORT_DESCRIPTOR
    Characteristics                 As Long
    TimeDateStamp                   As Long
    ForwarderChain                  As Long
    pName                           As Long
    FirstThunk                      As Long
End Type

' // Process import table
Function ProcessImportTable( _
                 ByVal pBase As Long) As ERROR_MESSAGES
    Dim NtHdr           As IMAGE_NT_HEADERS:        Dim datDirectory    As IMAGE_DATA_DIRECTORY
    Dim dsc             As IMAGE_IMPORT_DESCRIPTOR: Dim hLib            As Long
    Dim thnk            As Long:                    Dim Addr            As Long
    Dim fnc             As Long:                    Dim pData           As Long
        
    If GetImageNtHeaders(pBase, NtHdr) = 0 Then
        ProcessImportTable = EM_UNABLE_TO_GET_NT_HEADERS
        Exit Function
    End If
    
    ' // Import table processing
    If NtHdr.OptionalHeader.NumberOfRvaAndSizes > 1 Then
        
        If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_IMPORT, datDirectory) = 0 Then
            ProcessImportTable = EM_INVALID_DATA_DIRECTORY
            Exit Function
        End If
 
        ' // If import table exists
        If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then
        
            ' // Copy import descriptor
            pData = datDirectory.VirtualAddress + pBase
            tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc)
            
            ' // Go thru all descriptors
            Do Until dsc.Characteristics = 0 And _
                     dsc.FirstThunk = 0 And _
                     dsc.ForwarderChain = 0 And _
                     dsc.pName = 0 And _
                     dsc.TimeDateStamp = 0
                
                If dsc.pName > 0 Then
                
                    ' // Load needed library
                    hLib = tLoadLibrary(dsc.pName + pBase)
                    
                    If hLib = 0 Then
                        ProcessImportTable = EM_LOADLIBRARY_FAILED
                        Exit Function
                    End If
 
                    If dsc.Characteristics Then fnc = dsc.Characteristics + pBase Else fnc = dsc.FirstThunk + pBase
                    
                    ' // Go to names table
                    tCopyMemory IntPtr(thnk), fnc, 4
                    
                    ' // Go thru names table
                    Do While thnk
                    
                        ' // Check import type
                        If thnk < 0 Then
                            ' // By ordinal
                            Addr = tGetProcAddress(hLib, thnk And &HFFFF&)
                        Else
                            ' // By name
                            Addr = tGetProcAddress(hLib, thnk + 2 + pBase)
                        End If
                        
                        ' // Next function
                        fnc = fnc + 4
                        tCopyMemory IntPtr(thnk), fnc, 4
                        tCopyMemory dsc.FirstThunk + pBase, IntPtr(Addr), 4
                        dsc.FirstThunk = dsc.FirstThunk + 4
                        
                    Loop
                    
                End If
                
                ' // Next descriptor
                pData = pData + Len(dsc)
                tCopyMemory IntPtr(dsc.Characteristics), pData, Len(dsc)
                
            Loop
            
        End If
        
    End If
                 
End Function

Type IMAGE_BASE_RELOCATION
    VirtualAddress                  As Long
    SizeOfBlock                     As Long
End Type

' // Process relocations
Function ProcessRelocations( _
                 ByVal pBase As Long) As ERROR_MESSAGES
    Dim NtHdr           As IMAGE_NT_HEADERS:        Dim datDirectory    As IMAGE_DATA_DIRECTORY
    Dim relBase         As IMAGE_BASE_RELOCATION:   Dim entriesCount    As Long
    Dim relType         As Long:                    Dim dwAddress       As Long
    Dim dwOrig          As Long:                    Dim pRelBase        As Long
    Dim delta           As Long:                    Dim pData           As Long
    
    ' // Check if module has not been loaded to image base value
    If GetImageNtHeaders(pBase, NtHdr) = 0 Then
        ProcessRelocations = EM_UNABLE_TO_GET_NT_HEADERS
        Exit Function
    End If
    
    delta = pBase - NtHdr.OptionalHeader.ImageBase
    
    ' // Process relocations
    If delta Then
        
        ' // Get address of relocation table
        If GetDataDirectory(pBase, IMAGE_DIRECTORY_ENTRY_BASERELOC, datDirectory) = 0 Then
            ProcessRelocations = EM_INVALID_DATA_DIRECTORY
            Exit Function
        End If
        
        If datDirectory.Size > 0 And datDirectory.VirtualAddress > 0 Then
        
            ' // Copy relocation base
            pRelBase = datDirectory.VirtualAddress + pBase
            tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase)
            
            Do While relBase.VirtualAddress
            
                ' // To first reloc chunk
                pData = pRelBase + Len(relBase)
                
                entriesCount = (relBase.SizeOfBlock - Len(relBase)) \ 2
                
                Do While entriesCount > 0
                    
                    tCopyMemory IntPtr(relType), pData, 2
                    
                    Select Case (relType \ 4096) And &HF
                    Case IMAGE_REL_BASED_HIGHLOW
                        
                        ' // Calculate address
                        dwAddress = relBase.VirtualAddress + (relType And &HFFF&) + pBase
                        
                        ' // Get original address
                        tCopyMemory IntPtr(dwOrig), dwAddress, Len(dwOrig)
                        
                        ' // Add delta
                        dwOrig = dwOrig + delta
                        
                        ' // Save
                        tCopyMemory dwAddress, IntPtr(dwOrig), Len(dwOrig)
                        
                    End Select
                    
                    pData = pData + 2
                    entriesCount = entriesCount - 1
                    
                Loop
                
                ' // Next relocation base
                pRelBase = pRelBase + relBase.SizeOfBlock
                tCopyMemory IntPtr(relBase.VirtualAddress), pRelBase, Len(relBase)
                
            Loop
            
        End If
        
    End If
 
End Function

' // Set memory permissions
Private Function SetMemoryPermissions( _
                 ByVal pBase As Long) As ERROR_MESSAGES
    Dim iSec    As Long:                    Dim pNtHdr  As Long
    Dim NtHdr   As IMAGE_NT_HEADERS:        Dim sec     As IMAGE_SECTION_HEADER
    Dim Attr    As MEMPROTECT:              Dim pSec    As Long
    Dim ret     As Long
    
    pNtHdr = GetImageNtHeaders(pBase, NtHdr)
    If pNtHdr = 0 Then
        SetMemoryPermissions = EM_UNABLE_TO_GET_NT_HEADERS
        Exit Function
    End If
 
    ' // Get address of first section header
    pSec = pNtHdr + 4 + Len(NtHdr.FileHeader) + NtHdr.FileHeader.SizeOfOptionalHeader
    
    ' // Go thru section headers
    For iSec = 0 To NtHdr.FileHeader.NumberOfSections - 1
    
        ' // Copy section descriptor
        tCopyMemory IntPtr(sec.SectionName(0)), pSec, Len(sec)
        
        ' // Get type
        If sec.Characteristics And IMAGE_SCN_MEM_EXECUTE Then
            If sec.Characteristics And IMAGE_SCN_MEM_READ Then
                If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then
                    Attr = PAGE_EXECUTE_READWRITE
                Else
                    Attr = PAGE_EXECUTE_READ
                End If
            Else
                If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then
                    Attr = PAGE_EXECUTE_WRITECOPY
                Else
                    Attr = PAGE_EXECUTE
                End If
            End If
        Else
            If sec.Characteristics And IMAGE_SCN_MEM_READ Then
                If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then
                    Attr = PAGE_READWRITE
                Else
                    Attr = PAGE_READONLY
                End If
            Else
                If sec.Characteristics And IMAGE_SCN_MEM_WRITE Then
                    Attr = PAGE_WRITECOPY
                Else
                    Attr = PAGE_NOACCESS
                End If
            End If
        End If
        
        ' // Set memory permissions
        If tVirtualProtect(sec.VirtualAddress + pBase, sec.VirtualSize, Attr, IntPtr(ret)) = 0 Then
            SetMemoryPermissions = EM_UNABLE_TO_PROTECT_MEMORY
            Exit Function
        End If
        
        ' // Next section
        pSec = pSec + Len(sec)
        
    Next
    
End Function

' // Storage list item
Private Type BinStorageListItem
    ofstFileName        As Long            ' // Offset of file name
    ofstDestPath        As Long            ' // Offset of file path
    dwSizeOfFile        As Long            ' // Size of file
    ofstBeginOfData     As Long            ' // Offset of beginning data
    dwFlags             As FileFlags       ' // Flags
End Type
 
' // Execute list item
Private Type BinExecListItem
    ofstFileName        As Long            ' // Offset of file name
    ofstParameters      As Long            ' // Offset of parameters
    dwFlags             As ExeFlags        ' // Flags
End Type
 
' // Storage descriptor
Private Type BinStorageList
    dwSizeOfStructure   As Long            ' // Size of structure
    iExecutableIndex    As Long            ' // Index of main executable
    dwSizeOfItem        As Long            ' // Size of BinaryStorageItem structure
    dwNumberOfItems     As Long            ' // Number of files in storage
End Type
 
' // Execute list descriptor
Private Type BinExecList
    dwSizeOfStructure   As Long            ' // Size of structure
    dwSizeOfItem        As Long            ' // Size of BinaryExecuteItem structure
    dwNumberOfItems     As Long            ' // Number of items
End Type
 
' // Base information about project
Private Type BinProject
    dwSizeOfStructure   As Long            ' // Size of structure
    storageDescriptor   As BinStorageList  ' // Storage descriptor
    execListDescriptor  As BinExecList     ' // Command descriptor
    dwStringsTableLen   As Long            ' // Size of strings table
    dwFileTableLen      As Long            ' // Size of data table
End Type

Type IMAGE_DOS_HEADER
    e_magic                     As Integer
    e_cblp                      As Integer
    e_cp                        As Integer
    e_crlc                      As Integer
    e_cparhdr                   As Integer
    e_minalloc                  As Integer
    e_maxalloc                  As Integer
    e_ss                        As Integer
    e_sp                        As Integer
    e_csum                      As Integer
    e_ip                        As Integer
    e_cs                        As Integer
    e_lfarlc                    As Integer
    e_ovno                      As Integer
    e_res(0 To 3)               As Integer
    e_oemid                     As Integer
    e_oeminfo                   As Integer
    e_res2(0 To 9)              As Integer
    e_lfanew                    As Long
End Type

Type IMAGE_NT_HEADERS
    Signature                       As Long
    FileHeader                      As IMAGE_FILE_HEADER
    OptionalHeader                  As IMAGE_OPTIONAL_HEADER
End Type

Type IMAGE_FILE_HEADER
    Machine                         As Integer
    NumberOfSections                As Integer
    TimeDateStamp                   As Long
    PointerToSymbolTable            As Long
    NumberOfSymbols                 As Long
    SizeOfOptionalHeader            As Integer
    Characteristics                 As Integer
End Type

Type IMAGE_OPTIONAL_HEADER
    Magic                           As Integer
    MajorLinkerVersion              As Byte
    MinorLinkerVersion              As Byte
    SizeOfCode                      As Long
    SizeOfInitializedData           As Long
    SizeOfUnitializedData           As Long
    AddressOfEntryPoint             As Long
    BaseOfCode                      As Long
    BaseOfData                      As Long
    ImageBase                       As Long
    SectionAlignment                As Long
    FileAlignment                   As Long
    MajorOperatingSystemVersion     As Integer
    MinorOperatingSystemVersion     As Integer
    MajorImageVersion               As Integer
    MinorImageVersion               As Integer
    MajorSubsystemVersion           As Integer
    MinorSubsystemVersion           As Integer
    W32VersionValue                 As Long
    SizeOfImage                     As Long
    SizeOfHeaders                   As Long
    CheckSum                        As Long
    SubSystem                       As Integer
    DllCharacteristics              As Integer
    SizeOfStackReserve              As Long
    SizeOfStackCommit               As Long
    SizeOfHeapReserve               As Long
    SizeOfHeapCommit                As Long
    LoaderFlags                     As Long
    NumberOfRvaAndSizes             As Long
    DataDirectory(15)               As IMAGE_DATA_DIRECTORY
End Type

Type IMAGE_SECTION_HEADER
    SectionName(7)              As Byte
    VirtualSize                 As Long
    VirtualAddress              As Long
    SizeOfRawData               As Long
    PointerToRawData            As Long
    PointerToRelocations        As Long
    PointerToLinenumbers        As Long
    NumberOfRelocations         As Integer
    NumberOfLinenumbers         As Integer
    Characteristics             As Long
End Type

' // RVA to RAW
Function RVA2RAW( _
                 ByVal rva As Long, _
                 ByRef sec() As IMAGE_SECTION_HEADER) As Long
    Dim index As Long
    
    For index = 0 To UBound(sec)
        
        If rva >= sec(index).VirtualAddress And _
           rva < sec(index).VirtualAddress + sec(index).VirtualSize Then
            RVA2RAW = sec(index).PointerToRawData + (rva - sec(index).VirtualAddress)
            Exit Function
        End If
        
    Next
    
    RVA2RAW = rva
    
End Function

Private Type IMAGE_DATA_DIRECTORY
    VirtualAddress                  As Long
    Size                            As Long
End Type

Type IMAGE_RESOURCE_DIRECTORY
    Characteristics             As Long
    TimeDateStamp               As Long
    MajorVersion                As Integer
    MinorVersion                As Integer
    NumberOfNamedEntries        As Integer
    NumberOfIdEntries           As Integer
End Type

Type IMAGE_RESOURCE_DIRECTORY_ENTRY
    NameId                      As Long
    OffsetToData                As Long
End Type

Type IMAGE_RESOURCE_DIR_STRING_U
    Length                      As Integer
    NameString                  As String
End Type

Type IMAGE_RESOURCE_DATA_ENTRY
    OffsetToData                As Long
    Size                        As Long
    CodePage                    As Long
    Reserved                    As Long
End Type

' // Startup subroutine
Sub Main()
 
    ' // Load constants
    If Not LoadConstants Then
        MessageBox 0, GetString(MID_ERRORLOADINGCONST), 0, MB_ICONERROR Or MB_SYSTEMMODAL
        GoTo EndOfProcess
    End If
    
    ' // Load project
    If Not ReadProject Then
        MessageBox 0, GetString(MID_ERRORREADINGPROJECT), 0, MB_ICONERROR Or MB_SYSTEMMODAL
        GoTo EndOfProcess
    End If
    
    ' // Copying from storage
    If Not CopyProcess Then GoTo EndOfProcess
    
    ' // Execution process
    If Not ExecuteProcess Then GoTo EndOfProcess
    
    ' // If main executable is not presented exit
    If ProjectDesc.storageDescriptor.iExecutableIndex = -1 Then GoTo EndOfProcess
    
    ' // Run exe from memory
    If Not RunProcess Then
        ' // Error occrurs
        MessageBox 0, GetString(MID_ERRORSTARTUPEXE), 0, MB_ICONERROR Or MB_SYSTEMMODAL
    End If
    
EndOfProcess:
    
    If pProjectData Then
        HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pProjectData
    End If
    
    ExitProcess 0
    
End Sub

' // modConstants.bas - main module for loading constants
' // © Krivous Anatoly Anatolevich (The trick), 2016
 
Option Explicit
 
Public Enum MessagesID
    MID_ERRORLOADINGCONST = 100     ' // Errors
    MID_ERRORREADINGPROJECT = 101   '
    MID_ERRORCOPYINGFILE = 102      '
    MID_ERRORWIN32 = 103            '
    MID_ERROREXECUTELINE = 104      '
    MID_ERRORSTARTUPEXE = 105       '
    PROJECT = 200                   ' // Project resource ID
    API_LIB_KERNEL32 = 300          ' // Library names
    API_LIB_NTDLL = 350             '
    API_LIB_USER32 = 400            '
    MSG_LOADER_ERROR = 500
End Enum
 
' // Paths
 
Public pAppPath  As Long            ' // Path to application
Public pSysPath  As Long            ' // Path to System32
Public pTmpPath  As Long            ' // Path to Temp
Public pWinPath  As Long            ' // Path to Windows
Public pDrvPath  As Long            ' // Path to system drive
Public pDtpPath  As Long            ' // Path to desktop
 
' // Substitution constants
 
Public pAppRepl  As Long
Public pSysRepl  As Long
Public pTmpRepl  As Long
Public pWinRepl  As Long
Public pDrvRepl  As Long
Public pDtpRepl  As Long
Public pStrNull  As Long            ' // \0
 
Public hInstance    As Long         ' // Base address
Public lpCmdLine    As Long         ' // Command line
Public SI           As STARTUPINFO  ' // Startup parameters
Public LCID         As Long         ' // LCID
 
' // Load constants
Function LoadConstants() As Boolean
    Dim lSize   As Long
    Dim pBuf    As Long
    Dim index   As Long
    Dim ctl     As tagINITCOMMONCONTROLSEX
    
    ' // Load windows classes
    ctl.dwSize = Len(ctl)
    ctl.dwICC = &H3FFF&
    InitCommonControlsEx ctl
    
    ' // Get startup parameters
    GetStartupInfo SI
    
    ' // Get command line
    lpCmdLine = GetCommandLine()
    
    ' // Get base address
    hInstance = GetModuleHandle(ByVal 0&)
    
    ' // Get LCID
    LCID = GetUserDefaultLCID()
    
    ' // Alloc memory for strings
    pBuf = SysAllocStringLen(0, MAX_PATH)
    If pBuf = 0 Then Exit Function
    
    ' // Get path to process file name
    If GetModuleFileName(hInstance, pBuf, MAX_PATH) = 0 Then GoTo CleanUp
    
    ' // Leave only directory
    PathRemoveFileSpec pBuf
    
    ' // Save path
    pAppPath = SysAllocString(pBuf)
    
    ' // Get Windows folder
    If GetWindowsDirectory(pBuf, MAX_PATH) = 0 Then GoTo CleanUp
    pWinPath = SysAllocString(pBuf)
    
    ' // Get System32 folder
    If GetSystemDirectory(pBuf, MAX_PATH) = 0 Then GoTo CleanUp
    pSysPath = SysAllocString(pBuf)
    
    ' // Get Temp directory
    If GetTempPath(MAX_PATH, pBuf) = 0 Then GoTo CleanUp
    pTmpPath = SysAllocString(pBuf)
    
    ' // Get system drive
    PathStripToRoot pBuf
    pDrvPath = SysAllocString(pBuf)
    
    ' // Get desktop path
    If SHGetFolderPath(0, CSIDL_DESKTOPDIRECTORY, 0, SHGFP_TYPE_CURRENT, pBuf) Then GoTo CleanUp
    pDtpPath = SysAllocString(pBuf)
    
    ' // Load wildcards
    For index = 1 To 6
        If LoadString(hInstance, index, pBuf, MAX_PATH) = 0 Then GoTo CleanUp
        Select Case index
        Case 1: pAppRepl = SysAllocString(pBuf)
        Case 2: pSysRepl = SysAllocString(pBuf)
        Case 3: pTmpRepl = SysAllocString(pBuf)
        Case 4: pWinRepl = SysAllocString(pBuf)
        Case 5: pDrvRepl = SysAllocString(pBuf)
        Case 6: pDtpRepl = SysAllocString(pBuf)
        End Select
    Next
    
    ' // vbNullChar
    pStrNull = SysAllocStringLen(0, 0)
 
    ' // Success
    LoadConstants = True
    
CleanUp:
    
    If pBuf Then SysFreeString pBuf
    
End Function
 
' // Obtain string from resource (it should be less or equal MAX_PATH)
Public Function GetString( _
                ByVal ID As MessagesID) As Long
                
    GetString = SysAllocStringLen(0, MAX_PATH)
    
    If GetString Then
    
        If LoadString(hInstance, ID, GetString, MAX_PATH) = 0 Then SysFreeString GetString: GetString = 0: Exit Function
        If SysReAllocString(GetString, GetString) = 0 Then SysFreeString GetString: GetString = 0: Exit Function
        
    End If
    
End Function

' // Load project
Function ReadProject() As Boolean
    Dim hResource       As Long:                Dim hMememory       As Long
    Dim lResSize        As Long:                Dim pRawData        As Long
    Dim status          As Long:                Dim pUncompressed   As Long
    Dim lUncompressSize As Long:                Dim lResultSize     As Long
    Dim tmpStorageItem  As BinStorageListItem:  Dim tmpExecuteItem  As BinExecListItem
    Dim pLocalBuffer    As Long
    
    ' // Load resource
    hResource = FindResource(hInstance, GetString(PROJECT), RT_RCDATA)
    If hResource = 0 Then GoTo CleanUp
    
    hMememory = LoadResource(hInstance, hResource)
    If hMememory = 0 Then GoTo CleanUp
    
    lResSize = SizeofResource(hInstance, hResource)
    If lResSize = 0 Then GoTo CleanUp
    
    pRawData = LockResource(hMememory)
    If pRawData = 0 Then GoTo CleanUp
    
    pLocalBuffer = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, lResSize)
    If pLocalBuffer = 0 Then GoTo CleanUp
    
    ' // Copy to local buffer
    CopyMemory ByVal pLocalBuffer, ByVal pRawData, lResSize
    
    ' // Set default size
    lUncompressSize = lResSize * 2
    
    ' // Do decompress...
    Do
        
        If pUncompressed Then
            pUncompressed = HeapReAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, ByVal pUncompressed, lUncompressSize)
        Else
            pUncompressed = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, lUncompressSize)
        End If
        
        status = RtlDecompressBuffer(COMPRESSION_FORMAT_LZNT1, _
                                     ByVal pUncompressed, lUncompressSize, _
                                     ByVal pLocalBuffer, lResSize, lResultSize)
        
        lUncompressSize = lUncompressSize * 2
        
    Loop While status = STATUS_BAD_COMPRESSION_BUFFER
    
    pProjectData = pUncompressed
    
    If status Then GoTo CleanUp
 
    ' // Validation check
    If lResultSize < LenB(ProjectDesc) Then GoTo CleanUp
    
    ' // Copy descriptor
    CopyMemory ProjectDesc, ByVal pProjectData, LenB(ProjectDesc)
    
    ' // Check all members
    If ProjectDesc.dwSizeOfStructure <> Len(ProjectDesc) Then GoTo CleanUp
    If ProjectDesc.storageDescriptor.dwSizeOfStructure <> Len(ProjectDesc.storageDescriptor) Then GoTo CleanUp
    If ProjectDesc.storageDescriptor.dwSizeOfItem <> Len(tmpStorageItem) Then GoTo CleanUp
    If ProjectDesc.execListDescriptor.dwSizeOfStructure <> Len(ProjectDesc.execListDescriptor) Then GoTo CleanUp
    If ProjectDesc.execListDescriptor.dwSizeOfItem <> Len(tmpExecuteItem) Then GoTo CleanUp
    
    ' // Initialize pointers
    pStoragesTable = pProjectData + ProjectDesc.dwSizeOfStructure
    pExecutesTable = pStoragesTable + ProjectDesc.storageDescriptor.dwSizeOfItem * ProjectDesc.storageDescriptor.dwNumberOfItems
    pFilesTable = pExecutesTable + ProjectDesc.execListDescriptor.dwSizeOfItem * ProjectDesc.execListDescriptor.dwNumberOfItems
    pStringsTable = pFilesTable + ProjectDesc.dwFileTableLen
    
    ' // Check size
    If (pStringsTable + ProjectDesc.dwStringsTableLen - pProjectData) <> lResultSize Then GoTo CleanUp
    
    ' // Success
    ReadProject = True
    
CleanUp:
    
    If pLocalBuffer Then HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pLocalBuffer
    
    If Not ReadProject And pProjectData Then
        HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, pProjectData
    End If
    
End Function

' // Copying process
Function CopyProcess() As Boolean
    Dim bItem       As BinStorageListItem:  Dim index       As Long
    Dim pPath       As Long:                Dim dwWritten   As Long
    Dim msg         As Long:                Dim lStep       As Long
    Dim isError     As Boolean:             Dim pItem       As Long
    Dim pErrMsg     As Long:                Dim pTempString As Long
    
    ' // Set pointer
    pItem = pStoragesTable
    
    ' // Go thru file list
    For index = 0 To ProjectDesc.storageDescriptor.dwNumberOfItems - 1
 
        ' // Copy file descriptor
        CopyMemory bItem, ByVal pItem, Len(bItem)
        
        ' // Next item
        pItem = pItem + ProjectDesc.storageDescriptor.dwSizeOfItem
        
        ' // If it is not main executable
        If index <> ProjectDesc.storageDescriptor.iExecutableIndex Then
        
            ' // Normalize path
            pPath = NormalizePath(pStringsTable + bItem.ofstDestPath, pStringsTable + bItem.ofstFileName)
            
            ' // Error occurs
            If pPath = 0 Then
            
                pErrMsg = GetString(MID_ERRORWIN32)
                MessageBox 0, pErrMsg, 0, MB_ICONERROR Or MB_SYSTEMMODAL
                GoTo CleanUp
                
            Else
                Dim hFile   As Long
                Dim disp    As CREATIONDISPOSITION
                
                ' // Set overwrite flags
                If bItem.dwFlags And FF_REPLACEONEXIST Then disp = CREATE_ALWAYS Else disp = CREATE_NEW
                
                ' // Set number of subroutine
                lStep = 0
                
                ' // Run subroutines
                Do
                    ' // Disable error flag
                    isError = False
                    
                    ' // Free string
                    If pErrMsg Then SysFreeString pErrMsg: pErrMsg = 0
                    
                    ' // Choose subroutine
                    Select Case lStep
                    Case 0  ' // 0. Create folder
                    
                        If Not CreateSubdirectories(pPath) Then isError = True
                        
                    Case 1  ' // 1. Create file
                    
                        hFile = CreateFile(pPath, FILE_GENERIC_WRITE, 0, ByVal 0&, disp, FILE_ATTRIBUTE_NORMAL, 0)
                        If hFile = INVALID_HANDLE_VALUE Then
                            If GetLastError = ERROR_FILE_EXISTS Then Exit Do
                            isError = True
                        End If
                        
                    Case 2  ' // 2. Copy data to file
                    
                        If WriteFile(hFile, ByVal pFilesTable + bItem.ofstBeginOfData, _
                                     bItem.dwSizeOfFile, dwWritten, ByVal 0&) = 0 Then isError = True
                                     
                        If dwWritten <> bItem.dwSizeOfFile Then
                            isError = True
                        Else
                            CloseHandle hFile: hFile = INVALID_HANDLE_VALUE
                        End If
                        
                    End Select
                    
                    ' // If error occurs show notification (retry, abort, ignore)
                    If isError Then
                    
                        ' // Ignore error
                        If bItem.dwFlags And FF_IGNOREERROR Then Exit Do
 
                        pTempString = GetString(MID_ERRORCOPYINGFILE)
                        pErrMsg = StrCat(pTempString, pPath)
                        
                        ' // Cleaning
                        SysFreeString pTempString: pTempString = 0
                        
                        Select Case MessageBox(0, pErrMsg, 0, MB_ICONERROR Or MB_SYSTEMMODAL Or MB_CANCELTRYCONTINUE)
                        Case MESSAGEBOXRETURN.IDCONTINUE: Exit Do
                        Case MESSAGEBOXRETURN.IDTRYAGAIN
                        Case Else:  GoTo CleanUp
                        End Select
                        
                    Else: lStep = lStep + 1
                    End If
                    
                Loop While lStep <= 2
                        
                If hFile <> INVALID_HANDLE_VALUE Then
                    CloseHandle hFile: hFile = INVALID_HANDLE_VALUE
                End If
                
                ' // Cleaning
                SysFreeString pPath: pPath = 0
                
            End If
            
        End If
        
    Next
    
    ' // Success
    CopyProcess = True
    
CleanUp:
    
    If pTempString Then SysFreeString pTempString
    If pErrMsg Then SysFreeString pErrMsg
    If pPath Then SysFreeString pPath
    
    If hFile <> INVALID_HANDLE_VALUE Then
        CloseHandle hFile
        hFile = INVALID_HANDLE_VALUE
    End If
    
End Function

' // Create all subdirectories by path
Function CreateSubdirectories( _
                ByVal pPath As Long) As Boolean
    Dim pComponent As Long
    Dim tChar      As Integer
    
    ' // Pointer to first char
    pComponent = pPath
    
    ' // Go thru path components
    Do
    
        ' // Get next component
        pComponent = PathFindNextComponent(pComponent)
        
        ' // Check if end of line
        CopyMemory tChar, ByVal pComponent, 2
        If tChar = 0 Then Exit Do
        
        ' // Write null-terminator
        CopyMemory ByVal pComponent - 2, 0, 2
        
        ' // Check if path exists
        If PathIsDirectory(pPath) = 0 Then
        
            ' // Create folder
            If CreateDirectory(pPath, ByVal 0&) = 0 Then
                ' // Error
                CopyMemory ByVal pComponent - 2, &H5C, 2
                Exit Function
            End If
            
        End If
        
        ' // Restore path delimiter
        CopyMemory ByVal pComponent - 2, &H5C, 2
        
    Loop
    
    ' // Success
    CreateSubdirectories = True
    
End Function
 
' // Get normalize path (replace wildcards, append file name)
Function NormalizePath( _
                ByVal pPath As Long, _
                ByVal pTitle As Long) As Long
    Dim lPathLen    As Long:    Dim lRelacerLen As Long
    Dim lTitleLen   As Long:    Dim pRelacer    As Long
    Dim lTotalLen   As Long:    Dim lPtr        As Long
    Dim pTempString As Long:    Dim pRetString  As Long
    
    ' // Determine wildcard
    Select Case True
    Case IntlStrEqWorker(0, pPath, pAppRepl, 5): pRelacer = pAppPath
    Case IntlStrEqWorker(0, pPath, pSysRepl, 5): pRelacer = pSysPath
    Case IntlStrEqWorker(0, pPath, pTmpRepl, 5): pRelacer = pTmpPath
    Case IntlStrEqWorker(0, pPath, pWinRepl, 5): pRelacer = pWinPath
    Case IntlStrEqWorker(0, pPath, pDrvRepl, 5): pRelacer = pDrvPath
    Case IntlStrEqWorker(0, pPath, pDtpRepl, 5): pRelacer = pDtpPath
    Case Else: pRelacer = pStrNull
    End Select
    
    ' // Get string size
    lPathLen = lstrlen(ByVal pPath)
    lRelacerLen = lstrlen(ByVal pRelacer)
    
    ' // Skip wildcard
    If lRelacerLen Then
        pPath = pPath + 5 * 2
        lPathLen = lPathLen - 5
    End If
    
    If pTitle Then lTitleLen = lstrlen(ByVal pTitle)
    
    ' // Get length all strings
    lTotalLen = lPathLen + lRelacerLen + lTitleLen
    
    ' // Check overflow (it should be les or equal MAX_PATH)
    If lTotalLen > MAX_PATH Then Exit Function
    
    ' // Create string
    pTempString = SysAllocStringLen(0, MAX_PATH)
    If pTempString = 0 Then Exit Function
    
    ' // Copy
    lstrcpyn ByVal pTempString, ByVal pRelacer, lRelacerLen + 1
    lstrcat ByVal pTempString, ByVal pPath
 
    ' // If title is presented append
    If pTitle Then
 
        ' // Error
        If PathAddBackslash(pTempString) = 0 Then GoTo CleanUp
 
        ' // Copy file name
        lstrcat ByVal pTempString, ByVal pTitle
        
    End If
    
    ' // Alloc memory for translation relative path to absolute
    pRetString = SysAllocStringLen(0, MAX_PATH)
    If pRetString = 0 Then GoTo CleanUp
    
    ' // Normalize
    If PathCanonicalize(pRetString, pTempString) = 0 Then GoTo CleanUp
    
    NormalizePath = pRetString
    
CleanUp:
    
    If pTempString Then SysFreeString pTempString
    If pRetString <> 0 And NormalizePath = 0 Then SysFreeString pRetString
    
End Function
 
' // Concatenation strings
Function StrCat( _
                ByVal pStringDest As Long, _
                ByVal pStringAppended As Long) As Long
    Dim l1 As Long, l2 As Long
    
    l1 = lstrlen(ByVal pStringDest): l2 = lstrlen(ByVal pStringAppended)
    StrCat = SysAllocStringLen(0, l1 + l2)
    
    If StrCat = 0 Then Exit Function
    
    lstrcpyn ByVal StrCat, ByVal pStringDest, l1 + 1
    lstrcat ByVal StrCat, ByVal pStringAppended
    
End Function

Public Function MMXAdd( _
                ByRef dest As Integer, _
                ByRef src As Integer, _
                ByVal count As Long) As Long
End Function

Private Sub Form_Load()
    Dim src()   As Integer
    Dim dst()   As Integer
    Dim size    As Long
    Dim index   As Long
    
    size = 1024
    
    ReDim src(size - 1)
    ReDim dst(size - 1)
    
    For index = 0 To size - 1
        ' // Fill arrays with sine
        src(index) = Sin(index / 40) * 20000
        dst(index) = Sin(index / 23) * 20000
    Next
    
    ' // Add with saturation
    MMXAdd dst(0), src(0), size
    
    '// Draw result
    AutoRedraw = True
    
    Scale (0, 32767)-(index, -32768)
    
    For index = 0 To size - 1
        If index Then
            Me.Line -(index, dst(index))
        Else
            Me.PSet (index, dst(index))
        End If
    Next
    
End Sub

' The module modTrickUnregCOM.bas - for working with COM libraries without registration.
' © Krivous Anatolii Anatolevich (The trick), 2015
 
Option Explicit
 
Public Type GUID
    data1       As Long
    data2       As Integer
    data3       As Integer
    data4(7)    As Byte
End Type
 
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
                         ByVal lpszCLSID As Long, _
                         ByRef clsid As GUID) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                         ByRef src As Any, _
                         ByRef dst As Any) As Long
Private Declare Function SysFreeString Lib "oleaut32" ( _
                         ByVal lpbstr As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" _
                         Alias "LoadLibraryW" ( _
                         ByVal lpLibFileName As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" ( _
                         ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                         ByVal hModule As Long, _
                         ByVal lpProcName As String) As Long
Private Declare Function DispCallFunc Lib "oleaut32" ( _
                         ByVal pvInstance As Any, _
                         ByVal oVft As Long, _
                         ByVal cc As Integer, _
                         ByVal vtReturn As Integer, _
                         ByVal cActuals As Long, _
                         ByRef prgvt As Any, _
                         ByRef prgpvarg As Any, _
                         ByRef pvargResult As Variant) As Long
Private Declare Function LoadTypeLibEx Lib "oleaut32" ( _
                         ByVal szFile As Long, _
                         ByVal regkind As Long, _
                         ByRef pptlib As IUnknown) As Long
Private Declare Function memcpy Lib "kernel32" _
                         Alias "RtlMoveMemory" ( _
                         ByRef Destination As Any, _
                         ByRef Source As Any, _
                         ByVal Length As Long) As Long
Private Declare Function CreateStdDispatch Lib "oleaut32" ( _
                         ByVal punkOuter As IUnknown, _
                         ByVal pvThis As IUnknown, _
                         ByVal ptinfo As IUnknown, _
                         ByRef ppunkStdDisp As IUnknown) As Long
                         
Private Const IID_IClassFactory   As String = "{00000001-0000-0000-C000-000000000046}"
Private Const IID_IUnknown        As String = "{00000000-0000-0000-C000-000000000046}"
Private Const CC_STDCALL          As Long = 4
Private Const REGKIND_NONE        As Long = 2
Private Const TKIND_COCLASS       As Long = 5
Private Const TKIND_DISPATCH      As Long = 4
Private Const TKIND_INTERFACE     As Long = 3
 
Dim iidClsFctr      As GUID
Dim iidUnk          As GUID
Dim isInit          As Boolean
 
' // Get all co-classes described in type library.
Public Function GetAllCoclasses( _
                ByRef path As String, _
                ByRef listOfClsid() As GUID, _
                ByRef listOfNames() As String, _
                ByRef countCoClass As Long) As Boolean
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim count   As Long
    Dim index   As Long
    Dim pAttr   As Long
    Dim tKind   As Long
    
    ret = LoadTypeLibEx(StrPtr(path), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    count = ITypeLib_GetTypeInfoCount(typeLib)
    countCoClass = 0
    
    If count > 0 Then
    
        ReDim listOfClsid(count - 1)
        ReDim listOfNames(count - 1)
        
        For index = 0 To count - 1
        
            ret = ITypeLib_GetTypeInfo(typeLib, index, typeInf)
                        
            If ret Then
                Err.Raise ret
                Exit Function
            End If
            
            ITypeInfo_GetTypeAttr typeInf, pAttr
            
            GetMem4 ByVal pAttr + &H28, tKind
            
            If tKind = TKIND_COCLASS Then
            
                memcpy listOfClsid(countCoClass), ByVal pAttr, Len(listOfClsid(countCoClass))
                ret = ITypeInfo_GetDocumentation(typeInf, -1, listOfNames(countCoClass), vbNullString, 0, vbNullString)
                
                If ret Then
                    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
                    Err.Raise ret
                    Exit Function
                End If
                
                countCoClass = countCoClass + 1
                
            End If
            
            ITypeInfo_ReleaseTypeAttr typeInf, pAttr
            
            Set typeInf = Nothing
            
        Next
        
    End If
    
    If countCoClass Then
        
        ReDim Preserve listOfClsid(countCoClass - 1)
        ReDim Preserve listOfNames(countCoClass - 1)
    
    Else
    
        Erase listOfClsid()
        Erase listOfNames()
        
    End If
    
    GetAllCoclasses = True
    
End Function
 
' // Create IDispach implementation described in type library.
Public Function CreateIDispatch( _
                ByRef obj As IUnknown, _
                ByRef typeLibPath As String, _
                ByRef interfaceName As String) As Object
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim retObj  As IUnknown
    Dim pAttr   As Long
    Dim tKind   As Long
    
    ret = LoadTypeLibEx(StrPtr(typeLibPath), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    ret = ITypeLib_FindName(typeLib, interfaceName, 0, typeInf, 0, 1)
    
    If typeInf Is Nothing Then
        Err.Raise &H80004002, , "Interface not found"
        Exit Function
    End If
    
    ITypeInfo_GetTypeAttr typeInf, pAttr
    GetMem4 ByVal pAttr + &H28, tKind
    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
    
    If tKind = TKIND_DISPATCH Then
        Set CreateIDispatch = obj
        Exit Function
    ElseIf tKind <> TKIND_INTERFACE Then
        Err.Raise &H80004002, , "Interface not found"
        Exit Function
    End If
  
    ret = CreateStdDispatch(Nothing, obj, typeInf, retObj)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    Set CreateIDispatch = retObj
 
End Function
 
' // Create object by Name.
Public Function CreateObjectEx2( _
                ByRef pathToDll As String, _
                ByRef pathToTLB As String, _
                ByRef className As String) As IUnknown
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim pAttr   As Long
    Dim tKind   As Long
    Dim clsid   As GUID
    
    ret = LoadTypeLibEx(StrPtr(pathToTLB), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    ret = ITypeLib_FindName(typeLib, className, 0, typeInf, 0, 1)
    
    If typeInf Is Nothing Then
        Err.Raise &H80040111, , "Class not found in type library"
        Exit Function
    End If
 
    ITypeInfo_GetTypeAttr typeInf, pAttr
    
    GetMem4 ByVal pAttr + &H28, tKind
    
    If tKind = TKIND_COCLASS Then
        memcpy clsid, ByVal pAttr, Len(clsid)
    Else
        Err.Raise &H80040111, , "Class not found in type library"
        Exit Function
    End If
    
    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
            
    Set CreateObjectEx2 = CreateObjectEx(pathToDll, clsid)
    
End Function
                
' // Create object by CLSID and path.
Public Function CreateObjectEx( _
                ByRef path As String, _
                ByRef clsid As GUID) As IUnknown
                
    Dim hLib    As Long
    Dim lpAddr  As Long
    Dim isLoad  As Boolean
    
    hLib = GetModuleHandle(StrPtr(path))
    
    If hLib = 0 Then
    
        hLib = LoadLibrary(StrPtr(path))
        If hLib = 0 Then
            Err.Raise 53, , Error(53) & " " & Chr$(34) & path & Chr$(34)
            Exit Function
        End If
        
        isLoad = True
        
    End If
    
    lpAddr = GetProcAddress(hLib, "DllGetClassObject")
    
    If lpAddr = 0 Then
        If isLoad Then FreeLibrary hLib
        Err.Raise 453, , "Can't find dll entry point DllGetClasesObject in " & Chr$(34) & path & Chr$(34)
        Exit Function
    End If
 
    If Not isInit Then
        CLSIDFromString StrPtr(IID_IClassFactory), iidClsFctr
        CLSIDFromString StrPtr(IID_IUnknown), iidUnk
        isInit = True
    End If
    
    Dim ret     As Long
    Dim out     As IUnknown
    
    ret = DllGetClassObject(lpAddr, clsid, iidClsFctr, out)
    
    If ret = 0 Then
 
        ret = IClassFactory_CreateInstance(out, 0, iidUnk, CreateObjectEx)
    
    Else
    
        If isLoad Then FreeLibrary hLib
        Err.Raise ret
        Exit Function
        
    End If
    
    Set out = Nothing
    
    If ret Then
    
        If isLoad Then FreeLibrary hLib
        Err.Raise ret
 
    End If
    
End Function
 
' // Unload DLL if not used.
Public Function UnloadLibrary( _
                ByRef path As String) As Boolean
                
    Dim hLib    As Long
    Dim lpAddr  As Long
    Dim ret     As Long
    
    If Not isInit Then Exit Function
    
    hLib = GetModuleHandle(StrPtr(path))
    If hLib = 0 Then Exit Function
    
    lpAddr = GetProcAddress(hLib, "DllCanUnloadNow")
    If lpAddr = 0 Then Exit Function
    
    ret = DllCanUnloadNow(lpAddr)
    
    If ret = 0 Then
        FreeLibrary hLib
        UnloadLibrary = True
    End If
    
End Function
 
' // Call "DllGetClassObject" function using a pointer.
Private Function DllGetClassObject( _
                 ByVal funcAddr As Long, _
                 ByRef clsid As GUID, _
                 ByRef iid As GUID, _
                 ByRef out As IUnknown) As Long
                 
    Dim params(2)   As Variant
    Dim types(2)    As Integer
    Dim list(2)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = VarPtr(clsid)
    params(1) = VarPtr(iid)
    params(2) = VarPtr(out)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
             
    If resultCall Then Err.Raise 5: Exit Function
    
    DllGetClassObject = pReturn
    
End Function
 
' // Call "DllCanUnloadNow" function using a pointer.
Private Function DllCanUnloadNow( _
                 ByVal funcAddr As Long) As Long
                 
    Dim resultCall  As Long
    Dim pReturn     As Variant
    
    resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
             
    If resultCall Then Err.Raise 5: Exit Function
    
    DllCanUnloadNow = pReturn
    
End Function
 
' // Call "IClassFactory:CreateInstance" method.
Private Function IClassFactory_CreateInstance( _
                 ByVal obj As IUnknown, _
                 ByVal punkOuter As Long, _
                 ByRef riid As GUID, _
                 ByRef out As IUnknown) As Long
    
    Dim params(2)   As Variant
    Dim types(2)    As Integer
    Dim list(2)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = punkOuter
    params(1) = VarPtr(riid)
    params(2) = VarPtr(out)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    IClassFactory_CreateInstance = pReturn
    
End Function
 
' // Call "ITypeLib:GetTypeInfoCount" method.
Private Function ITypeLib_GetTypeInfoCount( _
                 ByVal obj As IUnknown) As Long
    
    Dim resultCall  As Long
    Dim pReturn     As Variant
 
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_GetTypeInfoCount = pReturn
    
End Function
 
' // Call "ITypeLib:GetTypeInfo" method.
Private Function ITypeLib_GetTypeInfo( _
                 ByVal obj As IUnknown, _
                 ByVal index As Long, _
                 ByRef ppTInfo As IUnknown) As Long
    
    Dim params(1)   As Variant
    Dim types(1)    As Integer
    Dim list(1)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = index
    params(1) = VarPtr(ppTInfo)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H10, CC_STDCALL, vbLong, 2, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_GetTypeInfo = pReturn
    
End Function
 
' // Call "ITypeLib:FindName" method.
Private Function ITypeLib_FindName( _
                 ByVal obj As IUnknown, _
                 ByRef szNameBuf As String, _
                 ByVal lHashVal As Long, _
                 ByRef ppTInfo As IUnknown, _
                 ByRef rgMemId As Long, _
                 ByRef pcFound As Integer) As Long
    
    Dim params(4)   As Variant
    Dim types(4)    As Integer
    Dim list(4)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = StrPtr(szNameBuf)
    params(1) = lHashVal
    params(2) = VarPtr(ppTInfo)
    params(3) = VarPtr(rgMemId)
    params(4) = VarPtr(pcFound)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H2C, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_FindName = pReturn
    
End Function
 
' // Call "ITypeInfo:GetTypeAttr" method.
Private Sub ITypeInfo_GetTypeAttr( _
            ByVal obj As IUnknown, _
            ByRef ppTypeAttr As Long)
    
    Dim resultCall  As Long
    Dim pReturn     As Variant
    
    pReturn = VarPtr(ppTypeAttr)
    
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(pReturn), 0)
          
    If resultCall Then Err.Raise resultCall: Exit Sub
 
End Sub
 
' // Call "ITypeInfo:GetDocumentation" method.
Private Function ITypeInfo_GetDocumentation( _
                 ByVal obj As IUnknown, _
                 ByVal memid As Long, _
                 ByRef pBstrName As String, _
                 ByRef pBstrDocString As String, _
                 ByRef pdwHelpContext As Long, _
                 ByRef pBstrHelpFile As String) As Long
    
    Dim params(4)   As Variant
    Dim types(4)    As Integer
    Dim list(4)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = memid
    params(1) = VarPtr(pBstrName)
    params(2) = VarPtr(pBstrDocString)
    params(3) = VarPtr(pdwHelpContext)
    params(4) = VarPtr(pBstrHelpFile)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H30, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeInfo_GetDocumentation = pReturn
    
End Function
 
' // Call "ITypeInfo:ReleaseTypeAttr" method.
Private Sub ITypeInfo_ReleaseTypeAttr( _
            ByVal obj As IUnknown, _
            ByVal ppTypeAttr As Long)
    
    Dim resultCall  As Long
    
    resultCall = DispCallFunc(obj, &H4C, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(ppTypeAttr)), 0)
          
    If resultCall Then Err.Raise resultCall: Exit Sub
 
End Sub

' Class clsTrickMP3Player.cls - for asynchronous play mp3-files from memory.
' © Krivous Anatolii Anatolevich (The trick), 2015
' Version 1.1
 
Option Explicit
 
Private Type WNDCLASSEX
    cbSize              As Long
    style               As Long
    lpfnwndproc         As Long
    cbClsextra          As Long
    cbWndExtra2         As Long
    hInstance           As Long
    hIcon               As Long
    hCursor             As Long
    hbrBackground       As Long
    lpszMenuName        As Long
    lpszClassName       As Long
    hIconSm             As Long
End Type
 
Private Type MPEGLAYER3WAVEFORMAT
    wFormatTag          As Integer
    nChannels           As Integer
    nSamplesPerSec      As Long
    nAvgBytesPerSec     As Long
    nBlockAlign         As Integer
    wBitsPerSample      As Integer
    cbSize              As Integer
    wID                 As Integer
    fdwFlags            As Long
    nBlockSize          As Integer
    nFramesPerBlock     As Integer
    nCodecDelay         As Integer
End Type
 
Private Type FrameInfo
    offset              As Long
    bitrate             As Long
End Type
 
Private Type Mp3Info
    format              As MPEGLAYER3WAVEFORMAT
    lpFrameOffset       As Long
    szDataSize          As Long
    samplesPerFrame     As Long
    framesCount         As Long
    frameOffset()       As FrameInfo
End Type
 
Private Type WAVEHDR
    lpData              As Long
    dwBufferLength      As Long
    dwBytesRecorded     As Long
    dwUser              As Long
    dwFlags             As Long
    dwLoops             As Long
    lpNext              As Long
    Reserved            As Long
End Type
 
Private Type mp3Buffer
    header              As WAVEHDR
    status              As Boolean
End Type
 
Private Type mp3Const
    bitrate(1, 15)      As Integer
    smprate(2, 3)       As Long
End Type
 
Private Type curBuffer
    b(15)               As Currency
End Type
 
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetMem8 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, lpValue As Any) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, lpBuffer As Any, ByVal nSize As Long) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassW" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExW" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, dwRefData As Any) As Long
Private Declare Function RemoveWindowSubclass Lib "Comctl32" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "Comctl32" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function waveOutOpen Lib "winmm" (lphWaveOut As Long, ByVal uDeviceID As Long, lpFormat As Any, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function waveOutPrepareHeader Lib "winmm" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutWrite Lib "winmm" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutUnprepareHeader Lib "winmm" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutClose Lib "winmm" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutReset Lib "winmm" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutPause Lib "winmm" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutRestart Lib "winmm" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutSetVolume Lib "winmm" (ByVal wDeviceID As Long, ByVal dwVolume As Long) As Long
Private Declare Function waveOutGetVolume Lib "winmm" (ByVal wDeviceID As Long, dwVolume As Long) As Long
 
Private Const Mp3Class                      As String = "TrickMP3PlayerClass"
Private Const HWND_MESSAGE                  As Long = -3
Private Const WAVE_MAPPER                   As Long = -1&
Private Const WHDR_DONE                     As Long = &H1
Private Const CALLBACK_WINDOW               As Long = &H10000
Private Const MM_WOM_DONE                   As Long = &H3BD
Private Const WM_TIMER                      As Long = &H113
Private Const WNDPROCINDEX                  As Long = 13
Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
Private Const HEAP_NO_SERIALIZE             As Long = &H1
Private Const HEAP_ZERO_MEMORY              As Long = &H8
Private Const GWL_USERDATA                  As Long = (-21)
Private Const MPEGLAYER3_FLAG_PADDING_OFF   As Long = 2
Private Const WAVE_FORMAT_MPEGLAYER3        As Long = &H55
Private Const MPEGLAYER3_WFX_EXTRA_BYTES    As Long = 12
Private Const MPEGLAYER3_ID_MPEG            As Long = 1
Private Const BUFFERS_COUNT                 As Long = 8
 
Private init        As Boolean
Private loaded      As Boolean
Private playing     As Boolean
Private paused      As Boolean
Private isLoop      As Boolean
Private constants   As mp3Const
Private hWnd        As Long
Private hHeap       As Long
Private lpWndProc   As Long
Private hWave       As Long
Private headers()   As mp3Buffer
Private curPosition As Long
Private fileInfo    As Mp3Info
Private buffer()    As Byte
Private mPan        As Single
Private mVolume     As Single
 
' // Initialize playback. The first parameter is a pointer to data of the raw mp3 file.
' // Second parameter is a size of this file in bytes.
' // Last parameter indicates that need to copy this file in the internal buffer.
Public Function Initialize(ByVal lpData As Long, ByVal szData As Long, Optional ByVal blCopy As Boolean) As Boolean
    Dim status  As Boolean
    Dim info    As Mp3Info
    Dim ret     As Long
    Dim index   As Long
    
    If Not init Then Exit Function
    
    status = Mp3GetInfo(lpData, szData, info)
    If Not status Then Exit Function
    
    If hWave Then ClearAll
    
    If blCopy Then
        
        ReDim buffer(info.szDataSize - 1)
        memcpy buffer(0), ByVal info.lpFrameOffset, info.szDataSize
        info.lpFrameOffset = VarPtr(buffer(0))
        
    End If
    
    ret = waveOutOpen(hWave, WAVE_MAPPER, info.format, hWnd, 0, CALLBACK_WINDOW)
    If ret Then hWave = 0:  Exit Function
 
    fileInfo = info
    curPosition = 0
    Me.Pan = mPan
    Me.Volume = mVolume
    
    loaded = True
    playing = False
    
End Function
 
' // Start playback. If it is the first call after stopping or initialization then parameter "looped" allows to play a data by circularly.
Public Function Play(Optional ByVal looped As Boolean) As Boolean
    Dim index   As Long
    Dim ret     As Long
    
    If Not (init And loaded) Then Exit Function
    
    isLoop = looped
    
    If paused Then
        
        If waveOutRestart(hWave) Then Exit Function
        paused = False
        
    Else
        
        curPosition = 0
        
        For index = 0 To BUFFERS_COUNT - 1
    
            headers(index).header.lpData = fileInfo.lpFrameOffset + fileInfo.frameOffset(curPosition).offset
    
            If index < fileInfo.framesCount - 1 Then
            
                headers(index).header.dwBufferLength = fileInfo.frameOffset(curPosition + 1).offset - fileInfo.frameOffset(curPosition).offset
                
            Else
 
                headers(index).header.dwBufferLength = fileInfo.szDataSize - fileInfo.frameOffset(curPosition).offset
                
                If isLoop Then
                    curPosition = 0
                Else
                    Exit For
                End If
                
            End If
    
            ret = waveOutPrepareHeader(hWave, headers(index).header, Len(headers(index).header))
            headers(index).status = ret = 0
    
            If ret Then ClearAll: Exit Function
    
            ret = waveOutWrite(hWave, headers(index).header, Len(headers(index).header))
            If ret Then ClearAll: Exit Function
            
            curPosition = curPosition + 1
            
        Next
        
    End If
    
    playing = True
    Play = True
    
End Function
 
' // Pause playback.
Public Function Pause() As Boolean
 
    If Not (init And loaded And playing) Then Exit Function
    
    waveOutPause hWave
    
    paused = True
    Pause = True
    
End Function
 
' // Stop playback.
Public Function StopPlaying() As Boolean
 
    If Not (init And loaded And playing) Then Exit Function
    
    paused = False
    playing = False
    curPosition = -1
    
    waveOutReset hWave
 
    StopPlaying = True
    
End Function
 
' // Set current playback position (in milliseconds).
Public Function SetPositionMs(ByVal pos As Long) As Boolean
    Dim frameLength As Single
    Dim index       As Long
    
    If Not (init And loaded) Then Err.Raise 5: Exit Function
    
    frameLength = fileInfo.samplesPerFrame / fileInfo.format.nSamplesPerSec
    index = pos / 1000 / frameLength
    
    If index >= fileInfo.framesCount Then Err.Raise 5:  Exit Function
    
    curPosition = index
    SetPositionMs = True
    
End Function
 
' // Get current playback position (in milliseconds).
Public Function GetPositionMs() As Long
    Dim frameLength As Single
    
    If Not (init And loaded) Then Exit Function
    
    frameLength = fileInfo.samplesPerFrame / fileInfo.format.nSamplesPerSec
    GetPositionMs = curPosition * frameLength * 1000
    
End Function
 
' // Get duration of the data in milliseconds.
Public Function GetDurationMs() As Long
    Dim frameLength As Single
    
    If Not (init And loaded) Then Exit Function
    
    frameLength = fileInfo.samplesPerFrame / fileInfo.format.nSamplesPerSec
    GetDurationMs = fileInfo.framesCount * frameLength * 1000
    
End Function
 
' // Get current bitrate.
Public Function GetBitrate() As Long
    
    If curPosition < 0 Then Exit Function
    GetBitrate = fileInfo.frameOffset(curPosition).bitrate
    
End Function
 
' // If playback is active then true.
Public Property Get IsPlaying() As Boolean
    IsPlaying = init And loaded And playing And Not paused
End Property
 
' // Volume
Public Property Get Volume() As Single
    Dim dwVolume    As Long
    Dim volLeft     As Long
    Dim volRight    As Long
    
    waveOutGetVolume hWave, dwVolume
    
    volLeft = dwVolume And &HFFFF&
    volRight = ((dwVolume And &HFFFF0000) \ &H10000) And &HFFFF&
    
    If volLeft > volRight Then Volume = volLeft / 65535 Else Volume = volRight / 65535
    
End Property
Public Property Let Volume(ByVal value As Single)
    Dim dwVolume    As Long
    Dim volRight    As Long
    
    If value > 1 Or value <= 0 Then Err.Raise 6: Exit Property
    
    mVolume = value
    
    If mPan > 0 Then
        volRight = value * 65535
        dwVolume = volRight * (1 - mPan)
    Else
        dwVolume = value * 65535
        volRight = dwVolume * (1 + mPan)
    End If
        
    If volRight And &H8000& Then
        dwVolume = dwVolume Or ((volRight And &H7FFF&) * &H10000) Or &H80000000
    Else
        dwVolume = dwVolume Or (volRight * &H10000)
    End If
    
    waveOutSetVolume hWave, dwVolume
     
End Property
 
' // Pan
Public Property Get Pan() As Single
    Dim dwVolume    As Long
    Dim volLeft     As Long
    Dim volRight    As Long
    
    waveOutGetVolume hWave, dwVolume
    
    volLeft = dwVolume And &HFFFF&
    volRight = ((dwVolume And &HFFFF0000) \ &H10000) And &HFFFF&
    If volLeft > volRight Then dwVolume = volLeft Else dwVolume = volRight
    
    If dwVolume = 0 Then dwVolume = 1
    Pan = (volRight - volLeft) / dwVolume
    
End Property
Public Property Let Pan(ByVal value As Single)
    
    If value > 1 Or value < -1 Then Err.Raise 6: Exit Property
    
    mPan = value
    Me.Volume = mVolume
    
End Property
 
' // Local procedures.
Private Function SUBCLASSPROC(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Dim index   As Long
    Dim lpData  As Long
    Dim inIDE   As Boolean
    
    Debug.Assert MakeTrue(inIDE)
    
    If inIDE Then
    
        If Msg = WM_TIMER Then
        
            KillTimer hWnd, wParam
            
            For index = 0 To BUFFERS_COUNT - 1
                
                If headers(index).header.dwFlags And WHDR_DONE Then
                    
                    WriteNext index
                    
                End If
                
            Next
            
        End If
        
    End If
    
    If Msg = MM_WOM_DONE Then
        
        If wParam <> hWave Then GoTo DefCall
        
        GetMem4 ByVal lParam, lpData
 
        index = GetBufferIndex(lpData)
 
        If index = -1 Then GoTo DefCall
        
        WriteNext index
        
    End If
    
DefCall:
    
    SUBCLASSPROC = DefSubclassProc(hWnd, Msg, wParam, lParam)
    
End Function
 
Private Sub WriteNext(ByVal index As Long)
    
    waveOutUnprepareHeader hWave, headers(index).header, Len(headers(index).header)
    
    If playing = False And paused = False Then Exit Sub
    
    If curPosition = -1 Then Exit Sub
    
    headers(index).header.dwFlags = headers(index).header.dwFlags And Not WHDR_DONE
    headers(index).header.lpData = fileInfo.lpFrameOffset + fileInfo.frameOffset(curPosition).offset
 
    If curPosition < fileInfo.framesCount - 1 Then
    
        headers(index).header.dwBufferLength = fileInfo.frameOffset(curPosition + 1).offset - fileInfo.frameOffset(curPosition).offset
        curPosition = curPosition + 1
        
    Else
    
        headers(index).header.dwBufferLength = fileInfo.szDataSize - fileInfo.frameOffset(curPosition).offset
        
        If isLoop Then
            curPosition = 0
        Else
            curPosition = -1
        End If
            
    End If
    
    waveOutPrepareHeader hWave, headers(index).header, Len(headers(index).header)
    waveOutWrite hWave, headers(index).header, Len(headers(index).header)
    
End Sub
 
Private Sub ClearAll()
    Dim index   As Long
 
    If hWave = 0 Then Exit Sub
 
    For index = 0 To BUFFERS_COUNT - 1
 
        If headers(index).status Then
            waveOutUnprepareHeader hWave, headers(index).header, Len(headers(index).header)
        End If
 
    Next
    
    If playing Or paused Then waveOutReset hWave
    
    waveOutClose hWave
    
    loaded = False
    playing = False
    paused = False
    hWave = 0
    
End Sub
 
Private Function GetBufferIndex(ByVal ptr As Long) As Long
    Dim index As Long
 
    For index = 0 To UBound(headers)
 
        If headers(index).header.lpData = ptr Then
            GetBufferIndex = index
            Exit Function
        End If
 
    Next
 
    GetBufferIndex = -1
End Function
 
Private Function Mp3GetInfo(ByVal lpData As Long, ByVal szData As Long, info As Mp3Info) As Boolean
    Dim hdr(9)  As Byte
    Dim size    As Long
    
    If szData >= 128 Then
        ' Skip ID3V1 tag
        memcpy hdr(0), ByVal lpData + szData - 128, 3
        
        If hdr(0) = &H54 And hdr(1) = &H41 And hdr(2) = &H47 Then
            
            szData = szData - 128
            
        End If
        
    End If
    
    ' Skip ID3V2 tags from beginning
    memcpy hdr(0), ByVal lpData, 10
    
    If hdr(0) = &H49 And hdr(1) = &H44 And hdr(2) = &H33 Then
        
        ' footer present
        If hdr(5) And &H10 Then
            szData = szData - 10
        End If
    
        size = hdr(6) * &H200000
        size = size Or (hdr(7) * &H4000&)
        size = size Or (hdr(8) * &H80&)
        size = size Or hdr(9)
        size = size + 10
        
        lpData = lpData + size
        szData = szData - size
            
    Else
        ' Skip ID3V2 tags from end
        memcpy hdr(0), ByVal lpData + szData - 10, 10
        
        If hdr(2) = &H49 And hdr(1) = &H44 And hdr(0) = &H33 Then
            
            szData = szData - 10
            
            size = hdr(6) * &H200000
            size = size Or (hdr(7) * &H4000&)
            size = size Or (hdr(8) * &H80&)
            size = size Or hdr(9)
            size = size + 10
        
            szData = szData - size
            
        End If
        
    End If
    
    If szData < 4 Then Exit Function
    
    info.framesCount = 0
    'Scan headers
    Do
        ' Find a frame sync
        Do
        
            GetMem4 ByVal lpData, hdr(0)
            
            If hdr(0) = &HFF And (hdr(1) And &HE0) = &HE0 Then
                Dim vers    As Long
                Dim layer   As Long
                Dim bitrate As Long
                Dim smprate As Long
                Dim padding As Long
                Dim channel As Long
                               
                vers = (hdr(1) And &H18) \ 8
                If vers = 1 Then Exit Function
    
                layer = (hdr(1) And &H6) \ 2
                If layer <> 1 Then Exit Function ' Only Layer 3
    
                If vers = 3 Then
                    bitrate = constants.bitrate(0, (hdr(2) And &HF0) \ &H10)
                Else
                    bitrate = constants.bitrate(1, (hdr(2) And &HF0) \ &H10)
                End If
 
                If vers = 3 Then
                    smprate = constants.smprate(0, (hdr(2) And &HC) \ &H4)
                ElseIf vers = 2 Then
                    smprate = constants.smprate(1, (hdr(2) And &HC) \ &H4)
                Else
                    smprate = constants.smprate(2, (hdr(2) And &HC) \ &H4)
                End If
                
                padding = (hdr(2) And &H2) \ 2
                channel = -(((hdr(3) And &HC0) \ 64) <> 3) + 1
                
                If vers = 3 Then
                    size = Int(144000 * bitrate / smprate) + padding
                Else
                    size = Int(72000 * bitrate / smprate) + padding
                End If
                
                With info
                    If .framesCount = 0 Then
 
                        With .format
                            .wFormatTag = WAVE_FORMAT_MPEGLAYER3
                            .cbSize = MPEGLAYER3_WFX_EXTRA_BYTES
                            .nChannels = channel
                            .nAvgBytesPerSec = bitrate * 128
                            .wBitsPerSample = 0
                            .nBlockAlign = 1
                            .nSamplesPerSec = smprate
                            .nFramesPerBlock = 1
                            .nCodecDelay = 0
                            .fdwFlags = MPEGLAYER3_FLAG_PADDING_OFF
                            .wID = MPEGLAYER3_ID_MPEG
                            .nBlockSize = size
                        End With
                                        
                        .lpFrameOffset = lpData
                        .szDataSize = szData
                        
                        If vers = 3 Then
                            .samplesPerFrame = 1152
                        Else
                            .samplesPerFrame = 576
                        End If
                        
                        ReDim .frameOffset(511)
                    
                    Else
                        
                        If UBound(.frameOffset) = info.framesCount Then
                            ReDim Preserve .frameOffset(UBound(.frameOffset) + 512)
                        End If
                        
                    End If
                    
                    .frameOffset(info.framesCount).offset = lpData - .lpFrameOffset
                    .frameOffset(info.framesCount).bitrate = bitrate
                    
                End With
                
                lpData = lpData + size
                szData = szData - size
                
                Exit Do
                
            End If
            
            lpData = lpData + 1
            szData = szData - 1
            
        Loop While szData >= 4
        
        info.framesCount = info.framesCount + 1
        
    Loop While szData >= 4
 
    Mp3GetInfo = True
    
End Function
 
Private Function GetWindowAndHeap(l_hwnd As Long, l_hHeap As Long) As Boolean
    Dim i1      As Long
    Dim i2      As Long
    Dim b       As Long
    Dim arr(16) As Integer
    
    If GetEnvironmentVariable(StrPtr(Mp3Class), arr(0), 32) Then
        
        i1 = 0: i2 = 8
        Do
            If arr(i1) <= &H39 Then b = arr(i1) - &H30 Else b = arr(i1) - &H37
            If l_hHeap And &H8000000 Then l_hHeap = ((l_hHeap And &H7FFFFF) * &H10 Or &H80000000) Or b Else l_hHeap = (l_hHeap * &H10) Or b
            If arr(i2) <= &H39 Then b = arr(i2) - &H30 Else b = arr(i2) - &H37
            If l_hwnd And &H8000000 Then l_hwnd = ((l_hwnd And &H7FFFFF) * &H10 Or &H80000000) Or b Else l_hwnd = (l_hwnd * &H10) Or b
            i1 = i1 + 1: i2 = i2 + 1
        Loop While i1 < 8
        
        GetWindowAndHeap = l_hwnd <> 0 And l_hHeap <> 0
        
    End If
 
End Function
 
Private Function SaveWindowAndHeap(ByVal l_hwnd As Long, ByVal l_hHeap As Long) As Boolean
    Dim i1      As Long
    Dim i2      As Long
    Dim b       As Long
    Dim arr(16) As Integer
    
    i1 = 7: i2 = 15
    Do
        b = l_hHeap And &HF
        If b < 10 Then arr(i1) = b + &H30 Else arr(i1) = b + &H37
        b = l_hwnd And &HF
        If b < 10 Then arr(i2) = b + &H30 Else arr(i2) = b + &H37
        l_hHeap = (l_hHeap And &HFFFFFFF0) \ &H10
        l_hwnd = (l_hwnd And &HFFFFFFF0) \ &H10
        i1 = i1 - 1: i2 = i2 - 1
    Loop While i1 >= 0
 
    SaveWindowAndHeap = SetEnvironmentVariable(StrPtr(Mp3Class), arr(0))
    
End Function
 
Private Sub Class_Initialize()
    Dim cls         As WNDCLASSEX
    Dim b           As curBuffer
    Dim isFirst     As Boolean
    Dim inIDE       As Boolean
    Dim AsmSize     As Long
    Dim lpAsm       As Long
    Dim lpFlag      As Long
    Dim hInstVB6    As Long
    Dim lpEbMode    As Long
    Dim hInstUser32 As Long
    Dim hComctl32   As Long
    Dim lpDefProc   As Long
    Dim lpSetTimer  As Long
    Dim clearFlag   As Long
        
    b.b(0) = 450377142658.6656@:    b.b(1) = 900743977448.248@:     b.b(2) = 1351114248211.6672@
    b.b(3) = 1801487954948.9248@:   b.b(4) = 2702228496423.3344@:   b.b(5) = 3602975909897.8496@
    b.b(6) = 4503737067267.712@:    b.b(7) = 18941235272.0895@:     b.b(8) = 4735201446.045@
    b.b(9) = 10307921515.2@:        b.b(10) = 13743895348.4@:       b.b(11) = 3435973838.4@
        
    memcpy constants.bitrate(0, 1), b.b(0), 96
    
    ReDim headers(BUFFERS_COUNT - 1)
    mVolume = 1
    
    isFirst = Not GetWindowAndHeap(hWnd, hHeap)
 
    Debug.Assert MakeTrue(inIDE)
    
    hInstUser32 = GetModuleHandle(StrPtr("user32"))
    
    If inIDE Then
        
        AsmSize = &H65
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        hComctl32 = GetModuleHandle(StrPtr("hComctl32"))
        If hComctl32 = 0 Then
            hComctl32 = LoadLibrary(StrPtr("Comctl32"))
            If hComctl32 = 0 Then Exit Sub
        End If
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        lpDefProc = GetProcAddress(hComctl32, "DefSubclassProc")
        lpSetTimer = GetProcAddress(hInstUser32, "SetTimer")
 
        b.b(0) = 843073850243758.4259@: b.b(1) = -457424984652572.8729@:    b.b(2) = 2989182470102.0276@
        b.b(3) = -7165957082854.492@:   b.b(4) = -16790531.982@:            b.b(5) = 10059.9531@
        b.b(6) = 116318324260473.7791@: b.b(7) = 116318324260473.7791@:     b.b(8) = 696980420845.4632@
        b.b(9) = 522808547116743.0705@: b.b(10) = 756460495277739.1878@:    b.b(11) = -10565565861.0689@
        b.b(12) = 41538.9951@
 
        If isFirst Then
            
            lpFlag = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, 4)
            If lpFlag = 0 Then Exit Sub
        
        Else
            
            lpFlag = GetWindowLong(hWnd, 0)
            
            GetMem4 ByVal lpFlag, clearFlag
            
            If clearFlag Then
                
                DestroyWindow hWnd
                HeapDestroy hHeap
                UnregisterClass StrPtr(Mp3Class), App.hInstance
                
                GetMem4 0&, ByVal lpFlag
                isFirst = True
                
                hWnd = 0
                hHeap = 0
                
                SaveWindowAndHeap 0, 0
                
            End If
            
        End If
 
    Else
        
        AsmSize = &H20
        
        b.b(0) = 522808547116743.0705@: b.b(1) = 756460495277739.1878@:    b.b(2) = -10565565861.0689@
        b.b(3) = 41538.9951@
        
    End If
    
    If isFirst Then
    
        hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
        If hHeap = 0 Then Exit Sub
        
    End If
    
    lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, AsmSize)
    
    If lpAsm = 0 Then
        If isFirst Then HeapDestroy hHeap
        Exit Sub
    End If
    
    lpWndProc = lpAsm
 
    memcpy ByVal lpAsm, b.b(0), AsmSize
 
    If inIDE Then
    
        GetMem4 lpEbMode - (lpAsm + &H9) - 5, ByVal lpAsm + &H9 + 1     ' Call EbMode
        GetMem4 lpSetTimer - (lpAsm + &H23) - 5, ByVal lpAsm + &H23 + 1 ' Call SetTimer
        GetMem4 lpDefProc - (lpAsm + &H40) - 5, ByVal lpAsm + &H40 + 1  ' call DefSubclassProc
        GetMem4 lpFlag, ByVal lpAsm + &H2                               ' Cmp [flag], 0
        GetMem4 lpFlag, ByVal lpAsm + &H2C                              ' Inc [flag]
        
        lpAsm = lpAsm + &H48
        
    End If
    
    Dim lpMeth      As Long
    Dim vTable      As Long
    
    GetMem4 ByVal ObjPtr(Me), vTable
    GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
    GetMem4 ObjPtr(Me), ByVal lpAsm + &H10                             ' Push Me
    GetMem4 lpMeth - (lpAsm + &H14) - 5, ByVal lpAsm + &H14 + 1        ' Call WndProc
        
    If isFirst Then
        
        lpDefProc = GetProcAddress(hInstUser32, "DefWindowProcW")
        
        cls.hInstance = App.hInstance
        cls.lpfnwndproc = lpDefProc
        cls.lpszClassName = StrPtr(Mp3Class)
        cls.cbSize = Len(cls)
        cls.cbWndExtra2 = 8
        
        If RegisterClassEx(cls) = 0 Then
  
            HeapDestroy hHeap
            Exit Sub
 
        End If
        
        hWnd = CreateWindowEx(0, StrPtr(Mp3Class), 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
        If hWnd = 0 Then Exit Sub
        
        SaveWindowAndHeap hWnd, hHeap
        
        If inIDE Then Call SetWindowLong(hWnd, 0, lpFlag)
    
    End If
        
    If SetWindowSubclass(hWnd, lpWndProc, ObjPtr(Me), 0) = 0 Then Exit Sub
    
    SetWindowLong hWnd, GWL_USERDATA, GetWindowLong(hWnd, GWL_USERDATA) + 1
    
    init = True
    
End Sub
 
Private Sub Class_Terminate()
    Dim refCt   As Long
    
    If Not init Then Exit Sub
    
    refCt = GetWindowLong(hWnd, GWL_USERDATA)
    
    If refCt = 0 Then
    
        DestroyWindow hWnd
        HeapDestroy hHeap
        UnregisterClass StrPtr(Mp3Class), App.hInstance
        SaveWindowAndHeap 0, 0
        
    Else
        
        RemoveWindowSubclass hWnd, lpWndProc, ObjPtr(Me)
        SetWindowLong hWnd, GWL_USERDATA, refCt - 1
        HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpWndProc
        
    End If
    
End Sub
 
Private Function MakeTrue(refBool As Boolean) As Boolean
    MakeTrue = True
    refBool = True
End Function