Publicar codigos

[crypto136]

Colocar en un formulario un control ListBox, un PictureBox, un textBox, y Tres CommandButton y un módulo bas.

Código fuente en el módulo bas:

Código:

Option Explicit
 
' Funciones Api, constantes
'---------------------------------------------------------------------
Private Declare Function FindResourceByNum Lib "kernel32" Alias "FindResourceA" ( _
    ByVal hInstance As Long, _
    ByVal lpName As String, _
    ByVal lpType As Long) As Long

Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" ( _
    ByVal lpLibFileName As String, _
    ByVal hFile As Long, _
    ByVal dwFlags As Long) As Long

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" ( _
    ByVal hInstance As Long, _
    ByVal lpName As String, _
    ByVal lpType As String) As Long

Private Declare Function LoadResource Lib "kernel32" ( _
    ByVal hInstance As Long, _
    ByVal hResInfo As Long) As Long

Private Declare Function LockResource Lib "kernel32" ( _
    ByVal hResData As Long) As Long

Private Declare Function SizeofResource Lib "kernel32" ( _
    ByVal hInstance As Long, _
    ByVal hResInfo As Long) As Long

Private Declare Function FreeResource Lib "kernel32" ( _
    ByVal hResData As Long) As Long

Private Declare Function EnumResourceNames Lib "kernel32" Alias "EnumResourceNamesA" ( _
    ByVal hModule As Long, _
    ByVal lpType As String, _
    ByVal lpEnumFunc As Long, _
    ByVal lParam As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As Long)

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
    ByVal dwExStyle As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String, _
    ByVal dwStyle As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hWndParent As Long, _
    ByVal hMenu As Long, _
    ByVal hInstance As Long, _
    lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

Private Const ANIMATE_CLASS = "SysAnimate32"
Private Const WS_EX_TRANSPARENT = &H20&
Private Const ACS_TRANSPARENT = &H2&
Private Const ACS_AUTOPLAY = &H4&
Private Const WM_USER = &H400&
Private Const ACM_OPEN = WM_USER + 100
Private Const ACM_PLAY = WM_USER + 101
Private Const ACM_STOP = WM_USER + 102

Private Animacion As Long
Private hModule As Long
Private Const TEMP_FILE_NAME = "c:\tempfile.tmp"
Public ResourceName() As String
Public ResourceCount As Long


' Funciones y subRutinas
'---------------------------------------------------------------------


Public Function ShowAVI(ByVal ResName As String, pb As PictureBox) As Boolean
On Error GoTo Salir
   Dim arr() As Byte, nFile As Integer, Ret As Long

   If Dir(TEMP_FILE_NAME) <> "" Then
        DestroyWindow Animacion
        Kill TEMP_FILE_NAME
   End If
   
   arr = GetDataArray("AVI", "#" & ResName)
   
   nFile = FreeFile
   Open TEMP_FILE_NAME For Binary As #nFile
      Put #nFile, , arr
   Close #nFile

    Animacion = CreateWindowEx(WS_EX_TRANSPARENT, ANIMATE_CLASS, "", _
                               &H50000000 Or ACS_TRANSPARENT, pb.ScaleLeft, _
                               pb.ScaleTop, pb.ScaleWidth, pb.ScaleHeight, _
                               pb.hwnd, 0&, App.hInstance, ByVal 0&)
   
    Ret = SendMessage(Animacion, ACM_OPEN, 0&, ByVal TEMP_FILE_NAME)
   
    ShowAVI = Ret
  Exit Function
Salir:

End Function
Private Function GetDataArray(ByVal ResType As String, _
                              ByVal ResName As String) As Variant
   Dim hRsrc As Long
   Dim hGlobal As Long
   Dim arrData() As Byte
   Dim lpData As Long
   Dim arrSize As Long
   
   If IsNumeric(ResType) Then
        hRsrc = FindResourceByNum(hModule, ResName, CLng(ResType))
   End If
   
   If hRsrc = 0 Then
        hRsrc = FindResource(hModule, ResName, ResType)
   End If
   
   If hRsrc = 0 Then Exit Function
   
   hGlobal = LoadResource(hModule, hRsrc)
   lpData = LockResource(hGlobal)
   arrSize = SizeofResource(hModule, hRsrc)
   
   If arrSize = 0 Then Exit Function
   
   ReDim arrData(arrSize - 1)
   
   Call CopyMemory(arrData(0), ByVal lpData, arrSize)
   Call FreeResource(hGlobal)
   
   GetDataArray = arrData

End Function

Function ResNamesCallBack(ByVal hMod As Long, ByVal ResType As Long, _
                          ByVal ResId As Long, ByVal lParam As Long) As Long
 
    ResourceName(UBound(ResourceName)) = ResId
    ReDim Preserve ResourceName(UBound(ResourceName) + 1)
   
    ResNamesCallBack = True
End Function

Private Function GetAviResource()
    ReDim ResourceName(1)
    Dim Ret As Long
    Ret = EnumResourceNames(hModule, "AVI", AddressOf ResNamesCallBack, 0)
    ResourceCount = UBound(ResourceName) - 1
End Function

Public Sub PlayAviResourse()
    Call SendMessage(Animacion, ACM_PLAY, -1, 0)
End Sub

Public Sub StopAviResourse()
    Call SendMessage(Animacion, ACM_STOP, -1, 0)
End Sub


