Biblioteca de código

[ranefi]

Uso de SaveSetting y GetSetting

Insertar el siguiente código en un...

Formulario

Código:

Const NomProg = "ranefilandia"


Sub ObtenAlCargar()
    With Me
        .WindowState = CInt(GetSetting(NomProg, _
            "Estado", "WindowState", .WindowState))
           
        .Height = CInt(GetSetting(NomProg, "Size", "Height", .Height))
        .Width = CInt(GetSetting(NomProg, "Size", "Width", .Width))
       
        .Left = CInt(GetSetting(NomProg, "Posicion", "Left", .Left))
        .Top = CInt(GetSetting(NomProg, "Posicion", "Top", .Top))
    End With
End Sub

Sub GuardaAlDescargar()
    With Me
        If Not .WindowState = 1 Then
            Call SaveSetting(NomProg, "Posicion", "Left", .Left)
            Call SaveSetting(NomProg, "Posicion", "Top", .Top)
           
            Call SaveSetting(NomProg, "Size", "Height", .Height)
            Call SaveSetting(NomProg, "Size", "Width", .Width)
           
            Call SaveSetting(NomProg, "Estado", "WindowState", .WindowState)
        End If
    End With
End Sub

Private Sub Form_Load()
    ObtenAlCargar
End Sub

Private Sub Form_Unload(Cancel As Integer)
    GuardaAlDescargar
End Sub

Si revisan el registro de Windows notarán para qué es cada parámetro.

La configuración se guarda en HKEY_CURRENT_U SER\Software\VB and VBA Programa Settings\NombreAplicacion

Nos vemos.

[ranefi]

Obtener la clave de Windows XP

Insertar el siguiente código en un...


Formulario

Código:

'**************************************
'Windows API/Global Declarations for :Vi
'     ew Windows XP CD Key
'**************************************
Option Explicit


Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long


Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long


Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that If you declare the lpData parameter as String, you must pass it By Value.
    Private Const REG_BINARY = 3
    Private Const HKEY_LOCAL_MACHINE = &H80000002
    Private Const ERROR_SUCCESS = 0&

'**************************************
' Name: View Windows XP CD Key
' Description:Function: sGetXPCDKey() wi
'     ll return the CD Key for Windows XP in t
'     he format XXXXX-XXXXX-XXXXX-XXXXX-XXXXX.
'
' By: Snytax
'
' Inputs:Nothing.
'
' Returns:Your Windows XP CD Key.
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=57164&lngWId=1'for details.'**************************************

'sGetXPCDKey() -
'Returns the Windows XP CD Key if succes
'     sful.
'Returns nothing upon failure.


Public Function sGetXPCDKey() As String
    'Read the value of:
    'HKLM\SOFTWARE\MICROSOFT\Windows NT\Curr
    '     entVersion\DigitalProductId
    Dim bDigitalProductID() As Byte
    Dim bProductKey() As Byte
    Dim ilByte As Long
    Dim lDataLen As Long
    Dim hKey As Long
    'Open the registry key: HKLM\SOFTWARE\MI
    '     CROSOFT\Windows NT\CurrentVersion


    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion", hKey) = ERROR_SUCCESS Then
        lDataLen = 164
        ReDim Preserve bDigitalProductID(lDataLen)
        'Read the value of DigitalProductID


        If RegQueryValueEx(hKey, "DigitalProductId", 0&, REG_BINARY, bDigitalProductID(0), lDataLen) = ERROR_SUCCESS Then
            'Get the Product Key, 15 bytes long, off
            '     set by 52 bytes
            ReDim Preserve bProductKey(14)


            For ilByte = 52 To 66
                bProductKey(ilByte - 52) = bDigitalProductID(ilByte)
            Next ilByte
        Else
            'ERROR: Could not read "DigitalProductID
            '     "
            sGetXPCDKey = ""
            Exit Function
        End If
    Else
        'ERROR: Could not open "HKLM\SOFTWARE\MI
        '     CROSOFT\Windows NT\CurrentVersion"
        sGetXPCDKey = ""
        Exit Function
    End If
    'Now we are going to 'base24' decode the
    '     Product Key
    Dim bKeyChars(0 To 24) As Byte
    'Possible characters in the CD Key:
    bKeyChars(0) = Asc("B")
    bKeyChars(1) = Asc("C")
    bKeyChars(2) = Asc("D")
    bKeyChars(3) = Asc("F")
    bKeyChars(4) = Asc("G")
    bKeyChars(5) = Asc("H")
    bKeyChars(6) = Asc("J")
    bKeyChars(7) = Asc("K")
    bKeyChars(8) = Asc("M")
    bKeyChars(9) = Asc("P")
    bKeyChars(10) = Asc("Q")
    bKeyChars(11) = Asc("R")
    bKeyChars(12) = Asc("T")
    bKeyChars(13) = Asc("V")
    bKeyChars(14) = Asc("W")
    bKeyChars(15) = Asc("X")
    bKeyChars(16) = Asc("Y")
    bKeyChars(17) = Asc("2")
    bKeyChars(18) = Asc("3")
    bKeyChars(19) = Asc("4")
    bKeyChars(20) = Asc("6")
    bKeyChars(21) = Asc("7")
    bKeyChars(22) = Asc("8")
    bKeyChars(23) = Asc("9")
    Dim nCur As Integer
    Dim sCDKey As String
    Dim ilKeyByte As Long
    Dim ilBit As Long


    For ilByte = 24 To 0 Step -1
        'Step through each character in the CD k
        '     ey
        nCur = 0


        For ilKeyByte = 14 To 0 Step -1
            'Step through each byte in the Product K
            '     ey
            nCur = nCur * 256 Xor bProductKey(ilKeyByte)
            bProductKey(ilKeyByte) = Int(nCur / 24)
            nCur = nCur Mod 24
        Next ilKeyByte
        sCDKey = Chr(bKeyChars(nCur)) & sCDKey
        If ilByte Mod 5 = 0 And ilByte <> 0 Then sCDKey = "-" & sCDKey
    Next ilByte
    sGetXPCDKey = sCDKey
