http://foro.elhacker.net/programacion_vb/srcmaltmutexbas_alternativa_a_createmutex-t243771.0.html

Option Explicit
'KERNEL32
Private Declare Function CreateSemaphoreW Lib "kernel32.dll" (ByVal lpSemaphoreAttributes As Long, ByVal lInitialCount As Long, ByVal lMaximumCount As Long, ByVal lpName As Long) As Long
 
Private Const ERROR_ALREADY_EXISTS  As Long = 183&
 
Public Function bWasIOpened(ByVal lpName As String) As Boolean
    bWasIOpened = (CreateSemaphoreW(0&, 0&, 1&, StrPtr(lpName)) > 0) And (Err.LastDllError = ERROR_ALREADY_EXISTS)
End Function

If App.PrevInstance = True Then End

Private Sub Form_Load()
    If bWasIOpened("Cualquier_Cosa") = True Then End
End Sub

'USER32
Private Declare Function ShowWindow Lib "USER32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindowA Lib "USER32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Const SW_HIDE   As Long = 0
Private Const SW_NORMAL As Long = 1
Private Const CLASSNAME As String = "ThunderRT6Main"
 
Public Sub AppTaskVisible(ByVal bVisible As Boolean)
    Dim lHwnd           As Long
 
    lHwnd = FindWindowA(CLASSNAME, App.Title)
    If lHwnd Then
        Call ShowWindow(lHwnd, IIf((bVisible = True), SW_NORMAL, SW_HIDE))
    End If
End Sub

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mNativeEnumDrives
' Author    : Karcrack
' Date      : 11/02/2010
' Purpose   : Enumerate Drives, allow filtering by device type
'---------------------------------------------------------------------------------------
'NTDLL
Private Declare Function NtQueryInformationProcess Lib "NTDLL" (ByVal hProcess As Long, ByVal ProcessInformationClass As Long, ProcessInformation As Any, ByVal ProcessInformationLength As Long, ReturnLength As Long) As Long
 
Private Type PROCESS_DEVICEMAP_INFORMATION
    DriveMap                As Long
    DriveType(1 To 32)      As Byte
End Type
 
Public Enum DeviceType
    DRIVE_NOFILTER = -1
    DRIVE_UNKNOWN
    DRIVE_NO_ROOT_DIR
    DRIVE_REMOVABLE
    DRIVE_FIXED
    DRIVE_REMOTE
    DRIVE_CDROM
    DRIVE_RAMDISK
End Enum
 
Private Const ProcessDeviceMap = 23
 
Public Function NtGetDrives(Optional ByVal lFilterType As DeviceType = DRIVE_NOFILTER) As Collection
    Dim tPDC                As PROCESS_DEVICEMAP_INFORMATION
    Dim i                   As Long
 
    Set NtGetDrives = New Collection
 
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        For i = 0 To 25
            If tPDC.DriveMap And 2 ^ i Then
                If (lFilterType = -1) Or (tPDC.DriveType(i + 1) = lFilterType) Then
                    NtGetDrives.Add Chr$(65 + i) & ":\"
                End If
            End If
        Next i
    End If
End Function

Private Sub Form_Load()
    Dim vItem               As Variant
 
    For Each vItem In NtGetDrives(DRIVE_REMOVABLE)
        MsgBox vItem
    Next vItem
End Sub

 Option Explicit
 
'NTDLL
Private Declare Function LdrLoadDll Lib "NTDLL" (ByVal pWPathToFile As Long, ByVal Flags As Long, ByRef pwModuleFileName As UNICODE_STRING, ByRef ModuleHandle As Long) As Long
Private Declare Function LdrGetProcedureAddress Lib "NTDLL" (ByVal ModuleHandle As Long, ByRef paFunctionName As Long, ByVal Ordinal As Integer, ByRef FunctionAddress As Long) As Long
Private Declare Sub RtlInitUnicodeString Lib "NTDLL" (DestinationString As Any, ByVal SourceString As Long)
 
Private Type UNICODE_STRING
    uLength         As Integer
    uMaximumLength  As Integer
    pBuffer         As Long
End Type
 
Public Function NtLoadLibrary(ByVal sName As String) As Long
    Dim US          As UNICODE_STRING
 
    Call RtlInitUnicodeString(US, StrPtr(sName))
    Call LdrLoadDll(ByVal 0&, ByVal 0&, US, NtLoadLibrary)
End Function
 
Public Function NtGetProcAddr(ByVal lModuleHandle As Long, ByVal sProc As String) As Long
    Dim i           As Long
    Dim ANSI()      As Byte
 
    ReDim ANSI(0 To Len(sProc))
    For i = 1 To Len(sProc)
        ANSI(i - 1) = Asc(Mid$(sProc, i, 1))
    Next i
 
    Call LdrGetProcedureAddress(lModuleHandle, VarPtr(ANSI(0)), ByVal 0&, NtGetProcAddr)
End Function

 Option Explicit
'KERNEL32
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "KERNEL32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
 
