Option Explicit
 
'-----------------------------------------
'Autor: Karcrack                          |
'Creditos: MSDN                           |
'Fecha: 10/10/08                          |
'Web: http://foro.fire-software.net       |
'Utilidad: Ejemplo de uso de las APIs para|
'enviar y recibir informacion con         |
'aplicaciones de Command Line.            |
'=========================================|
'Puedes distribuir libremente este codigo |
'Siempre que pongas el autor.             |
'------------------------------------------
 
Enum Colors
    Negro = &H0
    Azul = &H1
    Verde = &H2
    AguaMarina = &H3
    Red = &H4
    Purpura = &H5
    Amarillo = &H6
    Blanco = &H7
    Gris = &H8
    AzulClaro = &H9
    VerdeClaro = &HA&
    AguamarinaClaro = &HB&
    RojoClaro = &HC&
    PurpuraClaro = &HD&
    AmarilloClaro = &HE&
    BlancoBrillante = &HF&
End Enum
 
Private Const ENABLE_LINE_INPUT = &H2&
Private Const ENABLE_ECHO_INPUT = &H4&
Private Const ENABLE_MOUSE_INPUT = &H10&
Private Const ENABLE_PROCESSED_INPUT = &H1&
Private Const ENABLE_WINDOW_INPUT = &H8&
Private Const ENABLE_PROCESSED_OUTPUT = &H1&
Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_ERROR_HANDLE = -12&
Private Const INVALID_HANDLE_VALUE = -1&
 
Private mvarTitle   As String
Private mvarFColor  As Double
Private mvarBColor  As Double
Private hCMDIn      As Double
Private hCMDOut     As Double
 
Private Declare Function AllocConsole Lib "kernel32.dll" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long
 
Public Function GetData(Optional ByVal dCharacters As Double, Optional ByVal bLine As Boolean) As String
    Dim lPos            As Long
 
    GetData = String$(IIf(dCharacters = 0, 500, dCharacters), 0)
 
    Call ReadConsole(hCMDIn, GetData, Len(GetData), lPos, vbNull)
    GetData = Left$(GetData, lPos)
 
    If bLine = True Then
        GetData = Mid$(GetData, InStrRev(GetData, vbCrLf))
    End If
End Function
 
Public Function SendData(ByVal sData As String, Optional ByVal dNewFColor As Colors, Optional ByVal dNewBColor As Colors) As Boolean
    Dim dLenWritten     As Long
    Dim Color1          As Long
    Dim Color2          As Long
 
    If dNewFColor Then
        Color1 = dNewFColor
    Else
        Color1 = mvarFColor
    End If
 
    If dNewBColor Then
        Color2 = dNewBColor
    Else
        Color2 = mvarBColor
    End If
 
    Call SetConsoleTextAttribute(hCMDOut, Color1 Or Color2)
    Call WriteConsole(hCMDOut, ByVal sData, Len(sData), dLenWritten, ByVal 0&)
    If dLenWritten = Len(sData) Then
        SendData = True
    End If
    Call SetConsoleTextAttribute(hCMDOut, mvarFColor Or mvarBColor)
End Function
 
Public Property Let ForeColor(ByVal vData As Colors)
    mvarFColor = vData
    Call SetConsoleTextAttribute(hCMDOut, mvarFColor Or mvarBColor)
End Property
 
Public Property Get ForeColor() As Colors
    ForeColor = mvarFColor
End Property
 
Public Property Let BackColor(ByVal vData As Colors)
    mvarBColor = vData
    Call SetConsoleTextAttribute(hCMDOut, mvarFColor Or mvarBColor)
End Property
 
Public Property Get BackColor() As Colors
    BackColor = mvarBColor
End Property
 
Public Property Let Title(ByVal vData As String)
    mvarTitle = vData
    Call SetConsoleTitle(mvarTitle)
End Property
 
Public Property Get Title() As String
    Title = mvarTitle
End Property
 
Private Sub Class_Initialize()
    If App.LogMode = 0 Then AllocConsole
    hCMDOut = GetStdHandle(STD_OUTPUT_HANDLE)
    hCMDIn = GetStdHandle(STD_INPUT_HANDLE)
    Call SetConsoleTitle(mvarTitle)
    Call SetConsoleTextAttribute(hCMDOut, mvarFColor Or mvarBColor)
End Sub
 
Private Sub Class_Terminate()
    CloseHandle hCMDOut
    CloseHandle hCMDIn
    If App.LogMode = 0 Then FreeConsole
End Sub
 

• Introduccion
• Manos a la obra

• Salida
• Entrada

