'--------------------------------------------------------------------------------------------
' Module    : mNO_IP
' Author  : Karcrack
' Date      : 03/11/2009
' Purpose   : Retrieve No-IP DUC user & password
' Thanks    :
'       Cobein  :   Original code                (http://www.advancevb.com.ar/?p=247)
'       VBSpeed :   Original Decode64 function  (http://www.xbeat.net/vbspeed/c_Base64Dec.htm)
'---------------------------------------------------------------------------------------------
 
Option Explicit
 
Private Declare Function RegOpenKey Lib "ADVAPI32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "ADVAPI32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long
 
Public Function GetNO_IP(ByRef sUser As String, ByRef sPass As String) As Boolean
    Dim lhKey           As Long
    Dim sBuffer         As String * 512
 
    If Not RegOpenKey(&H80000002, "Software\Vitalwerks\DUC", lhKey) Then
        If RegQueryValueEx(lhKey, "Username", 0, 0, ByVal sBuffer, 512) = 0 Then
            sUser = Left$(sBuffer, lstrlen(sBuffer))
        End If
        If RegQueryValueEx(lhKey, "Password", 0, 0, ByVal sBuffer, 512) = 0 Then
            sPass = Decode64(Left$(sBuffer, lstrlen(sBuffer)))
        End If
        GetNO_IP = CBool(Len(sUser) And Len(sPass))
        Call RegCloseKey(lhKey)
    End If
End Function
 
Private Function Decode64(ByVal Base64String As String) As String
    Dim Enc()           As Byte
    Dim b()             As Byte
    Dim Out()           As Byte
    Dim Dec(255)        As Byte
    Dim i               As Long
    Dim j               As Long
    Dim L               As Long
 
    Enc = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
    For i = 0 To 255:   Dec(i) = 64:        Next i
    For i = 0 To 63:    Dec(Enc(i)) = i:    Next i
 
    L = Len(Base64String)
    b = StrConv(Base64String, vbFromUnicode)
 
    ReDim Preserve Out(0 To (L \ 4) * 3 - 1)
    For i = 0 To UBound(b) - 1 Step 4
        Out(j) = (Dec(b(i)) * 4) Or (Dec(b(i + 1)) \ 16): j = j + 1
        Out(j) = (Dec(b(i + 1)) And 15) * 16 Or (Dec(b(i + 2)) \ 4): j = j + 1
        Out(j) = (Dec(b(i + 2)) And 3) * 64 Or Dec(b(i + 3)): j = j + 1
    Next i
 
    ReDim Preserve Out(0 To UBound(Out) - IIf((b(L - 2) = 61), 2, IIf((b(L - 1) = 61), 1, 0)))
    Decode64 = StrConv(Out, vbUnicode)
End Function
 
Private Function lstrlen(ByVal sStr As String) As Long
    lstrlen = InStr(1, sStr & Chr$(0), Chr$(0)) - 1
End Function

    Dim U       As String
    Dim P       As String
 
    If GetNO_IP(U, P) = True Then
        MsgBox "Usuario:" & U & vbCrLf & "Password:" & P
    End If

'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
 
Private Const ProcessDeviceMap = 23
 
Public Function NtGetPenDrives() As Collection
    Dim cTMP                As New Collection
    Dim tPDC                As PROCESS_DEVICEMAP_INFORMATION
    Dim i                   As Long
    Dim lMask               As Long
 
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        For i = 1 To 25
            If tPDC.DriveMap And 2 ^ i Then
                If (tPDC.DriveType(i + 1) = 2) Then
                    cTMP.Add Chr$(65 + i) & ":\"
                End If
            End If
        Next i
    End If
 
    Set NtGetPenDrives = cTMP
End Function

Sub Main()
    Dim v                   As Variant
 
    For Each v In NtGetPenDrives
        Debug.Print v
    Next v
End Sub

• No incluye la unidad A:
• No filtra las unidades por BusType...

http://www.advancevb.com.ar/?p=335

'NTDLL
Private Declare Sub NtDelayExecution Lib "NTDLL" (ByVal Alertable As Boolean, ByRef Interval As Any)
 
Private Sub NtSleep(ByVal lMs As Long)
    Call NtDelayExecution(False, CCur(-(lMs)))
End Sub

Option Explicit
 
'KERNEL32
Private Declare Function lstrcpyW Lib "KERNEL32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
'NTDLL
Private Declare Function RtlGetCurrentPeb Lib "NTDLL" () As Long
'MSVBVM60
Private Declare Sub GetMem4 Lib "MSVBVM60" (ByVal Addr As Long, ByRef RetVal As Long)
 