End Function

Private Sub Form_Load()
    Me.Caption = sGetXPCDKey
End Sub

Muy interesante.

[ranefi]

Almacenar código de Visual Basic en una variable

Agregar 1 control CommandButton e insertar el siguiente código en un...

Formulario

Código:

Private Declare Function EbExecuteLine Lib "vba6.dll" _
    (ByVal pStringToExec As Long, ByVal Foo1 As Long, _
    ByVal Foo2 As Long, ByVal fCheckOnly As Long) As Long

Dim Codigo As String
Dim Ejecuta As Long

Private Sub Command1_Click()
    Codigo = "For i = 1 to 10:MsgBox " & _
        Chr(34) & "ranefi tiene " & Chr(34) & _
        "&i & " & Chr(34) & " novias" & Chr(34) & _
        ",VbInformation," & Chr(34) & "La pura verdad" & Chr(34) & ":Next"

    Ejecuta = EbExecuteLine(StrPtr(Codigo), 0&, 0&, Abs(False)) = 0
End Sub

Se puede usar en una aplicación cliente/servidor la cual pueda ejecutar código de forma remota. Nos vemos.

[ranefi]

Esperar finalización de un proceso

Agregar 1 control CommandButton e insertar el siguiente código en un...

Formulario

Código:

Const SYNCHRONIZE = &H100000
'STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF

Private Const INFINITE = -1&

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type

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

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

Private Declare Function OpenProcess Lib "Kernel32.dll" _
    (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcId As Long) As Long

Private Declare Function Waitforsingleobject Lib "kernel32" Alias _
    "WaitForSingleObject" (ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long

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

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


Private Sub Command1_Click()
    Dim pid As PROCESS_INFORMATION
    Dim ret As Long
   
    Shell "Notepad.exe", vbMaximizedFocus
   
    ret = FindWindow(vbNullString, "Sin título - Bloc de notas")
    ret = GetWindowThreadProcessId(ret, pid.hProcess)
    ret = OpenProcess(SYNCHRONIZE, False, CLng(pid.hProcess))

    If ret <> 0 Then
        ret = Waitforsingleobject(ret, INFINITE)
        MsgBox "Se cerró el Bloc de notas"
    Else
        MsgBox "No está abierto el Bloc de notas"
    End If
End Sub

Este código espera a que finalice el proceso del Bloc de notas para mostrar un mensaje indicando que ya está cerrado el Bloc de notas.

[ranefi]

Esperar finalización de un proceso 2

Insertar el siguiente código en un...

Módulo

Código:

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

Private Declare Function WaitForSingleObject _
    Lib "kernel32" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) _
    As Long

Private Declare Function CloseHandle _
    Lib "kernel32" ( _
    ByVal hObject As Long) _
    As Long
   
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFF

Sub Main()
    ShellAndWait ("PING www.google.com")
   
    MsgBox "Finalizó el proceso de PING"
End Sub

Private Sub ShellAndWait(CommandLine As String)
    Dim ShellId As Long
    Dim ShellHandle As Long
   
    ShellId = Shell(CommandLine, vbNormalFocus)
    ShellHandle = OpenProcess(SYNCHRONIZE, 0, ShellId)
   
    If ShellHandle <> 0 Then
        WaitForSingleObject ShellHandle, INFINITE
        CloseHandle ShellHandle
    End If
End Sub

Cuando se agregue el proyecto EXE estándar, se deberá agregar un módulo y posteriormente quitar el formulario que viene por defecto para que este ejemplo funcione correctamente. Nos vemos.

[ranefi]

Enganchando al teclado (Hook de teclado)