• Finalizando
• Ejemplo
• Despedida

Public Function SendCMD(ByVal sData As String) As Boolean
    'Si hay algun error devuelve False, si todo ha ido bien devuelve True
    On Error GoTo Fallo
 
    Dim FSO         As Object
    Dim sOut        As Object
    'Cargamos los objectos
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sOut = FSO.GetStandardStream(1) ' StdOut = 1
    'Llamamos a la funcion que envia la informacion
    Call sOut.WriteLine(sData)
    'Descargamos los objetos
    Set sOut = Nothing
    Set FSO = Nothing
    'Devolvemos True, todo ha ido bien
    SendCMD = True
    'Salimos de la funcion
    Exit Function
Fallo:
    'Algo fallo, devolvemos False
    SendCMD = False
End Function

Public Function GetCMD(Optional ByVal ReadLine As Boolean = False, Optional ByVal Caracteres As Long = 0) As String
    Dim FSO         As Object
    Dim sIn         As Object
 
    'Cargamos los objectos
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sIn = FSO.GetStandardStream(0) ' StdIn = 0
 
    If ReadLine = False Then
        'Si no queremos la ultima linea
        If Caracteres = 0 Then
            'Si lo queremos todo
            GetCMD = sIn.ReadAll
        Else
            'Si solo queremos los ultimos n Caracteres
            GetCMD = sIn.Read(Caracteres)
        End If
    Else
        'Si queremos solo la ultima linea
        GetCMD = sIn.ReadLine
    End If
    'Descargamos los objetos
    Set sIn = Nothing
    Set FSO = Nothing
End Function

LINK /EDIT /SUBSYSTEM:CONSOLE <Ruta Ejecutable>

Dim StrLINK     ,StrEXE      ,WSHShell    

'Ruta del LINK.exe de la carpeta VB
StrLINK = """C:\Archivos de programa\Microsoft Visual Studio\VB98\LINK.EXE"""
'Ruta del ejecutable que arrastras
StrEXE = """" & WScript.Arguments(0) & """"
Set WSHShell = CreateObject("WScript.Shell")

WSHShell.Run StrLINK & " /EDIT /SUBSYSTEM:CONSOLE " & StrEXE , 0

Set WSHShell = Nothing
WScript.Echo "Finalizado!!"

Option Explicit

Private Sub Form_Load()
    Dim Numero1     As Long
    Dim Numero2     As Long
    Dim Operacion   As String
    Dim Resultado   As Double
    
    'Para que no se vea la ventana
    Form1.Visible = False
    'Pedimos el primer numero
    Call SendCMD("Introduce el primer numero:")
    'Lo obtenemos
    Numero1 = GetCMD(True)
    'Pedimos el segundo
    Call SendCMD("Introduce el segundo numero:")
    'Lo obtenemos
    Numero2 = GetCMD(True)
    'Pedimos la operacion
    Call SendCMD("Introduce la operacion:" & vbCrLf & " + para suma" & vbCrLf & " - para resta" & vbCrLf & " * para multiplicacion" & vbCrLf & " / para division")
    'La obtenemos
    Operacion = GetCMD(False, 1)
    'Hacemos la operacion
    Select Case Operacion
        Case "+"
            Resultado = Numero1 + Numero2
        Case "-"
            Resultado = Numero1 - Numero2
        Case "*"
            Resultado = Numero1 * Numero2
        Case "/"
            Resultado = Numero1 / Numero2
    End Select
    'Devolvemos el resultado
    Call SendCMD(Resultado & vbCrLf)
    End
End Sub

Public Function SendCMD(ByVal sData As String) As Boolean
    'Si hay algun error devuelve False, si todo ha ido bien devuelve True
    On Error GoTo Fallo
    
    Dim FSO         As Object
    Dim sOut        As Object
    'Cargamos los objectos
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sOut = FSO.GetStandardStream(1) ' StdOut = 1
    'Llamamos a la funcion que envia la informacion
    Call sOut.WriteLine(sData)
    'Descargamos los objetos
    Set sOut = Nothing
    Set FSO = Nothing
    'Devolvemos True, todo ha ido bien
    SendCMD = True
    'Salimos de la funcion
    Exit Function
Fallo:
    'Algo fallo, devolvemos False
    SendCMD = False
End Function