Public Enum STRING_TYPE
    CurrentDirectoryPath = &H28
    DllPath = &H34
    ImagePathName = &H3C
    CommandLine = &H44
    WindowTitle = &H74
    DesktopName = &H7C
    ShellInfo = &H80
    RuntimeData = &H84
End Enum
 
'---------------------------------------------------------------------------------------
' Procedure : GetUPPString
' Author    : Karcrack
' Date      : 24/09/2009
' Purpose   : Get strings from PEB.RTL_USER_PROCESS_PARAMETERS
'---------------------------------------------------------------------------------------
'
Public Sub GetUPPString(ByRef sRet As String, ByVal lType As STRING_TYPE)
    Dim lUPP        As Long         'RTL_USER_PROCESS_PARAMETERS
    Dim lAddr       As Long         'RTL_USER_PROCESS_PARAMETERS.X
 
    Call GetMem4(RtlGetCurrentPeb + &H10, lUPP)
    Call GetMem4(lUPP + lType, lAddr)
    Call lstrcpyW(StrPtr(sRet), lAddr)
End Sub

Sub Main()
    Dim sStr        As String * 260
 
    Call GetUPPString(sStr, ImagePathName)
 
    MsgBox "MiRuta:" & vbCrLf & sStr
End Sub

Option Explicit
'USER32
Private Declare Function CallWindowProcA Lib "USER32" (ByVal lPtr As Long, 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
 
Private Const sThunk        As String = "8B7C24048B4C24088B54240CE8000000005D83ED118A1A885D1EC0<OPCODE>39FFFF42803A007404E2EEEB068B54240CEBF6C3"
 
'---------------------------------------------------------------------------------------
' Procedure : CryptIt
' Author    : Karcrack
' Date      : 19/09/2009
' Purpose   : Encrypt Using ROL/ROR operands...
' NOTES     : Now FULL ASM, to make it QUICKEST possible!
'             Now PASSWORD compatible
'             Fixed FULL rotation...
'---------------------------------------------------------------------------------------
'
Public Sub CryptIt(ByRef bvData() As Byte, ByRef bvPass() As Byte, Optional ByVal bDecrypt As Boolean = False, Optional ByVal bPreventFULL As Boolean = True)
    Dim i                   As Long
    Dim sASM                As String
    Dim bvASM(&HFF)         As Byte
 
    If bPreventFULL = True Then
        'Prevent FULL rotation...
        For i = LBound(bvPass) To UBound(bvPass)
            If Not (bvPass(i) Mod 8) Then bvPass(i) = bvPass(i) + 1
        Next i
    End If
 
    sASM = Replace$(sThunk, "<OPCODE>", IIf((bDecrypt = False), "4C", "44"))
 
    Call OPCODES(sASM, bvASM)
 
    Call CallWindowProcA(VarPtr(bvASM(0)), VarPtr(bvData(0)), UBound(bvData) + 1, VarPtr(bvPass(0)))
End Sub
 
Private Sub OPCODES(ByVal sThunk As String, ByRef bvTmp() As Byte)
    Dim i               As Long
 
    For i = 0 To Len(sThunk) - 1 Step 2
        bvTmp((i / 2)) = CByte("&H" & Mid$(sThunk, i + 1, 2))
    Next i
End Sub

    Dim bvPass()        As Byte
    Dim bvData()        As Byte
 
    bvPass = StrConv("YEEEAH!" & Chr$(0), vbFromUnicode)
    bvData = StrConv("KARCRACK FTW! =D", vbFromUnicode)
 
    Call CryptIt(bvData, bvPass)
 
    MsgBox StrConv(bvData, vbUnicode)
 
    Call CryptIt(bvData, bvPass, True)
    MsgBox StrConv(bvData, vbUnicode)

'NTDLL
Private Declare Function RtlGetVersion Lib "NTDLL" (ByRef lpVersionInformation As Long) As Long
 
Private Function NativeGetVersion() As String
    Dim tOSVw(&H54)     As Long
 
    tOSVw(0) = &H54 * &H4
    Call RtlGetVersion(tOSVw(0))
 
    NativeGetVersion = Join(Array(tOSVw(4), tOSVw(1), tOSVw(2)), ".")
End Function
 
Public Function VersionToName(ByVal sVersion As String) As String
    Select Case sVersion
        Case "1.0.0":     VersionToName = "Windows 95"
        Case "1.1.0":     VersionToName = "Windows 98"
        Case "1.9.0":     VersionToName = "Windows Millenium"
        Case "2.3.0":     VersionToName = "Windows NT 3.51"
        Case "2.4.0":     VersionToName = "Windows NT 4.0"
        Case "2.5.0":     VersionToName = "Windows 2000"
        Case "2.5.1":     VersionToName = "Windows XP"
        Case "2.5.3":     VersionToName = "Windows 2003 (SERVER)"
        Case "2.6.0":     VersionToName = "Windows Vista"
        Case "2.6.1":     VersionToName = "Windows 7"
        Case Else:        VersionToName = "Unknown"
    End Select
End Function

MsgBox VersionToName(NativeGetVersion)

http://www.advancevb.com.ar/?p=255
http://hackhound.org/forum/index.php?topic=21559.msg133308#msg133308

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mNativeGetDrives
' Author    : Karcrack
' Date      : 09/09/2009
' Purpose   : Alternative to GetLogicalDrives/GetLogicalDriveStrings/GetDriveType
'               using NATIVE APIs!!!!
' Thanks    : SkyWeb -> Tester =P
' ChangeLog :
'           - First release                                             090909
'           - Improved, now with structure and added NtGetDriveType     100909
'---------------------------------------------------------------------------------------
 
'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
 
Private Const ProcessDeviceMap = 23
 
Public Function NtGetLogicalDrives() As Long
    Dim tPDC                    As PROCESS_DEVICEMAP_INFORMATION
 
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        NtGetLogicalDrives = tPDC.DriveMap
    End If
End Function
 
Public Function NtGetLogicalDrivesStrings() As String
    Dim lUnits                  As Long
    Dim i                       As Long
 
    lUnits = NtGetLogicalDrives
 
    For i = 0 To 25
        If lUnits And 2 ^ i Then
            NtGetLogicalDrivesStrings = NtGetLogicalDrivesStrings & Chr$(Asc("A") + i) & ":\" & Chr$(0)
        End If
    Next i
End Function
 
Public Function NtGetDriveType(ByVal nDrive As String) As Long
    Dim tPDC                    As PROCESS_DEVICEMAP_INFORMATION
    Dim lNumb                   As Long
 
    If NtQueryInformationProcess(-1, ProcessDeviceMap, tPDC, Len(tPDC), ByVal 0&) = 0 Then
        lNumb = Asc(Left$(UCase$(nDrive), 1)) - Asc("A")
        If Not lNumb > 31 Then
            NtGetDriveType = tPDC.DriveType(lNumb + 1)
        End If
    End If
End Function

http://www.advancevb.com.ar/wp-content/2009/09/mNativeGetVersion.zip

Saludos

http://foro.elhacker.net/programacion_vb/src_deshabilitar_taskmgr_nuevo_metodo-t266708.0.html

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mKillRegedit
' Author    : Karcrack
' Now$      : 07/09/09 17:25
' Used for? : Disable Regedit
' TestedOn  : Windows XP SP3
'---------------------------------------------------------------------------------------
 
'USER32
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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, ByRef lpParam As Any) As Long
Private Declare Function RegisterClass Lib "USER32" Alias "RegisterClassA" (ByRef Class As WNDCLASS) As Long
Private Declare Function DefWindowProc Lib "USER32" Alias "DefWindowProcA" (ByVal Hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Type WNDCLASS
    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 String
    lpszClassName   As String
End Type
 
Public Sub DisableRegedit()
    Dim tWC     As WNDCLASS
 
    With tWC
        .style = &H6008
        .hInstance = App.hInstance
        .lpfnwndproc = GetPtr(AddressOf WndProc)
        .lpszMenuName = "#103"
        .lpszClassName = "RegEdit_RegEdit"
    End With
 
    If RegisterClass(tWC) Then
        Call CreateWindowEx(&H40000, "RegEdit_RegEdit", vbNullString, ByVal 0&, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&)
    End If
End Sub
 
Private Function WndProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    WndProc = DefWindowProc(Hwnd, uMsg, wParam, lParam)
End Function
 
Private Function GetPtr(ByVal lPtr As Long) As Long
    GetPtr = lPtr
End Function

regedit -m

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mKillTaskMgr
' Author    : Karcrack
' Now$      : 07/09/09 16:03
' Used for? : Disable TaskMgr
' Tested On : Windows XP, Windows Vista, Windows 7
' Thanks    : SkyWeb -> Support and Test (W$ Seven & Vista)
'---------------------------------------------------------------------------------------
 
'KERNEL32
Private Declare Function CreateMutexW Lib "KERNEL32" (ByRef lpMutexAttributes As Long, ByVal bInitialOwner As Long, ByVal lpuName As Long) As Long
Private Declare Function FreeLibrary Lib "KERNEL32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
'USER32
Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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, ByRef lpParam As Any) As Long
Private Declare Function LoadString Lib "USER32" Alias "LoadStringA" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long
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
 