Public Function InitResource(ByVal sLibName As String) As Boolean
    On Error Resume Next
    If hModule Then TerminateResource
    hModule = LoadLibraryEx(sLibName, 0, 1)
'   hModule = LoadLibrary(sLibName)
    If hModule Then Call GetAviResource
   
    InitResource = (hModule <> 0)
End Function
Public Sub TerminateResource()
    If Dir(TEMP_FILE_NAME) <> "" Then
        DestroyWindow Animacion
        Kill TEMP_FILE_NAME
    End If
    If hModule Then FreeLibrary (hModule)
End Sub

 

Código fuente en el formulario:

Código:

'Recibe el path del archivo a cargar, por ejemplo c:\windows\system32\shell32.dll
Private Sub Obtener_AVI(path)

Dim Ret As Long, i As Long
Ret = InitResource(path)

If Ret Then
    If ResourceCount > 0 Then
        For i = 1 To ResourceCount
            List1.AddItem ResourceName(i)
        Next
    Else
        MsgBox "No se han encontrado Recursos AVI", vbCritical
        TerminateResource
    End If
Else
    MsgBox "Error al acceder a la libreria", vbCritical
    TerminateResource
End If
End Sub

' Botón que carga y enumera los recursos avi
Private Sub Command3_Click()
Call Obtener_AVI(Trim$(Text1.Text))
End Sub

Private Sub Form_Load()
Command1.Caption = " Play AVI "
Command2.Caption = " STOP "
Command3.Caption = " cargar y enumerar "

Text1 = "c:\windows\system32\shell32.dll"

End Sub

'ListBox con los recursos
Private Sub List1_Click()
    Ret = ShowAVI(List1, Picture1)
        If Ret = 0 Then
            MsgBox "Error al acceder al recurso", vbCritical
            Exit Sub
        End If
    DoEvents
    Call PlayAviResourse
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call TerminateResource
End Sub

'Botón Play
Private Sub Command1_Click()
Call PlayAviResourse
End Sub

'Botón stop
Private Sub Command2_Click()
Call StopAviResourse
End Sub

Codigo Bajado de www.RecursosVi sualBasic.com

[crypto136]

pones un 2 TextBox, 1 Label, 1 Timer y remplazas el codigo este:
(jeje en realidad el label y el timer es puro diseño)

En el Form:

Código:

Private Sub Form_Load()
Label1.Caption = "[" & App.Path & "]$"
End Sub

Private Sub Label1_Change()
Text1.Left = Label1.Width + 150
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    If Text1.Text = "exit" Then
        End
    Else
        Text2.Text = CMD(Text1.Text)
        Text1.Text = ""
    End If
End If
End Sub

Private Sub Timer1_Timer()
Label1.Caption = "[" & App.Path & "]$"
End Sub

En un módulo:

Código:

Public Declare Function CreatePipe Lib "kernel32" ( _
          phReadPipe As Long, _
          phWritePipe As Long, _
          lpPipeAttributes As Any, _
          ByVal nSize As Long) As Long
     
      'Leer Tunel
      Public Declare Function ReadFile Lib "kernel32" ( _
          ByVal hFile As Long, _
          ByVal lpBuffer As String, _
          ByVal nNumberOfBytesToRead As Long, _
          lpNumberOfBytesRead As Long, _
          ByVal lpOverlapped As Any) As Long
     
      'Esto lo usa la funcion CreateProcessA
      Public Type SECURITY_ATTRIBUTES
          nLength As Long
          lpSecurityDescriptor As Long
          bInheritHandle As Long
      End Type
     
      'Esto lo usa la funcion CreateProcessA
      Public Type STARTUPINFO
          cb As Long
          lpReserved As Long
          lpDesktop As Long
          lpTitle As Long
          dwX As Long
          dwY As Long
          dwXSize As Long
          dwYSize As Long
          dwXCountChars As Long
          dwYCountChars As Long
          dwFillAttribute As Long
          dwFlags As Long
          wShowWindow As Integer
          cbReserved2 As Integer
          lpReserved2 As Long
          hStdInput As Long
          hStdOutput As Long
          hStdError As Long
      End Type
     
      'Esto lo usa la funcion CreateProcessA
      Public Type PROCESS_INFORMATION
          hProcess As Long
          hThread As Long
          dwProcessId As Long
          dwThreadID As Long
      End Type
     
      'Esta funcion lanza el proceso y
      'devuelve sus datos a traves de PROCESS_INFORMATION
      Public Declare Function CreateProcessA Lib "kernel32" ( _
          ByVal lpApplicationName As Long, _
          ByVal lpCommandLine As String, _
          lpProcessAttributes As SECURITY_ATTRIBUTES, _
          lpThreadAttributes As SECURITY_ATTRIBUTES, _
          ByVal bInheritHandles As Long, _
          ByVal dwCreationFlags As Long, _
          ByVal lpEnvironment As Long, _
          ByVal lpCurrentDirectory As Long, _
          lpStartupInfo As STARTUPINFO, _
          lpProcessInformation As PROCESS_INFORMATION) As Long
     
      'Cierra el tunel
      Public Declare Function CloseHandle Lib "kernel32" ( _
          ByVal hHandle As Long) As Long
     
      'Constantes necesarias para lo de antes
      Public Const NORMAL_PRIORITY_CLASS = &H20&
      Public Const STARTF_USESTDHANDLES = &H100&
      Public Const STARTF_USESHOWWINDOW = &H1
     
     

