Trucos para Visual Basic

[MaN!FesT]

Eliminar los bordes en tiempo de ejecución

Colocar un Command1:

Código:

rivate Declare Function CreateRoundRectRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long, _
ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hwnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long


Private Sub Command1_Click()
Dim lRet As Long
Dim l As Long
Dim Width As Long
Dim Height As Long

Width = Me.ScaleWidth / Screen.TwipsPerPixelX
Height = Me.ScaleHeight / Screen.TwipsPerPixelY

lRet = CreateRoundRectRgn(10, 35, Width, Height + 900, 0, 0)

l = SetWindowRgn(Me.hwnd, lRet, True)
End Sub

Simple pero Efectivo.

[MaN!FesT]

Obtener las cordenadas de el mouse

Colocar un Timer:

Código:

'Estructura de mcordenadas para el api GetCursorPos
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim Pt As POINTAPI

Private Sub Form_Load()
'Ponemos el Timer en 100
Timer1.Interval = 100
Me.FontSize = 13
End Sub

Private Sub Timer1_Timer()
'Recuperamos la posicion del cursor
GetCursorPos Pt

Me.CurrentX = 0
Me.CurrentY = 0

'borramos la pantalla del formulario
Me.Cls

Me.Print "Poisicion::"
'Imprimimos las cordenadas
Me.Print "X:" + Str$(Pt.X) + vbCrLf + "Y:" + Str$(Pt.Y)

End Sub

[MaN!FesT]

Obtener la velocidad de nuestro C.P.U

En un Form:

Código:

Private Sub Form_Load()
 
  'variable de retorno para el valor de la velocidad
  Dim ret As Long
  'variable para el objeto Wsh
  Dim Reg As Object
 
  Set Reg = CreateObject("WScript.Shell")
  'Leemos el valor
  ret = CLng(Reg.regread("HKEY_LOCAL_MACHINE\HARDWARE\DESCRIPTION\System\CentralProcessor\0\~MHz"))
  'Eliminamos la variable
  Set Reg = Nothing
 
  'Mostramos el valor
  MsgBox "La velocidad del Cpu es: " & CStr(ret) & " MHz", vbInformation, ""
End Sub

[MaN!FesT]

Lanzar procesos de forma invisible mediante Wmi

Colocar 2 Command Button, Command1 y Command2

Código:

Dim ServieceSet As Object
Private Sub EjecutatPrceso(path, Ver As Integer)
Dim error As Integer
strComputer = "."

Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

Set objStartup = objWMIService.Get("Win32_ProcessStartup")

Set objConfig = objStartup.SpawnInstance_
'Esto determina mediante la variable Ver si es visible o no el proceso
objConfig.ShowWindow = Ver
Set objProcess = GetObject("winmgmts:root\cimv2:Win32_Process")

'Si objProcess.Create devulve 0 quiere decir que no hubo error
'En el primer parámetro le pasamos el path del programa a ejecutar
error = objProcess.Create(path, Null, objConfig, intProcessID)

End Sub

Private Sub Command1_Click()
'Llamamos a EjecutarProceso pasandole el path y en el
'segundo parámetro si se lanza en forma visible (1) o no visible (12)
EjecutatPrceso "c:\windows\notepad.exe", 1
End Sub

Private Sub Command2_Click()
EjecutatPrceso "c:\windows\notepad.exe", 12
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Eliminamos las variables de objeto
Set objStartup = Nothing
Set objWMIService = Nothing
Set objConfig = Nothing
Set objProcess = Nothing

End Sub

Acá se lanza el Bloc de notas, para cambiar el programa o proceso especificar un path diferente en la llamada al procedimiento EjecutarProces o, que también tiene un parámetro de tipo numerico que especifica el si es visible (1) o invisible (12)

[MaN!FesT]

Ver si un puerto está en uso

Colocar un Command1 y un Text1 y especificar en el TextBox el número de puerto que se quiere consultar

 En el Formulario:

Código:

Private Function Puerto_En_Uso(ByVal Puerto As Integer) As Boolean


On Error Resume Next
'Variable de retorno y de objeto de Socket
Dim Win_Socket As Object, ret As Boolean


'creamos un objeto para utilizar el winsock
Set Win_Socket = CreateObject("MSWinsock.Winsock.1")
   
If Err.Number > 0 Then
   Err.Raise 30000, , "No se pudo crear el Objeto. Verifique que tiene instalada la referencia"
Exit Function
End If
   
'Limpiamos el error
Err.Clear