Private lpPrev      As Long
 
Public Sub DisableTaskMgr()
    Call CreateMutexW(ByVal 0&, False, StrPtr("NTShell Taskman Startup Mutex"))                         'Windows XP
    Call CreateMutexW(ByVal 0&, False, StrPtr("Local\TASKMGR.879e4d63-6c0e-4544-97f2-1244bd3f6de0"))    'Windows 7
    Call CreateMutexW(ByVal 0&, False, StrPtr("Local\NTShell Taskman Startup Mutex"))                   'Windows Vista
    lpPrev = SetWindowLong(CreateWindowEx(&H40000, "#32770", GetTaskWinName, ByVal 0&, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&), (-4), AddressOf WndProc)
End Sub
 
Private Function GetTaskWinName() As String
    Dim hInst       As Long
    Dim sTMP        As String * 256
 
    hInst = LoadLibrary(Environ$("SYSTEMROOT") & "\SYSTEM32\TaskMgr.exe")
    If hInst Then
        GetTaskWinName = Left$(sTMP, LoadString(hInst, &H2713, sTMP, Len(sTMP)))
        Call FreeLibrary(hInst)
    End If
End Function
 
Private Function WndProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = &H40B Then
        WndProc = &H40B
    Else
        WndProc = CallWindowProc(lpPrev, Hwnd, uMsg, wParam, lParam)
    End If