Public Function CMD(ByVal Comando As String) As String
      On Error GoTo ACAGAR
          Dim proc As PROCESS_INFORMATION     'Informacion de CreateProcessA
          Dim Ret As Long                     'Esto se usa para obtener el retorno de las
                                              'funciones API
          Dim start As STARTUPINFO            'Informacion de inicio para CreateProcessA
     
          Dim sa As SECURITY_ATTRIBUTES       'Atributos de seguridad para
                                              'CreateProcessA
          Dim hReadPipe As Long               'Lectura de Tunel
          Dim hWritePipe As Long              'Escritura de Tunel
          Dim lngBytesread As Long            'Cantidad de Bytes leidos
          Dim strBuff As String * 256         'Buffer de lectura de tunel
     
          'Creamos el tunel...
          sa.nLength = Len(sa)
          sa.bInheritHandle = 1&
          sa.lpSecurityDescriptor = 0&
          Ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
         
          If Ret = 0 Then
              'Si falla la creacion del tunel
              CMD = "Fallo de Conexion con Proceso. Error: " & Err.LastDllError
              Exit Function
          End If
         
          'Lanzamos el interprete de comandos...
          start.cb = Len(start)
          start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
          start.hStdOutput = hWritePipe
          start.hStdError = hWritePipe
          'Buscar la ruta del CMD.exe y añadir /c y el comando
          mCommand = Environ("COMSPEC") + " /c " + Comando
          'Creamos el proceso usando la String mCommand de antes...
          'y obtenemos RET para saber si se ha ejecutado
          Ret& = CreateProcessA(0&, mCommand, sa, sa, 1&, _
              NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
             
          If Ret <> 1 Then
              'si no se encuentra el comando...
              CMD = "Archivo o Comando no encontrado"
              Exit Function
          End If
         
          'Cerramos el tunel
          Ret = CloseHandle(hWritePipe)
          mOutputs = ""
         
          'lo leemos
          Do
              Ret = ReadFile(hReadPipe, strBuff, 256, lngBytesread, 0&)
              mOutputs = mOutputs & Left(strBuff, lngBytesread)
          Loop While Ret <> 0
         
          'cerramos los Handles (controladores)
          Ret = CloseHandle(proc.hProcess)
          Ret = CloseHandle(proc.hThread)
          Ret = CloseHandle(hReadPipe)
         
          'y hacemos que la funcion devuelva el resultado del comando a traves
          ' de la string mOutputs
          CMD = mOutputs
          Exit Function
ACAGAR:
          CMD = "Error:" + Err.Description
End Function

Luego para usarlo:
Respuesta = CMD("tasklist") 'ahi puede ir una variable...

Gracias a NYlOn por pasarme esto...

el documento no recuerdo de donde lo saque ( como siempre el crypto sin recordar la fuente ) pero lo pongo tal como lo encontre ahi esta quien paso el code  por cierto lo pimero del form no estaba en el texto original no es mucho pero por lo menos si el autor lee esto no dira que yo lo altere y me puse como autor

de todas formas lo meti en un rar el codigo, y el ejecutable tambien el .txt original


Para ver este enlace Registrate o Inicia Sesion

Dos en VB

pd: el code no es mio att : Crypto 136

[crypto136]

Agregar 2 CommandButton, 1Label y al control label agregarle el valor "0" en la propiedad Index(de esta forma sera cargada como una matriz de controles lo que nos permitira crear los demas controles).

Código:

Private Sub Command1_Click()

Dim i As Integer

    'Bucle para crear los labels y _
     ponerle algunas propiedades
    For i = 1 To 10
        ' Crea un nuevo control
        Load Label1(i)
       
        'Le establecemos algunas propiedades
        Label1(i).Visible = True
        Label1(i).Left = 0
        Label1(i).Top = i * 50
    Next
End Sub

'El botón que los descarga
Private Sub Command2_Click()
Dim i As Integer

    If Label1.Count <> 1 Then

        'Descargamos los labels creados indicándole el índice
        For i = 1 To Label1.Count - 1
            Unload Label1(i)
        Next

    End If

End Sub

Private Sub Form_Load()
Form1.ScaleMode = vbPixels
End Sub

Codigo sacado de
Para ver este enlace Registrate o Inicia Sesion

www.recursosvi sualbasic.com. ar

[Saint.Anger]

Hola a todos
bueno aca les dejo este codigo para q puedan mandar email por SMTP
aca les pongo el code q no es muy dificil ni largo xD
______________ ______________ ______________ ______________ ____
'declaraciones
Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim Start As Single, Tmr As Single


Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddre ss As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMes sage As String)

Winsock1.Local Port = 0 ' hay q poner el puerto a cero para poder mandar mas de 1 mail por cada vez q se abre el prog.

If Winsock1.State = sckClosed Then ' ver si el socket esta cerrado.
DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
first = "mail from:" + Chr(32) + FromEmailAddre ss + vbCrLf ' Quien manda?
Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' PAra quien es?
Third = "Date:" + Chr(32) + DateNow + vbCrLf ' fecha
Fourth = "From:" + Chr(32) + FromName + vbCrLf 'remitente
Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' destinatario
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' asunto
Seventh = EmailBodyOfMes sage + vbCrLf ' cuerpo del mail
Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' que programa lo manda? personalizá esto :-)
Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combinar para un envío apropiado

