Categoría: Visual Basic

Enviado por Yuri

Código fuente para averiguar el nombre de red de una PC, desde Visual Basic y utilizando API.

' Esta funcion permite saber el nombre de la PC en donde estamos ejecutando una
'aplicacion. Fue expuesta en la lista de noticas de Visual Basic.

Private Declare Function GetComputerName Lib "kernel32" Alias
"GetComputerNameA" (ByVal LpBuffer As String, nSize As Long) As Long

Function PCName() As String
Dim sBuffer As String
Dim lSize As Long
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetComputerName(sBuffer, lSize)
If lSize > 1 Then
PCName = Left$(sBuffer, lSize)
If Asc(Right$(PCName, 1)) = 0 Then
PCName = Left$(PCName, Len(PCName) - 1)
End If
Else
PCName = "Desconocido"
End If
End Function

'Llamando la funcion PCName, esta devuelve el nombre de la PC.

Enviado por Yuri

Código fuente para leer y escribir en archivos de configuración local (*.ini).

'Esta funcion la encontre cuando necesitaba validar ciertos parametros de 
'manera externa y antes de ejecutar mi sistema. Ahora cada uno le puede 'dar el uso que mas le convenga. No recuerdo exactamente 
'donde la encontre pero aclaro que fue asi, no la hago de mi propiedad.

'En un modulo Bas ponemos el siguiente codigo


'Declaración de las funciones API's para escribir y leer archivos INI.
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

'Función para leer los datos en archivos INI:
Public Function INI_Read(Filename As String, Key_Value As String, Key_Name As String, Optional ByVal Default As String) As String
'On Error GoTo ErrOut
Dim Size As Integer
Dim value As String

'Comprobamos que el archivo existe.
If Not SYS_FileExists(Filename) Then Err.Raise 53

'Se define el tamaño maximo de caracteres
'que podra tener la variable Value
value = Space(200)
'Se utiliza la función para obtener
'el valor de la clave
Size = GetPrivateProfileString(Key_Value, Key_Name, "", value, Len(value), Filename)
'Si el tamaño es mayor a -1 entonces
'se ha encontrado el valor de la clave
If Size > 0 Then
value = Left$(value, Size)
Else
INI_Read = Default
End If

'Devolver el dato...
'Verificar que el dato no sea nulo,
'en caso de ser nulo de se devuelve
'el valor por defecto (Default)
If Len(value) Then
INI_Read = value
Else
INI_Read = Default
End If
Exit Function

ErrOut:
INI_Read = Default
End Function

'Función para escrbir datos en archivos INI.
Public Function INI_Write(Filename As String, Key_Value As String, Key_Name As String, value As String) As Long
'On Error GoTo ErrOut
Dim Size As Integer

'Escribimos el valor de la clave en el INI
Size = WritePrivateProfileString(Key_Value, Key_Name, value, Filename)
INI_Write = 1
Exit Function

ErrOut:
INI_Write = 0
End Function


'********************* INVOCACION *****************
'Si nuestro archivo Ini ( Config.Ini ) es asi
[General]
Ruta="C:Sistema"
BaseDatos="Clientes.Mdb"

'En nuestro programa hacemos asi:
cRutaActual = INI_Read("Config.ini", "General", "Ruta", "C:")
cBaseDatos = INI_Read( "Config.Ini", "General", "BaseDatos", "Data.Mdb" )

'El ultimo parametro de invocacion son los valores default en caso no se 
'encuentre nada en el archivo Ini, como medida de consistencia
'

Cómo matar un proceso si se conoce el nombre del archivo EXE. Un método más seguro para cerrar aplicaciones en vez de utilizar el título de su ventana principal.

Este ejemplo muestra cómo cerrar un proceso con la API de Windows, y utilizando el nombre del EXE a cerrar. Código: Crear un proyecto nuevo de Visual Basic y en el Form1 colocar un TextBox y CommandButton, luego pegar el siguiente código.