Agregar 1 control CheckBox e insertar el siguiente código en un...

Formulario

Código:

'**************************************
' Name: Disable Low Level Keys
' Description:There are many situations
'     when it's need to disable some combinati
'     ons of keys from a VB program. For insta
'     nce, ALT-TAB, CTRL-ESC, ALT-ESC or other
'     s like these. Other combinations could b
'     e tested at form level using KeyPreview
'     property and KeyPress / KeyDown / KeyUp
'     events. All system keystrokes won't fire
'     key events in a form (or other controls)
'     because they are handled internally by t
'     he system. Since application threads nev
'     er receive messages for these keystrokes
'     , there is no way that an application ca
'     n intercept them and prevent the normal
'     processing. This behavior is "by design"
'     and ensures that a user can always switc
'     h to another application’s window even i
'     f an application’s thread enters an infi
'     nite loop or hangs.
'The question is how we can intercept this keystrokes? The solution could be achieved using hooks. A hook is a point in the Microsoft Windows message-handling mechanism where an application can install a subroutine To monitor the message traffic in the system and process certain types of messages before they reach the target window procedure.


'For Windows NT SP3 (or higher), Microsoft introduced a new hook: WH_KEYBOARD_LL. This hook is called the low-level hook because it is notified of keystrokes just after the user enters them and before the system gets a chance To process them. This hook has a serious drawback: the thread processing the hook filter Function could enter an infinite Loop or hang. If this happens, Then the system will no longer process keystrokes properly and the user will become incredibly frustrated. To alleviate this situation, Microsoft places a time limit on low-level hooks. When the system sends a notification to a low-level keyboard hook’s filter function, the system allows that function a fixed amount of time to execute. If the function does not return in the allotted time, the system ignores the hook filter function and processes the keystroke normally. The amount of time allowed (in milliseconds) is Set via the LowLevelHooksTimeout value under the following registry subkey: HKEY_CURRENT_USER\Control Panel\Desktop.
'    The program (VB) is disabling some of these combinations (ALT-TAB, CTRL-ESC and ALT-ESC) as Long as the option is checked.
' By: Ovidiu Crisan
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=13106&lngWId=1'for details.'**************************************

Dim hhkLowLevelKybd As Long


Private Sub chkDisable_Click()
    If chkDisable = vbChecked Then
        hhkLowLevelKybd = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0)
    Else
        UnhookWindowsHookEx hhkLowLevelKybd
        hhkLowLevelKybd = 0
    End If
End Sub


Private Sub Form_Unload(Cancel As Integer)
    If hhkLowLevelKybd <> 0 Then UnhookWindowsHookEx hhkLowLevelKybd
End Sub

Módulo

Código:

'**************************************
'Windows API/Global Declarations for :Di
'     sable Low Level Keys
'**************************************
Option Explicit


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


