Temas

Cree una clase para editar archivos ejecutables portables. Les dejo todo el proyecto, el que no entienda y le interese me dice en este mismo post y explico función por función, pero primero quiero saber si a alguien le interesa así no escribo al pedo xD.

También cree una GUI para demostrar el funcionamiento de la clase, dejo unos screenshots. El proyecto de la GUI lo ya casi lo termino y lo posteo, me falta la parte de edición pero la clase está terminada.

A la clase me falta agregarle cosas, pero lo voy a hacer en la semana. Por ejemplo extraer y editar recursos, administrar símbolos y varias cosas más. Los archivos ejecutables tienen muchas cosas que analizar.

Postee esto acá porque había amigos que no podían verlo en el laboratorio.

Saludos.

EDITADO:
Posteo el proyecto actualizado, y con la GUI casi terminada. No la voy a terminar porque me aburrí xD, pero voy a actualizar la clase para ver recursos & stuff.

Bueno este post es para saludar a Ap0calipse y desearle suerte ya que está por empezar la universidad.

Ap0 va a ser mi ingeniera informática favorita y ya es mi virukera favorita  ^_^, asì que se merece toda la suerte del mundo.

Que te vaya bien Ap0 y quedate ahi abajo que con lo que me diste ya puedo ir fácil y así nadie nos jode xD.

NOTA: Ya borraré este post mañana así que por favor Mods dejenlo.

Ya que estamos con los módulos pongo las declaraciones de la API de WinInet, ya que son muy útiles para el manejo de cookies, historial, opciones de internet, bajar archivos, etc, etc, etc.

Código [Seleccionar] Expandir


Option Explicit

'Funciones de WININET.DLL
'
Declare Function CommitUrlCacheEntry Lib "wininet" Alias "CommitUrlCacheEntryA" (ByVal lpszUrlName As String, ByVal lpszLocalFileName As String, ExpireTime As FILETIME, LastModifiedTime As FILETIME, ByVal CacheEntryType As Long, ByVal lpHeaderInfo As Byte, ByVal dwHeaderSize As Long, ByVal lpszFileExtension As String, ByVal dwReserved As Long) As Long
Declare Function CreateUrlCacheEntry Lib "wininet" Alias "CreateUrlCacheEntryA" (ByVal lpszUrlName As String, ByVal dwExpectedFileSize As Long, ByVal lpszFileExtension As String, ByVal lpszFileName As String, ByVal dwReserved As Long) As Long
Declare Function CreateUrlCacheGroup Lib "wininet" (ByVal dwFlags As Long, lpReserved As Any) As Long
Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Declare Function DeleteUrlCacheGroup Lib "wininet" (ByVal GroupID As Long, ByVal dwFlags As Long, lpReserved As Any) As Long
Declare Function FindCloseUrlCache Lib "wininet" (ByVal hEnumHandle As Long) As Long
Declare Function FindFirstUrlCacheEntry Lib "wininet" Alias "FindFirstUrlCacheEntryA" (ByVal lpszUrlSearchPattern As String, lpFirstCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwFirstCacheEntryInfoBufferSize As Long) As Long
Declare Function FindFirstUrlCacheEntryEx Lib "wininet" Alias "FindFirstUrlCacheEntryExA" (ByVal lpszUrlSearchPattern As String, ByVal dwFlags As Long, ByVal dwFilter As Long, ByVal GroupID As Long, lpFirstCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwFirstCacheEntryInfoBufferSize As Long, lpGroupAttributes As Any, ByVal pcbGroupAttributes As Long, lpReserved As Any) As Long
Declare Function FindNextUrlCacheEntry Lib "wininet" Alias "FindNextUrlCacheEntryA" (ByVal hEnumHandle As Long, lpNextCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwNextCacheEntryInfoBufferSize As Long) As Long
Declare Function FindNextUrlCacheEntryEx Lib "wininet" Alias "FindNextUrlCacheEntryExA" (ByVal hEnumHandle As Long, lpFirstCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwFirstCacheEntryInfoBufferSize As Long, lpGroupAttributes As Any, pcbGroupAttributes As Long, lpReserved As Any) As Long