Option Explicit

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" _
(ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

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

Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Const PROCESS_TERMINATE = &H1;
Private Const PROCESS_CREATE_THREAD = &H2;
Private Const PROCESS_VM_OPERATION = &H8;
Private Const PROCESS_VM_READ = &H10;
Private Const PROCESS_VM_WRITE = &H20;
Private Const PROCESS_DUP_HANDLE = &H40;
Private Const PROCESS_CREATE_PROCESS = &H80;
Private Const PROCESS_SET_QUOTA = &H100;
Private Const PROCESS_SET_INFORMATION = &H200;
Private Const PROCESS_QUERY_INFORMATION = &H400;
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000;
Private Const SYNCHRONIZE = &H100000;
Private Const PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF;

Private Sub Command1_Click()
Dim hSnapShot As Long, uProceso As PROCESSENTRY32
Dim res As Long, dwIDProceso As Long
Dim hProceso As Long, Resultado As Long

dwIDProceso = -1
hSnapShot = CreateToolhelpSnapshot(2&, 0&)
If hSnapShot <> 0 Then
    uProceso.dwSize = Len(uProceso)
    res = ProcessFirst(hSnapShot, uProceso)
    Do While res
        If Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1) = LCase(Text1.Text) Then
            'Si se encuentra el proceso, se guarda su ID.
            dwIDProceso = uProceso.th32ProcessID
            Exit Do
        End If
        res = ProcessNext(hSnapShot, uProceso)
    Loop
    Call CloseHandle(hSnapShot)
End If