Public Declare Function GetKeyState Lib "user32" _
        (ByVal nVirtKey As Long) As Integer


Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
        (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long


Public Declare Function CallNextHookEx Lib "user32" _
        (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long


Public Declare Function UnhookWindowsHookEx Lib "user32" _
        (ByVal hHook As Long) As Long
    Public Const HC_ACTION = 0
    Public Const WM_KEYDOWN = &H100
    Public Const WM_KEYUP = &H101
    Public Const WM_SYSKEYDOWN = &H104
    Public Const WM_SYSKEYUP = &H105
    Public Const VK_TAB = &H9
    Public Const VK_CONTROL = &H11
    Public Const VK_ESCAPE = &H1B
    Public Const WH_KEYBOARD_LL = 13
    Public Const LLKHF_ALTDOWN = &H20


Public Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
    End Type
    Dim p As KBDLLHOOKSTRUCT


Public Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim fEatKeystroke As Boolean


    If (nCode = HC_ACTION) Then
        If wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN Or wParam = WM_KEYUP Or wParam = WM_SYSKEYUP Then
            CopyMemory p, ByVal lParam, Len(p)
           
            fEatKeystroke = _
            ((p.vkCode = VK_TAB) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _
            ((p.vkCode = VK_ESCAPE) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _
            ((p.vkCode = VK_ESCAPE) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0))
        End If
    End If


    If fEatKeystroke Then
        LowLevelKeyboardProc = -1
    Else
        LowLevelKeyboardProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
    End If
End Function

Interesante, muy interesante. Nos vemos.

[ranefi]

Uso del control TreeView

En la ventana de componentes seleccionar la opción Microsoft Windows Common Controls 6.0, agregar 1 control TreeView e insertar el siguiente código en un...

Formulario

Código:

Private Sub Form_Load()
   Dim nodX As Node
   
   With TreeView1.Nodes
        Set nodX = .Add(, , "r", "ranefilandia")
        Set nodX = .Add("r", tvwChild, "c1", "colibrí")
        Set nodX = .Add("r", tvwChild, "c2", "ranefi")
        Set nodX = .Add("r", tvwChild, "c3", "cookie")
        Set nodX = .Add("c3", tvwChild, "c4", "güera")
        Set nodX = .Add("c3", tvwChild, "c5", "doña gata")
        Set nodX = .Add("c5", tvwChild, "c6", "opera")
        Set nodX = .Add("c5", tvwChild, "c7", "carín")
        Set nodX = .Add("c5", tvwChild, "c8", "gizmo")
   End With
   
   nodX.EnsureVisible
   
   TreeView1.BorderStyle = vbFixedSingle
   
   Me.Caption = "Da doble clic sobre cada uno de los nodos"
End Sub

Private Sub TreeView1_DblClick()
    Dim nodX As Node
    Dim strProps As String
   
   ' Establece la variable a SelectedItem.
   Set nodX = TreeView1.SelectedItem
   
   ' Obtiene las propiedades del nodo.
   strProps = "Texto: " & nodX.Text & vbLf
   strProps = strProps & "Clave: " & nodX.Key & vbLf
   
   On Error Resume Next ' El nodo raíz no tiene primario.
   strProps = strProps & "Primario: " & nodX.Parent.Text & vbLf
   strProps = strProps & "Primero del mismo nivel: " & _
        nodX.FirstSibling.Text & vbLf
   strProps = strProps & "Último del mismo nivel: " & _
        nodX.LastSibling.Text & vbLf
   strProps = strProps & "Siguiente: " & nodX.Next.Text & vbLf
   
   MsgBox strProps
End Sub

Es un ejemplo de MSDN. Nos vemos.

[ranefi]

Gráficos en 3D con MSChart

Seleccionar la opción Microsoft Chart Control 6.0 (OLEDB) de la ventana Componentes, agregar 1 control CommandButton, 1 control MSChart e insertar el siguiente código en un...

Formulario

Código:

Private Sub Command1_Click()
   With MSChart1
      ' Muestra un gráfico 3d con 8 columnas y 8 filas
      ' de datos.
      .chartType = VtChChartType3dBar
      .ColumnCount = 8
      .RowCount = 8
     
      For Column = 1 To 8
         For Row = 1 To 8
            .Column = Column
            .Row = Row
            .Data = Row * 10
         Next Row
      Next Column
     
      ' Utiliza el gráfico como fondo de la leyenda.
      .ShowLegend = True
      .SelectPart VtChPartTypePlot, index1, index2, index3, index4
      .EditCopy
      .SelectPart VtChPartTypeLegend, index1, index2, index3, index4
      .EditPaste
   End With
End Sub

Muy útil, ¿no creen?

PD: Código de MSDN.

[ranefi]

Cálcula tamaño de bytes

Agregar 1 control CommandButton, 1 control TextBox e insertar el siguiente código en un...

Formulario

Código:

Function SetBytes(Bytes) As String
On Error GoTo hell

    If Bytes >= 1073741824 Then
        SetBytes = Format(Bytes / 1024 / 1024 / 1024, "#0.00") _
            & " GB"
    ElseIf Bytes >= 1048576 Then
        SetBytes = Format(Bytes / 1024 / 1024, "#0.00") & " MB"
    ElseIf Bytes >= 1024 Then
        SetBytes = Format(Bytes / 1024, "#0.00") & " KB"
    ElseIf Bytes < 1024 Then
        SetBytes = Fix(Bytes) & " Bytes"
    End If
   
    Exit Function
hell:
    SetBytes = "0 Bytes"
End Function

Private Sub Command1_Click()
    Me.Caption = SetBytes(CDbl(Text1.Text))
End Sub

Código publicado por _Hendrix_. Nos vemos.

[ranefi]

Ejecutar secuencias de teclas en formulario para minimizarlo (CTRL + R)

Agregar 1 control Timer e insertar el siguiente código en un...

Formulario

Código:

Private Declare Function GetAsyncKeyState Lib "user32" _
    (ByVal vKey As Long) As Integer

Private Sub Form_Load()
    Form1.Hide
   
    Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
    If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyR) Then
        Shell "notepad", vbMaximizedFocus
    End If
End Sub

Código publicado por crypto136. Nos vemos.

[ranefi]

Crear Servicios en Windows

Agregar 2 controles CommandButton e insertar el siguiente código en un...

Formulario

Código:

Const NombrePC = "NombreMaquina"
Const NombreServicio = "NombreServicio"
Const RutaServicio = "C:\Ejecutable.exe"



Private Sub Command1_Click()
    ServiceInstall NombrePC, NombreServicio, RutaServicio
End Sub

Private Sub Command2_Click()
    ServiceUnInstall NombrePC, NombreServicio
End Sub

Módulo

Código:

'CODEADO POR K1Z4R
'23-5-2006
'Todo el codigo es mio menos las constantes, espero que les sirva ya que casi no hay informacion de esto en internet.
'K1Z4R no se hace responsable de lo que hagan con esto porque tienes fines educativos
'No quiten este texto.

Public Const SERVICES_ACTIVE_DATABASE = "ServicesActive"

' Service Control
Public Const SERVICE_CONTROL_STOP = &H1
Public Const SERVICE_CONTROL_PAUSE = &H2

' Service State - for CurrentState
Public Const SERVICE_STOPPED = &H1
Public Const SERVICE_START_PENDING = &H2
Public Const SERVICE_STOP_PENDING = &H3
Public Const SERVICE_RUNNING = &H4
Public Const SERVICE_CONTINUE_PENDING = &H5
Public Const SERVICE_PAUSE_PENDING = &H6
Public Const SERVICE_PAUSED = &H7

'Service Control Manager object specific access types
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SC_MANAGER_CONNECT = &H1
Public Const SC_MANAGER_CREATE_SERVICE = &H2
Public Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Public Const SC_MANAGER_LOCK = &H8
Public Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Public Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Public Const SC_MANAGER_ALL_ACCESS = _
    (STANDARD_RIGHTS_REQUIRED Or SC_MANAGER_CONNECT Or _
    SC_MANAGER_CREATE_SERVICE Or _
    SC_MANAGER_ENUMERATE_SERVICE Or SC_MANAGER_LOCK Or _
    SC_MANAGER_QUERY_LOCK_STATUS Or SC_MANAGER_MODIFY_BOOT_CONFIG)
    
'Service object specific access types
Public Const SERVICE_QUERY_CONFIG = &H1
Public Const SERVICE_CHANGE_CONFIG = &H2
Public Const SERVICE_QUERY_STATUS = &H4
Public Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Public Const SERVICE_START = &H10
Public Const SERVICE_STOP = &H20
Public Const SERVICE_PAUSE_CONTINUE = &H40
Public Const SERVICE_INTERROGATE = &H80
Public Const SERVICE_USER_DEFINED_CONTROL = &H100
Public Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
    SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG Or _
    SERVICE_QUERY_STATUS Or SERVICE_ENUMERATE_DEPENDENTS Or _
    SERVICE_START Or SERVICE_STOP Or SERVICE_PAUSE_CONTINUE Or _
    SERVICE_INTERROGATE Or SERVICE_USER_DEFINED_CONTROL)

'Service type
Private Const SERVICE_WIN32_OWN_PROCESS = &H10&
Private Const SERVICE_WIN32_SHARE_PROCESS = &H20&
Private Const SERVICE_WIN32 = SERVICE_WIN32_OWN_PROCESS + _
    SERVICE_WIN32_SHARE_PROCESS

'Service inicio
Private Const SERVICE_AUTO_START As Long = &H2
Private Const SERVICE_DEMAND_START As Long = &H3
Private Const SERVICE_DISABLED_START As Long = &H4

Private Const SERVICE_ERROR_NORMAL As Long = &H1

Type SERVICE_STATUS
    dwServiceType As Long
    dwCurrentState As Long
    dwControlsAccepted As Long
    dwWin32ExitCode As Long
    dwServiceSpecificExitCode As Long
    dwCheckPoint As Long
    dwWaitHint As Long
End Type

Declare Function CloseServiceHandle Lib "ADVAPI32.DLL" _
    (ByVal hSCObject As Long) As Long

Declare Function ControlService Lib "ADVAPI32.DLL" _
    (ByVal hService As Long, ByVal dwControl As Long, _
    lpServiceStatus As SERVICE_STATUS) As Long

Declare Function OpenSCManager Lib "ADVAPI32.DLL" _
    Alias "OpenSCManagerA" (ByVal lpMachineName As String, _
    ByVal lpDatabaseName As String, _
    ByVal dwDesiredAccess As Long) As Long

Declare Function OpenService Lib "ADVAPI32.DLL" _
    Alias "OpenServiceA" (ByVal hSCManager As Long, _
    ByVal lpServiceName As String, _
    ByVal dwDesiredAccess As Long) As Long

Declare Function QueryServiceStatus Lib "ADVAPI32.DLL" _
    (ByVal hService As Long, _
    lpServiceStatus As SERVICE_STATUS) As Long

Declare Function StartService Lib "ADVAPI32.DLL" _
    Alias "StartServiceA" (ByVal hService As Long, _
    ByVal dwNumServiceArgs As Long, _
    ByVal lpServiceArgVectors As Long) As Long

Declare Function CreateService Lib "ADVAPI32.DLL" _
    Alias "CreateServiceA" (ByVal hSCManager As Long, _
    ByVal lpServiceName As String, ByVal lpDisplayName As String, _
    ByVal dwDesiredAccess As Long, ByVal dwServiceType As Long, _
    ByVal dwStartType As Long, ByVal dwErrorControl As Long, _
    ByVal lpBinaryPathName As String, ByVal lpLoadOrderGroup As String, _
    ByVal lpdwTagId As String, ByVal lpDependencies As String, _
    ByVal lp As String, ByVal lpPassword As String) As Long

Declare Function DeleteService Lib "ADVAPI32.DLL" _
    (ByVal hService As Long) As Long

Dim ServiceStat As SERVICE_STATUS
Dim hSManager As Long
Dim hService As Long
Dim res As Long



Public Function ServiceStatus(ComputerName As String, ServiceName As String) As String
Dim hServiceStatus As Long

    ServiceStatus = ""
    hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, _
        SC_MANAGER_ALL_ACCESS)
    
    If hSManager <> 0 Then
        hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
        If hService <> 0 Then
            hServiceStatus = QueryServiceStatus(hService, ServiceStat)
            If hServiceStatus <> 0 Then
                Select Case ServiceStat.dwCurrentState
                Case SERVICE_STOPPED
                    ServiceStatus = "Parado"
                Case SERVICE_START_PENDING
                    ServiceStatus = "Iniciandose"
                Case SERVICE_STOP_PENDING
                    ServiceStatus = "Parandose"
                Case SERVICE_RUNNING
                    ServiceStatus = "Iniciado"
                Case SERVICE_CONTINUE_PENDING
                    ServiceStatus = "Continuandole"
                Case SERVICE_PAUSE_PENDING
                    ServiceStatus = "Pausandole"
                Case SERVICE_PAUSED
                    ServiceStatus = "Pausado"
                End Select
            End If
            CloseServiceHandle hService
        End If
        
        CloseServiceHandle hSManager
    End If