Public Function GetCMD(Optional ByVal ReadLine As Boolean = False, Optional ByVal Caracteres As Long = 0) As String
    Dim FSO         As Object
    Dim sIn         As Object
    
    'Cargamos los objectos
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sIn = FSO.GetStandardStream(0) ' StdIn = 0
    
    If ReadLine = False Then
        'Si no queremos la ultima linea
        If Caracteres = 0 Then
            'Si lo queremos todo
            GetCMD = sIn.ReadAll
        Else
            'Si solo queremos los ultimos n Caracteres
            GetCMD = sIn.Read(Caracteres)
        End If
    Else
        'Si queremos solo la ultima linea
        GetCMD = sIn.ReadLine
    End If
    'Descargamos los objetos
    Set sIn = Nothing
    Set FSO = Nothing
End Function

Option Explicit
 
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
 
Public Function CreateManifest() As Boolean
    'Si hay algun error sigue a la siguiente accion
    On Error Resume Next
    Dim sPath As String
    'Obtenemos la ruta de nuestro ejecutables
    sPath = String$(260, Chr$(0)) 'Gracias Cobein
    sPath = Left$(sPath, GetModuleFileName(App.hInstance, sPath, Len(sPath)))
    'Comprobamos qu eno existe ningun fichero .Manifest _
    'y que no estamos ejecutando la aplicacion desde el Visual Studio
    If App.LogMode = 0 Then Exit Function
    If Dir(sPath & ".manifest", vbReadOnly Or vbSystem Or vbHidden) = vbNullString Then
        'Obtenemos la version del Window$
        If Win2Version = "XP" Then
            'Si es XP significa que es compatible con el metodo Manifest _
            ', por lo tanto crea el fichero
            Open sPath & ".manifest" For Output As #1
                'Le introduce los datos...
                Print #1, FormatManifest
                'Todo ha ido bien...
                CreateManifest = True
            Close #1
            'Estable el fichero como: Oculto/System/SoloLectura/Archivo
            SetAttr sPath & ".manifest", vbHidden Or vbSystem Or vbReadOnly Or vbArchive
            'Y lo vuelve a ejecutar, para que los cambios tengan efecto
            Shell sPath, vbNormalFocus
            End
        End If
    End If
    'LLamamos al API....
    Call InitCommonControls
End Function
 
Private Function Win2Version() As String
    'Declaramos las variables para esta funcion
    Dim OSInf As OSVERSIONINFO, iRet As Integer
    OSInf.dwOSVersionInfoSize = 148
    OSInf.szCSDVersion = Space$(128)
    'Obtenemos la informacion del Window$
    iRet = GetVersionExA(OSInf)
    'Si no se ha podido obtener correctamente devuelve 'Unknown'
    If iRet = 0 Then Win2Version = "Unk": Exit Function
    With OSInf
        Select Case .dwPlatformId
            Case 1
                Select Case .dwMinorVersion
                    Case 0
                        'En caso de que sea Win95
                        Win2Version = "95"
                    Case 10
                        'En caso de que sea Win98
                        Win2Version = "98"
                    Case 90
                        'En caso de que sea Win Millenium
                        Win2Version = "Mi"
                End Select
            Case 2
                Select Case .dwMajorVersion
                    Case 3 Or 4
                        'En caso de que sea NT (Aqui no he distinguido entre las dos versiones...)
                        Win2Version = "NT"
                    Case 5
                        Select Case .dwMinorVersion
                            Case 0
                                'En caso de que sea Win2000
                                Win2Version = "2000"
                            Case 1
                                'En caso de que sea XP
                                Win2Version = "XP"
                            Case 2
                                'En caso de que sea Win2003 (SERVER)
                                Win2Version = "2003"
                        End Select
                    Case 6
                        'En caso de que sea Win Vista
                        Win2Version = "Vista"
                End Select
            Case Else
                'En caso de que sea que sea desconocido...
                Win2Version = "Unk"
        End Select
    End With
End Function
 