'Si el proceso no está abierto...
If dwIDProceso = -1 Then
    MsgBox "El proceso """ & LCase(Text1.Text) & """ no está abierto"
Else
    hProceso = OpenProcess(PROCESS_TERMINATE, True, dwIDProceso)
    Resultado = TerminateProcess(hProceso, 99)
    CloseHandle hProceso
    'Si se cerró correctamente...
    If Resultado <> 0 Then
        MsgBox "El proceso """ & LCase(Text1.Text) & """ ha sido cerrado correctamente."
    Else
        MsgBox "El proceso """ & LCase(Text1.Text) & """ no pudo ser cerrado."
    End If
End If
End Sub

Ejecutar la aplicación y escribir en el cuadro de texto el nombre del EXE a cerrar y luego pulsar el botón.

Un truco para que el contenido de una ficha se muestre apenas se pulse sobre la misma, como los cuadros de diálogo de Windows.

Normalmente en un cuadro de diálogo con fichas (como Propiedades de Pantalla), al hacer clic en alguna de ellas el contenido de la misma se muestra inmediatamente, cosa que no sucede con el control TabStrip de Visual Basic, en el cual la información de la ficha se muestra después que hemos soltado el botón izquierdo del mouse. En este truco vamos a subsanar ese error de diseño utilizando la llamada a la API mouse_event en el evento MouseDown del TabStrip para forzar al mismo a ejecutar el evento Click() antes de soltar el botón izquierdo del mouse.

1. Debemos de crear un TabStrip con la cantidad de fichas que deseemos, y crear una matriz de Frames llamada fraFichas, la cantidad de Frames debe ser igual a la cantidad de pestañas del TabStrip.
2. Pegar este código en el formulario:

   
   Option Explicit
   
   Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, _
       ByVal dx As Long, ByVal dy As Long, _
       ByVal cButtons As Long, ByVal dwExtraInfo As Long)
   
   Private Const MOUSEEVENTF_LEFTUP = &H4;
   
   Private Sub TabStrip1_Click()
   Dim i As Long
   For i = 0 To TabStrip1.Tabs.Count - 1
       fraFichas(i).Visible = False
   Next i
   fraFichas(TabStrip1.SelectedItem.Index - 1).Visible = True
   End Sub
   
   Private Sub TabStrip1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   mouse_event MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, 0&
   End Sub
   

3. Haga clic en el botón “Ejecutar” para probar la aplicación.

Una clase para crear cronómetros ascendentes y cuentas regresivas en tiempo real que supera las limitaciones del control Timer.

En algunas aplicaciones es necesario controlar el tiempo de una determinada tarea, un procedimiento, y de forma más elaborada en proyectos para control de cybercafés. Básicamente para crear cronómetros se usa el control Timer; sin embargo éste tiene sus limitaciones, como la falta de precisión entre eventos Timer y el contador se detiene al hacer CTRL+ALT+SUPR en Windows 9x, lo que hace que éste control no sea el más adecuado para crear cronómetros en tiempo real. Por ello es recomendable utilizar la API de Windows y esta clase simplifica el uso de la función GetTickCount para la creación de cronómetros de cuenta regresiva y normales.

Código fuente de la clase clsCronómetro:

Option Explicit

'Declaración de la API
Private Declare Function GetTickCount Lib "kernel32" () As Long

'Variables para el control del tiempo
Dim TiempoFinal As Long
Dim TiempoParado As Long
Dim CuandoParó As Long

'Establece una cuenta regresiva, donde
'el argumento "Segundos" es la cantidad de
'segundos que se quiere fijar.
Public Sub EstablecerTiempo(Segundos As Long)
TiempoFinal = QuitarDecimales(GetTickCount / 1000) + Segundos
TiempoParado = 0
End Sub

'Establece una cuenta libre, osea un cronómetro
'común y corriente. Si deseas puedes establecer el
'argumento "TiempoQueHaTranscurrido" para indicar
'desde dónde va a comenzar el cronómetro.
Public Sub EstablecerLibre(Optional TiempoQueHaTranscurrido As Long = 0)
TiempoFinal = QuitarDecimales(GetTickCount / 1000) - TiempoQueHaTranscurrido
TiempoParado = 0
End Sub

'Agrega tiempo a un cronómetro en curso, donde
'"Segundos" es la cantidad de tiempo a agregar.
Public Sub AgregarTiempo(Segundos As Long)
TiempoFinal = QuitarDecimales(TiempoFinal) + Segundos
End Sub

'Utilizar esta función para obtener el tiempo
'en curso de una cuenta regresiva.
Public Function ObtenerTiempo() As Long
ObtenerTiempo = TiempoFinal - QuitarDecimales(GetTickCount / 1000) + TiempoParado
End Function

'Utilizar esta función para obtener el tiempo
'en curso de un cronómetro normal.
Public Function ObtenerTiempoLibre() As Long
ObtenerTiempoLibre = QuitarDecimales(GetTickCount / 1000) - TiempoFinal - TiempoParado
End Function

'Detiene momentaneamente el tiempo de
'un cronómetro en curso.
Public Function CongelarTiempo()
CuandoParó = QuitarDecimales(GetTickCount / 1000)
End Function

'Reanuda el tiempo de un cronómetro en
'curso.
Public Function ReanudarTiempo()
TiempoParado = TiempoParado + QuitarDecimales(GetTickCount / 1000) - CuandoParó
End Function

'Función privada para quitar los decimales que se
'obtienen al llamar a la API GetTickCount.
Private Function QuitarDecimales(ByVal Número) As Long
On Error Resume Next
Dim NúmeroConvertido As String, NúmeroNuevo As String
NúmeroConvertido = Número
If Len(NúmeroConvertido) <> 1 Then
    NúmeroNuevo = Left(NúmeroConvertido, InStr(1, NúmeroConvertido, ".") - 1)
    If Err.Number = 5 Then NúmeroNuevo = NúmeroConvertido
Else
    NúmeroNuevo = NúmeroConvertido
End If
QuitarDecimales = Val(NúmeroNuevo)
End Function

Función FormatoHoras

Adicionalmente a la clase puedes usar esta función para convertir los segundos obtenidos con la función ObtenerTiempo u ObtenerTiempoLibre al formato “hh:mm:ss”.

'Función para convertir una cantidad de
'segundos en el formato "hh:mm:ss".
Private Function FormatoHoras(Segundos As Long) As String
Dim Hora As Long, Minuto As Long, Segundo As Long
Dim Tiempo As Single
Tiempo = Segundos
'Separa el tiempo en horas, minutos y segundos
Hora = Int(Tiempo / 3600)
Minuto = Int((Tiempo - Hora * 3600) / 60)
Segundo = Tiempo - Hora * 3600 - Minuto * 60
'Formatea el tiempo como cadena
FormatoHoras = Format(Hora, "00") & ":" & Format(Minuto, "00") & ":" & Format(Segundo, "00")
End Function

Función para detectar si un índice de una matriz de controles está libre y así poder reutilizarlo.

Hay situaciones en que es necesario cargar y descargar controles en tiempo de ejecución. La forma más sencilla de cargar un nuevo control en un formulario es usar una matriz de controles. Sin embargo, si los índices de la matriz no están en orden ascendente (provocado por descargas de algunos de los controles), no hay función intrínseca que permita hallar el primer índice libre de dicha matriz y aprovechar al máximo la numeración de la misma. Para ello sirve esta función: PrimerIndiceLibre, que permite detectar el primer índice libre de una matriz de controles usando bucles, en el caso que la numeración esté completa la función devuelve el último índice de la matriz + 1.

Código de la función:

Public Function PrimerIndiceLibre(Matriz As Object) As Integer
On Error GoTo Encontrado
Dim IndiceFaltante As Integer
Dim Nada As String
Dim i As Integer
For i = 0 To Matriz.
UBound
    Nada = Matriz(i).Tag
    DoEvents
Next i
PrimerIndiceLibre = Matriz.UBound + 1
Exit Function
Encontrado:
IndiceFaltante = i
DoEvents
PrimerIndiceLibre = IndiceFaltante
Exit Function
End Function

Cómo insertar imágenes JPG, GIF y BMP de una forma sencilla.

A veces es necesario aprovechar todos los recursos que nos brinda el control RichTextBox. Si estamos creando un procesador de textos con este control, nos sería interesante hacer que nuestros programas tengan muchas posibilidades (formato, color, viñetas, etc) pero entre una de ellas está la de poder insertar imágenes dentro del documento. Para ello vamos a usar el Portapapeles y una llamada a la API SendMessage para lograr poner la imagen dentro del RichTextBox. El proyecto también tiene el control CommonDialog para abrir la imagen.

Código:

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Long) As Long
Private Const WM_PASTE = &H302;

Private Sub cmdInsertarImagen_Click()
On Error GoTo ErrorImagen
Dim strRutaImagen As String
Dim imgLaImagen As Picture
Dim strContenidoPortapapeles As String
With cdlImagen
    .DialogTitle = "Insertar imagen"
    .CancelError = True
    .Filter = "Todos los archivos de imágenes|*.gif;*.jpg;*.jpe;*.bmp;*.png|" _
    & "Imágenes GIF (*.gif)|*.gif|Imágenes JPG (*.jpg, *.jpe)|*.jpg;*.jpe|" _
    & "Imágenes de mapas de bits (*.bmp)|*.bmp|Imágenes PNG (*.png)|*.png| _
    & "Todos los archivos (*.*)|*.*"
    .FilterIndex = 1
    .Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
    .ShowOpen
    strRutaImagen = .FileName
End With
Set imgLaImagen = LoadPicture(strRutaImagen)
strContenidoPortapapeles = Clipboard.GetText
Clipboard.Clear
Clipboard.SetData imgLaImagen
SendMessage rtfTexto.hWnd, WM_PASTE, 0, 0
Clipboard.Clear
Clipboard.SetText strContenidoPortapapeles
Exit Sub
ErrorImagen:
If Err.Number <> 32755 Then
    MsgBox "Error " & Err.Number & " " & Err.Description
    Exit Sub
End If
End Sub

La imagen queda insertada en el RichTextBox como si de un objeto se tratase. Se puede cambiar de tamaño, mover, y el texto va acompañado de la imagen.

Ejemplo para abrir archivos e imágenes utilizando Drag & Drop y OLE.

Los controles TextBox y PictureBox poseen compatibilidad con la tecnología OLE, la que permite arrastrar y pegar información desde otras aplicaciones y del mismo explorador. En este ejemplo vamos a hacer una programa que permita copiar y mover una imagen de un Picture a otro y a la vez abrir archivos de gráficos arrastrados desde el explorador.

Crea un formulario y coloca en él 2 controles Picture, llámalos picPartida y picDestino respectivamente y cargue cualquier imagen en el picPartida (propiedad Picture)

En el PictureBox picPartida establece la propiedad OLEDragMode a 1-Automatic y OLEDropMode a 0-None, y en el picDestino la propiedad OLEDragMode a 0-Manual y OLEDropMode a 1-Manual. Luego pega en el formulario el siguiente código:

Option Explicit

Private Sub picDestino_OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
'Si se ha arrrastrado una imagen
If Data.GetFormat(vbCFDIB) Then
    'Tomamos la información
    Set picDestino.Picture = Data.GetData(vbCFDIB)
'Si se han arrastrado archivos
ElseIf Data.GetFormat(vbCFFiles) Then
    'Prevenimos un posible error
    On Error Resume Next
    'Al intentar cargar el primero de los archivos
    Set picDestino.Picture = LoadPicture(Data.Files(1))
    If Err Then 'Si se produce un error
        'Indicamos que no es posible abrirlo
        MsgBox "No es posible abrir el archivo " & Data.Files(1)
    End If
End If

'En caso de que esté pulsada la techa Ctrl
If Shift And vbCtrlMask Then
    'La operación es mover
    Effect = vbDropEffectMove
End If
End Sub

Private Sub picDestino_OLEDragOver(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
'Si el formato es el apropiado
If Data.GetFormat(vbCFDIB) Or Data.GetFormat(vbCFFiles) Then
    'En caso de que esté pulsada la techa Ctrl
    If Shift And vbCtrlMask Then
        'La operación es mover
        Effect = vbDropEffectMove
    End If
Else 'Si el formato no es el esperado
    Effect = vbDropEffectNone 'No aceptamos
End If
End Sub

Ejecute la aplicación. Puede arrastrar la imagen del picPartida al picDestino para copiarla. Si mantiene pulsada la tecla CTRL la imagen se moverá. También puede arrastrar archivos de imágenes desde el explorador al picDestino para abrirlos.

Código para cerrar un proceso utilizando el título de la ventana principal del programa. Muy útil en casos que se desee cerrar aplicaciones desde nuestro programa.

Crear un módulo y pegue el siguiente código:

Option Explicit

Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long

Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject _
As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
   (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

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

Const PROCESS_TERMINATE = &H1;
Const PROCESS_QUERY_INFORMATION = &H400;
Const STILL_ACTIVE = &H103;

Public Sub CerrarProceso(TítuloVentana As String)
Dim hProceso As Long
Dim lEstado As Long
Dim idProc As Long
Dim winHwnd As Long

winHwnd = FindWindow(vbNullString, TítuloVentana)
If winHwnd = 0 Then
    Debug.Print "El proceso no está abierto": Exit Sub
End If
Call GetWindowThreadProcessId(winHwnd, idProc)

' Obtenemos el handle al proceso
hProceso = OpenProcess(PROCESS_TERMINATE Or _
PROCESS_QUERY_INFORMATION, 0, idProc)
If hProceso <> 0 Then
    ' Comprobamos estado del proceso
    GetExitCodeProcess hProceso, lEstado
    If lEstado = STILL_ACTIVE Then
    ' Cerramos el proceso
        If TerminateProcess(hProceso, 9) <> 0 Then
            Debug.Print "Proceso cerrado"
        Else
            Debug.Print "No se pudo matar el proceso"
        End If
    End If
    ' Cerramos el handle asociado al proceso
    CloseHandle hProceso
Else
    Debug.Print "No se pudo tener acceso al proceso"
End If
End Sub

Por ejemplo, si desea cerrar la calculadora de Windows, llame a la función así: CerrarProceso(“Calculadora”). Donde “Calculadora” es el título de la ventana del programa que desea cerrar.