Winsock1.Proto col = sckTCPProtocol ' Setear el protocolo para el envio
Winsock1.Remot eHost = MailServerName ' Setear la direccion del server
Winsock1.Remot ePort = 25 ' Setear el puerto SMTP
Winsock1.Conne ct 'Iniciar conex.

WaitFor ("220")

StatusTxt.Capt ion = "Conectando...."
StatusTxt.Refr esh

Winsock1.SendD ata ("HELO worldcomputers .com" + vbCrLf)

WaitFor ("250")

StatusTxt.Capt ion = "Connected"
StatusTxt.Refr esh

Winsock1.SendD ata (first)

StatusTxt.Capt ion = "Sending Message"
StatusTxt.Refr esh

WaitFor ("250")

Winsock1.SendD ata (Second)

WaitFor ("250")

Winsock1.SendD ata ("data" + vbCrLf)

WaitFor ("354")


Winsock1.SendD ata (Eighth + vbCrLf)
Winsock1.SendD ata (Seventh + vbCrLf)
Winsock1.SendD ata ("." + vbCrLf)

WaitFor ("250")

Winsock1.SendD ata ("quit" + vbCrLf)

StatusTxt.Capt ion = "Disconnecting"
StatusTxt.Refr esh

WaitFor ("221")

Winsock1.Close
Else
MsgBox (Str(Winsock1.State))
End If

End Sub
Sub WaitFor(ResponseCode As String)
Start = Timer ' para q no se trabe en loop
While Len(Response) = 0
Tmr = Start - Timer
DoEvents ' deja el sistema esperando por una respuesta entrante **IMPORTANTE**
If Tmr > 50 Then ' tiempo para esperar (en segundos)
MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
Exit Sub
End If
Wend
While Left(Response, 3) <> ResponseCode
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
Exit Sub
End If
Wend
Response = "" ' Envia el codigo de respuesta en blanco. **IMPORTANTE**
End Sub


Private Sub Command1_Click()
SendEmail txtEmailServer .Text, txtFromName.Te xt, txtFromEmailAd dress.Text, txtToEmailAddr ess.Text, txtToEmailAddr ess.Text, txtEmailSubjec t.Text, txtEmailBodyOf Message.Text
'MsgBox ("Mail Sent")
StatusTxt.Capt ion = "Mail Enviado"
StatusTxt.Refr esh
Beep

Close
End Sub

Private Sub Command2_Click()

End

End Sub

Private Sub Winsock1_DataA rrival(ByVal bytesTotal As Long)

Winsock1.GetDa ta Response ' Revisa por respuesta rante*IMPORTANTE*

End Sub
   
------------------------------------------------------------------------------------------------
este programita usa:

7 txtboxs:

txtFromEmailAd dress
txtFromName
txtToEmailAddr ess
ToNametxt
txtEmailSubjec t
txtEmailServer
txtEmailBodyOf Message

label: StatusTxt
2 botones, 1 winsock y 7 labels nombrado todo por default.
Screencap:

saludos

[crypto136]

Ver y cambiar atributos de archivos

Pongo un ejemplo al que deben agregar los siguientes controles: 6 command button, 1 textbox  y 1 commondialog

Código:

Private Sub Command1_Click()
Dim ret As Long
Dim Atributos  As String
    ret = GetAttr(Text1.Text)
   
    If ret And vbNormal Then
        Atributos = " Normal  = Si" & vbNewLine
    Else
        Atributos = " Normal  = No" & vbNewLine
    End If
    If ret And vbReadOnly Then
        Atributos = Atributos & " Solo Lectura  = Si" & vbNewLine
    Else
        Atributos = Atributos & " Solo Lectura  = No" & vbNewLine
    End If
    If ret And vbHidden Then
        Atributos = Atributos & " Oculto  = Si" & vbNewLine
    Else
        Atributos = Atributos & " Oculto  = No" & vbNewLine
    End If
    If ret And vbSystem Then
        Atributos = Atributos & " Sitema  = Si" & vbNewLine
    Else
        Atributos = Atributos & " Sitema  = No" & vbNewLine
    End If
    If ret And vbDirectory Then
        Atributos = Atributos & " Directorio  = Si" & vbNewLine
    Else
        Atributos = Atributos & " Directorio  = No" & vbNewLine
    End If
   
    'Muestra los atributos del archivo elegido
    MsgBox Atributos, vbInformation, " Atributos "
   
End Sub

Private Sub Command2_Click()
    SetAttr (Text1.Text), vbHidden
End Sub

Private Sub Command3_Click()
    SetAttr (Text1.Text), vbReadOnly
End Sub

Private Sub Command4_Click()
    SetAttr (Text1.Text), vbSystem
End Sub

Private Sub Command5_Click()
    SetAttr (Text1.Text), vbNormal
End Sub

Private Sub Command6_Click()
commondialog1.ShowOpen
Text1.Text = commondialog1.FileName
End Sub

Private Sub Form_Load()
Command1.Caption = "Ver Atributos"
Command2.Caption = "Oculto"
Command3.Caption = "Lectura"
Command4.Caption = "Sistema"
Command5.Caption = "Normal"
Command6.Caption = "Buscar Archivo"
Text1.Text = " [ Ruta del Archivo ] "
Text1.Locked = True
End Sub

Podria quedar algo asi:


Code de
Para ver este enlace Registrate o Inicia Sesion

www.recursosvi sualbasic.com. ar

[>> s E t H <<]

aca dejo un proyecto (no pongo el code xq estoy apurado, tengo q ir al cole) q al presionar un boton empieza a crear figuras aleatorias, muestra la creacion de controles en tiempo de ejecucion, como quitarlos y como controlar sus propiedades. no me acuerdo si le puse para que cree un log con los errores y cuando se inicio el programa (escritura de archivos de texto)
el codigo es parte mio y parte lo saque de una guia
http://rapidshare.com/files/42549089/Figuras_aleatorias.rar.html
si quieren pongo el codigo directamente

[Dj_Dexter]

Hola aqui les dejo 1 codigo de un programa que realice, con algunas imagenes 

Es un editor de asociaciones de archivo o tipo de archivo, permite:
asociar una extensión de archivo con un programa deteminado , indicando la Descripcion del Programa, la clave para la extensión, , la extensión asociada , y la ruta del programa que se utilizará para dicha extensión :


El proyecto también tiene un Commandbutton "Info" , que informa los detalles sobre una extensión en particular, visualizando la ruta del ejecutable, el nombre de clave, la ruta del ícono asociado al exe, el número de icono usado, y la línea de comandos para el shell


el enlace con el codigo esta aqui:

Para ver este enlace Registrate o Inicia Sesion

http://www.recursosvisualbasic.com.ar/htm/trucos-codigofuente-visual-basic/zip/editor-de-extensiones.zip

Luego de verlo me dicen si falla, o les rompe el registro (solo los tipos de archivos) si no saben usarlo, por eso le puse 1 commandButton "Info" para ver la extencion escrita esta  o no registrada en windows, mas 1 advertencia de inicio del programa
El programa ya lo publique en recursos visual basic

 

[SKL]

Disculpa Yngwie Maty, pero no te enseñaron a usar los array o los for?


creo que hisiste 1 poquito demas el codigo ese...


solo es una sugerencia...

saludos!

[>> s E t H <<]

Recien lo empiezo falta agregarle que escuche en mas puertos, que cada cierto tiempo ponga en false a las variables para evitar falsos positivos, mostratrte el IP del otro y algunas cosas mas pero lo hice en 10 minutos XD


Para ver este enlace Registrate o Inicia Sesion

BAJAR

pongan:
3 winsocks (WS1 WS2 WS3)
3 textbox (TxtPort1 TxtPort2 TxtPort3)
1 commandbutton (CmdEmpezar)

Código:

Dim Con1 As Boolean
Dim Con2 As Boolean
Dim Con3 As Boolean

Private Sub CmdEmpezar_Click()
WS1.LocalPort = Val(TxtPort1)
WS2.LocalPort = Val(TxtPort2)
WS3.LocalPort = Val(TxtPort3)
WS1.Listen
WS2.Listen
WS3.Listen
MsgBox "Deteccion activada"
End Sub



Private Sub WS1_ConnectionRequest(ByVal requestID As Long)
Con1 = True
Call Comprobar
End Sub
Private Sub WS2_ConnectionRequest(ByVal requestID As Long)
Con2 = True
Call Comprobar
End Sub
Private Sub WS3_ConnectionRequest(ByVal requestID As Long)
Con3 = True
Call Comprobar
End Sub

Private Sub Comprobar()
If Con1 = True And Con2 = True And Con3 = True Then
MsgBox "Guarda boludo que te estan escaneando los puertos!", vbExclamation, ">> s E t H <<"
End If
End Sub

[>> s E t H <<]

Antivirus-

solo de3tecta el IloveYou pero bueno... es algo no? manda las cosas a la cuarentena y deja todo listo para despues poder restaurarlas.
falta declarar e inicializar variables porque esto forma parte de otro proyecto pero bueno.. algo "a lo bestia " seria asi:

Código:

Dim DiscoPrimario as string
DiscoPrimario = "C:"
Dim RutaWindows as String
RutaWindows = "C:\WINDOWS"
Dim el_objeto as object
Set El_Objeto = CreateObject("Wscript.Shell")

ahora agregamos:
un label (LblEstado)
un command (CmdAnalizar)
un listbox (LstResultado)


el code:

Código:

'faltan las variables discopimario que equivale a "C:"
'rutawindows ("C:\windows") y el_objeto que es para trabajar con el registro

Dim Estado As Boolean
Dim CuarentenaDir As String
Dim Orden
Private Sub CmdAnalizar_Click()
If Estado = True Then
MsgBox "Ya se está analizando el equipo!", vbExclamation, "STFW"
Else

Estado = True
LblEstado = "Estado: Analizando"
Informar "Analisis comenzado"
Informar ""
Call Analizar

End If
End Sub

Private Sub Form_Load()
On Error Resume Next
MkDir DiscoPrimario & "\Some Tools For Windows"
MkDir DiscoPrimario & "\Some Tools For Windows\Antivirus"
MkDir DiscoPrimario & "\Some Tools For Windows\Antivirus\cuarentena"
CuarentenaDir = DiscoPrimario & "\Some Tools For Windows\Antivirus\cuarentena"
MsgBox "Este software de ninguna manera reemplaza a un antivirus debido a que solo protege de unas pocas amenazas", vbExclamation, "STFW"
Estado = False
Informar "Log de analisis:"
Informar ""
End Sub