Private Sub Form_Load()
    MsgBox Hex$(NtGetProcAddr(NtLoadLibrary("KERNEL32"), "ExitProcess")) & vbCrLf & Hex$(GetProcAddress(LoadLibrary("KERNEL32"), "ExitProcess"))
End Sub

Option Explicit
 
'---------------------------------------------------------------------------------------
' Module    : mAntiVirtualPC
' Author    : Karcrack
' Now$      : 06/09/2009  17:35
' Used for? : Known if being Virtualized inside M$ Virtual PC
' Thanks    : Kiash > He tested on Virtual PC
' Original C source:
'    BOOL IsVirtualPC(void){
'        __try{
'            __asm{
'                mov eax, 1
'                _emit 0x0F
'                _emit 0x3F
'                _emit 0x07
'                _emit 0x0B
'                _emit 0xC7
'                _emit 0x45
'                _emit 0xFC
'                _emit 0xFF
'                _emit 0xFF
'                _emit 0xFF
'                _emit 0xFF
'            }
'        }__except(1){
'            return FALSE;
'        }
'        return TRUE;
'    }
'---------------------------------------------------------------------------------------
 
'KERNEL32
Private Declare Function SetUnhandledExceptionFilter Lib "KERNEL32" (ByVal lpTopLevelExceptionFilter As Long) As Long
'USER32
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'MSVBVM60
Private Declare Sub PutMem8 Lib "MSVBVM60" (inDst As Any, ByVal inSrc As Currency)
 
Private Const THUNK_ANTI1       As Currency = -104917872100.9905@           'db 0x0F, 0x3F,0x07,0x0B,0xC7,0x45,0xFC,0xFF
Private Const THUNK_ANTI2       As Currency = -802975918416356.9665@        'db 0xFF,0xFF,0xFF + RET + NOP + NOP + NOP + NOP
 
Private m_bFlag                 As Boolean
 
Public Function IsVirtualPC() As Boolean
    On Error Resume Next
    Dim bvASM(&HF)              As Byte
    Dim lOldSEH                 As Long
 
    m_bFlag = True
    lOldSEH = SetUnhandledExceptionFilter(AddressOf ExceptionHandler)
 
    Call PutMem8(ByVal VarPtr(bvASM(0)), THUNK_ANTI1)
    Call PutMem8(ByVal VarPtr(bvASM(0)) + 8, THUNK_ANTI2)
 
    Call CallWindowProc(VarPtr(bvASM(0)), 0&, 0&, 0&, 0&)
 
    Call SetUnhandledExceptionFilter(lOldSEH)
    IsVirtualPC = m_bFlag
End Function
 
Public Function ExceptionHandler(ByRef uException As Long) As Long
    m_bFlag = False: ExceptionHandler = -1
    ' VB Will process our error :P
    Call Mid$(vbNullString, 0)
End Function

Option Explicit
'---------------------------------------------------------------------------------------
' Module        : mVirtualized
' Author        : Karcrack
' Date          : 09/09/09
' Used for?     : Detect Virtualized Machines... like VMWare/V.PC/QEmu...
' Tested On     :
'                   - Virtual PC 2007, 1.0      (Tested by: KIASH!)
'                   - VMWare ,6.5.3.185404      (Tested by: SkyWeb!)
'
' Reference     :
'                   :http://www.cs.nps.navy.mil/people/faculty/irvine/publications/2000/VMM-usenix00-0611.pdf
'                   :http://invisiblethings.org/papers/redpill.html
'                   :http://www.ntsecurity.nu/onmymind/2007/2007-02-27.html
'                   :http://blog.assarbad.net/wp-content/uploads/2006/11/redpill_getting_colorless.pdf
'---------------------------------------------------------------------------------------
 
'USER32
Private Declare Function CallThunk8 Lib "USER32" Alias "CallWindowProcW" (ByRef cThunk As Currency, Optional ByVal Param1 As Long, Optional ByVal Param2 As Long, Optional ByVal Param3 As Long, Optional ByVal Param4 As Long) As Long
 
Public Function ImVirtualized() As Boolean
    Dim tIDT(2 + 4)     As Byte
 
'    mov ecx, [esp+4]\
'    sidt [ecx]       |->; -439297879751758.3221@
'    retn            /
 
    Call CallThunk8(-439297879751758.3221@, ByVal VarPtr(tIDT(0)))
    ImVirtualized = (tIDT(5)  > &HD0)
End Function

'USER32
Private Declare Function CallThunk8 Lib "USER32" Alias "CallWindowProcW" (ByRef cThunk As Currency, Optional ByVal Param1 As Long = 0, Optional ByVal Param2 As Long = 0, Optional ByVal Param3 As Long = 0, Optional ByVal Param4 As Long = 0) As Long
 
'---------------------------------------------------------------------------------------
' Procedure : FS_GetCurrentProcessId
' Author    : Karcrack
' Date      : 23/09/2009
' Purpose   : GetCurrentProcessId@Kernel32 alternative. Reads info from TIB
'---------------------------------------------------------------------------------------
'
Public Function FS_GetCurrentProcessId() As Long
    '                                   mov eax, [FS:0x20]
    FS_GetCurrentProcessId = CallThunk8(-801556291178721.2444@)
End Function