Declare Function FtpCommand Lib "wininet" Alias "FtpCommandA" (ByVal hFtpConnect As Long, ByVal fExpectResponse As Long, ByVal dwFlag As Long, ByVal lpszCommand As String, ByVal dwContext As Long) As Long
Declare Function FtpCreateDirectory Lib "wininet" Alias "FtpCreateDirectoryA" (ByVal hFTPSession As Long, ByVal lpszDirectory As String) As Long
Declare Function FtpDeleteFile Lib "wininet" Alias "FtpDeleteFileA" (ByVal hFTPSession As Long, ByVal lpszFileName As String) As Long
Declare Function FtpFindFirstFile Lib "wininet" Alias "FtpFindFirstFileA" (ByVal hFTPSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function FtpGetCurrentDirectory Lib "wininet" Alias "FtpGetCurrentDirectoryA" (ByVal hFTPSession As Long, ByVal lpszCurrentDirectory As String, ByVal lpdwCurrentDirectory As Long) As Long
Declare Function FtpGetFile Lib "wininet" Alias "FtpGetFileA" (ByVal hFTPSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwLocalFlagsAndAttributes As Long, ByVal dwInternetFlags As Long, ByVal dwContext As Long) As Long
Declare Function FtpOpenFile Lib "wininet" Alias "FtpOpenFileA" (ByVal hFTPSession As Long, ByVal lpszFileName As String, ByVal fdwAccess As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function FtpPutFile Lib "wininwt" Alias "FtpPutFileA" (ByVal hFTPSession As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function FtpRemoveDirectory Lib "wininet" Alias "FtpRemoveDirectoryA" (ByVal hFTPSession As Long, ByVal lpszDirectory As String) As Long
Declare Function FtpRenameFile Lib "wininet" Alias "FtpRenameFileA" (ByVal hFTPSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Long
Declare Function FtpSetCurrentDirectory Lib "wininet" Alias "FtpSetCurrentDirectoryA" (ByVal hFTPSession As Long, ByVal lpszDirectory As String) As Long

Declare Function GetUrlCacheEntryInfo Lib "wininet" Alias "GetUrlCacheEntryInfoA" (ByVal lpszUrlName As String, lpCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwCacheEntryInfoBufferSize As Long) As Long
Declare Function GetUrlCacheEntryInfoEx Lib "wininet" Alias "GetUrlCacheEntryInfoExA" (ByVal lpszUrlName As String, lpCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwCacheEntryInfoBufferSize As Long, ByVal lpszReserved As String, ByVal lpdwReserved As Long, lpReserved As Any, ByVal dwFlags As Long) As Long

Declare Function GopherCreateLocator Lib "wininet" Alias "GopherCreateLocatorA" (ByVal lpszHost As String, ByVal nServerPort As Integer, ByVal lpszDisplayString As String, ByVal lpszSelectorString As String, ByVal dwGopherType As Long, ByVal lpszLocator As String, ByVal lpdwBufferLength As Long) As Long
Declare Function GopherFindFirstFile Lib "wininet" Alias "GopherFindFirstFileA" (ByVal hGopherSession As Long, ByVal lpszLocator As String, ByVal lpszSearchString As String, lpFindData As GOPHER_FIND_DATA, ByVal dwFlags As Long, ByVal dwContext As Long)
Declare Function GopherGetAttribute Lib "wininet" Alias "GopherGetAttributeA" (ByVal hGopherSession As Long, ByVal lpszLocator As String, ByVal lpszAttributeName As String, ByVal lpBuffer As Byte, ByVal dwBufferLength As Long, ByVal lpdwCharactersReturned As Long, ByVal lpfnEnumerator As Long, ByVal dwContext As Long) As Long
Declare Function GopherGetLocatorType Lib "wininet" Alias "GopherGetLocatorTypeA" (ByVal lpszLocator As String, ByVal lpdwGopherType As Long) As Long
Declare Function GopherOpenFile Lib "wininet" Alias "GopherOpenFileA" (ByVal hGopherSession As Long, ByVal lpszLocator As String, ByVal lpszView As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Declare Function HttpAddRequestHeaders Lib "wininet" Alias "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwModifiers As Long) As Long
Declare Function HttpEndRequest Lib "wininet" Alias "HttpEndRequestA" (ByVal hRequest As Long, lpBuffersOut As INTERNET_BUFFERS, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function HttpOpenRequest Lib "wininet" Alias "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal lpszVerb As String, ByVal lpszObjectName As String, ByVal lpszVersion As String, ByVal lpszReferer As String, lpszAcceptTypes() As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function HttpQueryInfo Lib "wininet" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal dwInfoLevel As Long, lpvBuffer As Any, ByVal lpdwBufferLength As Long, ByVal lpdwIndex As Long) As Long
Declare Function HttpSendRequest Lib "wininet" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, lpOptional As Any, ByVal dwOptionalLength As Long) As Long
Declare Function HttpSendRequestEx Lib "wininet" Alias "HttpSendRequestExA" (ByVal hRequest As Long, lpBuffersIn As INTERNET_BUFFERS, lpBuffersOut As INTERNET_BUFFERS, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Declare Function InternetAttemptConnect Lib "wininet" Alias "" (ByVal dwReserved As Long) As Long
Declare Function InternetAutodial Lib "wininet" Alias "" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Declare Function InternetAutodialHangup Lib "wininet" Alias "" (ByVal dwReserved As Long) As Long
Declare Function InternetCanonicalizeUrl Lib "wininet" Alias "InternetCanonicalizeUrlA" (ByVal lpszUrl As String, ByVal lpszBuffer As String, ByVal lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Declare Function InternetCheckConnection Lib "wininet" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long)
Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Long
Declare Function InternetCombineUrl Lib "wininet" Alias "InternetCombineUrlA" (ByVal lpszBaseUrl As String, ByVal lpszRelativeUrl As String, ByVal lpszBuffer As String, lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Declare Function InternetConfirmZoneCrossing Lib "wininet" Alias "InternetConfirmZoneCrossingA" (ByVal hWnd As Long, ByVal szUrlPrev As String, ByVal szUrlNew As Long, ByVal bPost As Boolean) As Long
Declare Function InternetConnect Lib "wininet" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal lpszServerName As String, ByVal nServerPort As Long, ByVal lpszUsername As String, ByVal lpszPassword As String, ByVal dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long)
Declare Function InternetCrackUrl Lib "wininet" Alias "InternetCrackUrlA" (ByVal lpszUrl As String, ByVal dwUrlLength As Long, ByVal dwFlags As Long, lpUrlComponents As URL_COMPONENTS)
Declare Function InternetCreateUrl Lib "wininet" Alias "InternetCreateUrlA" (lpUrlComponents As URL_COMPONENTS, ByVal dwFlags As Long, ByVal lpszUrl As String, ByVal lpdwUrlLength As Long) As Long
Declare Function InternetDial Lib "wininet" Alias "InternetDialA" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, ByVal lpdwConnection As Long, ByVal dwReserved As Long) As Long
Declare Function InternetErrorDlg Lib "wininet" (ByVal hWnd As Long, ByVal hInternet As Long, ByVal dwError As Long, ByVal dwFlags As Long, lppvData As Any) As Long
Declare Function InternetFindNextFile Lib "wininet" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As Any) As Long
Declare Function InternetGetConnectedState Lib "wininet" (ByVal lpdwFlags As Long, ByVal dwReserved As Long) As Long
Declare Function InternetGetCookie Lib "wininet" Alias "InternetGetCookieA" (ByVal lpszUrlName As String, ByVal lpszCookieName As String, ByVal lpszCookieData As String, ByVal lpdwSize As Long) As Long
Declare Function InternetGetLastResponseInfo Lib "wininet" Alias "InternetGetLastResponseInfoA" (ByVal lpdwError As Long, ByVal lpszBuffer As String, ByVal lpdwBufferLength As Long) As Long
Declare Function InternetGoOnline Lib "wininet" Alias "InternetGoOnlineA" (ByVal lpszUrl As String, ByVal hwndParent As Long, ByVal dwReserved As Long) As Long
Declare Function InternetHangUp Lib "wininet" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
Declare Function InternetLockRequestFile Lib "wininet" (ByVal hInternet As Long, lphLockReqHandle As Long)
Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function InternetQueryDataAvailable Lib "wininet" (ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function InternetQueryOption Lib "wininet" Alias "InternetQueryOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByVal lpBuffer As String, ByVal lpdwBufferLength As Long) As Long
Declare Function InternetReadFile Lib "wininet" Alias "InternetReadFileA" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long) As Long
Declare Function InternetReadFileEx Lib "wininet" Alias "InternetReadFileExA" (ByVal hFile As Long, lpBuffersOut As INTERNET_BUFFERS, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function InternetSetCookie Lib "wininet" Alias "InternetSetCookieA" (ByVal lpszUrlName As String, ByVal lpszCookieName As String, ByVal lpszCookieData As Long) As Long
Declare Function InternetSetDialState Lib "wininet" Alias "InternetSetDialStateA" (ByVal lpszConnectoid As String, ByVal dwState As Long, ByVal dwReserved As Long) As Long
Declare Function InternetSetFilePointer Lib "wininet" (ByVal hFile As Long, ByVal lDistanceToMove As Long, pReserved As Any, ByVal dwMoveMethod As Long, ByVal dwContext As Long) As Long
Declare Function InternetSetOption Lib "wininet" Alias "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByVal lpBuffer As Long, ByVal dwBufferLength As Long) As Long
Declare Function InternetSetStatusCallback Lib "wininet" Alias "InternetSetStatusCallbackA" (ByVal hInternet As Long, ByVal lpfnInternetCallback As Long) As Long
Declare Function InternetTimeFromSystemTime Lib "wininet" Alias "InternetTimeFromSystemTimeA" (pst As SystemTime, ByVal dwRFC As Long, ByVal lpszTime As String, ByVal cbTime As Long) As Long
Declare Function InternetUnlockRequestFile Lib "wininet" Alias "" (ByVal hLockHandle As Long) As Long
Declare Function InternetWriteFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToWrite As Long, ByVal lpdwNumberOfBytesWritten As Long) As Long

Declare Function ReadUrlCacheEntryStream Lib "wininet" (ByVal hUrlCacheStream As Long, ByVal dwLocation As Long, lpBuffer As Any, lpdwLen As Long, ByVal dwReserved As Long) As Long
Declare Function RetrieveUrlCacheEntryFile Lib "wininet" Alias "RetrieveUrlCacheEntryFileA" (ByVal lpszUrlName As String, lpCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwCacheEntryInfoBufferSize As Long, ByVal dwReserved As Long) As Long
Declare Function RetrieveUrlCacheEntryStream Lib "wininet" Alias "RetrieveUrlCacheEntryStreamA" (ByVal lpszUrlName As String, lpCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal lpdwCacheEntryInfoBufferSize As Long, ByVal fRandomRead As Boolean, ByVal dwReserved As Long) As Long
Declare Function SetUrlCacheEntryGroup Lib "wininet" Alias "SetUrlCacheEntryGroupA" (ByVal lpszUrlName As String, ByVal dwFlags As Long, ByVal GroupID As Long, ByVal pbGroupAttributes As Byte, ByVal cbGroupAttributes As Long, lpReserved As Any) As Long
Declare Function SetUrlCacheEntryInfo Lib "wininet" Alias "SetUrlCacheEntryInfoA" (ByVal lpszUrlName As String, lpCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, ByVal dwFieldControl As Long) As Long
Declare Function UnlockUrlCacheEntryFile Lib "wininet" Alias "UnlockUrlCacheEntryFileA" (ByVal lpszUrlName As String, ByVal dwReserved As Long) As Long
Declare Function UnlockUrlCacheEntryStream Lib "wininet" (ByVal hUrlCacheStream As Long, ByVal dwReserved As Long) As Long


Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0      'indicates to use config info from registry
Public Const INTERNET_OPEN_TYPE_DIRECT = 1         'direct to net
Public Const INTERNET_OPEN_TYPE_PROXY = 3          'via named proxy

Public Const INTERNET_FLAG_EXISITING_CONNECT = &H20000000
Public Const INTERNET_FLAG_RELOAD = &H80000000   ' read from wire even if locally cached

'Opciones adicionales
Public Const INTERNET_FLAG_SECURE = &H800000    'use PCT/SSL if applicable (HTTP)
Public Const INTERNET_FLAG_KEEP_CONNECTION = &H400000   'use keep-alive semantics
Public Const INTERNET_FLAG_NO_AUTO_REDIRECT = &H200000     'don't handle redirections automatically
Public Const INTERNET_FLAG_READ_PREFETCH = &H100000        'do background read prefetch
Public Const INTERNET_FLAG_NO_COOKIES = &H80000    'no automatic cookie handling
Public Const INTERNET_FLAG_NO_AUTH = &H40000    'no automatic authentication handling

'Opciones del cache
Public Const INTERNET_FLAG_MUST_CACHE_REQUEST = &H10    'fails if unable to cache request
Public Const INTERNET_FLAG_RESYNCHRONIZE = &H800        'asking wininet to update an item if it is newer

'Opciones de seguridad
Public Const INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP = &H8000       'ex: https:// to http://
Public Const INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS = &H4000      'ex: http:// to https://
Public Const INTERNET_FLAG_IGNORE_CERT_DATE_INVALID = &H2000      'expired X509 Cert.
Public Const INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000        'bad common name in X509 Cert.

Public Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000   'don't write this item to the cache
Public Const INTERNET_FLAG_DONT_CACHE = INTERNET_FLAG_NO_CACHE_WRITE
Public Const INTERNET_FLAG_MAKE_PERSISTENT = &H2000000      'make this item persistent in cache

'Longitud máxima de campos
Public Const INTERNET_MAX_HOST_NAME_LENGTH = 256
Public Const INTERNET_MAX_USER_NAME_LENGTH = 128
Public Const INTERNET_MAX_PASSWORD_LENGTH = 128
Public Const INTERNET_MAX_PORT_NUMBER_LENGTH = 5    'INTERNET_PORT is unsigned short
Public Const INTERNET_MAX_PORT_NUMBER_VALUE = 65535     'maximum unsigned short value
Public Const INTERNET_MAX_PATH_LENGTH = 2048
Public Const INTERNET_MAX_PROTOCOL_NAME = "gopher"  'longest protocol name
Public Const INTERNET_MAX_URL_LENGTH = (6 - 1 + 3 + INTERNET_MAX_PATH_LENGTH)   '6=Len(INTERNET_MAX_PROTOCOL_NAME); 3=Len("://")

'Para FTP
Public Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Public Const FTP_TRANSFER_TYPE_ASCII = &H1
Public Const FTP_TRANSFER_TYPE_BINARY = &H2

Public Const INTERNET_FLAG_TRANSFER_ASCII = FTP_TRANSFER_TYPE_ASCII
Public Const INTERNET_FLAG_TRANSFER_BINARY = FTP_TRANSFER_TYPE_BINARY

Public Const FTP_TRANSFER_TYPE_MASK = (FTP_TRANSFER_TYPE_ASCII Or FTP_TRANSFER_TYPE_BINARY)

'Para Gopher
'Tipo de datos
Public Const GOPHER_TYPE_TEXT_FILE = &H1    'Archivo de texto
Public Const GOPHER_TYPE_DIRECTORY = &H2    'Directorio
Public Const GOPHER_TYPE_CSO = &H4          'Servidor de libreta de direcciones CSO
Public Const GOPHER_TYPE_ERROR = &H8        'Indicador de error
Public Const GOPHER_TYPE_MAC_BINHEX = &H10  'Archivo Macintosh en formato BINHEX
Public Const GOPHER_TYPE_DOS_ARCHIVE = &H20     'Archivo de MS-DOS
Public Const GOPHER_TYPE_UNIX_UUENCODED = &H40  'Archivo UUENCODED
Public Const GOPHER_TYPE_INDEX_SERVER = &H80    'Servidor de indices
Public Const GOPHER_TYPE_TELNET = &H100     'Servidor Telnet
Public Const GOPHER_TYPE_BINARY = &H200     'Archivo binario
Public Const GOPHER_TYPE_REDUNDANT = &H400  'Indica que es un duplicado del servidor
Public Const GOPHER_TYPE_TN3270 = &H800     'Servidor TN3270
Public Const GOPHER_TYPE_GIF = &H1000       'Archivo de imagen GIF
Public Const GOPHER_TYPE_IMAGE = &H2000     'Archivo de imagen
Public Const GOPHER_TYPE_BITMAP = &H4000    'Archivo de mapa de bits
Public Const GOPHER_TYPE_MOVIE = &H8000     'Archivo de película
Public Const GOPHER_TYPE_SOUND = &H10000    'Archivo de sonido
Public Const GOPHER_TYPE_HTML = &H20000     'Documento HTML
Public Const GOPHER_TYPE_PDF = &H40000      'Archivo PDF
Public Const GOPHER_TYPE_CALENDAR = &H80000     'Archivo de calendario
Public Const GOPHER_TYPE_INLINE = &H100000      'Archivo Inline
Public Const GOPHER_TYPE_UNKNOWN = &H20000000   'Elemento desconocido
Public Const GOPHER_TYPE_ASK = &H40000000       'Ask+ Item
Public Const GOPHER_TYPE_GOPHER_PLUS = &H80000000   'Gopher+ Item

Public Const MAX_GOPHER_DISPLAY_TEXT = 128
Public Const MAX_GOPHER_SELECTOR_TEXT = 256
Public Const MAX_GOPHER_HOST_NAME = INTERNET_MAX_HOST_NAME_LENGTH
Public Const MAX_GOPHER_LOCATOR_LENGTH = (1 + MAX_GOPHER_DISPLAY_TEXT + 1 + MAX_GOPHER_SELECTOR_TEXT + 1 + MAX_GOPHER_HOST_NAME + 1 + INTERNET_MAX_PORT_NUMBER_LENGTH + 1 + 1 + 2)

'Para HTTP
Public Const HTTP_QUERY_MIME_VERSION = 0
Public Const HTTP_QUERY_CONTENT_TYPE = 1
Public Const HTTP_QUERY_CONTENT_TRANSFER_ENCODING = 2
Public Const HTTP_QUERY_CONTENT_ID = 3
Public Const HTTP_QUERY_CONTENT_DESCRIPTION = 4
Public Const HTTP_QUERY_CONTENT_LENGTH = 5
Public Const HTTP_QUERY_CONTENT_LANGUAGE = 6
Public Const HTTP_QUERY_ALLOW = 7
Public Const HTTP_QUERY_PUBLIC = 8
Public Const HTTP_QUERY_DATE = 9
Public Const HTTP_QUERY_EXPIRES = 10
Public Const HTTP_QUERY_LAST_MODIFIED = 11
Public Const HTTP_QUERY_MESSAGE_ID = 12
Public Const HTTP_QUERY_URI = 13
Public Const HTTP_QUERY_DERIVED_FROM = 14
Public Const HTTP_QUERY_COST = 15
Public Const HTTP_QUERY_LINK = 16
Public Const HTTP_QUERY_PRAGMA = 17
Public Const HTTP_QUERY_VERSION = 18                        'special: part of status line
Public Const HTTP_QUERY_STATUS_CODE = 19                    'special: part of status line
Public Const HTTP_QUERY_STATUS_TEXT = 20                    'special: part of status line
Public Const HTTP_QUERY_RAW_HEADERS = 21                    'special: all headers as ASCIIZ
Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22               'special: all headers
Public Const HTTP_QUERY_CONNECTION = 23
Public Const HTTP_QUERY_ACCEPT = 24
Public Const HTTP_QUERY_ACCEPT_CHARSET = 25
Public Const HTTP_QUERY_ACCEPT_ENCODING = 26
Public Const HTTP_QUERY_ACCEPT_LANGUAGE = 27
Public Const HTTP_QUERY_AUTHORIZATION = 28
Public Const HTTP_QUERY_CONTENT_ENCODING = 29
Public Const HTTP_QUERY_FORWARDED = 30
Public Const HTTP_QUERY_FROM = 31
Public Const HTTP_QUERY_IF_MODIFIED_SINCE = 32
Public Const HTTP_QUERY_LOCATION = 33
Public Const HTTP_QUERY_ORIG_URI = 34
Public Const HTTP_QUERY_REFERER = 35
Public Const HTTP_QUERY_RETRY_AFTER = 36
Public Const HTTP_QUERY_SERVER = 37
Public Const HTTP_QUERY_TITLE = 38
Public Const HTTP_QUERY_USER_AGENT = 39
Public Const HTTP_QUERY_WWW_AUTHENTICATE = 40
Public Const HTTP_QUERY_PROXY_AUTHENTICATE = 41
Public Const HTTP_QUERY_ACCEPT_RANGES = 42
Public Const HTTP_QUERY_SET_COOKIE = 43
Public Const HTTP_QUERY_COOKIE = 44
Public Const HTTP_QUERY_REQUEST_METHOD = 45                 'special: GET/POST etc.
Public Const HTTP_QUERY_MAX = 45
Public Const HTTP_QUERY_CUSTOM = 65535
Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
Public Const HTTP_QUERY_FLAG_SYSTEMTIME = &H40000000
Public Const HTTP_QUERY_FLAG_NUMBER = &H20000000
Public Const HTTP_QUERY_FLAG_COALESCE = &H10000000

'Servidores de Internet
Public Const INTERNET_SERVICE_FTP = 1
Public Const INTERNET_SERVICE_GOPHER = 2
Public Const INTERNET_SERVICE_HTTP = 3

'Indicadores para InternetQueryOption e InternetSetOption
Public Const INTERNET_OPTION_CALLBACK = 1
Public Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
Public Const INTERNET_OPTION_CONNECT_RETRIES = 3
Public Const INTERNET_OPTION_CONNECT_BACKOFF = 4
Public Const INTERNET_OPTION_SEND_TIMEOUT = 5
Public Const INTERNET_OPTION_CONTROL_SEND_TIMEOUT = INTERNET_OPTION_SEND_TIMEOUT
Public Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
Public Const INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT = INTERNET_OPTION_RECEIVE_TIMEOUT
Public Const INTERNET_OPTION_DATA_SEND_TIMEOUT = 7
Public Const INTERNET_OPTION_DATA_RECEIVE_TIMEOUT = 8
Public Const INTERNET_OPTION_HANDLE_TYPE = 9
Public Const INTERNET_OPTION_CONTEXT_VALUE = 10

Public Const INTERNET_OPTION_READ_BUFFER_SIZE = 12
Public Const INTERNET_OPTION_WRITE_BUFFER_SIZE = 13

Public Const INTERNET_OPTION_ASYNC_ID = 15
Public Const INTERNET_OPTION_ASYNC_PRIORITY = 16

Public Const INTERNET_OPTION_PARENT_HANDLE = 21
Public Const INTERNET_OPTION_KEEP_CONNECTION = 22
Public Const INTERNET_OPTION_REQUEST_FLAGS = 23
Public Const INTERNET_OPTION_EXTENDED_ERROR = 24

Public Const INTERNET_OPTION_OFFLINE_MODE = 26
Public Const INTERNET_OPTION_CACHE_STREAM_HANDLE = 27
Public Const INTERNET_OPTION_USERNAME = 28
Public Const INTERNET_OPTION_PASSWORD = 29
Public Const INTERNET_OPTION_ASYNC = 30
Public Const INTERNET_OPTION_SECURITY_FLAGS = 31
Public Const INTERNET_OPTION_SECURITY_CERTIFICATE_STRUCT = 32
Public Const INTERNET_OPTION_DATAFILE_NAME = 33
Public Const INTERNET_OPTION_URL = 34
Public Const INTERNET_OPTION_SECURITY_CERTIFICATE = 35
Public Const INTERNET_OPTION_SECURITY_KEY_BITNESS = 36
Public Const INTERNET_OPTION_REFRESH = 37
Public Const INTERNET_OPTION_PROXY = 38
Public Const INTERNET_OPTION_SETTINGS_CHANGED = 39
Public Const INTERNET_OPTION_VERSION = 40

'Estados de la conexión
Public Const INTERNET_STATUS_RESOLVING_NAME = 10
Public Const INTERNET_STATUS_NAME_RESOLVED = 11
Public Const INTERNET_STATUS_CONNECTING_TO_SERVER = 20
Public Const INTERNET_STATUS_CONNECTED_TO_SERVER = 21
Public Const INTERNET_STATUS_SENDING_REQUEST = 30
Public Const INTERNET_STATUS_REQUEST_SENT = 31
Public Const INTERNET_STATUS_RECEIVING_RESPONSE = 40
Public Const INTERNET_STATUS_RESPONSE_RECEIVED = 41
Public Const INTERNET_STATUS_CTL_RESPONSE_RECEIVED = 42
Public Const INTERNET_STATUS_PREFETCH = 43
Public Const INTERNET_STATUS_CLOSING_CONNECTION = 50
Public Const INTERNET_STATUS_CONNECTION_CLOSED = 51
Public Const INTERNET_STATUS_HANDLE_CREATED = 60
Public Const INTERNET_STATUS_HANDLE_CLOSING = 70
Public Const INTERNET_STATUS_REQUEST_COMPLETE = 100
Public Const INTERNET_STATUS_REDIRECT = 110

'Puertos estandard
Public Const INTERNET_DEFAULT_FTP_PORT = 21               'default for FTP servers
Public Const INTERNET_DEFAULT_GOPHER_PORT = 70            '    "     "  gopher "
Public Const INTERNET_DEFAULT_HTTP_PORT = 80              '    "     "  HTTP   "
Public Const INTERNET_DEFAULT_HTTPS_PORT = 443            '    "     "  HTTPS  "
Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080           'default for SOCKS firewall servers.

'Modos de acceso a los archivos
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000

'Posiciones en el archivo
Public Const FILE_BEGIN = 0
Public Const FILE_CURRENT = 1
Public Const FILE_END = 2

Public Const MAX_PATH = 260

Public Type FILETIME
  dwLowDateTime   As Long
  dwHighDateTime  As Long
End Type

Public Type SystemTime
  wYear         As Integer
  wMonth        As Integer
  wDayOfWeek    As Integer
  wDay          As Integer
  wHour         As Integer
  wMinute       As Integer
  wSecond       As Integer
  wMilliseconds As Integer
End Type

Public Type INTERNET_CACHE_ENTRY_INFO_UNION
  dwReserved    As Long
  dwExemptDelta As Long
End Type

Public Type INTERNET_CACHE_ENTRY_INFO
  dwStructSize      As Long    'Tamaño, en bytes de la estructura
  lpszSourceUrlName As String 'Dirección URL
  lpszLocalFileName As String 'Nombre del archivo local
  CacheEntryType    As Long
  dwUseCount        As Long  'Cuenta del usuario actual de la entrada del cache
  dwHitRate         As Long   'Numero de veces que la entrada del cache fue recuperada
  dwSizeLow         As Long
  dwSizeHigh        As Long
  LastModifiedTime  As FILETIME
  ExpireTime        As FILETIME
  LastAccessTime    As FILETIME
  LastSyncTime      As FILETIME
  lpHeaderInfo      As Byte    'Dirección del búfer que contiene la información del encabezado
  dwHeaderInfoSize  As Long    'Tamaño del búfer de lpHeaderInfo
  lpszFileExtension As String
  Union             As INTERNET_CACHE_ENTRY_INFO_UNION
End Type

Public Type WIN32_FIND_DATA
  dwFileAttributes  As Long
  ftCreationTime    As FILETIME
  ftLastAccessTime  As FILETIME
  ftLastWriteTime   As FILETIME
  nFileSizeHigh     As Long
  nFileSizeLow      As Long
  dwReserved0       As Long
  dwReserved1       As Long
  cFileName         As String * MAX_PATH
  cAlternate        As String * 14
End Type

Public Type GOPHER_FIND_DATA
  DisplayString(MAX_GOPHER_DISPLAY_TEXT + 1) As Byte
  GopherType            As Long
  SizeLow               As Long
  SizeHigh              As Long
  LastModificationTime  As FILETIME
  Locator(MAX_GOPHER_LOCATOR_LENGTH + 1) As Byte
End Type

Public Type GOPHER_ADMIN_ATTRIBUTE_TYPE
  Comment       As String
  EmailAddress  As String
End Type

Public Type GOPHER_SCORE_ATTRIBUTE_TYPE
  Score As Integer
End Type

Public Type GOPHER_SCORE_RANGE_ATTRIBUTE_TYPE
  LowerBound As Integer
  UpperBound As Integer
End Type

Public Type GOPHER_SITE_ATTRIBUTE_TYPE
  Site As String
End Type

Public Type GOPHER_ORGANIZATION_ATTRIBUTE_TYPE
  Organization As String
End Type

Public Type GOPHER_LOCATION_ATTRIBUTE_TYPE
  Location As String
End Type

Public Type GOPHER_GEOGRAPHICAL_LOCATION_ATTRIBUTE_TYPE
  DegreesNorth  As Integer
  MinutesNorth  As Integer
  SecondsNorth  As Integer
  DegreesEast   As Integer
  MinutesEast   As Integer
  SecondsEast   As Integer
End Type

Public Type GOPHER_TIMEZONE_ATTRIBUTE_TYPE
  Zone As Integer
End Type

Public Type GOPHER_PROVIDER_ATTRIBUTE_TYPE
  Provider As String
End Type

Public Type GOPHER_VERSION_ATTRIBUTE_TYPE
  Version As String
End Type

Public Type GOPHER_ABSTRACT_ATTRIBUTE_TYPE
  ShortAbstract As String
  AbstractFile  As String
End Type

Public Type GOPHER_VIEW_ATTRIBUTE_TYPE
  ContentType As String
  Language    As String
  Size        As Long
End Type

Public Type GOPHER_VERONICA_ATTRIBUTE_TYPE
  TreeWalk As Long
End Type

Public Type GOPHER_ASK_ATTRIBUTE_TYPE
  QuestionType As String
  QuestionText As String
End Type

Public Type GOPHER_UNKNOWN_ATTRIBUTE_TYPE
  Text As String
End Type

Public Type GOPHER_ATTRIBUTE_TYPE_UNION
  Admin                 As GOPHER_ADMIN_ATTRIBUTE_TYPE
  ModDate               As FILETIME
  Score                 As GOPHER_SCORE_ATTRIBUTE_TYPE
  ScoreRange            As GOPHER_SCORE_RANGE_ATTRIBUTE_TYPE
  Site                  As GOPHER_SITE_ATTRIBUTE_TYPE
  Organization          As GOPHER_ORGANIZATION_ATTRIBUTE_TYPE
  Location              As GOPHER_LOCATION_ATTRIBUTE_TYPE
  GeographicalLocation  As GOPHER_GEOGRAPHICAL_LOCATION_ATTRIBUTE_TYPE
  TimeZone              As GOPHER_TIMEZONE_ATTRIBUTE_TYPE
  Provider              As GOPHER_PROVIDER_ATTRIBUTE_TYPE
  Version               As GOPHER_VERSION_ATTRIBUTE_TYPE
  Abstract              As GOPHER_ABSTRACT_ATTRIBUTE_TYPE
  View                  As GOPHER_VIEW_ATTRIBUTE_TYPE
  Veronica              As GOPHER_VERONICA_ATTRIBUTE_TYPE
  Ask                   As GOPHER_ASK_ATTRIBUTE_TYPE
  Unknown               As GOPHER_UNKNOWN_ATTRIBUTE_TYPE
End Type

Public Type GOPHER_ATTRIBUTE_TYPE
  CategoryId    As Long
  AttributeId   As Long
  AttributeType As GOPHER_ATTRIBUTE_TYPE_UNION
End Type

Public Type INTERNET_BUFFERS
  dwStructSize    As Long
  Next            As Long      'Dirección del siguiente INTERNET_BUFFERS
  lpcszHeader     As String    'Cadena que contiene los encabezados
  dwHeadersLength As Long      'Tamaño de los encabezados si lpcszHeader no es Nulo
  dwHeadersTotal  As Long      'Tamaño total de los encabezados si no hay suficiente memoria en lpcszHeader
  lpvBuffer       As Variant   'Búfer de datos
  dwBufferLength  As Long      'Tamaño de lpvBuffer si lpvBuffer no es Nulo
  dwBufferTotal   As Long
  dwOffsetLow     As Long      'Usado para leer rangos
  dwOffsetHigh    As Long      'Usado para leer rangos
End Type

Public Type URL_COMPONENTS
  dwStructSize      As Long
  lpszScheme        As String
  dwSchemeLength    As Long
  nScheme           As Integer
  lpszHostName      As String
  dwHostNameLength  As Long
  nPort             As Integer
  lpszUsername      As String
  dwUserNameLength  As Long
  lpszPassword      As String
  dwPasswordLength  As Long
  lpszUrlPath       As String
  dwUrlPathLength   As Long
  lpszExtraInfo     As String
  dwExtraInfoLength As Long
End Type

Function InternetStatusCallback(ByVal hInternet As Long, ByVal dwContext As Long, ByVal dwInternetStatus As Long, lpvStatusInformation As Variant, ByVal dwStatusInformationLength As Long)

End Function


Saludos.

[win.tlb]

Para los que le interese la programación de virus este código sirve para buscar espacios libres en la sección de código del ejecutable para luego poder insertar nuestro código ahi.

Lo bueno de este método es que la sección de código (.text) siempre tiene permiso de ejecución por lo que no nos dará errores de protección.

Necesita agregar como referencia al proyecto win.tlb

Código [Seleccionar] Expandir


'
'Coded by Slasher
'
Option Explicit
Option Base 1

Public Const IMAGE_SIZEOF_SHORT_NAME = 8
Public Const IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16

Public Const IMAGE_DOS_SIGNATURE = &H5A4D      ' MZ
Public Const IMAGE_OS2_SIGNATURE = &H454E      ' NE
Public Const IMAGE_OS2_SIGNATURE_LE = &H454C   ' LE
Public Const IMAGE_NT_SIGNATURE = &H4550       ' PE
Public Const IMAGE_FILE_UNKNOWN = &H0          ' Desconocido


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(3)    As Integer
  e_oemid     As Integer
  e_oeminfo   As Integer
  e_res2(9)   As Integer
  e_lfanew    As Long
End Type

Type IMAGE_FILE_HEADER
  Magic                 As Long
  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_DATA_DIRECTORY
  VirtualAddress  As Long
  Size            As Long
End Type

Type IMAGE_OPTIONAL_HEADER
'Campos estándar
'
  Magic                     As Integer
  MajorLinkerVersion        As Byte
  MinorLinkerVersion        As Byte
  SizeOfCode                As Long
  SizeOfInitializedData     As Long
  SizeOfUninitializedData   As Long
  AddressOfEntryPoint       As Long
  BaseOfCode                As Long
  BaseOfData                As Long
 
'Campos adicionales de NT
'
  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
  Reserved1                     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(IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1) As IMAGE_DATA_DIRECTORY
End Type

Type HoleInfo
  Offset  As Long
  Size    As Long
End Type

Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long
Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long

Sub Main()
        Dim lpHoles() As HoleInfo
        Dim hMap&, lBase&, lSize&
        Dim lHoles&, i&

  hMap = MapExe("C:\WINDOWS\SYSTEM32\NOTEPAD.EXE")
  lBase = GetCodeOffset(hMap, lSize)
 
  'Busca huecos de 128 bytes como mínimo.
  '
  lHoles = FindHoles(hMap, lBase, lSize, lpHoles, 128)
 
  For i = 1 To lHoles
    Debug.Print "Hueco Nº " & i, "Offset: 0x" & Hex$(lpHoles(i).Offset), _
                "Tamaño: 0x" & Hex$(lpHoles(i).Size)
  Next
 
  Call VirtualFree(hMap, 0&, MEM_RELEASE)

End Sub

Function MapExe(Filename As String) As Long
        Dim hMem&, hFile&
        Dim r&

  hFile = CreateFile(Filename, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0&, OPEN_EXISTING, 0&, 0&)
 
  If hFile = INVALID_HANDLE_VALUE Then Exit Function
 
  'Asigna memoria.
  '
  hMem = VirtualAlloc(0&, GetFileSize(hFile, 0), MEM_COMMIT, PAGE_READWRITE)
 
  'Lee el archivo a memoria.
  '
  r = ReadFile(hFile, ByVal hMem, GetFileSize(hFile, 0), 0&, ByVal 0&)
 
  MapExe = hMem
End Function

Function GetCodeOffset(hMap As Long, Optional outSize As Long) As Long
        Dim lpDosHdr  As IMAGE_DOS_HEADER
        Dim lpFileHdr As IMAGE_FILE_HEADER
        Dim lpOptHdr  As IMAGE_OPTIONAL_HEADER
        Dim r&

  r = ReadProcessMemory(GetCurrentProcess(), hMap, lpDosHdr, Len(lpDosHdr))
 
  If lpDosHdr.e_magic <> IMAGE_DOS_SIGNATURE Then Exit Function
 
  r = ReadProcessMemory(GetCurrentProcess(), hMap + lpDosHdr.e_lfanew + Len(lpFileHdr), lpOptHdr, Len(lpOptHdr))
 
  outSize = lpOptHdr.SizeOfCode
  GetCodeOffset = lpOptHdr.BaseOfCode
End Function

Function FindHoles(hMap As Long, BaseOfCode As Long, SizeOfCode As Long, outHoles() As HoleInfo, Optional MinSize As Integer) As Long
        Dim btData() As Byte
        Dim lHoleSize&, lCnt&
        Dim r&, i&

  ReDim btData(SizeOfCode) As Byte
 
  r = ReadProcessMemory(GetCurrentProcess(), hMap + BaseOfCode, btData(1), SizeOfCode)
 
  If MinSize <= 0 Then MinSize = 128
 
  Erase outHoles
 
  For i = 1 To SizeOfCode
    If btData(i) <> 0 And lHoleSize > MinSize Then
      lCnt = lCnt + 1
     
      ReDim Preserve outHoles(lCnt) As HoleInfo
     
      outHoles(lCnt).Offset = BaseOfCode + i
      outHoles(lCnt).Size = lHoleSize
     
      lHoleSize = 0
     
    ElseIf btData(i) = 0 Then
      lHoleSize = lHoleSize + 1
    End If
  Next
 
  FindHoles = lCnt
End Function


Saludos.

Código [Seleccionar] Expandir


Option Explicit

Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2

Const ANYSIZE_ARRAY = 1

Type LUID
  LowPart As Long
  HighPart As Long
End Type

Type LUID_AND_ATTRIBUTES
  pLuid As LUID
  Attributes As Long
End Type

Type TOKEN_PRIVILEGES
  PrivilegeCount As Long
  Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type

Declare Function GetCurrentProcess Lib "kernel32" () As Long
Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLUID As LUID) As Long
Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

Declare Function SetSystemPowerState Lib "kernel32" (ByVal fSuspend As Long, ByVal fForce As Long) As Long

Private Sub SetShutdownPrivilege()
    Dim lpLUID        As LUID
    Dim lpToken       As TOKEN_PRIVILEGES
    Dim lpPrevToken   As TOKEN_PRIVILEGES
    Dim hToken&, r&

    r = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken)
    r = LookupPrivilegeValue(vbNullString, "SeShutdownPrivilege", lpLUID)
   
    With lpToken
      .PrivilegeCount = 1
      .Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
      .Privileges(0).pLuid = lpLUID
    End With
   
    r = AdjustTokenPrivileges(hToken, False, lpToken, 4 + (12 * lpToken.PrivilegeCount), lpPrevToken, 4 + (12 * lpPrevToken.PrivilegeCount))
End Sub

Sub SuspendSystem()
  Call SetShutdownPrivilege
  Call SetSystemPowerState(True, False)
End Sub


Buenas. Tengo montado un server de CS en LAN y quería crear una tabla de ranking.

Estuve buscando por el foro y por internet y no encontré ningún plugin o método para crear un ranking para el cs (o será que no soy tan vicioso y no sé buscar xD).

Cualquiera que sepa algo al respecto se lo voy a agradecer.

Saludos.

Bueno lo siguiente es un código que escribi hace mucho y que lista todos los procesos del sistema, cos sus threads, módulos atados y las ventanas de cada thread. Se puede utilizar para hacer un árbol de recursos o algo similar.

También tiene un sistema que loguea los procesos creando una tabla en memoria con los datos de todos los procesos y luego se puede guardar en un archivo.

El código es algo complejo pero no tengo ganas de ponerle los comentarios xDDD. Con sólo llamar a EnumProcesses la variable global SysProcess va a tener almacenados todos los procesos y sus datos.

Código [Seleccionar] Expandir


'*****************************************************************
'
'Autor: Slasher Keeper
'Descripción:
'   * Lista procesos del sistema y sus recursos.
'   * Loguea los procesos.
'*****************************************************************
'
Option Explicit
Option Base 1

Public Const MAX_PATH = 260

Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8

Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)

Type WindowInfo
  ProcessId       As Long
  ThreadID        As Long
  NumThdWindows   As Long
  ThreadWindows() As Long
  hwndParent      As Long
  hwnd            As Long
  hModule         As Long
  hIcon           As Long
  Identifier      As Long
  WindowProc      As Long
  hInstance       As Long
  Style           As Long
  UserData        As Long
  ChildWindows()  As Long
  NumOfChild      As Integer
  Index           As Integer
  ClassName       As String
  Text            As String * MAX_PATH
  ModuleName      As String * MAX_PATH
End Type

Type ThreadInfo
  ThreadID      As Long
  BasePriority  As Long
  UsageCount    As Long
  AttachCount   As Long
End Type

Type ModuleInfo
  BaseAddress   As Long
  hModule       As Long
  ModuleSize    As Long
  ProcessId     As Long
  ModuleId      As Long
  GlobalUsage   As Long
  ProcessUsage  As Long
  Filename      As String * MAX_PATH
  ModuleName    As String * MAX_PATH
End Type

Type ProcessInfo
  hProcess          As Long
  ProcessId         As Long
  ParentProcessID   As Long
  PriorityClass     As Long
  MinWorkingSetSize As Long
  MaxWorkingSetSize As Long
  ExitCode          As Long
  AffinityMask      As Long
  SysAffinityMask   As Long
  HandleCount       As Long
  NumOfThreads      As Long
  NumOfModules      As Long
  CurrentMemPage    As Long
  Threads()         As ThreadInfo
  Modules()         As ModuleInfo
  ExeFilename       As String * MAX_PATH
  Index             As Integer
End Type

Type FileVersionInfo
    CompanyName      As String
    FileDescription  As String
    FileVersion      As String
    InternalName     As String
    LegalCopyright   As String
    OriginalFileName As String
    ProductName      As String
    ProductVersion   As String
    Comments         As String
    FileOS           As String
End Type

Type HEAPENTRY32
    dwSize        As Long
    hHandle       As Long
    dwAddress     As Long
    dwBlockSize   As Long
    dwFlags       As Long
    dwLockCount   As Long
    dwResvd       As Long
    th32ProcessID As Long
    th32HeapID    As Long
End Type

Type Var
    wLength         As Integer
    wValueLength    As Integer
    wType           As Integer
    szKey           As Long
    Padding         As Long
    Value()         As Long
End Type

Type MODULEENTRY32
    dwSize          As Long
    th32ModuleID    As Long
    th32ProcessID   As Long
    GlblcntUsage    As Long
    ProccntUsage    As Long
    modBaseAddr     As Long
    modBaseSize     As Long
    hModule         As Long
    szModule        As String * 256
    szExePath       As String * 256
End Type

Type PROCESSENTRY32
    dwSize            As Long
    cntUsage          As Long
    th32ProcessID     As Long
    th32DefaultHeapID As Long
    th32ModuleID      As Long
    cntThreads        As Long
    th32ParentProcessID As Long
    pcPriClassBase    As Long
    dwFlags           As Long
    szExeFile         As String * MAX_PATH
End Type

Type THREADENTRY32
    dwSize As Long
    cntUsage As Long
    th32ThreadID As Long
    th32OwnerProcessID As Long
    tpBasePri As Long
    tpDeltaPri As Long
    dwFlags As Long
End Type

Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Declare Function Heap32First Lib "kernel32" (lpHE As HEAPENTRY32, ByVal th32ProcessID As Long, ByVal th32HeapID As Long) As Boolean
Declare Function Heap32ListFirst Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPENTRY32) As Boolean
Declare Function Heap32ListNext Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPENTRY32) As Boolean
Declare Function Heap32Next Lib "kernel32" (lpHE As HEAPENTRY32) As Boolean
Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, lpME As MODULEENTRY32) As Boolean
Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, lpME As MODULEENTRY32) As Boolean
Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lpPE As PROCESSENTRY32) As Boolean
Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lpPE As PROCESSENTRY32) As Boolean
Declare Function Thread32First Lib "kernel32" (ByVal hSnapshot As Long, lpte As THREADENTRY32) As Boolean
Declare Function Thread32Next Lib "kernel32" (ByVal hSnapshot As Long, lpte As THREADENTRY32) As Boolean
Declare Function Toolhelp32ReadProcessMemory Lib "kernel32" (ByVal th32ProcessID As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal cbRead As Long, lpNumberOfBytesRead As Long) As Boolean