'Establecemos el puerto
Win_Socket.LocalPort = Puerto

'Ponemos a la escucha
Win_Socket.Listen


ret = Err.Number = 10048

'Cerramos el Socket
Win_Socket.Close
'Eliminamos la variable
Set Win_Socket = Nothing

'Devolvemos el valor True/False si el puerto está en uso
Puerto_En_Uso = ret

End Function


Private Sub Command1_Click()
MsgBox "El puerto está en uso: ?? " & Puerto_En_Uso(CLng(Text1))
End Sub

[MaN!FesT]

Truco para ocultar un proceso del administrador de tareas

Colocar 2 CommandButton. El Command1 oculta el proceso, el Command2 lo reestablece.

En un Modulo:

Código:

PCSTR
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

Type LV_TEXT
    sItemText As String * 80
End Type


Public Function Procesos(ByVal hWnd2 As Long, lParam As String) As Boolean
  Dim Nombre As String * 255, nombreClase As String * 255
  Dim Nombre2 As String, nombreClase2 As String
  Dim X As Long, Y As Long
  X = GetWindowText(hWnd2, Nombre, 255)
  Y = GetClassName(hWnd2, nombreClase, 255)
  'Buffers
  Nombre = Left$(Nombre, X)
  nombreClase = Left$(nombreClase, Y)
 
  Nombre2 = Trim$(Nombre)
  nombreClase2 = Trim$(nombreClase)
 
  'SysListView32 es el nombre de clase del LV del Administrador de T
  If nombreClase2 = "SysListView32" And Nombre2 = "Procesos" Then
     OcultarItems (hWnd2)
     Exit Function
  End If
 
  If Nombre2 = "" And nombreClase2 = "" Then
     Procesos = False
  Else
     Procesos = True
  End If
End Function

'A esta función se le pasa el Handle del ListView del Administrador de tareas _
que es obtenido desde la función " Procesos "
Private Function OcultarItems(ByVal hListView As Long) ' As Variant
   Dim pid As Long, tid As Long
   Dim hProceso As Long, nElem As Long, lEscribiendo As Long, i As Long
   Dim DirMemComp As Long, dwTam As Long
   Dim DirMemComp2 As Long
   Dim sLVItems() As String
   Dim li As LV_ITEM
   Dim lt As LV_TEXT
   If hListView = 0 Then Exit Function
   tid = GetWindowThreadProcessId(hListView, pid)
   
   'Obtiene el número de items del ListView
   nElem = SendMessage(hListView, LVM_GETTITEMCOUNT, 0, 0&)
   
   If nElem = 0 Then Exit Function
   
   ReDim sLVItems(nElem - 1)
   
   li.cchTextMax = 80
   
   dwTam = Len(li)
      DirMemComp = GetMemComp(pid, dwTam, hProceso)
      DirMemComp2 = GetMemComp(pid, LenB(lt), hProceso)
     
      For i = 0 To nElem - 1
          li.lpszText = DirMemComp2
          li.cchTextMax = 80
          li.iItem = i
          li.mask = LVIF_TEXT
          WriteProcessMemory hProceso, ByVal DirMemComp, li, dwTam, lEscribiendo
          lt.sItemText = Space(80)
          WriteProcessMemory hProceso, ByVal DirMemComp2, lt, LenB(lt), lEscribiendo
         
          'Recupera un item del LV
          Call SendMessage(hListView, LVM_GETITEMW, 0, ByVal DirMemComp)
          Call ReadProcessMemory(hProceso, ByVal DirMemComp2, lt, LenB(lt), lEscribiendo)
         
          'Acá verifica si lt.sItemText es el nombre del exe. Si está Lo elimina
         
          If TrimNull(StrConv(lt.sItemText, vbFromUnicode)) = App.EXEName & ".exe" Then
           Call SendMessage(hListView, LVM_DELETEITEM, i, 0)
           Exit Function
          End If
      Next i
     
      CloseMemComp hProceso, DirMemComp, dwTam
      CloseMemComp hProceso, DirMemComp2, LenB(lt)

End Function