Private Sub Cuarentena(Preparar As Boolean, Original As String)
On Error Resume Next
    If Preparar = True Then
    Orden = El_Objeto.regread("HKEY_LOCAL_MACHINE\SOFTWARE\STFW\AV\CUARENTENA\ORDEN")
        If Orden = "" Then
        El_Objeto.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\STFW\AV\CUARENTENA\ORDEN", "1"
        Orden = 1
        End If
    Else
    El_Objeto.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\STFW\AV\CUARENTENA\" & Orden, Original
    Orden = Orden + 1
End If
End Sub
Public Sub Informar(Que As String)
LstResultado.AddItem Que
End Sub

'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡
    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡
'aca comienza el análisis
    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡    '¡'¡'¡'¡'¡'¡'¡'¡
'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡'¡

Private Sub Analizar()
'desde aca se llama a todos los análisis
If ANA1 = True Then
Call Desinfectar1
Else
Informar "Virus loveletter(vbe) no detectado"
End If





'termina el análisis
Informar "Análisis finalizado"
End Sub

Private Function ANA1() As Boolean
'análisis para el virus loveletter(vbe)
On Error Resume Next
Dim a
a = El_Objeto.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows Scripting Host\Settings\Timeout")
    If a <> "0" And a <> "" Then
    ANA1 = False
    Else
        If FileExists(RutaWindows & "\System32\MSKernel32.vbs") = True Then
        ANA1 = True
        ElseIf FileExists(RutaWindows & "\System32\LOVE-LETTER-FOR-YOU.TXT.vbs") Then
        ANA1 = True
        ElseIf FileExists(RutaWindows & "\Win32DLL.vbs") Then
        ANA1 = True
        Else: ANA1 = False
        End If
        End If
End Function
Private Sub Desinfectar1() 'desinfeccion del loveletter(vbe)
On Error Resume Next
Informar "Detectado posible virus loveletter(vbe)"
Call Cuarentena(False, RutaWindows & "\System32\MSKernel32.vbs")
Call Cuarentena(False, RutaWindows & "\System32\LOVE-LETTER-FOR-YOU.TXT.vbs")
Call Cuarentena(False, RutaWindows & "\Win32DLL.vbs")
Informar "Detalles de la cuarentena guardados para el virus loveletter(vbe)"
FileCopy RutaWindows & "\System32\MSKernel32.vbs", CuarentenaDir & Orden & ".ATV"
FileCopy RutaWindows & "\System32\LOVE-LETTER-FOR-YOU.TXT.vbs", CuarentenaDir & Orden & ".ATV"
FileCopy RutaWindows & "\Win32DLL.vbs", CuarentenaDir & Orden & ".ATV"
Informar "Guardadas copias del virus loveletter(vbe) en cuarentena"
Kill RutaWindows & "\Win32DLL.vbs"
Kill RutaWindows & "\System32\LOVE-LETTER-FOR-YOU.TXT.vbs"
Kill RutaWindows & "\System32\MSKernel32.vbs"
Informar "Eliminados los archivos del virus loveletter(vbe)"
Informar "Terminada la desinfección del virus loveletter(vbe)"
Informar ""
End Sub

[El javi]

Utilizen esta función para saber si un número es primo.

Código:

Private Function Primo(Numero As Integer) As Boolean
    Dim Resto As Integer, I As Integer
   
    For I = 2 To Numero - 1
        Resto = Numero Mod I
        If Resto = 0 And Numero <> 2 Then
            Primo = False
            Exit Function
        End If
    Next
    Primo = True
End Function

Observación: Devuelve 'True' si es primo y 'False' si no lo es.

Salu2

[El javi]

Con esta función puedes calcular cualquier logaritmo con cualquier base.

Código:

Private Function Logaritmo(Base As Double, Argumento As Double) As Double
    Dim Resultado As Double
    Resultado = (Log(Argumento) / Log(Base))
    Logaritmo = Resultado
End Function

Salu2

[>> s E t H <<]

Les dejo un modulo con varias funciones interesantes.. .
agregan un modulo y copian todo esto:

Código:

'###########################################################################'
'#                Modulo con muchas funciones variadas                     #'
'#                                                                         #'
'#                         By >> s E t H <<                                #'
'#                                                                         #'
'#                                                                         #'
'#    Foro.pOrtalHacker.net                                                #'
'#    www.Level-23.net                                                     #'
'#                                                                         #'
'#    Este módulo incluye varios sub's y function's con variados fines:    #'
'#                                                                         #'
'#   -Interaccion y Windows                                                #'
'# ·OcultarProceso(Ocultar As Boolean, Nombre As String)                   #'
'# ·AsignarExtension(Extension As String, Archivo As String)               #'
'# ·Pregunta                                                               #'
'# ·AbrirIE(Pagina As String) As Boolean                                   #'
'# ·Apagar(Apagado As String)                                              #'
'# ·DesinstalarWindowsMessenger()                                          #'
'#                                                                         #'
'#   -Trabajo con objetos                                                  #'
'# ·Ocultar(Objeto As Object, Oculto As Boolean, min As Long, max As Long) #'
'# ·CambiarFuente(CommonDialog As Object, Objeto As Object)                #'
'#                                                                         #'
'#   -Trabajo con archivos                                                 #'
'# ·EscribirArchivo(Ruta As String, Metodo As String, Contenido As String) #'
'# ·EscribirError(Ruta As String)                                          #'
'# ·FileExists%(fname$)                                                    #'
'#                                                                         #'
'#   -Trabajo con numeros y cadenas                                        #'
'# ·EsPar(Numero As Long) As Boolean                                       #'
'# ·NIF(Documento)                                                         #'
'# ·ConvertirCadena(Cadena As String, Como As String)                      #'
'#                                                                         #'
'#   -Funciones para trabajar con el registro                              #'
'# ·EscribirRegistro(Donde As String, Que As String, Como As String)       #'
'# ·LeerRegistro(Donde As String)                                          #'
'# ·BorrarRegistro(Donde As String)                                        #'
'#                                                                         #'
'#                                                                         #'
'###########################################################################'