Private Function FormatManifest() As String
    Dim Header As String
    'Carga el .manifest en una variable
    Header = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & " standalone=" & Chr(34) & "yes" & Chr(34) & "?>" _
                & vbCrLf & "<assembly xmlns=" & Chr(34) & "urn:schemas-microsoft-com:asm.v1" & Chr(34) & " manifestVersion=" & Chr(34) & "1.0" & Chr(34) & ">" _
                & vbCrLf & "<assemblyIdentity" _
                & vbCrLf & "version=" & Chr(34) & "1.0.0.0" & Chr(34) _
                & vbCrLf & "processorArchitecture=" & Chr(34) & "X86" & Chr(34) _
                & vbCrLf & "name=" & Chr(34) & App.EXEName & ".exe" & Chr(34) _
                & vbCrLf & "type=" & Chr(34) & "win32" & Chr(34) _
                & vbCrLf & "/>" _
                & vbCrLf & "<description>" & App.Comments & "</description>" _
                & vbCrLf & "<dependency>" _
                & vbCrLf & "<dependentAssembly>" _
                & vbCrLf & "<assemblyIdentity" _
                & vbCrLf & "type=" & Chr(34) & "win32" & Chr(34) _
                & vbCrLf & "name=" & Chr(34) & "Microsoft.Windows.Common-Controls" & Chr(34) _
                & vbCrLf & "version=" & Chr(34) & "6.0.0.0" & Chr(34) _
                & vbCrLf & "processorArchitecture=" & Chr(34) & "X86" & Chr(34) _
                & vbCrLf & "publicKeyToken=" & Chr(34) & "6595b64144ccf1df" & Chr(34) _
                & vbCrLf & "language=" & Chr(34) & "*" & Chr(34) _
                & vbCrLf & "/>" _
                & vbCrLf & "</dependentAssembly>" _
                & vbCrLf & "</dependency>" _
                & vbCrLf & "</assembly>"
    FormatManifest = Header
End Function
 

Por lo visto los chicos de Microsoft tuvieron algunos problemas , porque resulta, que al poner un optionbutton dentro de un frame se queda de color de fondo negro, asi que, os doy la solucion al problema: Meter los controles con los que os pase eso dentro de un Picture... eso lo soluciona

• cifra usando un StrReverse() o un Xor()
• La funcion del Xor es dinámica, lo que significa que varia cada vez que encriptas un proyecto.
• Permite seleccionar los ficheros del proyecto que se encriptaran.
• Permite crear ficheros de respaldo de los fichero modificados.
• Muestra el progreso de encriptacion de cada fichero, en la parte inferior de la ventana.

/* Esta es una pequeña funcion que devuleve la IP
   Actual siempre y cuando se navege desde el navegador 'karcrack'
*/
<?PHP
	$Nav = $_SERVER['HTTP_USER_AGENT'];
	if ($Nav == "karcrack")
	{
		echo $_SERVER['REMOTE_ADDR'];
	}
	else
	{
		echo '127.0.0.1';
	} 
?>

'Esto se pone siempre xD
Option Explicit
'Se declara el Objecto.
Public WinHttp As Object
'Se declaran las constantes para la configuracion del WinHttp
Public Const WinHttpRequestOption_EnableHttp1_1 As Long = 17
Public Const WinHttpRequestOption_EnableHttpsToHttpRedirects As Long = 12
Public Const WinHttpRequestOption_EnableRedirects As Long = 6
Public Const WinHttpRequestOption_UserAgentString As Long = 0
Public Const HTTPREQUEST_PROXYSETTING_DIRECT As Long = 1
 
'Esta funcion configura el WinHttp con las opciones mas habituales...
Public Sub SetHTTPLib()
    'Se vacia el objecto.
    Set WinHttp = Nothing
    'Se carga el objecto
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With WinHttp
        'Permite la version del protocolo http 1.1
        .Option(WinHttpRequestOption_EnableHttp1_1) = True
        'Permite la redireccion de https:// a http://
        .Option(WinHttpRequestOption_EnableHttpsToHttpRedirects) = True
        'Permite las demas redirecciones
        .Option(WinHttpRequestOption_EnableRedirects) = True
        'Modifica el Navegador, para que nuestro script PHP sepa que somos notros :D
        .Option(WinHttpRequestOption_UserAgentString) = "karcrack"
        'Desactiva el proxy.
        .SetProxy HTTPREQUEST_PROXYSETTING_DIRECT
    End With
End Sub
 
Public Function ObIP(ByVal URL As String) As String
    Call SetHTTPLib
    With WinHttp
        'Se conecta.
        .Open "GET", URL
        'Pide la IP
        .Send
        'La obtiene
        ObIP = .ResponseText
    End With
End Function

msgbox ObIp ("URL_DONDE_ESTA_EL_SCRIPT_EN_PHP")

Saludos

• Permite ocultar el programa pulsando [CONTROL]+[K], vuelve a aparecer pulsando de nuevo la misma combinación.
• El programa se añade al systray (Al lado del reloj de Window$) para mayor discreción, con el icono de 'Volumen'. Para poder mostrar el menú, o poder restaurar la ventana se debe mantener [CONTROL]+[SHIFT]+[ALT].
• Permite modificar la transparencia de la ventana haciendo doble click sobre las partes vacías del form (los frames no valen ).
• Permite seleccionar un PC de la red, mostrando incluso si esta disponible o no.
• Muestra el progreso de cada acción individual y de la acción conjunta.