Private Function GetMemComp(ByVal pid As Long, ByVal memTam As Long, hProceso As Long) As Long
   
    hProceso = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ _
                           Or PROCESS_VM_WRITE, False, pid)
    GetMemComp = VirtualAllocEx(ByVal hProceso, ByVal 0&, ByVal memTam, _
                           MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
End Function

Private Sub CloseMemComp(ByVal hProceso As Long, ByVal DirMem As Long, ByVal memTam As Long)
   
   Call VirtualFreeEx(hProceso, ByVal DirMem, memTam, MEM_RELEASE)
   CloseHandle hProceso

End Sub

'Elimina los nulos
Private Function TrimNull(sInput As String) As String
   Dim pos As Integer
   pos = InStr(sInput, Chr$(0))
   If pos Then
      TrimNull = Left$(sInput, pos - 1)
      Exit Function
   End If
   TrimNull = sInput
End Function

'Temporizador que cheaquea constantemente si el Administrador de tareas está ejecutandose
Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Dim Handle As Long
'Se obtiene el HWND del administrador de tareas
Handle = FindWindow(vbNullString, "Administrador de tareas de Windows")

'Si el administrador está visible el handle es distinto de 0 _
y se llama a EnumChildWindows pasandole el Handle del AT y la dirección _
de la función Procesos. EnumChildWindows obtiene el handle del ListView
If Handle <> 0 Then
   EnumChildWindows Handle, AddressOf Procesos, 1
End If
End Sub

'Oculta y visualiza el item del proceso
Public Sub Ocultar(ByVal hwnd As Long)
    App.TaskVisible = False
    SetTimer hwnd, 0, 20, AddressOf TimerProc
End Sub

Public Sub Mostrar(ByVal hwnd As Long)
    App.TaskVisible = True
    KillTimer hwnd, 0
End Sub

En un Formulario:

Código:

'Oculta el proceso del Administrador de Tareas
Private Sub Command1_Click()
Ocultar Me.hwnd
End Sub

'Visualiza el proceso
Private Sub Command2_Click()
Mostrar Me.hwnd
End Sub

MMMMMMMMMMMM

[MaN!FesT]

Apagar y Encender el monitor

No me acuerdo donde vi este ejemplo permite apagar el monitor durante unos segundos y luego reestablecerlo usando el api SendMessage. El valor 2 en el último parámetro lo apaga, el valor -1 lo enciende.

Código:

Option Explicit

'Api SendMessage
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

'Constantes para SendMessage
Const WM_SYSCOMMAND = &H112&
Const SC_MONITORPOWER = &HF170&

Private Sub Command1_Click()
   
   
    If MsgBox("Pagar el monitor por 15 segundos ?", vbQuestion) = vbNo Then Exit Sub
       
        Timer1.Enabled = True
        'Apaga el monitor
        SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 2&
   
End Sub

Private Sub Form_Load()
    '15 segundos de lapso
    Timer1.Interval = 15000
    Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
   
    Timer1.Enabled = False
    'Prende el monitor
    SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1&
End Sub

[MaN!FesT]

Cambiar el papel tapiz en NT y XP

Colocar 3 Command: Command1 (selecciona el archivo de imagen ), Command2 ( cambia el fondo) y Command3 lo reestablece. También un control Commondialog (CommonDialog1)

Código:

Option Explicit
'Api SystemParametersInfo
Private Declare Function SystemParametersInfo Lib "user32" _
        Alias "SystemParametersInfoA" (ByVal uAction As _
        Long, ByVal uParam As Long, ByVal lpvParam As Any, _
        ByVal fuWinIni As Long) As Long

'Constantes
Const SPIF_SENDWININICHANGE = &H2
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1

'Seleccionamos una imagen para el papel tapiz
Private Sub Command1_Click()
  With CommonDialog1
     
      .Filter = ("Archivos BMP (*.BMP)|*.BMP")
      .ShowOpen
   
  If .FileName <> "" Then
    Me.Picture = LoadPicture(.FileName)
  End If
End With
End Sub

Private Sub Command2_Click()
  If CommonDialog1.FileName = "" Then Exit Sub
     'Ejecutamos el Api pasandole la ruta del bitmap y las constantes
     SystemParametersInfo SPI_SETDESKWALLPAPER, 0, _
    CommonDialog1.FileName, SPIF_UPDATEINIFILE Or _
    SPIF_SENDWININICHANGE
 
End Sub

Private Sub Command3_Click()
  'Para sacar el papel Tapiz se le envía una cadena vacía en lpvParam
  SystemParametersInfo SPI_SETDESKWALLPAPER, 0, "", _
  SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE
End Sub

Private Sub Form_Load()
Command1.Caption = " Seleccionar Bitmap "
Command2.Caption = " Establecer papel Tapiz "
Command3.Caption = " Eliminar papel Tapiz "

End Sub

[MaN!FesT]

Ocultar y reestablecer el TaskBar de windows

Colocar un command1 y un Command2:

Código:

Option Explicit

'Declaración de las constantes para pasarle a SetWindowPos
Private Const SWP_HIDEWINDOW As Long = &H80&
Private Const SWP_SHOWWINDOW As Long = &H40&

'Api: busca el Handle del taskBar
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'SetWindowPos lo Oculta y lo reestablece
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
    ByVal cy As Long, ByVal wFlags As Long) As Long