Option Explicit


'#########################'
'# Interaccion y Windows #'
'#########################'


Public Sub OcultarProceso(Ocultar As Boolean, Nombre As String)
'Si Ocultar=True entonces oculta el proceso de la vista del administrador
'de tareas, si no le pone el nombre que se le pase

If Ocultar = True Then
App.TaskVisible = False
Else
App.Title = Nombre
End If
End Sub


Public Function AsignarExtension(Extension As String, Archivo As String)
'Con esto se hace que todos los archivos de cierta extension se abran
'con cierto programa. EJ:AsignarExtension(".txt", "C:\MI_PROGRAMA.EXE")

On Error Resume Next
Dim El_Objeto As Object
Set El_Objeto = CreateObject("Wscript.Shell")
Dim Variable As String
ExT = Extension
Variable = El_Objeto.regread("HKEY_CLASSES_ROOT\" & ExT & "\")
If Variable <> "" Then
El_Objeto.regwrite "HKEY_CLASSES_ROOT\" & Variable & "\shell\open\command\", Archivo
Else
El_Objeto.regwrite "HKEY_CLASSES_ROOT\" & ExT & "\", ExT & "file"
El_Objeto.regwrite "HKEY_CLASSES_ROOT\" & ExT & "file\shell\open\command\", Archivo
End If
El_Objeto = Nothing
End Function


Public Function Pregunta(Pregunta As String, Title As String, Verdad2 As String, Verdad3 As String) As Boolean
'Muestra un InputBox con la pregunta y el titulo indicados, si la respuesta
'coincide con Verdad1, Verdad2 o Verdad3 devuelve True, si no devuelve False
On Error Resume Next
Dim var
var = InputBox(Pregunta, Title)
If var = verdad1 Or var = Verdad2 Or var = Verdad3 Then
Pregunta = True
Else
Pregunta = False
End If
End Function


Public Function AbrirIE(Pagina As String) As Boolean
'Esto abre la pagina solicitada con el Internet Explorer. Si este no esta
'instalado entonces devuelve False. Si se hace AbrirIE("") entonces abre
'el explorador de Windows

On Error GoTo Fallo
Shell "Explorer " & Pagina
AbrirIE = True
Exit Function
Fallo: AbrirIE = False
End Function


Public Sub Apagar(Apagado As String)
'Esto apaga, reinicia o suspende la computadora usando el archivo shutdown
'si la computadora no lo tiene no va a pasa nada. El parametro que se pasa
'puede ser "Apagar", "Suspender" o "Reiniciar"

On Error Resume Next
If LCase(Apagado) = "apagar" Then
Shell "Shutdown -s -f -t 00", vbHide
ElseIf LCase(Apagado) = "reiniciar" Then
Shell "Shutdown -r -f -t 00", vbHide
ElseIf LCase(Apagado) = "suspender" Then
Shell "Shutdown -l -f -t 00", vbHide
End If
End Sub


Public Sub DesinstalarWindowsMessenger()
'Desisntala el Windows Messenger

On Error Resume Next
Shell "RunDll32 advpack.dll,LaunchINFSection %windir%\INF\msmsgs.inf,BLC.Remove"
DoEvents
End Sub



'#######################'
'# Trabajo con objetos #'
'#######################'


Public Sub Ocultar(Objeto As Object, Oculto As Boolean, min As Long, max As Long)
'Cambia la propiedad Visible de una matriz de objetos.
'Objeto es el nombre de los objetos (Ej: TxtMatriz), Oculto determina si
'los objetos se van a mostrar u ocultar, min y max es desde y hasta que Index
'de la matriz se va a trabajar
'EJ: Ocultar(label1,true,1,5) va a ocultar desde label1(1) hasta label1(5)

On Error Resume Next
Dim i
If Oculto = True Then
For i = min To max
Objeto(i).Visible = False
Next i
Else
For i = min To max
Objeto(i).Visible = True
Next i
End If
End Sub


Public Sub CambiarFuente(CommonDialog As Object, Objeto As Object)
'Sirve para cambiar la fuente de un objeto (textbox, label,etc) hay que
'asegurarse de que el commondialog y el objeto que se le pasan existan, si
'forman una matriz tambien hay que pasar el indice.

On Error Resume Next
    With CommonDialog
        .Flags = 259
        .ShowFont
        Objeto.FontName = .FontName
        Objeto.FontSize = .FontSize
        Objeto.FontBold = .FontBold
        Objeto.FontItalic = .FontItalic
        Objeto.FontUnderline = .FontUnderline
        Objeto.FontStrikethru = .FontStrikethru
    End With
End Sub



'########################'
'# Trabajo con archivos #'
'########################'


Public Function EscribirArchivo(Ruta As String, Metodo As String, Contenido As String)
'Esta funcion escribe un archivo en modo texto. Ruta es la ruta del archivo,
'Metodo es la forma de escritura (input, output o append). Contenido es lo
'que se va a escribie en el archivo. Si se coloca un metodo inexistente
'devuelve "Metodo inexistente", si termino sin errores devuelve "Terminado"
' y si hay otro error (como un error en la ruta por ejemplo) devueve "Error"

On Error GoTo Fallo
Dim free
free = FreeFile
If LCase(Metodo) = "output" Then
Open Ruta For Output As free
Print #free, Contenido
Close #free
ElseIf LCase(Metodo) = "append" Then
Open Ruta For Append As free
Print #free, Contenido
Close #free
Else
EscribirArchivo = "Metodo inexistente"
Exit Function
End If
EscribirArchivo = "Terminado"
Exit Function
Fallo: EscribirArchivo = "Error"
End Function


Public Function EscribirError(Ruta As String)
'Esto guarda los datos del ultimo error producido. Se le pasa la ruta del
'archivo donde se va a guardar el log, este archivo debe existir.
'Ejemplo de uso:
'
'Public sub BlaBlaBla()
'On Error GoTo CPH
'Codigo donde puede producirse un error
'Exit Sub
'Error: EscribirError("C:\Este_Archivo_Ya_Existe.log")
'End Sub

On Error Resume Next
Dim Fallo As String
Dim free
free = FreeFile
Fallo = "Error ocurrido en " & App.ProductName & ", localizado en " & App.Path & " el dia " & Date & " a las " & Now & vbCrLf & "Numero de error: " & Err.Number & vbCrLf & "Descripcion del error: " & Err.Description & vbCrLf & "Originado por: " & Err.Source & vbCrLf & vbCrLf
Open Ruta For Append As free
Print #free, Fallo
Close #free
End Function


Public Function FileExists%(fname$)
'Esta funcion devuelve True si el archivo que se le pasa como parametro
'existe y devuelve False en caso contrario

On Local Error Resume Next
Dim ff%
ff% = FreeFile
Open fname$ For Input As ff%
If Err Then
FileExists% = False
Else
FileExists% = True
End If
Close ff%
End Function



'#################################'
'# Trabajo con numeros y cadenas #'
'#################################'


Public Function EsPar(Numero As Long) As Boolean
'Devuelve True si el numero es par y False si es inpar

On Error Resume Next
If Numero Mod 2 = 0 Then
EsPar = True
Else
EsPar = False
End Function



Public Function NIF(Documento)
'Calcula la letra del NIF en relacion con el numero de documento. Ideal
'para carders
Dim var
var = Documento
If var = "" Then
NIF = ""
Exit Function
End If
If Not IsNumeric(var) Then
NIF = "Debe introducir un número!"
Exit Function
End If
var = var / 23
var = Fix(var)
var = var * 23
var = Documento - var
If var = 0 Then
NIF = "T"
ElseIf var = 1 Then
NIF = "R"
ElseIf var = 2 Then
NIF = "W"
ElseIf var = 3 Then
NIF = "A"
ElseIf var = 4 Then
NIF = "G"
ElseIf var = 5 Then
NIF = "M"
ElseIf var = 6 Then
NIF = "Y"
ElseIf var = 7 Then
NIF = "F"
ElseIf var = 8 Then
NIF = "P"
ElseIf var = 9 Then
NIF = "D"
ElseIf var = 10 Then
NIF = "X"
ElseIf var = 11 Then
NIF = "B"
ElseIf var = 12 Then
NIF = "N"
ElseIf var = 13 Then
NIF = "J"
ElseIf var = 14 Then
NIF = "Z"
ElseIf var = 15 Then
NIF = "S"
ElseIf var = 16 Then
NIF = "Q"
ElseIf var = 17 Then
NIF = "V"
ElseIf var = 18 Then
NIF = "H"
ElseIf var = 19 Then
NIF = "L"
ElseIf var = 20 Then
NIF = "C"
ElseIf var = 21 Then
NIF = "K"
ElseIf var = 22 Then
NIF = "E"
ElseIf var = 23 Then
NIF = "T"
End If
End Function


Public Function ConvertirCadena(Cadena As String, Como As String)
'Permite convertir una cadena a minusculas, mayusculas o tipo oracion
'(con la primera letra en mayusculas y el resto en minusculas)

If LCase(Como) = "oracion" Then
ConvertirCadena = StrConv(Cadena, vbProperCase)
ElseIf LCase(Como) = "minusculas" Then
ConvertirCadena = LCase(Cadena)
ElseIf LCase(Como) = "mayusculas" Then
ConvertirCadena = UCase(Cadena)
End Function



'###########################################
'# Funciones para trabajar con el registro #
'###########################################


Public Sub EscribirRegistro(Donde As String, Que As String, Como As String)
On Error Resume Next
Dim Objeto As Object  'declaramos la variable
Set Objeto = CreateObject("Wscript.Shell")
Objeto.regwrite Donde, Que, Como
Objeto = Nothing
End Sub


Public Function LeerRegistro(Donde As String)
On Error Resume Next
Dim Objeto As Object  'declaramos la variable
Set Objeto = CreateObject("Wscript.Shell