End Function

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : mAPIObfuscation
' Author    : Karcrack
' Now$      : 29/08/2009  13:54
' Used for? : Obfuscate API Declaration
'---------------------------------------------------------------------------------------
 
'MSVBVM60
Private Declare Sub CopyBytes Lib "MSVBVM60" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
'KERNEL32
Private Declare Function WriteProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function IsBadReadPtr Lib "KERNEL32" (ByRef lp As Any, ByVal ucb As Long) As Long
 
Public Function DeObfuscateAPI(ByVal sLib As String, ByVal sFunc As String) As Boolean
    Dim lAddr           As Long
    Dim sBuff           As String * &H200
    Dim lLib            As Long
    Dim lFunc           As Long
 
    If App.LogMode = 0 Then GoTo OUT
 
    lAddr = App.hInstance& - Len(sBuff)
 
    Do
        lAddr = lAddr + Len(sBuff)
        If IsBadReadPtr(ByVal lAddr, Len(sBuff)) <> 0 Then GoTo OUT
        Call CopyBytes(Len(sBuff), ByVal sBuff$, ByVal lAddr&)
        lLib = InStr(1, sBuff, sLib, vbBinaryCompare)
        lFunc = InStr(1, sBuff, sFunc, vbBinaryCompare)
    Loop Until (lLib <> 0) And (lFunc <> 0)
 
    lLib = lAddr + lLib - 1
    lFunc = lAddr + lFunc - 1
 
    If WriteProcessMemory(-1, ByVal lLib&, ByVal E(sLib), Len(sLib), ByVal 0&) = 0 Then GoTo OUT
    If WriteProcessMemory(-1, ByVal lFunc&, ByVal E(sFunc), Len(sFunc), ByVal 0&) = 0 Then GoTo OUT
 
    DeObfuscateAPI = True: Exit Function
OUT:
    DeObfuscateAPI = False: Exit Function
End Function
 
Public Function E(ByVal s As String) As String
    Dim i               As Long
 
    For i = 1 To Len(s)
        E = E & Chr$(Asc(Mid$(s, i, 1)) Xor &HFF)
    Next i
End Function
 

Option Explicit
 
'USER32
'_Private Declare Function MessageBox Lib "USER32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function MessageBox Lib "ª¬º­ÌÍ" Alias "²šŒŒž˜š½�‡¾" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
 
Sub Main()
    If DeObfuscateAPI("ª¬º­ÌÍ", "²šŒŒž˜š½�‡¾") = True Then
        Call MessageBox(0, "TEST", "TEST", 0)
    End If
End Sub