Private Sub Command1_Click()
    'Variable de retorno para el HWND
    Dim ret As Long

    'Se le pasa el nombre de clase a FindWindow
    ret = FindWindow("Shell_TrayWnd", vbNullString)
    Call SetWindowPos(ret, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub

Private Sub Command2_Click()
    'Variable de retorno para el HWND
    Dim ret As Long

    'Se le pasa el nombre de clase a FindWindow para obtener el handle
    ret = FindWindow("Shell_TrayWnd", vbNullString)
    Call SetWindowPos(ret, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

Private Sub Form_Load()
   
    Command1.Caption = " Ocultar barra de tarea "
    Command2.Caption = " Mostrar barra de tarea "
End Sub

[MaN!FesT]

Deshabilitar y habilitar la barra de tareas

Colocar un Command1 y un Command2

Código:

Option Explicit

'Función FindWindow para obtener el HWND del Taskbar
Private Declare Function FindWindow Lib _
    "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

'Función EnableWindow para deshabilitar y habilitar una ventana
Private Declare Function EnableWindow Lib _
    "user32" (ByVal hwnd As Long, _
    ByVal fEnable As Long) As Long

'El 0 deshabilita la barra y el 1 la restaura
Private Sub TaskBar(ByVal Index As Long)
    Dim Accion    As Long, ret   As Long

    Select Case Index
        Case 0: Accion = 0
        Case 1: Accion = 1
    End Select
   
    'Shell_TrayWnd es el nombre de clase
    ret = FindWindow("Shell_TrayWnd", vbNullString)
    'Le pasamos el HWMD del TaskBar y el valor para activar o deshabilitar
    EnableWindow ret, Accion
End Sub

'Deshabilita
Private Sub Command1_Click()
    TaskBar 0
End Sub

'Activa
Private Sub Command2_Click()
    TaskBar 1
End Sub

Private Sub Form_Load()
Command1.Caption = " Deshabilitar "
Command2.Caption = " Habilitar "
End Sub

'Habilita
Private Sub Form_Unload(Cancel As Integer)
    TaskBar 1
End Sub

....

[MaN!FesT]

Minimizar todas las ventanass

POner un command1

Código:

'Declaración del Api keybd_event
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
                                    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'Constantes
Const KEYEVENTF_KEYUP = &H2
Const VK_LWIN = &H5B


Private Sub Command1_Click()

Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(77, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)

End Sub

Private Sub Form_Load()
Command1.Caption = " Minimizar todas las ventanas abiertas "
End Sub

MMM un timer con un lapso de "1" mmmm jaja

[MaN!FesT]

Capturar la pantalla entera o la ventana activa

Añadir dos botones y escribir el siguiente código:

Código:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte,
ByVal bScan As Byte, ByVal dwFlags As Long,
ByVal dwExtraInfo As Long)

Private Sub Command1_Click()
'Captura la ventana activa
keybd_event 44, 0, 0&, 0&
End Sub

Private Sub Command2_Click()
'Captura toda la pantalla
keybd_event 44, 1, 0&, 0&
End Sub

[MaN!FesT]

Apagar el equipo, reiniciar Windows, reiniciar el Sistema

Añadir tres botones a un formulario y escribir lo siguiente en el código del formulario:

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]

Ejecutar una conexión vía red telefonica

Código:

Private Sub Form_Load()
Dim AbrirConexion As Long
AbrirConexion = Shell("rundll32.exe rnaui.dll,RnaDial " &
"ConexiónInternet", 1)
SendKeys "{ENTER}"
End Sub

[MaN!FesT]

Ocultar la barra de tareas en Windows 95 y/o Windows NT

En un módulo:

Código:

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName_
 As String, ByVal lpWindowName As String) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter
As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long,_
ByVal wFlags As Long) As Long
Global Ventana As Long
Global Const Muestra = &H40
Global Const Oculta = &H80

Agregar un command1, y command2:

Código:

'Oculta la barra de tareas
Private Sub Command1_Click()
    Ventana = FindWindow("Shell_traywnd", "")
    Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Oculta)
End Sub

'Muestra la barra de tareas
Private Sub Command2_Click()
    Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Muestra)
End Sub