End Function

Public Sub ServicePause(ComputerName As String, ServiceName As String)
    hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, _
        SC_MANAGER_ALL_ACCESS)
    
    If hSManager <> 0 Then
        hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
        If hService <> 0 Then
            res = ControlService(hService, SERVICE_CONTROL_PAUSE, ServiceStat)
            CloseServiceHandle hService
        End If
        
        CloseServiceHandle hSManager
    End If
End Sub

Public Sub ServiceStart(ComputerName As String, ServiceName As String)
    hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, _
        SC_MANAGER_ALL_ACCESS)
    
    If hSManager <> 0 Then
        hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
        If hService <> 0 Then
            res = StartService(hService, 0, 0)
            CloseServiceHandle hService
        End If
        CloseServiceHandle hSManager
    End If
End Sub

Public Sub ServiceStop(ComputerName As String, ServiceName As String)
    hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, _
        SC_MANAGER_ALL_ACCESS)
    
    If hSManager <> 0 Then
        hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
        If hService <> 0 Then
            res = ControlService(hService, SERVICE_CONTROL_STOP, ServiceStat)
            CloseServiceHandle hService
        End If
        CloseServiceHandle hSManager
    End If
End Sub

Public Sub ServiceInstall(ComputerName As String, ServiceName As String, Path As String)
    hSManager = OpenSCManager(ComputerName, vbNullString, _
        SC_MANAGER_CREATE_SERVICE)
    hService = CreateService(hSManager, ServiceName, ServiceName, _
        SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, _
        SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, Path, _
        vbNullString, vbNullString, vbNullString, vbNullString, _
        vbNullString)
    
    CloseServiceHandle hService
    CloseServiceHandle hSManager