Declare Function GetCurrentThread Lib "kernel32" () As Long 'Devuelve una pseudo-referencia al subproceso actual.
Declare Function GetCurrentThreadId Lib "kernel32" () As Long   'Devuelve el identificador de subproceso del subproceso que llama a la función.
Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long   'Devuelve el estado de terminación del subproceso actual.
Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long   'Devuelve la clase de prioridad para el proceso especificado.
Declare Function GetProcessAffinityMask Lib "kernel32" (ByVal hProcess As Long, lpProcessAffinityMask As Long, SystemAffinityMask As Long) As Long  'Devuelve la máscara de afinidad (valor que indica sobre qué procesador se puede ejecutar) para el proceso especificado.
Declare Function GetProcessShutdownParameters Lib "kernel32" (lpdwLevel As Long, lpdwFlags As Long) As Long 'Devuelve los parámetros de cierre para el proceso que llama a la función.
Declare Function GetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, lpMinimumWorkingSetSize As Long, lpMaximumWorkingSetSize As Long) As Long 'Obtiene el mínimo y el máximo del tamaño del espacio de trabajo (working set) de un proceso especificado.
Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long   'Devuelve el nivel de prioridad para el subproceso especificado.
Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long    'Establece la clase de prioridad para el proceso especificado.

Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long
Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long

Declare Function GetWindowModuleFileName Lib "user32" Alias "GetWindowModuleFileNameA" (ByVal hwnd As Long, ByVal lpszFileName As String, ByVal cchFileNameMax As Long) As Long
Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, lParam As WindowInfo) As Long
Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long


Public SysProcess()   As ProcessInfo
Public SysModule()    As ModuleInfo
Public Windows()      As WindowInfo

Public lSysProcCnt  As Long
Public lSysModCnt  As Long
Public lWinCnt      As Long

Private CancelProcessLog  As Boolean
Private bIsLogging        As Boolean
Private bProcLogStarted   As Boolean

Private hProcTable        As Long

Property Get ActiveProcessId() As Long
            Dim r&
  r = GetWindowThreadProcessId(GetForegroundWindow, ActiveProcessId)
End Property

Property Get ActiveProcess() As ProcessInfo
  ActiveProcess = GetProcessInfoById(ActiveProcessId)
End Property

Property Get ActiveThreadId() As Long
  ActiveThreadId = GetWindowThreadProcessId(GetForegroundWindow, 0)
End Property

Property Get IsProcessLogEnabled() As Boolean
  IsProcessLogEnabled = bIsLogging
End Property

Sub EnumProcesses(Optional OpenHandles As Boolean = False)
     
      Dim hSnap&
      Dim pe32 As PROCESSENTRY32

  Erase SysProcess
  lSysProcCnt = 0
 
  'Crea el objeto Snapshot.
  hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
 
  pe32.dwSize = LenB(pe32)
 
  'Obtiene el primer proceso.
  If Process32First(hSnap, pe32) Then
    lSysProcCnt = 1
    ReDim SysProcess(lSysProcCnt) As ProcessInfo
   
    SysProcess(lSysProcCnt) = GetProcessInfo(pe32, OpenHandles)
    SysProcess(lSysProcCnt).Index = lSysProcCnt
   
    Do While Process32Next(hSnap, pe32)
      lSysProcCnt = lSysProcCnt + 1
      ReDim Preserve SysProcess(lSysProcCnt) As ProcessInfo
     
      SysProcess(lSysProcCnt) = GetProcessInfo(pe32, OpenHandles)
      SysProcess(lSysProcCnt).Index = lSysProcCnt
    Loop
  End If
 
  Call CloseHandle(hSnap)
 
End Sub