End Sub

Public Sub ServiceUnInstall(ComputerName As String, ServiceName As String)
    hSManager = OpenSCManager(ComputerName, vbNullString, _
        SC_MANAGER_CREATE_SERVICE)
    hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)

    DeleteService hService

    CloseServiceHandle hService
    CloseServiceHandle hSManager
End Sub

¡Excelente! ¿No creen?

Código de Kizar.

[ranefi]

Buscar en un LIstBox

Agregar 2 controles; 1 TextBox, 1 ListBox, dejar sus nombres predeterminado s e insertar el siguiente código en un...

Formulario

Código:

Function BuscaListBox(lst As ListBox, CadenaTexto As String) As Boolean
    On Error Resume Next
    Dim I As Integer
   
    For I = 0 To lst.ListCount
        If lst.List(I) Like "*" & UCase(CadenaTexto) & "*" Then
            BuscaListBox = True: lst.ListIndex = I: GoTo ups
        End If
    Next I
    BuscaListBox = False
ups:
End Function

Private Sub Form_Load()
    With List1
        .AddItem "MÉXICO"
        .AddItem "RANEFILANDIA"
        .AddItem "ARGENTINA"
        .AddItem "VENEZUELA"
        .AddItem "ESPAÑA"
        .AddItem "GUATEMALA"
        .AddItem "CHILE"
    End With
End Sub

Private Sub Text1_Change()
    BuscaListBox List1, Text1.Text
End Sub

Muy útil cuando se requiere trabajar con bases de datos y ListBox.

[ranefi]

Buscar en un ComboBox

Agregar 2 controles; 1 TextBox, 1 ComboBox, dejar sus nombres predeterminado s e insertar el siguiente código en un...

Formulario

Código:

Function BuscaComboBox(cmb As ComboBox, CadenaTexto As String) As Boolean
    On Error Resume Next
    Dim I As Integer
   
    For I = 0 To cmb.ListCount
        If cmb.List(I) Like "*" & UCase(CadenaTexto) & "*" Then
            BuscaComboBox = True: cmb.ListIndex = I: GoTo ups
        End If
    Next I
    BuscaComboBox = False
ups:
End Function

Private Sub Form_Load()
    With Combo1
        .AddItem "MÉXICO"
        .AddItem "RANEFILANDIA"
        .AddItem "ARGENTINA"
        .AddItem "VENEZUELA"
        .AddItem "ESPAÑA"
        .AddItem "GUATEMALA"
        .AddItem "CHILE"
    End With
End Sub

Private Sub Text1_Change()
    BuscaComboBox Combo1, Text1.Text
End Sub

Como ya vieron, es idéntico al código del control ListBox.

[ranefi]

Buscar y quitar carácteres en un archivo

Agregar 1 control; 1 CommandButton e insertar el siguiente código en un...

Formulario

Código:

Sub QuitaCosasRaras(strArchivo As String, strTeintXtoPorQuitar As String, strTeintXtoNuevo As String)
    Dim strLinea As String
    Dim intNumstrArchivo As Integer, intX As Integer
   
    intNumstrArchivo = FreeFile()
   
        On Error GoTo ups
        Open strArchivo For Input As #intNumstrArchivo
            Do Until EOF(intNumstrArchivo)
                Line Input #intNumstrArchivo, strLinea
               
                strLinea = Replace(strLinea, strTeintXtoPorQuitar, strTeintXtoNuevo)
               
                strLineaGlobal = strLinea
               
                Open strArchivo & ".tmp" For Append As #2
                    Print #2, strLineaGlobal
                Close #2
            Loop
        Close #intNumstrArchivo
       
        Kill strArchivo
        FileCopy strArchivo & ".tmp", strArchivo
        Kill strArchivo & ".tmp"
    Exit Sub
ups:
    MsgBox Err.Description
    Exit Sub
End Sub

Private Sub Command1_Click()
    QuitaCosasRaras "C:\prueba.txt", Chr(34), ""
End Sub

Private Sub Form_Load()
    Dim strPrueba As String
    Dim intNumArchivo As Integer, intCuenta As Integer
   
    strPrueba = "C:\prueba.txt"
    intNumArchivo = FreeFile()
   
    Open strPrueba For Output As #intNumArchivo
        For intCuenta = 1 To 10
            Print #intNumArchivo, "hola mundo, te saluda " & _
                Chr(34) & "ranefi" & Chr(34) & " desde " & _
                Chr(34) & "ranefilandia" & Chr(34)
        Next
    Close #intNumArchivo
End Sub