Function GetWindowInfo(ByVal hwnd As Long, Optional EnumThdWins As Boolean = True) As WindowInfo
  On Error Resume Next
 
          Dim r&
 
  With GetWindowInfo
    .hwnd = hwnd
    .hwndParent = GetParent(hwnd)
    .ThreadID = GetWindowThreadProcessId(hwnd, .ProcessId)
    .hIcon = GetClassLong(.hwndParent, GCL_HICON)
    .hInstance = GetWindowLong(.hwndParent, GWL_HINSTANCE)
    .Identifier = GetWindowLong(.hwndParent, GWL_ID)
    .Style = GetWindowLong(.hwndParent, GWL_STYLE)
    .WindowProc = GetWindowLong(.hwndParent, GWL_WNDPROC)
    .UserData = GetWindowLong(.hwndParent, GWL_USERDATA)
    r = EnumChildWindows(hwnd, AddressOf EnumChildProc, GetWindowInfo)
   
    .ClassName = String$(256, 0)
    r = GetClassName(hwnd, .ClassName, MAX_PATH)
    .ClassName = Left$(.ClassName, r)
   
    .Text = GetWindowText(hwnd)
   
    r = GetWindowModuleFileName(hwnd, .ModuleName, MAX_PATH)
    .ModuleName = Left$(.ModuleName, r)
   
    .hModule = GetModuleHandle(Trim(.ModuleName))
   
    If EnumThdWins Then _
    r = EnumThreadWindows(.ThreadID, AddressOf EnumThreadWndProc, GetWindowInfo)
  End With
 
End Function

Function GetProcessInfo(pProcess As PROCESSENTRY32, Optional OpenHandle As Boolean = False) As ProcessInfo
  'Obtiene información acerca de un proceso.
  '
  With GetProcessInfo
    .hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, pProcess.th32ProcessID)
    .ProcessId = pProcess.th32ProcessID
    .ParentProcessID = pProcess.th32ParentProcessID
    .PriorityClass = GetPriorityClass(.hProcess)
    .NumOfThreads = pProcess.cntThreads
    .Threads = EnumThreads(.ProcessId)
    .Modules = EnumModules(.ProcessId, .NumOfModules)
    .ExeFilename = RTrim$(pProcess.szExeFile)
    .HandleCount = pProcess.cntUsage
    Call GetProcessWorkingSetSize(.hProcess, .MinWorkingSetSize, .MaxWorkingSetSize)
    Call GetExitCodeProcess(.hProcess, .ExitCode)
    Call GetProcessAffinityMask(.hProcess, .AffinityMask, .SysAffinityMask)
   
    If Not OpenHandle Then
      'Se cierra el controlador del proceso.
      '
      Call CloseHandle(.hProcess)
      .hProcess = 0
    End If
  End With
 
End Function

Function EnumThreads(ByVal ProcessId As Long) As ThreadInfo()

      Dim te32 As THREADENTRY32
      Dim thds() As ThreadInfo
      Dim iCount%
      Dim hSnap&
 
 
  'Crea el objeto snapshot.
  hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
 
  te32.dwSize = LenB(te32)
 
  If Thread32First(hSnap, te32) Then
    'Si se obtiene el primer subproceso.
   
    If te32.th32OwnerProcessID = ProcessId Then GoSub GetThreadInfo
   
    Do While Thread32Next(hSnap, te32)
      'Obtiene los siguientes subprocesos y verifica
      'que pertenezcan al proceso especificado.
     
      If te32.th32OwnerProcessID = ProcessId Then
        GoSub GetThreadInfo
      End If
    Loop
  End If
 
  CloseHandle hSnap
  EnumThreads = thds
 
  Exit Function
 
GetThreadInfo:
  iCount = iCount + 1
  ReDim Preserve thds(iCount) As ThreadInfo
 
  With thds(iCount)
    .ThreadID = te32.th32ThreadID
    .BasePriority = te32.tpBasePri
    .UsageCount = te32.cntUsage
  End With
  Return
End Function

Function EnumModules(Optional ByVal ProcessId As Long, Optional NumOfModules As Long) As ModuleInfo()
     
      Dim me32 As MODULEENTRY32
      Dim pModule() As ModuleInfo
      Dim iCount%
      Dim hSnap&
 
  If ProcessId = 0 Then ProcessId = GetCurrentProcessId
 
  'Crea el objeto snapshot.
  hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, ProcessId)
 
  me32.dwSize = LenB(me32)
 
  If Module32First(hSnap, me32) Then
    'Si se obtiene el primer módulo.
   
    GoSub GetModuleInfo
   
    Do While Module32Next(hSnap, me32)
      'Obtiene los siguientes módulos.
     
      If me32.th32ProcessID = ProcessId Then
        GoSub GetModuleInfo
      End If
    Loop
  End If
 
  CloseHandle hSnap
 
  NumOfModules = iCount
  EnumModules = pModule
 
  Exit Function
 
GetModuleInfo:
  iCount = iCount + 1
  ReDim Preserve pModule(iCount) As ModuleInfo
 
  With pModule(iCount)
    .hModule = me32.hModule
    .ModuleId = me32.th32ModuleID
    .BaseAddress = me32.modBaseAddr
    .ModuleSize = me32.modBaseSize
    .GlobalUsage = me32.GlblcntUsage
    .ProcessUsage = me32.ProccntUsage
    .ProcessId = ProcessId
    .ModuleName = Left$(me32.szModule, InStr(1, me32.szModule, vbNullChar) - 1)
    .Filename = Left$(me32.szExePath, InStr(1, me32.szExePath, vbNullChar) - 1)
  End With
  Return
 
End Function

Function EnumSysModules() As Long
  On Error Resume Next
 
        Dim i&, ind&
       
  Call EnumProcesses
  Erase SysModule
  lSysModCnt = 0
 
  For i = 1 To lSysProcCnt
    For ind = 1 To SysProcess(i).NumOfModules
      If Not ModuleExist(SysProcess(i).Modules(ind)) Then
        lSysModCnt = lSysModCnt + 1
        ReDim Preserve SysModule(lSysModCnt) As ModuleInfo
       
        SysModule(lSysModCnt) = SysProcess(i).Modules(ind)
      End If
    Next
  Next
 
  EnumSysModules = lSysModCnt
 
End Function

Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
     
      Dim pWin As WindowInfo

  pWin = GetWindowInfo(hwnd, False)
 
  lWinCnt = lWinCnt + 1
  ReDim Preserve Windows(lWinCnt) As WindowInfo
 
  pWin.Index = lWinCnt
  Windows(lWinCnt) = pWin
 
  EnumWindowsProc = True
 
End Function

Function EnumChildProc(ByVal hwnd As Long, lParam As WindowInfo) As Boolean
  With lParam
    .NumOfChild = .NumOfChild + 1
    ReDim Preserve .ChildWindows(.NumOfChild)
   
    .ChildWindows(.NumOfChild) = hwnd
   
  End With
 
  EnumChildProc = True
End Function

Function EnumThreadWndProc(ByVal hwnd As Long, lParam As WindowInfo) As Boolean
  With lParam
    .NumThdWindows = .NumThdWindows + 1
    ReDim Preserve .ThreadWindows(.NumThdWindows) As Long
   
    .ThreadWindows(.NumThdWindows) = hwnd
   
    EnumThreadWndProc = True
  End With
End Function

Function KillProcessByName(AppExeFilename As String, Optional Wait As Boolean = False, Optional WaitTime As Long, Optional KillAll As Boolean = False) As Boolean
            Dim sAppName$
            Dim i%
           
  Call EnumProcesses
 
  For i = 1 To lSysProcCnt
    sAppName = RTrim$(Replace(GetFileTitle(SysProcess(i).ExeFilename), vbNullChar, vbNullString))
   
    If InStr(1, sAppName, AppExeFilename, vbTextCompare) Then
      If SysProcess(i).ProcessId = GetCurrentProcessId Then Exit Function
     
      KillProcessByName = KillProcessById(SysProcess(i).ProcessId, Wait, WaitTime)
     
      If Not KillAll Then
        Exit For
      End If
    End If
  Next
 
End Function

Function KillProcessById(ProcessId As Long, Optional Wait As Boolean = False, Optional WaitTime As Long) As Boolean
            Dim hProcess&, r&

  If ProcessId = GetCurrentProcessId Then Exit Function
 
  hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId)
 
  If hProcess Then
    KillProcessById = (TerminateProcess(hProcess, 0))
   
    If Wait Then
      If WaitTime = 0 Then WaitTime = 3000
     
      r = WaitForSingleObject(hProcess, WaitTime)
     
      If r <> WAIT_OBJECT_0 Then
        KillProcessById = False
      End If
    End If
   
    r = CloseHandle(hProcess)
  End If
End Function

Function GetProcessInfoById(ProcessId As Long) As ProcessInfo
            Dim pProcess As ProcessInfo
            Dim i&

  Call EnumProcesses
 
  For i = 1 To lSysProcCnt
    If SysProcess(i).ProcessId = ProcessId Then
      GetProcessInfoById = SysProcess(i)
      Exit For
    End If
  Next
End Function

Private Function ModuleExist(pModuleInfo As ModuleInfo) As Boolean
  On Error Resume Next
 
          Dim i&

  For i = 1 To lSysModCnt
    If (pModuleInfo.Filename Like SysModule(i).Filename) And _
       pModuleInfo.ModuleId = SysModule(i).ModuleId Then
       
      ModuleExist = True
      Exit For
    End If
  Next
End Function


Sub ProcLogTmrProc(ByVal hwnd As Long, ByVal uMsg As Integer, ByVal idEvent As Integer, ByVal dwTime As Long)
          Dim r&

  r = KillTimer(0&, idEvent)
  bProcLogStarted = True
  Call StartProcessLog
End Sub

Function StartProcessLog() As Long

  'Devuelve un puntero a memoria en donde se encuentran
  'almacenados una serie de estructuras ProcessInfo
  'que identifican a los procesos.
  'Estas estructuras comienzan 4 (cuatro) bytes más
  'adelante que dicho puntero. Esto cuatro bytes
  'es un valor de tipo Long que indica la cantidad
  'de estructuras que existen en la tabla.
 
  On Error Resume Next
 
        Dim pProcessInfo As ProcessInfo
        Dim pProcess() As ProcessInfo
        Dim lProcCnt&
        Dim snTime!
        Dim i&, r&

  If Not bProcLogStarted Then
    r = SetTimer(0&, 0&, 0&, AddressOf ProcLogTmrProc)
    Exit Function
  End If
 
  Call EnumProcesses
  Call ProcTableInitialize
 
  snTime = Timer
 
  Do While Not CancelProcessLog
 
    If (Timer - snTime) > 2 Then
      Call EnumProcesses
     
      snTime = Timer
    End If
   
    If lSysProcCnt <> lProcCnt Then
      'Terminó o se creó un proceso.
      '
      If lProcCnt < lSysProcCnt Then
        'Fue creado un nuevo proceso.
        '

        For i = lProcCnt + 1 To lSysProcCnt
         
          Call ProcTableAddEntry(SysProcess(i))
         
          If i Mod 4 = 0 Then DoEvents
        Next
       
        pProcess = SysProcess
        lProcCnt = lSysProcCnt
       
      Else
        'Si terminó un proceso
        'busca el proceso que terminó.
        '
       
      End If
     
      pProcess = SysProcess
      lProcCnt = lSysProcCnt
   
    End If
   
    DoEvents
  Loop
 
  StartProcessLog = hProcTable
 
  CancelProcessLog = False
  bProcLogStarted = False
 
  Call ProcTableRelease
End Function

Sub EndProcessLog()
  CancelProcessLog = True
End Sub

Function ProcTableAddEntry(pInfo As ProcessInfo) As Boolean
            Dim lOffset&, r&, i&
            Dim dtNow As Date

  If ProcTableGetEntryCount >= 32767 Then Exit Function
 
  'Actualiza la tabla de módulos.
  '
  Call ProcTableRefreshModuleTable
 
  '16 bytes: 8 bytes to start time, 8 bytes to end time
 
  lOffset = ProcTableCalculateOffset(ProcTableGetEntryCount + 1)
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, GetProcessInfoSize(pInfo), 4)
  lOffset = lOffset + 4
 
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, pInfo, 52)
 
  lOffset = lOffset + 52
 
  For i = 1 To pInfo.NumOfThreads
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, pInfo.Threads(i), Len(pInfo.Threads(i)))
   
    lOffset = lOffset + Len(pInfo.Threads(i))
  Next
 
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, ProcTableGetIndexes(pInfo)(1), 4 * pInfo.NumOfModules)
  lOffset = lOffset + (4 * pInfo.NumOfModules)
 
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, CInt(Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString)))), 2&)
  lOffset = lOffset + 2
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal pInfo.ExeFilename, Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString))))
  lOffset = lOffset + Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString)))
 
  dtNow = Now
 
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, dtNow, 8)
  r = WriteProcessMemory(GetCurrentProcess(), lOffset + 8, dtNow, 8)
 
  If r Then
    r = WriteProcessMemory(GetCurrentProcess(), hProcTable, ProcTableGetEntryCount() + 1, 2)
  End If
 
  ProcTableAddEntry = (r <> 0)
End Function

Function ProcTableGetEntry(Index As Integer) As ProcessInfo
          Dim lOffset&, r&, i&
          Dim pEntry As ProcessInfo
          Dim iSize%, iModSize%
         
  If (Index < 0 Or Index > ProcTableGetEntryCount()) Or hProcTable = 0 Then Exit Function
 
  lOffset = ProcTableCalculateOffset(Index)
 
  r = ReadProcessMemory(GetCurrentProcess(), lOffset + 4, pEntry, 52)
  lOffset = lOffset + 4 + 52
 
  ReDim pEntry.Threads(1 To pEntry.NumOfThreads) As ThreadInfo
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, pEntry.Threads(1), Len(pEntry.Threads(1)) * pEntry.NumOfThreads)
  lOffset = lOffset + (Len(pEntry.Threads(1)) * pEntry.NumOfThreads)
 
  ReDim pEntry.Modules(1 To pEntry.NumOfModules) As ModuleInfo
 
  For i = 1 To pEntry.NumOfModules
    r = ReadProcessMemory(GetCurrentProcess(), lOffset, pEntry.Modules(i), 28)
    lOffset = lOffset + 28
    r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2&)
    lOffset = lOffset + 2
    r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.Modules(i).Filename, iSize)
    lOffset = lOffset + iSize
    r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2&)
    lOffset = lOffset + 2
    r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.Modules(i).ModuleName, iSize)
    lOffset = lOffset + iSize
  Next
 
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2)
  lOffset = lOffset + 2
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.ExeFilename, iSize)
 
  ProcTableGetEntry = pEntry
End Function

Function ProcTableGetEntryCount() As Integer
          Dim iCnt%
         
  If hProcTable Then
    Call ReadProcessMemory(GetCurrentProcess(), hProcTable, iCnt, 2)
    ProcTableGetEntryCount = iCnt
  End If
End Function

Function ProcTableFindEntry(ProcessId As Long, Optional outIndex As Integer) As ProcessInfo
        Dim pProcess As ProcessInfo
        Dim i%

  For i = 1 To ProcTableGetEntryCount()
    pProcess = ProcTableGetEntry(i)
   
    If pProcess.ProcessId = ProcessId Then
      ProcTableFindEntry = pProcess
      outIndex = i
     
      Exit For
    End If
  Next
End Function

Function ProcTableNotifyEnd(ProcessId As Long) As Boolean
            Dim dtEndTime As Date
            Dim pProcess As ProcessInfo
            Dim iIndex%, lOffset&
            Dim r&
           
  pProcess = ProcTableFindEntry(ProcessId, iIndex)
  lOffset = ProcTableGetOffset(pProcess) + ProcTableGetEntrySize(iIndex) - 8
 
  dtEndTime = Now
  r = WriteProcessMemory(GetCurrentProcess(), lOffset, dtEndTime, 8)

End Function

Function ProcTableCalculateOffset(Index As Integer) As Long
          Dim lOffset&
          Dim pProcInfo As ProcessInfo
          Dim pThdInfo As ThreadInfo
          Dim pModInfo  As ModuleInfo
          Dim i%, r&
          Dim lSize&


  lOffset = GetProcTableOffset
 
  For i = 1 To ProcTableGetEntryCount()
    lOffset = lOffset + lSize
    r = ReadProcessMemory(GetCurrentProcess(), hProcTable + lOffset, lSize, 4)
   
    If i = Index Then Exit For
   
  Next
 
  lOffset = hProcTable + lOffset
  ProcTableCalculateOffset = lOffset
 
End Function

Function ProcTableGetOffset(ProcessInfo As ProcessInfo) As Long
          Dim pProcInfo As ProcessInfo, i%

  For i = 1 To ProcTableGetEntryCount()
    pProcInfo = ProcTableGetEntry(i)
   
    If pProcInfo.ProcessId = ProcessInfo.ProcessId Then
      'Se encontró el proceso en la tabla.
      '
      ProcTableGetOffset = ProcTableCalculateOffset(i)
      Exit For
    End If
   
  Next
End Function

Function ProcTableGetEntrySize(Index As Integer) As Long
            Dim lOffset&, lSize&
            Dim r&
 
  lOffset = ProcTableCalculateOffset(Index)
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, lSize, 4)

  ProcTableGetEntrySize = lSize
End Function

Function GetProcessInfoSize(ProcInfo As ProcessInfo) As Long
            Dim pThdInfo As ThreadInfo
            Dim pModInfo As ModuleInfo
            Dim lSize&, i&

  lSize = 52 + (Len(pThdInfo) * ProcInfo.NumOfThreads) + 16 + 4
 
  lSize = lSize + ProcInfo.NumOfModules * 4 'Tabla de indices de modulos.
 
  lSize = lSize + Len(RTrim$(Replace$(ProcInfo.ExeFilename, vbNullChar, vbNullString)))
  lSize = lSize + 2
 
  GetProcessInfoSize = lSize
End Function