En este ejemplo el código lo que hace es localicar Chr(34) (") y sustituirlo por nada. Claro que al iniciar la aplicación se crea un archivo en la unidad C con la frase hola mundo, te saluda "ranefi" desde "ranefilandia". Espero les sirva ya que a mí me resultó muy útil en el trabajo.

[ranefi]

Control SSTab con fondo

Agregar 2 controles; 1 control Image, 1 control SSTab (Componentes-Microsoft Tabbed Dialog Control 6.0) e insertar el siguiente código en un...

Formulario

Código:

Sub CambiaFondoTab()
    With Image1
        .Picture = LoadPicture(App.Path & "\" & "imagen.jpg")
        .Visible = False
       
        ' grab our background image's dimensions for later use
        mBrush = CreatePatternBrush(.Picture.Handle)
        bgWid = Me.ScaleX(.Picture.Width, vbHimetric, vbPixels)
        bgHgt = Me.ScaleY(.Picture.Height, vbHimetric, vbPixels)
   
        ' Start the subclassing
        oldSSTabProc = SetWindowLong(SSTab1.hwnd, GWL_WNDPROC, AddressOf SSTabProc)
    End With
End Sub


Friend Function NewSSTabProc(ByVal sstHwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
   
    Dim aRect       As RECT
    Dim updateRect  As RECT
    Dim destDC      As Long
    Dim tempDC      As Long
    Dim tempBmp     As Long
    Dim origDC      As Long
    Dim origBmp     As Long
    Dim maskDC      As Long
    Dim maskBmp     As Long
    Dim memDC       As Long
    Dim memBmp      As Long
   
    Dim wid         As Long
    Dim hgt         As Long
    Dim x           As Long
    Dim y           As Long
    Dim aControl    As Control
   
    Dim origBrush As Long
    Dim origColor As Long
   
    On Error Resume Next
    If wMsg = &HF Then  'WM_PAINT
       
        GetUpdateRect sstHwnd, updateRect, False
        With updateRect
            Debug.Print "(" & .Left & "," & .Top & ")-(" & .Right & "," & .Bottom & ")"
        End With
       
        ' get the SSTab's device context
        destDC = GetDC(sstHwnd)
       
        ' get the SSTab's window dimensions
        GetWindowRect sstHwnd, aRect
        wid = aRect.Right - aRect.Left
        hgt = aRect.Bottom - aRect.Top
       
        ' create our other temporary device contexts.
        maskDC = CreateCompatibleDC(destDC)
        maskBmp = CreateBitmap(wid, hgt, 1, 1, ByVal 0&)
        memDC = CreateCompatibleDC(destDC)
        memBmp = CreateCompatibleBitmap(destDC, wid, hgt)
        tempDC = CreateCompatibleDC(destDC)
        tempBmp = CreateCompatibleBitmap(destDC, wid, hgt)
        origDC = CreateCompatibleDC(destDC)
        origBmp = CreateCompatibleBitmap(destDC, wid, hgt)
       
        ' delete the temporary 1x1 bitmap and put our (wid)x(hgt) ones in
        DeleteObject SelectObject(maskDC, maskBmp)
        DeleteObject SelectObject(memDC, memBmp)
        DeleteObject SelectObject(tempDC, tempBmp)
        DeleteObject SelectObject(origDC, origBmp)
       
        ' Call the control's original handler... paints the control on our back buffer
        CallWindowProc oldSSTabProc, sstHwnd, wMsg, origDC, lParam

        ' This helps our mask to correctly calculate the b & w pixels of
        '  our mask. Only really works in Win98 and greater... and even then
        '  it is sometimes flakey... may need to loop thru x & y and use
        '  GetPixel/SetPixel to create mask if it is not generated properly.
        origColor = SetBkColor(destDC, GetSysColor(15))
        SetBkColor origDC, GetSysColor(15)
        ' create a b&w pixel mask - background color is white, everything else
        '  is black.
        BitBlt maskDC, 0, 0, wid, hgt, origDC, 0, 0, vbSrcCopy
               

        ' select the pattern brush into the DC and pattern blit
        origBrush = SelectObject(tempDC, mBrush)
        PatBlt tempDC, 0, 0, wid, hgt, vbPatCopy
        SelectObject tempDC, origBrush
       
        ' clean up our original image of the control so only the non background
        '  color parts are showing... make everything else white.
        BitBlt memDC, 0, 0, wid, hgt, maskDC, 0, 0, vbSrcCopy
        BitBlt memDC, 0, 0, wid, hgt, origDC, 0, 0, vbSrcPaint
       

        'punch the hole for our control image
        BitBlt tempDC, 0, 0, wid, hgt, maskDC, 0, 0, vbMergePaint
        'put the control images back in
        BitBlt tempDC, 0, 0, wid, hgt, memDC, 0, 0, vbSrcAnd
        'copy our new version back to the control
        BitBlt destDC, 0, 0, wid, hgt, tempDC, 0, 0, vbSrcCopy

        ' clean up all of our used graphical resources (VERY IMPORTANT!!!)
        DeleteDC tempDC
        DeleteObject tempBmp
        DeleteDC maskDC
        DeleteObject maskBmp
        DeleteDC memDC
        DeleteObject memBmp
        DeleteDC origDC
        DeleteObject origBmp
       
        ' Replace the original background color
        SetBkColor destDC, origColor
        ' Release the SSTab's device context back to the system
        ReleaseDC sstHwnd, destDC
       
        ValidateRect sstHwnd, 0
               
        On Error GoTo 0
    ElseIf wMsg = &H2 Then 'WM_DESTROY
        DeleteObject mBrush
        SetWindowLong sstHwnd, GWL_WNDPROC, oldSSTabProc
        NewSSTabProc = CallWindowProc(oldSSTabProc, sstHwnd, wMsg, wParam, lParam)
    ElseIf wMsg = &H138 Then    '&H138 = WM_CTLCOLORSTATIC
        SetBkMode wParam, 1     ' make the text draw transparent
        NewSSTabProc = mBrush   ' return the background brush
    Else
        NewSSTabProc = CallWindowProc(oldSSTabProc, sstHwnd, wMsg, wParam, lParam)
    End If
    On Error GoTo 0
End Function

Private Sub Form_Load()
    CambiaFondoTab
End Sub

Insertar el siguiente código en un...

Módulo

Código:

''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const GWL_WNDPROC = (-4) 'PARA EL COLOR DEL SSTAB
''''''''''''''''''''''''''''''''''''''''''''''''''''''

'PARA EL CONTROL SSTAB''''''''''''''''''''''''''''''''
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
''''''''''