Function ProcTableSaveToFile(Filename As String, Optional AppendData As Boolean = True) As Boolean
            Dim hFile&, sMagic$
            Dim lOffset&, lTableSize&
            Dim sData$, lDataSize&
            Dim r&

  hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, 1&, 0&, OPEN_ALWAYS, 0&, 0&)
  If hFile = INVALID_HANDLE_VALUE Then Exit Function
 
  sMagic = String$(3, 0)
  r = ReadFileStr(hFile, ByVal sMagic, 3&, 0&, ByVal 0&)
 
  If AppendData And StrComp(sMagic, "DAT") = False Then
    lOffset = GetFileSize(hFile, 0) + 1
   
  ElseIf Not AppendData Or StrComp(sMagic, "DAT") Then
    r = CloseHandle(hFile)
    r = DeleteFile(Filename)

    hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, 1&, 0&, CREATE_ALWAYS, 0&, 0&)
   
    r = WriteFileStr(hFile, ByVal "DAT", 3&, 0&, ByVal 0&)
   
    lOffset = 21
  End If
 
  lTableSize = ProcTableGetTableSize()
  lDataSize = GetModuleTableSize + lTableSize + 1
 
  r = SetFilePointer(hFile, 3, 0, FILE_BEGIN)
  r = WriteFile(hFile, ByVal hProcTable, 10, 0&, ByVal 0&)
  r = WriteFile(hFile, 1, 1, 0&, ByVal 0&)  'Formato del archivo.
  r = WriteFile(hFile, 1, 1, 0&, ByVal 0&)  'cifrado.
  r = WriteFile(hFile, lDataSize, 4, 0&, ByVal 0&)   'Longitud de los datos no cifrados.
  r = SetFilePointer(hFile, lOffset, 0, FILE_BEGIN)
 
  sData = String$(lDataSize, 0)
  r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 10, ByVal sData, Len(sData))
 
  r = WriteFile(hFile, Len(sData), 4, 0&, ByVal 0&)    'Longitud de los datos cifrados.
  r = WriteFileStr(hFile, ByVal sData, Len(sData), 0&, ByVal 0&)  'Datos cifrados.

  r = CloseHandle(hFile)
End Function

Function ProcTableGetTableSize() As Long
            Dim lSize&, i%

  For i = 1 To ProcTableGetEntryCount()
    lSize = lSize + ProcTableGetEntrySize(i)
  Next
 
  ProcTableGetTableSize = lSize
End Function

Function GetModInfoSize(pInfo As ModuleInfo) As Long
          Dim lSize&
 
  With pInfo
    lSize = 28
    lSize = lSize + Len(RTrim$(Replace$(.Filename, vbNullChar, vbNullString)))
    lSize = lSize + Len(RTrim$(Replace$(.ModuleName, vbNullChar, vbNullString)))
   
    GetModInfoSize = lSize
  End With
End Function

Function GetProcTableOffset() As Long
          Dim lSize&
          Dim r&

  r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 6, lSize, 4)
  GetProcTableOffset = lSize + 10
End Function

Function GetProcTableOffsetRVA() As Long
          Dim lSize&

  lSize = hProcTable + GetProcTableOffset
  GetProcTableOffsetRVA = lSize
End Function

Function ProcTableGetModuleCount() As Long
          Dim lCnt&, r&
         
  r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 2, lCnt, 4)
  ProcTableGetModuleCount = lCnt
End Function

Function ProcTableGetModuleOffset(Index As Long) As Long
            Dim lOffset&, i&, r&
            Dim lSize&

  lOffset = 10
 
  For i = 1 To ProcTableGetModuleCount
    lOffset = lOffset + lSize
    r = ReadProcessMemory(GetCurrentProcess(), hProcTable + lOffset, lSize, 4&)
   
    If Index = i Then
      ProcTableGetModuleOffset = hProcTable + lOffset
      Exit For
    End If
  Next
End Function

Function ProcTableGetModuleInfo(Index As Long) As ModuleInfo
            Dim pModule As ModuleInfo
            Dim lOffset&, i&, r&
            Dim iSize%

  lOffset = ProcTableGetModuleOffset(Index) + 4
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, pModule, 28)
  lOffset = lOffset + 28
 
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2)
  lOffset = lOffset + 2
  If iSize > MAX_PATH Then iSize = MAX_PATH
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pModule.Filename, iSize)
 
  lOffset = lOffset + iSize
 
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2)
  If iSize > MAX_PATH Then iSize = MAX_PATH
  lOffset = lOffset + 2
  r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pModule.ModuleName, iSize)

  ProcTableGetModuleInfo = pModule
End Function

Function ProcTableGetModuleIndex(ModuleId As Long) As Long
          Dim pModule As ModuleInfo
          Dim i&

  For i = 1 To ProcTableGetModuleCount
    pModule = ProcTableGetModuleInfo(i)
   
    If pModule.ModuleId = ModuleId Then
      ProcTableGetModuleIndex = i
      Exit For
    End If
  Next
End Function

Function ProcTableGetIndexes(ProcInfo As ProcessInfo) As Long()
          Dim pModule As ModuleInfo
          Dim lIndex&(), lCnt&
          Dim i&, ind%

  For i = 1 To ProcTableGetModuleCount
    pModule = ProcTableGetModuleInfo(i)
   
    For ind = 1 To ProcInfo.NumOfModules
      If pModule.ModuleId = ProcInfo.Modules(ind).ModuleId Then
        lCnt = lCnt + 1
        ReDim Preserve lIndex&(lCnt)
     
        lIndex&(lCnt) = i
       
        Exit For
       
      End If
    Next
  Next
 
  ProcTableGetIndexes = lIndex
 
End Function

Function GetModuleTableSize() As Long
        Dim lSize&, r&

  r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 6, lSize, 4)
  GetModuleTableSize = lSize
End Function

Sub ProcTableInitialize()
  If hProcTable = 0 Then
    'Asigna memoria para 32767 entradas en la tabla, aprox..
    '
    hProcTable = VirtualAlloc(0&, 10551296 + 2&, MEM_COMMIT, PAGE_READWRITE)
    Call ProcTableInitModuleTable
  End If
End Sub

Sub ProcTableRelease(Optional Force As Boolean = False)
          Dim r&
         
  If hProcTable Then
    r = VirtualFree(hProcTable, 0&, MEM_RELEASE)
   
    If r Or Force Then
      hProcTable = 0
    End If
  End If
End Sub

Sub ProcTableInitModuleTable()
        Dim lOffset&, i&
        Dim lTableSize&
        Dim r&
       

  Call EnumSysModules
 
  lOffset = hProcTable + 10
 
  For i = 1 To lSysModCnt
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, GetModInfoSize(SysModule(i)) + 4 + 4, 4)
    lOffset = lOffset + 4
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, SysModule(i), 28)
    lOffset = lOffset + 28
   
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString))), 2)
    lOffset = lOffset + 2
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal SysModule(i).Filename, Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString))))
    lOffset = lOffset + Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString)))
   
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString))), 2)
    lOffset = lOffset + 2
    r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal SysModule(i).ModuleName, Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString))))
    lOffset = lOffset + Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString)))
   
    lTableSize = lTableSize + GetModInfoSize(SysModule(i)) + 4 + 2 + 2
  Next
 
  r = WriteProcessMemory(GetCurrentProcess(), hProcTable + 2, lSysModCnt, 4)
  r = WriteProcessMemory(GetCurrentProcess(), hProcTable + 6, lTableSize, 4)

End Sub

Sub ProcTableRefreshModuleTable()
        Dim hTmp&, lSize&, r&
 
  lSize = ProcTableGetTableSize
  hTmp = VirtualAlloc(0&, lSize, MEM_COMMIT, PAGE_READWRITE)
 
  If hTmp Then
    r = ReadProcessMemory(GetCurrentProcess(), GetProcTableOffsetRVA, _
        ByVal hTmp, lSize)
   
    If r Then
      Call ProcTableInitModuleTable
     
      r = ReadProcessMemory(GetCurrentProcess(), hTmp, _
          ByVal GetProcTableOffsetRVA, lSize)

    End If
   
    r = VirtualFree(hTmp, 0, MEM_RELEASE)
  End If
End Sub

Function GetVersionInfo(Filename As String) As FileVersionInfo
            Dim pFixedInfo As VS_FIXEDFILEINFO
            Dim pFileInfo As FileVersionInfo
            Dim sCharset$, btCharset(4) As Byte
            Dim lCharset&, hCharBlck&
            Dim lInfoSize&, hVersion&
            Dim sVerData$, sVerBlck$, lLen&
            Dim sVerInfo$(9), sData$, i%, r&
            Dim lBinType&
           
  lInfoSize = GetFileVersionInfoSize(Filename, 0&)
  sVerData$ = String$(lInfoSize, 0)
 
  r = GetFileVersionInfo(Filename, 0&, lInfoSize, sVerData)
 
  If r = 0 Then Exit Function
 
  r = VerQueryValue(sVerData, "\VarFileInfo\Translation", hCharBlck, lLen)
 
  If r = 0 Then Exit Function
 
  r = ReadProcessMemory(GetCurrentProcess(), hCharBlck, btCharset(1), lLen)
 
  lCharset = btCharset(3) + btCharset(4) * &H100 + _
             btCharset(1) * &H10000 + btCharset(2) * &H1000000
 
  sCharset$ = Hex$(lCharset)
  sCharset$ = String(8 - Len(sCharset$), "0") & sCharset$
 
  sVerInfo(1) = "CompanyName"
  sVerInfo(2) = "FileDescription"
  sVerInfo(3) = "FileVersion"
  sVerInfo(4) = "InternalName"
  sVerInfo(5) = "LegalCopyright"
  sVerInfo(6) = "OriginalFileName"
  sVerInfo(7) = "ProductName"
  sVerInfo(8) = "ProductVersion"
  sVerInfo(9) = "Comments"

  For i = 1 To 9
    sVerBlck$ = "\StringFileInfo\" & sCharset & "\" & sVerInfo(i)
   
    r = VerQueryValue(sVerData, sVerBlck, hVersion, lInfoSize)
   
    If r Then
      sData = String$(lInfoSize, 0)
     
      r = ReadProcessMemory(GetCurrentProcess(), hVersion, ByVal sData, lInfoSize)
     
      sData = Left$(sData, lInfoSize - 1)
     
      With GetVersionInfo
        Select Case i
          Case 1: .CompanyName = sData
          Case 2: .FileDescription = sData
          Case 3: .FileVersion = sData
          Case 4: .InternalName = sData
          Case 5: .LegalCopyright = sData
          Case 6: .OriginalFileName = sData
          Case 7: .ProductName = sData
          Case 8: .ProductVersion = sData
          Case 9: .Comments = sData
        End Select
       
        If GetBinaryType(Filename, lBinType) Then
          Select Case lBinType
            Case SCS_32BIT_BINARY: .FileOS = "Ejecutable Para Windows De 32 Bits"
            Case SCS_DOS_BINARY: .FileOS = "Ejecutable Para MS-DOS"
            Case SCS_OS216_BINARY: .FileOS = "Ejecutable Para OS/2 De 16 Bits"
            Case SCS_PIF_BINARY: .FileOS = "Acceso Directo A Programa De MS-DOS"
            Case SCS_POSIX_BINARY: .FileOS = "Archivo Ejecutable Para POSIX"
            Case SCS_WOW_BINARY: .FileOS = "Ejecutable Para Windows De 16 Bits"
            Case Else: .FileOS = "Sistema Desconocido"
          End Select
        End If

      End With
    End If
  Next
End Function

Function GetPriorityClassName(PriorityClass As Long) As String
            Dim sName$
       
  Select Case PriorityClass
    Case HIGH_PRIORITY_CLASS: sName$ = "Alta"
    Case IDLE_PRIORITY_CLASS: sName$ = "Inactivo"
    Case NORMAL_PRIORITY_CLASS: sName$ = "Normal"
    Case REALTIME_PRIORITY_CLASS: sName$ = "Tiempo Real"
    Case Else: sName$ = "Desconocida"
  End Select

  GetPriorityClassName = sName$
End Function

Function GetWindowText(hwnd As Long) As String
        Dim sTitle$, r&
       
  sTitle = String$(255, 0): r = Win.GetWindowText(hwnd, sTitle, 255)
  sTitle = Left$(sTitle, r)
 
  GetWindowText = sTitle
End Function

Function GetFileTitle(Filename As String) As String
  GetFileTitle = Trim(Replace(Mid$(Filename, InStrRev(Filename, "\") + 1), vbNullChar, vbNullString))
End Function



Enjoy!!

Saludos.

Revisando mis codes encontré un módulo que tiene todos los procedimientos para manipular el registro del sistema usando las funciones de la API. Es un código muy viejo así que disculpen pero mi gramática de código no era muy buena .

Código [Seleccionar] Expandir


Option Explicit


Private Declare Function OSRegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function OSRegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function OSRegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long
Private Declare Function OSRegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function OSRegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" (ByVal hKey As Long) As Long

Private Declare Function OSRegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function OSRegFlushKey Lib "advapi32.dll" Alias "RegFlushKey" (ByVal hKey As Long) As Long
Private Declare Function OSRegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function OSRegReplaceKey Lib "advapi32.dll" Alias "RegReplaceKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpNewFile As String, ByVal lpOldFile As String) As Long
Private Declare Function OSRegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function OSRegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Declare Function OSRegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function OSRegQueryValueEx Lib "advapi32.dll" 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 OSRegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function OSRegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

'Tipos de datos del registro
'
Const REG_NONE = 0                'No definido
Const REG_SZ = 1                  'Cadena de texto
Const REG_EXPAND_SZ = 2           'Cadena que contiene una referencia a una variable de entorno (por ej. %windir%)
Const REG_BINARY = 3              'Datos binarios en cualquier formato
Const REG_DWORD = 4               'Número de 32 bits
Const REG_DWORD_LITTLE_ENDIAN = 4 'Igual a REG_DWORD
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6                'Un vínculo Unicode símbolico
Const REG_MULTI_SZ = 7            'Una matriz de cadenas terminadas en dos caracteres nulos
Const REG_RESOURCE_LIST = 8       'Lista de recursos de un controlador de dispositivo

Const READ_CONTROL = &H20000  'El derecho para leer la información en el descriptor de seguridad del objeto, no incluyendo la información en SACL.
Const SYNCHRONIZE = &H100000

'Derechos normales de acceso
'
Const STANDARD_RIGHTS_ALL = &H1F0000          'Lectura y escritura
Const STANDARD_RIGHTS_READ = (READ_CONTROL)   'Lectura
Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)  'Escritura

'Argumentos para RegOpenKey
'
Const KEY_QUERY_VALUE = &H1         'Permiso para consultar los datos de una subclave
Const KEY_SET_VALUE = &H2           'Permiso para establecer los datos de una subclave
Const KEY_CREATE_SUB_KEY = &H4      'Permiso para crear subclaves
Const KEY_ENUMERATE_SUB_KEYS = &H8  'Permiso para enumerar subclaves
Const KEY_NOTIFY = &H10             'Permiso para cambiar notificación
Const KEY_CREATE_LINK = &H20        'Permiso para crear un vínculo simbólico
Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))

'Valores devueltos por lpdwDisposition de RegCreateKey
'
Const REG_CREATED_NEW_KEY = &H1     'Se creó una nueva clave
Const REG_OPENED_EXISTING_KEY = &H2 'Se abrió una clave existente

'Valores para dwNotifyFilter de RegNotifyChangeKeyValue
'
Const REG_NOTIFY_CHANGE_NAME = &H1          'Si se agrega o elimina una clave
Const REG_NOTIFY_CHANGE_ATTRIBUTES = &H2    'Cambiar atributos de la clave
Const REG_NOTIFY_CHANGE_LAST_SET = &H4      'Modificar, agregar o eliminar un valor de la clave
Const REG_NOTIFY_CHANGE_SECURITY = &H8      'Cambiar el descriptor de seguridad de la clave (SECURITY_DESCRIPTOR)

'Argumentos para dwOptions de RegCreateKey
'
Const REG_OPTION_NON_VOLATILE = 0   '(Predeterminado) Crea una clave normalmente
Const REG_OPTION_VOLATILE = 1       'Borra la clave al reiniciar el sistema
Const REG_OPTION_CREATE_LINK = 2    'Crea un vínculo virtual
Const REG_OPTION_BACKUP_RESTORE = 4 'Para Windows NT

Const REG_OPTION_RESERVED = 0   'Reservado

Const REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)
Const REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)

'Para el argumento dwFlags de RegRestoreKey
'
Const REG_WHOLE_HIVE_VOLATILE = &H1 'Borra la clave al reiniciar el sistema

'Claves del registro
'
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_DYN_DATA = &H80000006
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_PERFORMANCE_DATA = &H80000004 'Sólo para NT
Const HKEY_USERS = &H80000003

Const ERROR_SUCCESS = 0&
Const ERROR_NO_MORE_ITEMS = 259&    'No hay más elementos

Const MODULE_DESC$ = "Registry Module"

Enum RegKeyConstants
    RegClassesRoot = HKEY_CLASSES_ROOT
    RegCurrentConfig = HKEY_CURRENT_CONFIG
    RegCurrentUser = HKEY_CURRENT_USER
    RegDynData = HKEY_DYN_DATA
    RegLocalMachine = HKEY_LOCAL_MACHINE
    RegPerformanceData = HKEY_PERFORMANCE_DATA
    RegUsers = HKEY_USERS
End Enum

Enum RegAccessType
    regqueryvalue = KEY_QUERY_VALUE
    RegSetValue = KEY_SET_VALUE
    RegCreateSubKey = KEY_CREATE_SUB_KEY
    RegEnumerateSubKeys = KEY_ENUMERATE_SUB_KEYS
    RegNotify = KEY_NOTIFY
    RegCreateLink = KEY_CREATE_LINK
    RegAllAccess = KEY_ALL_ACCESS
    RegRead = KEY_READ
    RegWrite = KEY_WRITE
    RegExecute = KEY_EXECUTE
End Enum

Enum RegValueTypeConstants
    RegString = REG_SZ
    RegExpandString = REG_EXPAND_SZ
    RegMultiString = REG_MULTI_SZ
    RegBinary = REG_BINARY
    RegDWORD = REG_DWORD
    RegDWORDLittleEndian = REG_DWORD_LITTLE_ENDIAN
    RegDWORDBigEndian = REG_DWORD_BIG_ENDIAN
    RegLink = REG_LINK
    RegUnknown = REG_NONE
    RegResourceList = REG_RESOURCE_LIST
End Enum

Enum RegCreateOptionsConstants
    RegVolatile = REG_OPTION_VOLATILE
    RegNonVolatile = REG_OPTION_NON_VOLATILE
    RegOptionBackupRestore = REG_OPTION_BACKUP_RESTORE
End Enum

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Type RegValue
    sName As String
    cType As RegValueTypeConstants
    vData As Variant
    lData As Long
End Type

Type RegKey
    lLongKey  As RegKeyConstants
    sStringKey As String
    sPath As String
    sName As String
    lNameLen As Long
    lHandle As Long
    lSubKeys As Long
    lValues As Long
    tValues() As RegValue
    sClass As String
End Type

Function RegOpenKey(Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String, Optional DesiredAccess As RegAccessType = RegAllAccess) As RegKey
        Dim iPos%, r&
  With RegOpenKey
    r = OSRegOpenKeyEx(CLng(Key), SubKey, 0&, CLng(DesiredAccess), .lHandle)
    If r = ERROR_SUCCESS Then
      If Right(SubKey, 1) = "\" Then SubKey = Left(SubKey, Len(SubKey) - 1)
     
      iPos = InStrRev("\", SubKey)
     
      .sName = Mid(SubKey, iPos + 1)
      .lNameLen = LenB(.sName)
      .lLongKey = Key
      .sStringKey = GetKeyString(.lLongKey)
      .sPath = Left(SubKey, iPos)
    End If
  End With
End Function

Function RegCreateKey(Key As RegKeyConstants, SubKey As String, Optional Options As RegCreateOptionsConstants = RegNonVolatile, Optional DesiredAccess As RegAccessType = RegAllAccess, Optional Class As String) As RegKey
        Dim sa As SECURITY_ATTRIBUTES, r&
        Dim iPos%

  With RegCreateKey
    r = OSRegCreateKeyEx(CLng(Key), SubKey, 0&, Class, CLng(Options), _
    CLng(DesiredAccess), sa, .lHandle, 0&)
   
    If r = ERROR_SUCCESS Then
        If Not Right(SubKey, 1) Like "\" Then SubKey = SubKey & "\"
       
        iPos = InStrRev("\", SubKey)
       
        .sName = Mid(SubKey, iPos + 1)
        .lNameLen = LenB(.sName)
        .lLongKey = Key
        .sStringKey = GetKeyString(.lLongKey)
        .sPath = Left(SubKey, iPos)
    End If
  End With
End Function

Function RegConnectRegistry(MachineName As String, Optional Key As RegKeyConstants = RegLocalMachine) As RegKey
        Dim r&
  With RegConnectRegistry
    r = OSRegConnectRegistry(MachineName, CLng(Key), .lHandle)
   
    If r = ERROR_SUCCESS Then
      .sName = GetKeyString(Key)
      .lNameLen = LenB(.sName)
      .lLongKey = Key
      .sStringKey = GetKeyString(.lLongKey)
    End If
  End With
End Function

Function RegCloseKey(hKey As Long) As Boolean
  RegCloseKey = (OSRegCloseKey(hKey) = ERROR_SUCCESS)
End Function

Function RegDeleteKey(Key As RegKeyConstants, SubKey As String) As Boolean
  RegDeleteKey = (OSRegDeleteKey(CLng(Key), SubKey) = ERROR_SUCCESS)
End Function

Function RegEnumKeyNames(TargetArray() As String, Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String, Optional MaxKeysToEnum As Long = -1) As Long
  On Error GoTo CloseKey
          Dim iCount%, iArrayType%
          Dim hKey&, ft As FILETIME
          Dim r&, sName$, lName&

  hKey = RegOpenKey(Key, SubKey, RegEnumerateSubKeys).lHandle
 
  If hKey <> ERROR_SUCCESS Then
    Erase TargetArray
   
    Do
      lName = 256: sName = String(lName, 0)
      r = OSRegEnumKeyEx(hKey, iCount, sName, lName, 0&, ByVal "", 0&, ft)
     
      If r <> ERROR_NO_MORE_ITEMS Then
        ReDim Preserve TargetArray(iCount) As String
        TargetArray(iCount) = Left(sName, lName)
      Else
        GoTo CloseKey
      End If
Step:
      iCount = iCount + 1
      If MaxKeysToEnum > -1 And iCount = MaxKeysToEnum Then GoTo CloseKey
    Loop
   
CloseKey:
    Call RegCloseKey(hKey)
   
    RegEnumKeyNames = iCount
  End If
End Function

Function RegEnumKeys(TargetArray() As RegKey, Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String, Optional bEnumValues As Boolean = False, Optional MaxKeysToEnum As Long = -1) As Long
  On Error GoTo CloseKey
         
          Dim iCount%, iArrayType%
          Dim hKey&, ft As FILETIME
          Dim r&, sName$, lName&
          Dim sClass$, lClass&
         
  hKey = RegOpenKey(Key, SubKey, RegEnumerateSubKeys).lHandle
 
  If hKey <> ERROR_SUCCESS Then
    Erase TargetArray
   
    Do
      lName = 256: sName = String(lName, 0)
      lClass = 256: sClass = String(lName, 0)
     
      r = OSRegEnumKeyEx(hKey, iCount, sName, lName, 0&, sClass, lClass, ft)
     
      If bEnumValues Then
        'Enumerar valores
      End If
     
      If r <> ERROR_NO_MORE_ITEMS Then
        ReDim Preserve TargetArray(iCount) As RegKey
       
        With TargetArray(iCount)
            .sName = Left(sName, lName)
            .lNameLen = LenB(.sName)
            .lLongKey = Key
            .sStringKey = GetKeyString(.lLongKey)
            .sPath = SubKey
            .lValues = RegEnumValues(.tValues, hKey)
        End With
      Else
        GoTo CloseKey
      End If
Step:
      iCount = iCount + 1
      If MaxKeysToEnum > -1 And iCount = MaxKeysToEnum Then GoTo CloseKey
    Loop
CloseKey:
    Call RegCloseKey(hKey)
   
    RegEnumKeys = iCount - 1
  End If
End Function

Function RegQueryInfoKey(Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String, Optional QueryValues As Boolean = False, Optional OpenKey As Boolean = False) As RegKey
          Dim hKey&, ft As FILETIME
          Dim lClass&, r&
          Dim iPos%
         
  With RegQueryInfoKey
    hKey = RegOpenKey(Key, SubKey, RegRead).lHandle
   
    If hKey <> ERROR_SUCCESS Then
     
      lClass = 256: .sClass = String(lClass, 0)
      r = OSRegQueryInfoKey(hKey, .sClass, lClass, 0&, .lSubKeys, 0&, 0&, .lValues, 0&, 0&, 0&, ft)
     
      If r = ERROR_SUCCESS Then
        iPos = InStrRev(SubKey, "\")
        .sClass = Left(.sClass, lClass)
        .sName = Mid(SubKey, iPos + 1)
        .lNameLen = Len(.sName)
        .sPath = Left(SubKey, iPos)
        .lLongKey = Key
        .sStringKey = GetKeyString(.lLongKey)
       
        If Not OpenKey Then Call RegCloseKey(hKey) Else .lHandle = hKey
       
        If QueryValues Then
          r = RegEnumValues(.tValues, Key, SubKey)
        End If
      End If
    End If
  End With
End Function

Function RegFlushKey(hKey As Long) As Boolean
    RegFlushKey = (OSRegFlushKey(hKey) = ERROR_SUCCESS)
End Function

Function RegEnumValueNames(TargetArray() As String, Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String) As Long
  On Error GoTo CloseKey
          Dim hKey&, r&
          Dim sName$, lName&
          Dim lCount&
          Dim btData As Byte, lData&
          Dim lType&
 
  hKey = RegOpenKey(Key, SubKey, regqueryvalue).lHandle
 
  If hKey <> ERROR_SUCCESS Then
    Erase TargetArray

    Do
      lName = 256: sName = String(lName, 0)
      lData = 2000
      r = OSRegEnumValue(hKey, lCount&, sName, lName, 0&, 0&, ByVal btData, lData)
     
      If r = ERROR_SUCCESS Then
          ReDim Preserve TargetArray(lCount) As String
          TargetArray(lCount) = Left(sName, lName)
      Else: GoTo CloseKey
      End If
     
      lCount = lCount + 1
    Loop
   
CloseKey:

    Call RegCloseKey(hKey)
    RegEnumValueNames = lCount - 1
  End If
End Function

Function RegEnumValues(TargetArray() As RegValue, Optional Key As RegKeyConstants = RegLocalMachine, Optional ByVal SubKey As String) As Long
  On Error GoTo CloseKey
          Dim hKey&, r&
          Dim sName$, lName&
          Dim lCount&
          Dim btData As Byte, lData&
          Dim lType&
 
  hKey = RegOpenKey(Key, SubKey, KEY_QUERY_VALUE).lHandle
 
  If hKey <> ERROR_SUCCESS Then
    Erase TargetArray
   
    Do
      lName = 256: sName = String(lName, 0)
      lData = 2000
      r = OSRegEnumValue(hKey, lCount&, sName, lName, 0&, lType, ByVal btData, lData)
     
      If r = ERROR_SUCCESS Then
        ReDim Preserve TargetArray(lCount) As RegValue
        TargetArray(lCount) = RegGetValue(hKey, , Left(sName, lName))
      Else: GoTo CloseKey
      End If
     
      lCount = lCount + 1
    Loop
CloseKey:
   
    Call RegCloseKey(hKey)
    RegEnumValues = lCount - 1
  End If
End Function

Function RegGetValueData(Key As RegKeyConstants, Optional ByVal SubKey As String, Optional ValueName As String) As Variant
          Dim hKey&, r&
          Dim sData$, lDataLen&
          Dim lData&, ValType As RegValueTypeConstants
         
  hKey = RegOpenKey(Key, SubKey, regqueryvalue).lHandle
  ValType = RegString
  If hKey <> ERROR_SUCCESS Then
    Select Case ValType
      Case RegString, RegMultiString, RegExpandString, RegBinary, RegUnknown
        sData = String(2000, 0)
        lDataLen = LenB(sData)
        r = OSRegQueryValueEx(hKey, ValueName, 0&, ValType, _
                            ByVal sData, lDataLen)
        If ValType = RegDWORD Or ValType = RegDWORDBigEndian Or ValType = RegDWORDLittleEndian Then GoTo LongType
        RegGetValueData = Left(sData, lDataLen - 1)
      Case Else
LongType:
        r = OSRegQueryValueEx(hKey, ValueName, 0&, ValType, _
                             lData, lDataLen)
        RegGetValueData = lData
    End Select
    Call RegCloseKey(hKey)
  End If
End Function

Function RegGetValue(Key As RegKeyConstants, Optional ByVal SubKey As String, Optional ValueName As String) As RegValue
        Dim hKey&, r&
        Dim sData$, lDataLen&
        Dim lData&, ValType As RegValueTypeConstants

hKey = RegOpenKey(Key, SubKey, regqueryvalue).lHandle
ValType = RegString

If hKey <> ERROR_SUCCESS Then
  With RegGetValue
    Select Case ValType
        Case RegLink, RegString, RegMultiString, RegExpandString, RegBinary, RegUnknown
            sData = String(2000, 0)
            lDataLen = LenB(sData)
            r = OSRegQueryValueEx(hKey, ValueName, 0&, ValType, _
                                ByVal sData, lDataLen)
            If ValType = RegDWORD Or ValType = RegDWORDBigEndian Or ValType = RegDWORDLittleEndian Then GoTo LongType
            If r = ERROR_SUCCESS Then
                .vData = Left(sData, lDataLen)
                .lData = lDataLen
                .cType = ValType
                .sName = ValueName
            End If
        Case Else
LongType:
            r = OSRegQueryValueEx(hKey, ValueName, 0&, ValType, _
                                 lData, lDataLen)
            If r = ERROR_SUCCESS Then
                .vData = lData
                .lData = lDataLen
                .cType = ValType
                .sName = ValueName
            End If
    End Select
    Call RegCloseKey(hKey)
  End With
End If
End Function

Function RegDeleteValue(Key As RegKeyConstants, Optional ByVal SubKey As String, Optional ValueName As String) As Boolean
        Dim hKey&
hKey = RegOpenKey(Key, SubKey, RegSetValue).lHandle
RegDeleteValue = (OSRegDeleteValue(hKey, ValueName) = ERROR_SUCCESS)
Call RegCloseKey(hKey)
End Function

Function RegSetValues(Key As RegKeyConstants, SubKey As String, ValueName As Variant, Data As Variant, Optional ValueType As RegValueTypeConstants = RegString) As Integer
          Dim hKey&, r&
          Dim i%, iScsCount%
  hKey = RegOpenKey(Key, SubKey, RegSetValue).lHandle
 
  If hKey <> ERROR_SUCCESS Then
    If IsArray(ValueName) And IsArray(Data) Then
      'Si son dos matrices
      If (UBound(ValueName) - LBound(ValueName)) <> (UBound(Data) - LBound(Data)) Then
        'Si no tienen las mismas dimensiones se produce un error
        Call Err.Raise(45, MODULE_DESC, "Las matrices no tienen la misma dimensión")
      Else
        For i = LBound(ValueName) To UBound(ValueName)
          'Identifica el tipo de valor que se va a establecer
          Select Case ValueType
            Case RegString, RegMultiString, RegExpandString, RegBinary, RegUnknown
              r = OSRegSetValueEx(hKey, ValueName(i), 0&, _
                  CLng(ValueType), ByVal CStr(Data(i)), LenB(Data(i)))
            Case Else
              r = OSRegSetValueEx(hKey, ValueName(i), 0&, _
                  CLng(ValueType), CLng(Data(i)), 4)
          End Select
         
          'Si no hay ningún error aumenta el contador de valores
          'que se pudieron establecer
          If r = ERROR_SUCCESS Then iScsCount = iScsCount + 1
        Next
       
        'Devuelve el la cantidad de valores que se establecieron
        RegSetValues = iScsCount
      End If
    ElseIf IsArray(ValueName) Then
      'Si los nombres de valores están en una matriz
      For i = LBound(ValueName) To UBound(ValueName)
        'Establece todos los valores pero con los mismos datos
        Select Case ValueType
          Case RegString, RegMultiString, RegExpandString, RegBinary, RegUnknown
            r = OSRegSetValueEx(hKey, ValueName(i), 0&, _
                CLng(ValueType), ByVal CStr(Data), LenB(Data))
          Case Else
            r = OSRegSetValueEx(hKey, ValueName(i), 0&, _
                CLng(ValueType), CLng(Data), 4)
        End Select
       
        If r = ERROR_SUCCESS Then iScsCount = iScsCount + 1
      Next
     
      RegSetValues = iScsCount
    Else
      Select Case ValueType
        Case RegString, RegMultiString, RegExpandString, RegBinary, RegUnknown, RegLink
            r = OSRegSetValueEx(hKey, ValueName, 0&, _
                CLng(ValueType), ByVal CStr(Data), LenB(Data))
       
        Case Else
            r = OSRegSetValueEx(hKey, ValueName, 0&, _
                CLng(ValueType), CLng(Data), 4)
      End Select
     
      RegSetValues = True
    End If
  End If
 
  Call RegCloseKey(hKey)
End Function

Function RegIsKey(Key As RegKeyConstants, Optional ByVal SubKey As String) As Boolean
            Dim hKey&
 
  hKey = RegOpenKey(Key, SubKey).lHandle
  RegIsKey = (hKey <> 0)
 
  Call RegCloseKey(hKey)
End Function

Function GetKeyString(hKey As Variant) As String
  Select Case hKey
    Case RegClassesRoot, "HKCR", "HKEY_CLASSES_ROOT": GetKeyString = "HKEY_CLASSES_ROOT"
    Case RegCurrentConfig, "HKCC", "HKEY_CURRENT_CONFIG": GetKeyString = "HKEY_CURRENT_CONFIG"
    Case RegCurrentUser, "HKCU", "HKEY_CURRENT_USER": GetKeyString = "HKEY_CURRENT_USER"
    Case RegDynData, "HKDD", "HKEY_DYN_DATA": GetKeyString = "HKEY_DYN_DATA"
    Case RegLocalMachine, "HKLM", "HKEY_LOCAL_MACHINE": GetKeyString = "HKEY_LOCAL_MACHINE"
    Case RegPerformanceData, "HKPD", "HKEY_PERFORMANCE_DATA": GetKeyString = "HKEY_PERFORMANCE_DATA"
    Case RegUsers, "HKU", "HKEY_USERS": GetKeyString = "HKEY_USERS"
  End Select
End Function

Function GetKeyLong(hKey As Variant) As String
  Select Case hKey
    Case RegClassesRoot, "HKCR", "HKEY_CLASSES_ROOT": GetKeyLong = RegClassesRoot
    Case RegCurrentConfig, "HKCC", "HKEY_CURRENT_CONFIG": GetKeyLong = RegCurrentConfig
    Case RegCurrentUser, "HKCU", "HKEY_CURRENT_USER": GetKeyLong = RegCurrentUser
    Case RegDynData, "HKDD", "HKEY_DYN_DATA": GetKeyLong = RegDynData
    Case RegLocalMachine, "HKLM", "HKEY_LOCAL_MACHINE": GetKeyLong = RegLocalMachine
    Case RegPerformanceData, "HKPD", "HKEY_PERFORMANCE_DATA": GetKeyLong = RegPerformanceData
    Case RegUsers, "HKU", "HKEY_USERS": GetKeyLong = RegUsers
  End Select
End Function


Cualquier cosa que no entiendan dirigirse a MSDN .

Saludos.

Muchas veces es difícil encontrar las funciones de WinSock para VB, así que recopilé todas las funciones, estructuras, constantes, etc. que se usan para manipular sockets en Windows.

También puse algunas funciones básicas para ejemplificar el uso de las funciones.

Código [Seleccionar] Expandir


'*************************************************************
'¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬
'     Application Programming Inteface (API) for WinSock
'
'Este módulo contiene todas las declaraciones necesarias para
'utilizar los sockets de sistema. El funcionamiento y ejemplo
'de estas funciones se pueden encontrar en MSDN:
'
'http://msdn.microsoft.com
'
'Autor: Slasher Keeper :)
'Fuente: MSDN Library
'
'¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬¬
'**************************************************************

Option Explicit

#Const WS_CURVERSION = 2


Public Const WS_VERSION_REQD = &H101
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD = 1
Public Const SOCKET_ERROR = -1
Public Const WSADescription_Len = 256
Public Const WSASYS_Status_Len = 128
Public Const FD_SETSIZE = 64

'Network Events.
'
Public Const FD_READ_BIT = 0
Public Const FD_READ = 1
Public Const FD_WRITE_BIT = 1
Public Const FD_WRITE = 2
Public Const FD_OOB_BIT = 2
Public Const FD_OOB = 4
Public Const FD_ACCEPT_BIT = 3
Public Const FD_ACCEPT = 8
Public Const FD_CONNECT_BIT = 4
Public Const FD_CONNECT = 16
Public Const FD_CLOSE_BIT = 5
Public Const FD_CLOSE = 32
Public Const FD_QOS_BIT = 6
Public Const FD_QOS = 64
Public Const FD_GROUP_QOS_BIT = 7
Public Const FD_GROUP_QOS = 128
Public Const FD_ROUTING_INTERFACE_CHANGE_BIT = 8
Public Const FD_ROUTING_INTERFACE_CHANGE = 256
Public Const FD_ADDRESS_LIST_CHANGE_BIT = 9
Public Const FD_ADDRESS_LIST_CHANGE = 512
Public Const FD_MAX_EVENTS = 10
Public Const FD_ALL_EVENTS = 1023

'Namespaces.
'
Public Const NS_ALL = 0

Public Const NS_SAP = 1
Public Const NS_NDS = 2
Public Const NS_PEER_BROWSE = 3

Public Const NS_TCPIP_LOCAL = 10
Public Const NS_TCPIP_HOSTS = 11
Public Const NS_DNS = 12
Public Const NS_NETBT = 13
Public Const NS_WINS = 14

Public Const NS_NBP = 20

Public Const NS_MS = 30
Public Const NS_STDA = 31
Public Const NS_NTDS = 32

Public Const NS_X500 = 40
Public Const NS_NIS = 41
Public Const NS_NISPLUS = 42

Public Const NS_WRQ = 50

Public Const SERVICE_REGISTER = 1
Public Const SERVICE_DEREGISTER = 2
Public Const SERVICE_FLUSH = 3
Public Const SERVICE_FLAG_HARD = &H2

Enum SearchControlFlags
  LUP_DEEP = &H1
  LUP_CONTAINERS = &H2
  LUP_NOCONTAINERS = &H4
  LUP_NEAREST = &H8
  LUP_RETURN_NAME = &H10
  LUP_RETURN_TYPE = &H20
  LUP_RETURN_VERSION = &H40
  LUP_RETURN_COMMENT = &H80
  LUP_RETURN_ADDR = &H100
  LUP_RETURN_BLOB = &H200
  LUP_RETURN_ALIASES = &H400
  LUP_RETURN_QUERY_STRING = &H800
  LUP_RETURN_ALL = &HFF0
  LUP_RES_SERVICE = &H8000
  LUP_FLUSHCACHE = &H1000
  LUP_FLUSHPREVIOUS = &H2000
End Type


'Protocolos
'
Enum SockProtocols
  IPPROTO_IP = 0                           'dummy for IP
  IPPROTO_ICMP = 1                         'control message protocol
  IPPROTO_IPIP = 4
  IPPROTO_GGP = 2                          ' gateway^2 (deprecated)
  IPPROTO_TCP = 6                          ' tcp
  IPPROTO_EGP = 8
  IPPROTO_PUP = 12                         ' pup
  IPPROTO_UDP = 17                         ' user datagram protocol
  IPPROTO_IDP = 22                         ' xns idp
  IPPROTO_ND = 77                          ' UNOFFICIAL net disk proto
  NSPROTO_IPX = 1000
  NSPROTO_SPX = 1256
  NSPROTO_SPXII = 1257
End Enum

'Socket types.
'
Enum SockTypes
  SOCK_STREAM = 1 'Envía datos como flujo de bytes.
  SOCK_DGRAM = 2  'Datagrama. Protocolo de conexión.
  SOCK_RAW = 3    '???
  SOCK_RDM = 4    'Reliably-Delivered Message (Mensaje confiablemente-entregado)
                  'Es un protocolo que conserva los límites del mensaje en los
                  'datos
  SOCK_SEQPACKET = 5  'Flujo de paquetes secuenciados. Es esencialmente igual
                      'que SOCK_RDM.
End Enum

Enum SockPorts
  '
  'Standard well-known ports
  '
  IPPORT_ECHO = 7
  IPPORT_DISCARD = 9
  IPPORT_SYSTAT = 11
  IPPORT_DAYTIME = 13
  IPPORT_NETSTAT = 15
  IPPORT_FTP = 21
  IPPORT_TELNET = 23
  IPPORT_SMTP = 25
  IPPORT_TIMESERVER = 37
  IPPORT_NAMESERVER = 42
  IPPORT_WHOIS = 43
  IPPORT_MTP = 57

  IPPORT_TFTP = 69
  IPPORT_RJE = 77
  IPPORT_FINGER = 79
  IPPORT_TTYLINK = 87
  IPPORT_SUPDUP = 95

  IPPORT_EXECSERVER = 512
  IPPORT_LOGINSERVER = 513
  IPPORT_CMDSERVER = 514
  IPPORT_EFSSERVER = 520

  'UDP ports.
  '
  IPPORT_BIFFUDP = 512
  IPPORT_WHOSERVER = 513
  IPPORT_ROUTESERVER = 520

  'Los puertos menores a este valor están reservados para
  'procesos con provilegios.
  '
  IPPORT_RESERVED = 1024

  'Los puertos mayores a este valor están reservados para
  'procesos sin privilegios.
  '
  IPPORT_USERRESERVED = 5000

End Enum

Enum SockErrors
  '
  'Windows Sockets definitions of regular Berkeley error constants
  '
 
   WSABASEERR = 10000
   WSAEWOULDBLOCK = (WSABASEERR + 35)
   WSAEINPROGRESS = (WSABASEERR + 36)
   WSAEALREADY = (WSABASEERR + 37)
   WSAENOTSOCK = (WSABASEERR + 38)
   WSAEDESTADDRREQ = (WSABASEERR + 39)
   WSAEMSGSIZE = (WSABASEERR + 40)
   WSAEPROTOTYPE = (WSABASEERR + 41)
   WSAENOPROTOOPT = (WSABASEERR + 42)
   WSAEPROTONOSUPPORT = (WSABASEERR + 43)
   WSAESOCKTNOSUPPORT = (WSABASEERR + 44)
   WSAEOPNOTSUPP = (WSABASEERR + 45)
   WSAEPFNOSUPPORT = (WSABASEERR + 46)
   WSAEAFNOSUPPORT = (WSABASEERR + 47)
   WSAEADDRINUSE = (WSABASEERR + 48)
   WSAEADDRNOTAVAIL = (WSABASEERR + 49)
   WSAENETDOWN = (WSABASEERR + 50)
   WSAENETUNREACH = (WSABASEERR + 51)
   WSAENETRESET = (WSABASEERR + 52)
   WSAECONNABORTED = (WSABASEERR + 53)
   WSAECONNRESET = (WSABASEERR + 54)
   WSAENOBUFS = (WSABASEERR + 55)
   WSAEISCONN = (WSABASEERR + 56)
   WSAENOTCONN = (WSABASEERR + 57)
   WSAESHUTDOWN = (WSABASEERR + 58)
   WSAETOOMANYREFS = (WSABASEERR + 59)
   WSAETIMEDOUT = (WSABASEERR + 60)
   WSAECONNREFUSED = (WSABASEERR + 61)
   WSAELOOP = (WSABASEERR + 62)
   WSAENAMETOOLONG = (WSABASEERR + 63)
   WSAEHOSTDOWN = (WSABASEERR + 64)
   WSAEHOSTUNREACH = (WSABASEERR + 65)
   WSAENOTEMPTY = (WSABASEERR + 66)
   WSAEPROCLIM = (WSABASEERR + 67)
   WSAEUSERS = (WSABASEERR + 68)
   WSAEDQUOT = (WSABASEERR + 69)
   WSAESTALE = (WSABASEERR + 70)
   WSAEREMOTE = (WSABASEERR + 71)
   WSAEDISCON = (WSABASEERR + 101)
End Enum

Enum SockAddressFamilies
   AF_UNSPEC = 0                    'unspecified
   AF_UNIX = 1                      'local to host (pipes, portals)
   AF_INET = 2                      'internetwork: UDP, TCP, etc.
   AF_IMPLINK = 3                   'arpanet imp addresses
   AF_PUP = 4                       'pup protocols: e.g. BSP
   AF_CHAOS = 5                     'mit CHAOS protocols
   AF_IPX = 6                       'IPX and SPX
   AF_NS = 6                        'XEROX NS protocols
   AF_ISO = 7                       'ISO protocols
   AF_OSI = AF_ISO                  'OSI is ISO
   AF_ECMA = 8                      'european computer manufacturers
   AF_DATAKIT = 9                   'datakit protocols
   AF_CCITT = 10                    'CCITT protocols, X.25 etc
   AF_SNA = 11                      'IBM SNA
   AF_DECnet = 12                   'DECnet
   AF_DLI = 13                      'Direct data link interface
   AF_LAT = 14                      'LAT
   AF_HYLINK = 15                   'NSC Hyperchannel
   AF_APPLETALK = 16                'AppleTalk
   AF_NETBIOS = 17                  'NetBios-style addresses
End Enum

Type SOCKADDR
  sa_family   As Integer
  sa_data     As String * 14
End Type

Type IN_ADDR
  s_b1 As Byte
  s_b2 As Byte
  s_b3 As Byte
  s_b4 As Byte
  s_w1 As Integer
  s_w2 As Integer
End Type

Type SOCKADDR_IN
  sin_family  As Integer
  sin_port    As Integer
  sin_addr    As IN_ADDR
  sin_zero    As String * 8
End Type

Type OVERLAPPED
  Internal      As Long
  InternalHigh  As Long
  Offset        As Long
  OffsetHigh    As Long
  hEvent        As Long
End Type

Type CSADDR_INFO
  LocalAddr     As Long
  RemoteAddr    As Long
  iSocketType   As Long
  iProtocol     As SockProtocols
End Type

Type HOSTENT
  h_name          As Long     'official name of host
  h_aliases       As Long     'alias list
  h_addrtype      As Integer  'host address type
  h_length        As Integer
  h_addr_list     As Long     'list of addresses
End Type


Type PROTOENT
  p_name        As String
  p_aliases(15) As String
  p_proto       As Integer
End Type

Type SERVENT
  s_name        As String
  s_aliases(15) As String
  s_port        As Integer
  s_proto       As String
End Type

Type SERVICE_ADDRESS
  dwAddressType     As Long
  dwAddressFlags    As Long
  dwAddressLength   As Long
  dwPrincipalLength As Long
  lpAddress         As Byte
  lpPrincipal       As Byte
End Type

Type SERVICE_ADDRESSES
  dwAddressCount  As Long
  Addresses(1)    As SERVICE_ADDRESS
End Type

Type BLOB
  cbSize      As Long
  pBlobData   As Byte
End Type

Type SERVICE_INFO
  lpServiceType       As Long
  lpServiceName       As String
  lpComment           As String
  lpLocale            As String
  dwDisplayHint       As Long
  dwVersion           As Long
  dwTime              As Long
  lpMachineName       As String
  lpServiceAddress As SERVICE_ADDRESSES
  ServiceSpecificInfo As BLOB
End Type

Type NS_SERVICE_INFO
  dwNameSpace As Long
  ServiceInfo As SERVICE_INFO
End Type

Type WSADATA
  wversion          As Integer
  wHighVersion      As Integer
  szDescription(0 To WSADescription_Len) As Byte
  szSystemStatus(0 To WSASYS_Status_Len) As Byte
  iMaxSockets       As Integer
  iMaxUdpDg         As Integer
  lpszVendorInfo    As Long
End Type

Type LARGE_INTEGER
  lowpart As Long
  highpart As Long
End Type

Type FD_SET
  fd_count              As Long
  fd_array(FD_SETSIZE)  As Long
End Type

Type TIMEVAL
  tv_sec  As Long
  tv_usec As Long
End Type

Type TRANSMIT_FILE_BUFFERS
  Head        As Long
  HeadLength  As Long
  Tail        As Long
  TailLength  As Long
End Type

Type FLOWSPEC
  TokenRate           As Long     'In Bytes/sec
  TokenBucketSize     As Long     'In Bytes
  PeakBandwidth       As Long     'In Bytes/sec
  Latency             As Long     'In microseconds
  DelayVariation      As Long     'In microseconds
  ServiceType         As Integer  'Guaranteed, Predictive,
                                  'Best Effort, etc.
  MaxSduSize          As Long     'In Bytes
  MinimumPolicedSize  As Long     'In Bytes
End Type

Type PROTOCOL_INFO
  dwServiceFlags  As Long
  iAddressFamily  As Long
  iMaxSockAddr    As Long
  iMinSockAddr    As Long
  iSocketType     As Long
  iProtocol       As Long
  dwMessageSize   As Long
  lpProtocol      As Long
End Type

Declare Function accept Lib "ws2_32" (ByVal sck As Long, addr As SOCKADDR, AddrLen As Integer) As Long

Declare Function AcceptEx Lib "ws2_32" (ByVal sListenSocket As Long, ByVal sAcceptSocket As Long, lpOutputBuffer As Any, ByVal dwReceiveDataLength As Long, ByVal dwLocalAddressLength As Long, ByVal dwRemoteAddressLength As Long, lpdwBytesReceived As Long, lpOverlapped As OVERLAPPED) As Long

Declare Function bind Lib "ws2_32" (ByVal sck As Long, name As SOCKADDR, ByVal namelen As Long) As Long
Declare Function closesocket Lib "ws2_32" (ByVal sck As Long) As Long

Declare Function Connect Lib "ws2_32" (ByVal sck As Long, ByVal SckName As String, ByVal namelen As Long) As Long
Declare Function EnumProtocols Lib "ws2_32" Alias "EnumProtocolsA" (ByVal lpiProtocols As SockProtocols, ByVal lpProtocolBuffer As PROTOCOL_INFO, ByVal lpdwBufferLength As Long)

Declare Sub GetAcceptExSockaddrs Lib "ws2_32" (lpOutputBuffer As Any, ByVal dwReceiveDataLength As Long, ByVal dwLocalAddressLength As Long, ByVal dwRemoteAddressLength As Long, LocalSockaddr As Long, LocalSockaddrLength As Long, RemoteSockaddr As Long, RemoteSockaddrLength As Long)

Declare Function GetAddressByName Lib "ws2_32" Alias "GetAddressByNameA" (ByVal dwNameSpace As Long, ByVal lpServiceType As Long, ByVal lpServiceName As Long, ByVal lpiProtocols As SockProtocols, ByVal dwResolution As Long, ByVal lpServiceAsyncInfo As Long, lpCsaddrBuffer As CSADDR_INFO, ByVal lpdwBufferLength As Long, ByVal lpAliasBuffer As Long, ByVal lpdwAliasBufferLength As Long) As Long

Declare Function gethostbyaddr Lib "ws2_32" (ByVal addr As String, ByVal iaddrlen As Long, ByVal iaddrtype As Long) As HOSTENT

Declare Function gethostbyname Lib "ws2_32" (ByVal hostname As String) As Long

Declare Function gethostname Lib "ws2_32" (ByVal name As String, ByVal namelen As Long) As Long

Declare Function GetNameByType Lib "ws2_32" Alias "GetNameByTypeA" (ByVal lpServiceType As Long, ByVal lpServiceName As String, ByVal dwNameLength As Long) As Long

Declare Function getpeername Lib "ws2_32" (ByVal sck As Long, name As SOCKADDR, ByVal namelen As Long) As Long

Declare Function getprotobyname Lib "ws2_32" (ByVal name As String) As PROTOENT

Declare Function getprotobynumber Lib "ws2_32" (ByVal Number As Long) As PROTOENT

Declare Function getservbyname Lib "ws2_32" (ByVal name As String, ByVal proto As String) As SERVENT

Declare Function getservbyport Lib "ws2_32" (ByVal port As Integer, ByVal proto As String) As SERVENT


Declare Function GetService Lib "ws2_32" Alias "GetServiceA" (ByVal dwNameSpace As Long, ByVal lpGuid As Long, ByVal lpServiceName As String, ByVal dwProperties As Long, lpBuffer As NS_SERVICE_INFO, ByVal lpdwBufferSize As Long, ByVal lpServiceAsyncInfo As Long) As Long

Declare Function GetSockName Lib "ws2_32" Alias "GetSockNameA" (ByVal sck As Long, name As Long, ByVal namelen As Long) As Long

Declare Function getsockopt Lib "ws2_32" (ByVal sck As Long, ByVal level As Long, ByVal optname As Long, ByVal optval As Long, optlen As Long) As Long

Declare Function GetTypeByName Lib "ws2_32" Alias "GetTypeByNameA" ()

Declare Function htons Lib "ws2_32" (ByVal hostshort As Integer) As Integer

Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long

Declare Function inet_addr Lib "ws2_32" (ByVal cp As String) As Long

Declare Function inet_ntoa Lib "ws2_32" (pin As IN_ADDR) As Long

Declare Function ioctlsocket Lib "ws2_32" (ByVal s As Long, ByVal cmd As Long, ByVal argp As Long) As Integer

Declare Function listen Lib "ws2_32" (ByVal s As Long, ByVal backlog As Integer) As Integer

Declare Function ntohl Lib "ws2_32" (ByVal netlong As Long) As Long

Declare Function ntohs Lib "ws2_32" (ByVal netshort As Integer) As Integer

Declare Function recv Lib "ws2_32" (ByVal s As Long, ByVal buf As String, ByVal BufLen As Integer, ByVal flags As Integer) As Integer

Declare Function recvfrom Lib "ws2_32" (ByVal s As Long, ByVal buf As String, ByVal BufLen As Integer, ByVal flags As Integer, from As SOCKADDR, fromlen As Integer) As Integer

Declare Function sockselect Lib "ws2_32" Alias "select" (ByVal nfds As Integer, readfds As FD_SET, writefds As FD_SET, exceptfds As FD_SET, timeout As TIMEVAL) As Integer

Declare Function send Lib "ws2_32" (ByVal s As Long, ByVal buf As Long, ByVal BufLen As Integer, ByVal flags As Integer) As Integer

Declare Function sendto Lib "ws2_32" (ByVal s As Long, ByVal buf As Long, ByVal BufLen As Integer, ByVal flags As Integer, sckto As SOCKADDR, ByVal tolen As Integer) As Integer

Declare Function SetService Lib "ws2_32" Alias "SetServiceA" (ByVal dwNameSpace As Long, ByVal dwOperation As Long, ByVal dwFlags As Long, lpServiceInfo As SERVICE_INFO, ByVal lpServiceAsyncInfo As Long, ByVal lpdwStatusFlags As Long) As Long

Declare Function setsockopt Lib "ws2_32" (ByVal s As Long, ByVal level As Integer, ByVal optname As Integer, ByVal optval As Long, ByVal optlen As Long) As Integer

Declare Function shutdown Lib "ws2_32" (ByVal s As Long, ByVal how As Integer) As Integer

Declare Function socket Lib "ws2_32" (ByVal iAddressFamily As Long, ByVal iType As Long, ByVal iProtocol As Long) As Long

Declare Function TransmitFile Lib "ws2_32" (ByVal hSocket As Long, ByVal hFile As Long, ByVal nNumberOfBytesToWrite As Long, ByVal nNumberOfBytesPerSend As Long, ByVal lpOverlapped As OVERLAPPED, ByVal lpTransmitBuffers As TRANSMIT_FILE_BUFFERS, ByVal dwFlags As Long) As Boolean


Const MAX_PROTOCOL_CHAIN = 7

Type WSAPROTOCOLCHAIN
  ChainLen As Integer   'the length of the chain,
                        'length = 0 means layered protocol,
                        'length = 1 means base protocol,
                        'length > 1 means protocol chain
  ChainEntries(MAX_PROTOCOL_CHAIN) As Long  'a list of dwCatalogEntryIds
End Type

Const WSAPROTOCOL_LEN = 255

Type WSAPROTOCOL_INFO
    dwServiceFlags1                 As Long
    dwServiceFlags2                 As Long
    dwServiceFlags3                 As Long
    dwServiceFlags4                 As Long
    dwProviderFlags                 As Long
    ProviderId                      As CLSID
    dwCatalogEntryId                As Long
    ProtocolChain                   As WSAPROTOCOLCHAIN
    iVersion                        As Integer
    iAddressFamily                  As Integer
    iMaxSockAddr                    As Integer
    iMinSockAddr                    As Integer
    iSocketType                     As Integer
    iProtocol                       As Integer
    iProtocolMaxOffset              As Integer
    iNetworkByteOrder               As Integer
    iSecurityScheme                 As Integer
    dwMessageSize                   As Integer
    dwProviderReserved              As Integer
    szProtocol(WSAPROTOCOL_LEN + 1) As Byte
End Type
 
Declare Function WSAAccept Lib "ws2_32" (ByVal hSocket As Long, pSockAddr As SOCKADDR, ByVal AddrLen As Integer, ByVal lpfnCondition As Long, ByVal dwCallbackData As Long) As Long

Declare Function WSAAddressToString Lib "ws2_32" Alias "WSAAddressToStringA" (lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, lpProtocolInfo As PROTOCOL_INFO, ByVal lpszAddressString As String, ByVal lpdwAddressStringLength As Long) As Long

Declare Function WSAAsyncGetHostByAddr Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal lpNetAddr As Long, ByVal AddrLen As Long, ByVal AddrType As Long, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncGetHostByName Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal lpHostName As String, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncGetProtoByName Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal lpHostName As String, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncGetProtoByNumber Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal iNumer As Integer, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncGetServByName Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal lpServiceName As String, ByVal lpProtocolName As String, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncGetServByPort Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal iPort As Integer, ByVal lpProtocolName As String, ByVal lpBuf As Long, ByVal BufLen As Long) As Long

Declare Function WSAAsyncSelect Lib "ws2_32" (ByVal hSocket As Long, ByVal hWnd As Long, ByVal wMsg As Integer, ByVal lEvent As Long) As Integer

Declare Function WSACancelAsyncRequest Lib "ws2_32" (ByVal hAsyncTaskHandle As Long) As Integer

Declare Function WSACleanup Lib "ws2_32" () As Integer

Declare Function WSACloseEvent Lib "ws2_32" (ByVal hEvent As Long) As Boolean
Declare Function WSAConnect Lib "ws2_32" (ByVal hSocket As Long, lpSckName As SOCKADDR, ByVal iSckNameLen As Integer, ByVal lpCallerData As Long, lpCalleeData As Long, lpSQOS As FLOWSPEC, lpGQOS As FLOWSPEC) As Integer

Declare Function WSACreateEvent Lib "ws2_32" () As Long

Declare Function WSADuplicateSocket Lib "ws2_32" Alias "WSADuplicateSocketA" (ByVal hSocket As Long, ByVal dwProcessId As Long, lpProtocolInfo As WSAPROTOCOL_INFO)

Type WSANAMESPACE_INFO
  NSProviderId    As CLSID
  dwNameSpace     As Long
  fActive         As Boolean
  dwVersion       As Long
  lpszIdentifier  As Long
End Type

Declare Function WSAEnumNameSpaceProviders Lib "ws2_32" Alias "WSAEnumNameSpaceProvidersA" (lpdwBufferLength As Long, lpnspBuffer As Long) As Integer

Type WSANETWORKEVENTS
  lNetworkEvents            As Long
  iErrorCode(FD_MAX_EVENTS) As Integer
End Type

Declare Function WSAEnumNetworkEvents Lib "ws2_32" (ByVal hSocket As Long, ByVal hEventObject As Long, lpNetworkEvents As WSANETWORKEVENTS)

Declare Function WSAEnumProtocols Lib "ws2_32" Alias "WSAEnumProtocolsA" (ByVal lpiProtocols As Long, lpProtocolBuffer As Long, ByVal lpdwBufferLength As Long) As Integer


Declare Function WSAEventSelect Lib "ws2_32" (ByVal hSocket As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long)

Declare Function WSAGetLastError Lib "ws2_32" () As Integer

Type WSAOVERLAPPED
  Internal      As Long
  InternalHigh  As Long
  Offset        As Long
  OffsetHigh    As Long
  hEvent        As Long
End Type

Declare Function WSAGetOverlappedResult Lib "ws2_32" (ByVal hSocket As Long, lpOverlapped As WSAOVERLAPPED, lpcbTransfer As Long, ByVal fWait As Boolean, ByVal lpdwFlags As Long) As Boolean

Type WSABUF
  dwBufferLen As Long
  lpBuffer    As Long
End Type

Type QUALITYOFSERVICE
  SendingFlowspec   As FLOWSPEC
  ReceivingFlowspec As FLOWSPEC
  ProviderSpecific  As WSABUF
End Type

Declare Function WSAGetQOSByName Lib "ws2_32" (ByVal hSocket As Long, lpQOSName As Long, lpQOS As QUALITYOFSERVICE)

Declare Function WSAGetServiceClassInfo Lib "ws2_32" Alias "WSAGetServiceClassInfoA" (lpProviderId As CLSID, lpServiceClassId As CLSID, ByVal lpdwBufferLength As Long, ByVal lpServiceClassInfo As Long) As Integer

Declare Function WSAGetServiceClassNameByClassId Lib "ws2_32" Alias "WSAGetServiceClassNameByClassIdA" (lpServiceClassId As CLSID, ByVal lpszServiceClassName As String, ByVal lpdwBufferLength As Integer) As Integer

Declare Function WSAHtonl Lib "ws2_32" (ByVal hSocket As Long, ByVal dwHostLong As Long, dwNetLong As Long) As Integer

Declare Function WSAHtons Lib "ws2_32" (ByVal hSocket As Long, ByVal iHostShort As Integer, lpNetShort As Integer) As Integer

Type WSAServiceClassInfo
  lpServiceClassId      As CLSID
  lpszServiceClassName  As String
  dwCount               As Long
  lpClassInfos          As Long
End Type

Declare Function WSAInstallServiceClass Lib "ws2_32" Alias "WSAInstallServiceClassA" (lpServiceClassInfo As WSAServiceClassInfo)

Declare Function WSAIoctl Lib "ws2_32" (ByVal hSocket As Long, ByVal dwIoControlCode As Long, ByVal lpvInBuffer As Long, ByVal cbInBuffer As Long, ByVal lpvOUTBuffer As Long, ByVal bOUTBuffer As Long, lpcbBytesReturned As Long, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long)

Declare Function WSAJoinLeaf Lib "ws2_32" (ByVal hSocket As Long, lpSckName As SOCKADDR, ByVal iSckNameLen As Integer, lpCallerData As WSABUF, lpCalleeData As WSABUF, lpSQOS As FLOWSPEC, lpGQOS As FLOWSPEC, ByVal dwFlags As Long) As Long

Enum WSAEcomparator
  COMP_EQUAL = 0
  COMP_NOTLESS = 1
End Enum

Type WSAVersion
  dwVersion As Long
  ecHow     As WSAEcomparator
End Type

Type AFPROTOCOLS
  iAddressFamily  As Integer
  iProtocol       As Integer
End Type

Type SOCKET_ADDRESS
  lpSockaddr      As Long
  iSockaddrLength As Long
End Type

Type WSAQuerySet
  dwSize                  As Long
  lpszServiceInstanceName As String
  lpServiceClassId        As CLSID
  lpVersion               As WSAVersion
  lpszComment             As String
  dwNameSpace             As Long
  lpNSProviderId          As CLSID
  lpszContext             As String
  dwNumberOfProtocols     As Long
  lpafpProtocols          As Long
  lpszQueryString         As String
  dwNumberOfCsAddrs       As Long
  lpcsaBuffer             As CSADDR_INFO
  dwOutputFlags           As Long
  lpBlob                  As BLOB
End Type

Declare Function WSALookupServiceBegin Lib "ws2_32" Alias "WSALookupServiceBeginA" (ByVal lpqsRestrictions As WSAQuerySet, ByVal dwControlFlags As SearchControlFlags, lphLookup As Long) As Integer

Declare Function WSALookupServiceEnd Lib "ws2_32" (ByVal hLookup As Long) As Integer

Declare Function WSALookupServiceNext Lib "ws2_32" Alias "WSALookupServiceNextA" (ByVal hLookup As Long, ByVal dwControlFlags As SearchControlFlags, lpdwBufferLength As Long, lpqsResults As WSAQuerySet) As Integer

Declare Function WSANtohl Lib "ws2_32" (ByVal hSocket As Long, ByVal lpNetLong As Long, lpHostLong As Long) As Integer

Declare Function WSANtohs Lib "ws2_32" (ByVal hSocket As Long, ByVal lpNetShort As Integer, lpHostShort As Integer) As Integer

Declare Function WSAProviderConfigChange Lib "ws2_32" (ByVal lpNotificationHandle As Long, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long) As Integer

Declare Function WSARecvEx Lib "ws2_32" (ByVal hSocket As Long, ByVal lpBuffers As Long, ByVal dwBufferCount As Long, lpNumberOfBytesRecvd As Long, lpFlags As Long, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long) As Integer

Declare Function WSARecvDisconnect Lib "ws2_32" (ByVal hSocket As Long, lpInboundDisconnectData As WSABUF) As Integer

Declare Function WSARecvFrom Lib "ws2_32" (ByVal hSocket As Long, ByVal lpBuffers As Long, ByVal dwBufferCount As Long, lpNumberOfBytesRecvd As Long, lpFlags As Long, lpFrom As SOCKADDR, lpFromlen As Integer, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long) As Integer

Declare Function WSARemoveServiceClass Lib "ws2_32" (lpServiceClassId As CLSID) As Integer

Declare Function WSAResetEvent Lib "ws2_32" (ByVal hEvent As Long) As Boolean

Declare Function WSASend Lib "ws2_32" (ByVal hSocket As Long, ByVal lpBuffers As Long, ByVal dwBufferCount As Long, lpNumberOfBytesSent As Long, ByVal dwFlags As Long, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long) As Integer

Declare Function WSASendDisconnect Lib "ws2_32" (ByVal hSocket As Long, boundDisconnectData As WSABUF) As Integer

Declare Function WSASendTo Lib "ws2_32" (ByVal hSocket As Long, ByVal lpBuffers As Long, ByVal dwBufferCount As Long, lpNumberOfBytesSent As Long, ByVal dwFlags As Long, lpTo As SOCKADDR, ByVal iToLen As Integer, lpOverlapped As WSAOVERLAPPED, ByVal lpCompletionROUTINE As Long) As Integer

Declare Function WSASetEvent Lib "ws2_32" (ByVal hEvent As Long) As Boolean
Declare Sub WSASetLastError Lib "ws2_32" (ByVal iError As Integer)

Enum WSAESETSERVICEOP
  RNRSERVICE_REGISTER = 0
  RNRSERVICE_DEREGISTER = 1
  RNRSERVICE_DELETE = 2
End Enum

Declare Function WSASetService Lib "ws2_32" Alias "WSASetServiceA" (lpqsRegInfo As WSAQuerySet, essOperation As WSAESETSERVICEOP, ByVal dwControlFlags As Long) As Integer

Declare Function WSASocket Lib "ws2_32" Alias "WSASocketA" (ByVal iAddressFamily As Integer, ByVal iType As Integer, ByVal iProtocol As Integer, lpProtocolInfo As WSAPROTOCOL_INFO, ByVal lpGroup As Long, ByVal dwFlags As Long) As Long

Declare Function WSAStartup Lib "ws2_32" (ByVal wVersionRequired As Long, lpWSAData As WSADATA) As Long

Declare Function WSAStringToAddress Lib "ws2_32" (ByVal AddressString As String, ByVal AddressFamily As Integer, lpProtocolInfo As WSAPROTOCOL_INFO, lpAddress As SOCKADDR, lpAddressLength As Integer) As Integer

Public SockLastError As Long

Function sckhibyte(ByVal wParam As Integer)
  sckhibyte = (wParam \ &H100) And &HFF&
End Function

Function scklobyte(ByVal wParam As Integer)
  scklobyte = wParam And &HFF&
End Function

Property Get LocalHostName() As String
     
      Dim sStr As String * 256, lStr&
      Dim r&
     
  r = gethostname(sStr, 256)
  SockLastError = WSAGetLastError()
 
  LocalHostName = Trim(Replace(sStr, vbNullChar, vbNullString))
End Property

Property Get LocalHostIP() As String

   Dim sHostName$, pHostent&
   Dim pHost As HOSTENT
   Dim hIPAddress&, sIPAddress$
   Dim abIPAddress() As Byte
   Dim i%


  sHostName = LocalHostName
  pHostent = gethostbyname(sHostName)
  SockLastError = WSAGetLastError()

  If pHostent = 0 Then Exit Property
 
  CopyMemory ByVal pHost, ByVal pHostent, ByVal LenB(pHost)
  CopyMemory hIPAddress, ByVal pHost.h_addr_list, ByVal 4&

  ReDim abIPAddress(1 To pHost.h_length)
  CopyMemory abIPAddress(1), ByVal hIPAddress, ByVal pHost.h_length

  For i = 1 To pHost.h_length
    sIPAddress = sIPAddress & abIPAddress(i) & "."
  Next
 
  LocalHostIP = Left$(sIPAddress, Len(sIPAddress) - 1)
 
End Property

Sub SocketsInitialize()
      Dim WSAD As WSADATA
      Dim iReturn As Integer
      Dim sLowByte As String, sHighByte As String, sMsg As String

    iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
    SockLastError = WSAGetLastError()

    If iReturn <> 0 Then
      Exit Sub
    End If

    If LoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
      (LoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
        HiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
       
        Exit Sub
    End If

    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
      Exit Sub
    End If

End Sub

Function SocketsCleanup() As Long
  SocketsCleanup = WSACleanup()
End Function

Function CreateSocket(ByVal SockType As SockTypes, Optional ByVal Protocol As SockProtocols = IPPROTO_TCP) As Long
  CreateSocket = socket(AF_NETBIOS, SockType, Protocol)
  SockLastError = WSAGetLastError
End Function

Function DestroySocket(hSocket As Long) As Boolean
  DestroySocket = (closesocket(hSocket) = 0)
  SockLastError = WSAGetLastError
End Function

Function GetSckName(hSocket As Long) As String
      Dim sName$
      Dim pSckAdd As SOCKADDR, lpAdd&
      Dim r&
 
  r = GetSockNameA(hSocket, lpAdd, LenB(pSckAdd))
  SockLastError = WSAGetLastError
 
  CopyMemory ByVal pSckAdd, ByVal lpAdd, ByVal LenB(pSckAdd)
 
  GetSckName = Trim(Replace(pSckAdd.sa_data, vbNullChar, vbNullString))
 
End Function


Saludos.