necesito un codigo de vb

Este es el primer Formulario(FRMAPAGAMAQUINA) Con 2 CheckBox 3Optionbutton 2 Frames y 2 Commandbutton

Código:

Option Explicit
'Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
'Private Const TOKEN_QUERY As Long = &H8
'Private Const SE_PRIVILEGE_ENABLED As Long = &H2
'
'Private Const EWX_LOGOFF As Long = &H0
'Private Const EWX_SHUTDOWN As Long = &H1
'Private Const EWX_REBOOT As Long = &H2
'Private Const EWX_FORCE As Long = &H4
'Private Const EWX_POWEROFF As Long = &H8
'Private Const EWX_FORCEIFHUNG As Long = &H10 '2000/XP only
'
'Private Const VER_PLATFORM_WIN32_NT As Long = 2
'
'Private Type OSVERSIONINFO
'  OSVSize         As Long
'  dwVerMajor      As Long
'  dwVerMinor      As Long
'  dwBuildNumber   As Long
'  PlatformID      As Long
'  szCSDVersion    As String * 128
'End Type
'
'Private Type LUID
'   dwLowPart As Long
'   dwHighPart As Long
'End Type
'
'Private Type LUID_AND_ATTRIBUTES
'   udtLUID As LUID
'   dwAttributes As Long
'End Type
'
'Private Type TOKEN_PRIVILEGES
'   PrivilegeCount As Long
'   laa As LUID_AND_ATTRIBUTES
'End Type
'
'Private Declare Function ExitWindowsEx Lib "user32" _
'   (ByVal dwOptions As Long, _
'   ByVal dwReserved As Long) As Long
'
'Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
'
'Private Declare Function OpenProcessToken Lib "advapi32" _
'  (ByVal ProcessHandle As Long, _
'   ByVal DesiredAccess As Long, _
'   TokenHandle As Long) As Long
'
'Private Declare Function LookupPrivilegeValue Lib "advapi32" _
'   Alias "LookupPrivilegeValueA" _
'  (ByVal lpSystemName As String, _
'   ByVal lpName As String, _
'   lpLuid As LUID) As Long
'
'Private Declare Function AdjustTokenPrivileges Lib "advapi32" _
'  (ByVal TokenHandle As Long, _
'   ByVal DisableAllPrivileges As Long, _
'   NewState As TOKEN_PRIVILEGES, _
'   ByVal BufferLength As Long, _
'   PreviousState As Any, _
'   ReturnLength As Long) As Long
'
'Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
  
Public Sub Command1_Click()

   Dim uflags As Long
   Dim success As Long
   
   If Option1.Value = True Then uflags = EWX_LOGOFF
   If Option2.Value = True Then uflags = EWX_SHUTDOWN
   If Option3.Value = True Then uflags = EWX_REBOOT
   'If Option4.Value = True Then uflags = EWX_POWEROFF
   
   If Check1.Value = vbChecked Then uflags = uflags Or EWX_FORCE
   If Check2.Value = vbChecked Then uflags = uflags Or EWX_FORCEIFHUNG
   
  'assume success
   success = True
  
  'if running under NT or better,
  'the shutdown privledges need to
  'be adjusted to allow the ExitWindowsEx
  'call. If the adjust call fails on a NT+
  'system, success holds False, preventing shutdown.
   If IsWinNTPlus Then
      success = EnableShutdownPrivledges()
   End If
   If success Then Call ExitWindowsEx(uflags, 0&)
End Sub
  
Private Function EnableShutdownPrivledges() As Boolean
   Dim hProcessHandle As Long
   Dim hTokenHandle As Long
   Dim lpv_la As LUID
   Dim token As TOKEN_PRIVILEGES
   hProcessHandle = GetCurrentProcess()
   If hProcessHandle <> 0 Then
   
     'open the access token associated
     'with the current process. hTokenHandle
     'returns a handle identifying the
     'newly-opened access token
      If OpenProcessToken(hProcessHandle, _
                        (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), _
                         hTokenHandle) <> 0 Then
   
        'obtain the locally unique identifier
        '(LUID) used on the specified system
        'to locally represent the specified
        'privilege name. Passing vbNullString
        'causes the api to attempt to find
        'the privilege name on the local system.
         If LookupPrivilegeValue(vbNullString, _
                                 "SeShutdownPrivilege", _
                                 lpv_la) <> 0 Then
         
           'TOKEN_PRIVILEGES contains info about
           'a set of privileges for an access token.
           'Prepare the TOKEN_PRIVILEGES structure
           'by enabling one privilege.
            With token
               .PrivilegeCount = 1
               .laa.udtLUID = lpv_la
               .laa.dwAttributes = SE_PRIVILEGE_ENABLED
            End With
   
           'Enable the shutdown privilege in
           'the access token of this process.
           'hTokenHandle: access token containing the
           '  privileges to be modified
           'DisableAllPrivileges: if True the function
           '  disables all privileges and ignores the
           '  NewState parameter. If FALSE, the
           '  function modifies privileges based on
           '  the information pointed to by NewState.
           'token:  TOKEN_PRIVILEGES structure specifying
           '  an array of privileges and their attributes.
           '
           'Since were just adjusting to shut down,
           'BufferLength, PreviousState and ReturnLength
           'can be passed as null.
            If AdjustTokenPrivileges(hTokenHandle, _
                                     False, _
                                     token, _
                                     ByVal 0&, _
                                     ByVal 0&, _
                                     ByVal 0&) <> 0 Then
                                     
              'success, so return True
               EnableShutdownPrivledges = True
   
            End If  'AdjustTokenPrivileges
         End If  'LookupPrivilegeValue
      End If  'OpenProcessToken
   End If  'hProcessHandle
End Function
 
Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FRMAPAGAMAQUINA = Nothing
End Sub

Este es el segundo Formulario(FRMCAMBIACLAVE) Con 1 CheckBox 3TextBox 3 Labels y 2 CommandButton y los tres TextBox van indexados en orden

Código:

Private Obj As New ClsRegistry
Private uPassword As String  'password administrador

Private Sub CMDACEPTAR_Click()
  If valida Then Exit Sub
  If Encrip(Trim(TxtClave(0)), Len(Trim(TxtClave(0)))) = uPassword Then
    If Encrip(Trim(TxtClave(2)), Len(Trim(TxtClave(2)))) = Encrip(Trim(TxtClave(1)), Len(Trim(TxtClave(1)))) Then
         Trim (TxtClave(2).Text)
         Grabar_Datos_Admin (Trim(TxtClave(2)))
        MsgBox "Se cambio la contraseña satisfactoriamente", vbInformation, "Mensaje"
        Unload Me
      Else
        MsgBox "Confirmación de contraseña no coincide con la nueva contraseña", vbInformation, "Mensaje"
        Me.TxtClave(2).SetFocus
        Exit Sub
    End If
    Else
     MsgBox "Contraseña anterior incorrecta", vbInformation, "Advertencia"
     Me.TxtClave(0).SetFocus
     Exit Sub
  End If
End Sub

Private Sub CMDCANCELAR_Click()
  Unload Me
End Sub

Private Sub Form_Activate()
  Leer_Datos_Admin
  If Obj.ReadReg("Microsoft\Windows\CurrenVersion\Run", App.EXEName, App.Path & "\" & App.EXEName & ".EXE") Then
     Me.Check1.Value = 1
  Else
     Me.Check1.Value = 0
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set FRMCAMBIACLAVE = Nothing
End Sub


Private Sub Label2_Click()

End Sub

Private Sub TxtClave_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
  If KeyCode = 13 Then SendKeys "{TAB}"
End Sub

Private Sub TxtClave_KeyPress(Index As Integer, KeyAscii As Integer)
  KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Function valida() As Boolean
  If Trim(TxtClave(0)) = "" Then
     MsgBox "Contraseña incorrecta", 0 + 64 + 0, "Mensaje"
     valida = True
     Exit Function
  End If
  If Trim(TxtClave(1)) = "" Then
     MsgBox "Contraseña incorrecta", 0 + 64 + 0, "Mensaje"
     valida = True
     Exit Function
  End If
  If Trim(TxtClave(2)) = "" Then
     MsgBox "Contraseña incorrecta", 0 + 64 + 0, "Mensaje"
     valida = True
     Exit Function
  End If
  valida = False
End Function

Private Sub Grabar_Datos_Admin(Optional ByVal strPassword As Variant)
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry
    
    voObjRegistry.WriteSettings C_APPNAME, "Administrador", "Password", Encrip(Trim(strPassword), Len(Trim(strPassword)))
    
    Set voObjRegistry = Nothing
End Sub

Private Sub Check1_Click()
If Check1.Value = 1 Then
   Obj.AppWriteSettings "Microsoft\Windows\CurrenVersion\Run", App.EXEName, App.Path & "\" & App.EXEName & ".EXE"
Else
   Obj.DeleteKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run"
End If
End Sub

Private Sub Leer_Datos_Admin()
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry
    
    uPassword = voObjRegistry.ReadSettings(C_APPNAME, "Administrador", "Password")
    Set voObjRegistry = Nothing
End Sub

Este es el Tercer Formulario(FRMCERRARSISTEMA) Con 1Label 1TextBox y 2 Commandbutton

Código:

Private uPassword As String  'password administrador
Dim rpta

Private Sub Leer_Datos_Admin()
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry
    
    uPassword = voObjRegistry.ReadSettings(C_APPNAME, "Administrador", "Password")
    Set voObjRegistry = Nothing
End Sub

Private Sub CMDACEPTAR_Click()
    If Encrip(Trim(TxtClave.Text), Len(Trim(TxtClave.Text))) = uPassword Then
        Grabar_Tiempo_Nulo
        nid.cbSize = Len(nid)
        nid.hwnd = Me.hwnd
        nid.uId = vbNull
        Call Shell_NotifyIcon(NIM_DELETE, nid)
        ShowTaskBark
        End
        Else
       rpta = MessageBox(Me.hwnd, "Contraseña Incorrecta", "Advertencia", 0 + 64 + 0)
       TxtClave.SetFocus
       Exit Sub
    End If
End Sub

Private Sub CMDCANCELAR_Click()
    Unload Me
End Sub

Private Sub Form_Activate()
    Me.Top = (Screen.Height - Me.Height) - 450
    Me.Left = (Screen.Width - Me.Width) - 450
End Sub

Private Sub Form_Load()
    Leer_Datos_Admin
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FRMCERRARSISTEMA = Nothing
End Sub

Public Function Grabar_Tiempo_Nulo()
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    Obj.WriteSettings C_APPNAME, "Time", "Time", ""
    Obj.WriteSettings C_APPNAME, "Time", "FechaHora", ""
    Set Obj = Nothing
End Function

Private Sub TxtClave_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then SendKeys "{TAB}"
End Sub

Private Sub TxtClave_KeyPress(KeyAscii As Integer)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Este es el cuarto Formulario(FRMMENSAJE) Con (1TextBox Multilinea,Scroll bar vertical) 1 Commandbutton

Código:

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Activate()
TxtMensaje.Text = UCase(TextoMsje)
TxtMensaje.Refresh
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / 15, _
             Me.Top / 15, Me.Width / 15, _
             Me.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
End Sub

Private Sub Form_Unload(Cancel As Integer)
    TextoMsje = ""
   Set FRMMENSAJE = Nothing
End Sub

Private Sub TxtMensaje_Change()

End Sub

Este es el Quinto Formulario(FRMTIMEREST) Con 3 Labels 1shape 1 Timer

Código:

Dim J As Integer

Private Sub Form_Load()
    Dim lngRegion As Long
    Dim lngReturn As Long
    Dim lngFormWidth As Long
    Dim lngFormHeight As Long
    
    lngFormWidth = (Me.Width / Screen.TwipsPerPixelX) - 50
    lngFormHeight = (Me.Height / Screen.TwipsPerPixelY) - 50
    lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
    lngReturn = SetWindowRgn(Me.hwnd, lngRegion, True)
    SiempreVisible Me, True
    Me.Top = (Screen.Height - Me.Height) / 2
    Me.Left = (Screen.Width - Me.Width) / 2
    LblTime.Caption = Trim(TxtMsgBox)
    J = 0
End Sub

Private Sub Label1_Click()

End Sub

Private Sub Timer1_Timer()
J = J + 1
If J = 5 Then
    Timer1.Interval = 0
    Timer1.Enabled = False
    Unload Me
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    TxtMsgBox = ""
    Set FRMTIMEREST = Nothing
End Sub

Acontinuacion Posteare lo demas Falta Del Cliente (1 Formulario 5 modulos 4 Modulos de clase)

<Codigos del Cliente> Parte 2

Este es el primer Formulario(SLFORM) Con (2 ComboBox Indexados) 6 Labels 2 Frames y (3 Commandbutton Indexados)2 menus 1 picturebox 1 timer 1 textbox 1 winsock

Código:

'Private WithEvents cTmr As CLSResTimer
Private WithEvents cTmr As CTimer
Private Obj As New ClsRegistry
Dim sResolution As Variant    'verifica si se ha alterado la resolucion
Private EntrarRegedit As Boolean
Private uPassword As String
Private TiempoIni As String             'tiempo inicial
Public Tsegundos As Integer               'Segundos del tiempo
Private TsegundosMas As Integer    'Segundos del tiempo Aumentado
Private TiempoReciv As String        'Tiempo enviado por el Servidor
Private EstadoForm As Boolean
Private iTime As String                       'almacena tiempo restante
Private iDate As Variant                     ''contiene hora en que termina tiempo de usuario
Private sDife As Variant                      'diferencia entre de segundos
Private Bandera As Boolean               'para crear parpadea del tiempo restante

Private Type STARTUPINFO
      cb As Long
      lpReserved As String
      lpDesktop As String
      lpTitle As String
      dwX As Long
      dwY As Long
      dwXSize As Long
      dwYSize As Long
      dwXCountChars As Long
      dwYCountChars As Long
      dwFillAttribute As Long
      dwFlags As Long
      wShowWindow As Integer
      cbReserved2 As Integer
      lpReserved2 As Long
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long
End Type

'Valores para dwFlags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESIZE = &H2
Private Const STARTF_USEPOSITION = &H4
Private Const STARTF_USECOUNTCHARS = &H8
Private Const STARTF_USEFILLATTRIBUTE = &H10
Private Const STARTF_RUNFULLSCREEN = &H20        '  se ignora para plataformas que no sean x86
Private Const STARTF_FORCEONFEEDBACK = &H40
Private Const STARTF_FORCEOFFFEEDBACK = &H80
Private Const STARTF_USESTDHANDLES = &H100

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

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

Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
      ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
      lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
'Mover formulario
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private Sub Form_Load()
   If App.PrevInstance = True Then
        MessageBox Me.hwnd, "Ya existe una ejecución de la aplicacion", "Mensaje", 0 + 64 + 0
        End
   End If
   On Error Resume Next
   If Existe_Datos_Admin = "" Then Grabar_Datos_Admin
   'lcdTest.NewLCD Picture1
   Call ExistsIni
   NroPuerto = Trim(Leer_Puerto_Regedit)
   If (NroPuerto = "") Then NroPuerto = LeerPuerto
   If (NroPuerto <> "" And PortInUse(CInt(Trim(NroPuerto)))) Then NroPuerto = LeerPuerto
   Call Listo
   DoEvents
   TiempoIni = 0
   EstadoForm = True
   HideApp True 'descomentar para que se oculte la aplicacion al presionar teclas ctrl+alt+sup
   'Set cTmr = New CLSResTimer
   Set cTmr = New CTimer
    'cTmr.Add "OneTimer", 1000, False
   cTmr.Interval = 1000
   EntrarRegedit = True
End Sub

Private Sub Form_Activate()
  m_Resolucion = GetResolutionScreen()
  If Not EstadoForm Then Exit Sub
  If Not EntrarRegedit Then Exit Sub
  Leer_Datos_Regedit
  EntrarRegedit = False
  LoadSystray
End Sub

Private Sub CmdBoton_Click(Index As Integer)
Leer_Datos_Admin
If Trim(TxtClave.Text) = Trim(uPassword) Then
   Select Case Index
                Case 0
                            If (Val(CboTiempo(0).Text) > 0 Or Val(CboTiempo(1).Text) > 0) Then
                            TiempoReciv = Format(Val(CboTiempo(0).Text), "0#") & ":" & Format(Val(CboTiempo(1).Text), "0#") & ":00"
                            Call IniciaTiempo
                            Else
                            MsgBox "Debe selecciónar un tiempo", vbQuestion + vbCritical, "Enred@do"
                            CboTiempo(1).SetFocus
                            Exit Sub
                            End If
                Case 1
                            FRMCAMBIACLAVE.Show 1
                Case 2
                            FRMAPAGAMAQUINA.Show 1
                Case 3
                            HBTeclas False
                            ShowTaskBark
                            Unload Me
                            End
   End Select
End If
TxtClave.Text = ""
End Sub

Private Sub Form_Unload(Cancel As Integer)
    nid.cbSize = Len(nid)
    nid.hwnd = Me.hwnd
    nid.uId = vbNull
    Call Shell_NotifyIcon(NIM_DELETE, nid)
    Set lcdTest = Nothing
    Set cTmr = Nothing
    Set SLFORM = Nothing
End Sub

Private Sub MNUCERRARSIST_Click()
    FRMCERRARSISTEMA.Show vbModal
End Sub


Private Sub TxtClave_KeyPress(KeyAscii As Integer)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub Winsock1_Close()
    Winsock1.Close
    Winsock1.Listen
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
    'Recibimos una petición de conexión y la aceptamos.
    If Winsock1.State = sckConnected Or Winsock1.State = sckListening Then
       Winsock1.Close
    End If
    Winsock1.Accept requestID
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim Datos As String
    Dim swLanzado As Boolean
    Dim ModoVentana As Integer
    Dim Posicion As Integer
    Dim LongTrozo As Integer
    Dim Cadena As String
    Dim lValDev     As Long
    
    'Han llegado datos por el socket. Vamos a ver qué encontramos.
    Datos = String(bytesTotal, Chr$(0))
    'Recuperamos los datos recibidos.
    Winsock1.GetData Datos
    
    'Aquí interpretamos el montaje que hemos hecho en PrjConexion para saber qué hemos de ejecutar y cómo.
    Posicion = InStr(4, Datos, "#ModoVentana=")
    If Posicion > 0 Then
        LongTrozo = Len(Mid$(Datos, Posicion))
        Posicion = Posicion + 13
        ModoVentana = Val(Mid$(Datos, Posicion))
        Else
        ModoVentana = vbNormalFocus
    End If
    Select Case UCase(Mid$(Datos, 1, 3))
            Case "EA#"
                        On Error Resume Next
'                        swLanzado = ExecCmd(Mid$(Datos, 4, Len(Datos) - LongTrozo - 3), ModoVentana, False)
                        Cadena = Mid(Datos, 4)
                        Cadena = Mid(Cadena, 1, Val(InStr(1, Cadena, "#") - 1))
                        lValDev = ShellExecute(Me.hwnd, "Open", Cadena, "", "", vbNormalFocus)
                        'Contestamos a SocketTalk y le decimos si ha ido bien o no.
                        'La respuesta he preferido darla como string en vez de como boolean porque en el entorno
                        'donde yo voy a emplear Prjconexion no tengo muy claro que reciba correctamente los booleanos.
'                        If swLanzado Then
'                          Winsock1.SendData "Ok"
'                        Else
'                           Winsock1.SendData "NoOk"
'                        End If
            Case "ES#"
                        swLanzado = ExecCmd(Mid$(Datos, 4, Len(Datos) - LongTrozo - 3), ModoVentana, True)

                        'Igual que en el caso asíncrono, contestamos.
                        If swLanzado Then
                           Winsock1.SendData "Ok"
                        Else
                           Winsock1.SendData "NoOk"
                        End If
            Case "TM#" 'Tiempo
                        'Si lo que nos han enviado no es ninguna orden de ejecución (algo que empiece por
                        'EA# o ES#) devolvemos los datos recibidos tal cual. Winsock1.SendData datos
                        TiempoReciv = Trim(Mid(Datos, 4))
                        Call IniciaTiempo
            Case "DH#" 'Tiempo
                        'Deshabilita la maquina haciendo la variable Tsegundos a 0
                        Tsegundos = 0
            Case "MJ#" 'Mensaje de maquina proncipal
                        'Activa el formulario de mensaje del servidor
                        TextoMsje = Trim(Mid(Datos, 4))
                        FRMMENSAJE.Show
            Case "AP#" 'apagar maquina
                        If Trim(Mid(Datos, 4)) = "2" Then
                           FRMAPAGAMAQUINA.Option2.Value = True
                           FRMAPAGAMAQUINA.Check1.Value = 1
                           FRMAPAGAMAQUINA.Command1_Click
                        End If
            Case "IM#" ' Recupera tiempo si se reinicio maquina
                        'Activa el formulario de mensaje del servidor
                        TiempoIni = Trim(Mid(Datos, 4))
    End Select
End Sub

Private Function ExecCmd(cmdline As String, ModoVentana As Integer, swWait As Boolean) As Boolean
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ret As Long
   'Initialize the STARTUPINFO structure:
    start.cb = Len(start)

   'Le decimos que haga caso de lo que indique wShowWindow
    start.dwFlags = STARTF_USESHOWWINDOW

   'Le indicamos el modo en que se abrirá la
   'nueva ventana.
    start.wShowWindow = ModoVentana
        
   'He de reconocer que esto lo he sacado de Microsoft, aunque he añadido cosas de
   'mi cosecha, pues en el ejemplo de MS no explicaba como especificar el modo de
   'presentación de la ventana.

   ' Start the shelled application:
    ret = CreateProcessA(0&, cmdline, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    If ret = 0 Then
       ExecCmd = False
    Else
       ExecCmd = True
       If swWait Then
         'Atención, si la aplicación que lanzamos es el Explorador de Windows no conseguiremos que
         'WaitForSingeObject se espere, sino que actuará como si la aplicación hubiese terminado. No sé
         'por qué, pero si alguien lo averigua me gustará que me lo diga. Sí funciona correctamente con la mayoría de
         'programas, y también con los programas hechos en VB.
         
         'Wait for the shelled application to finish:
          ret = WaitForSingleObject(proc.hProcess, INFINITE)
          ret = CloseHandle(proc.hProcess)
       End If
    End If
End Function

Public Function LlenaDatos()
    For i = 0 To 10
        CboTiempo(0).AddItem i
    Next
    For i = 0 To 4
        CboTiempo(1).AddItem i
    Next
    For i = 6 To 54 Step 6
        CboTiempo(1).AddItem i
    Next
    CboTiempo(0).ListIndex = 0
    CboTiempo(1).ListIndex = 0
End Function

Public Function BloqueaSistema(Estado As Boolean)
If Not Estado Then   'minimizado
   SiempreVisible Me, True
   LblTime.Visible = True
'   Picture1.Visible = True
   LblTexto.Visible = False
   LblFondo.Visible = True
   Frame1.Visible = False
   WindowState = 0 'Normal
   Width = 1580 'Screen.Width * 0.08    ' Establecer el ancho del formulario.
   Height = 300 'Establecer el alto del formulario.
   Left = (Screen.Width - Width) / 2   ' Centrar el formulario horizontalmente.
   Top = 20 ' ARRIBA

   LblFondo.Width = Me.Width
   LblFondo.Height = Me.Height
   LblTime.Height = 220
   LblTime.Width = 1500

'   Picture1.Top = 50
'   Picture1.Left = 53
   
   LblFondo.Top = 0
   LblFondo.Left = 0
   LblTime.Top = 30
   LblTime.Left = 30
   
   If Not IsWinNTPlus Then HBTeclas False 'desbloquea las teclas ctrl+alt+supr
   If IsWinNTPlus Then
       UnHookKeyB     'bloquea teclas ctrl+esc , alt+tab, alt+esc, boton de windows
       ShowTaskBark
   End If
Else    'maximizado
   If Not IsWinNTPlus Then HBTeclas True   'bloquea las teclas ctrl+alt+supr
   If IsWinNTPlus Then
       HookKeyB App.hInstance     'bloquea teclas ctrl+esc , alt+tab, alt+esc, boton de windows
       HideTaskBar
   End If
   SiempreVisible Me, False
   LblTime.Visible = False
   Picture1.Visible = False
   LblFondo.Visible = False
   LblTexto.Visible = True
   Frame1.Visible = True
   WindowState = 2 'maximixado
   LblTexto.Caption = "INTERNET "
   LblTexto.Font.Size = 60
   LblTexto.Left = (Width - LblTexto.Width) / 2 ' Centrar el formulario horizontalmente.
   LblTexto.Top = 2000
   Frame1.Left = (Width - Frame1.Width) / 2 ' Centrar el formulario horizontalmente.
   Frame1.Top = LblTexto.Top + LblTexto.Height + 300
End If
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' al cerrar el formulario, quitar el gancho del teclado
    UnHookKeyB
End Sub

Private Function Leer_Datos_Regedit()
    Leer_Tiempo_Regedit
    If (iTime = "") Then
          Grabar_Tiempo_Nulo
          BloqueaSistema True
          LlenaDatos
          Exit Function
    End If
    iDate = DateAdd("s", DateDiff("s", 0, CDate(iTime)), CDate(iDate))   'contiene hora en que termino tiempo de usuario
    If Now >= CDate(iDate) Then
        Grabar_Tiempo_Nulo
        BloqueaSistema True
        LlenaDatos
        Exit Function
    End If
    
    If (iTime <> "") And (Now < CDate(iDate)) Then
        sDife = DateDiff("s", Now, CDate(iDate))
        TiempoReciv = TiempoRestante(0, Val(sDife))
        IniciaTiempo
    End If
End Function

Private Sub Grabar_Datos_Admin()
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry

    voObjRegistry.WriteSettings C_APPNAME, "Administrador", "Password", Encrip(Trim("ADMIN"), Len(Trim("ADMIN")))
    Set voObjRegistry = Nothing
End Sub

Private Sub Leer_Datos_Admin()
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry

    uPassword = voObjRegistry.ReadSettings(C_APPNAME, "Administrador", "Password")
    uPassword = Desencrip(uPassword, Len(uPassword))
    Set voObjRegistry = Nothing
End Sub

Private Function Existe_Datos_Admin() As String
    Dim voObjRegistry As ClsRegistry
    Set voObjRegistry = New ClsRegistry
    
    Existe_Datos_Admin = voObjRegistry.ReadSettings(C_APPNAME, "Administrador", "Password")
    Set voObjRegistry = Nothing
End Function

Public Function Grabar_Tiempo_Regedit(ByVal strDato As Variant, sDate As Variant)
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    Obj.WriteSettings C_APPNAME, "Time", "Time", Trim(strDato)
    Obj.WriteSettings C_APPNAME, "Time", "FechaHora", Trim(sDate)
    Set Obj = Nothing
End Function

Private Function Leer_Tiempo_Regedit()
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    iTime = Obj.ReadSettings(C_APPNAME, "Time", "Time")
    iDate = Obj.ReadSettings(C_APPNAME, "Time", "FechaHora")
    Set Obj = Nothing
End Function

Public Function Grabar_Tiempo_Nulo()
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    Obj.WriteSettings C_APPNAME, "Time", "Time", ""
    Obj.WriteSettings C_APPNAME, "Time", "FechaHora", ""
    Set Obj = Nothing
End Function

Private Function IniciaTiempo()
    If Not cTmr.Enabled Then cTmr.Enabled = True
    If Val(Tsegundos) > 0 Then
         TsegundosMas = DateDiff("s", TiempoIni, TiempoReciv)
         Tsegundos = Val(Tsegundos) + Val(TsegundosMas)
         TiempoReciv = ""
         Exit Function
    End If
    Tsegundos = Val(DateDiff("s", TiempoIni, TiempoReciv))
    LblTime.Caption = TiempoRestante(0, Tsegundos)
    LblTime.Refresh
    'lcdTest.Caption = LblTime.Caption
    BloqueaSistema False
End Function

Private Sub cTmr_Timer()
   DoEvents
   If Val(Tsegundos) <= 0 Then
        If cTmr.Enabled = True Then cTmr.Enabled = False
        Grabar_Tiempo_Nulo
        sResolution = GetResolutionScreen
        If m_Resolucion <> sResolution Then SetResolutionScreen m_Resolucion
        BloqueaSistema True
        LlenaDatos
        Exit Sub
   End If
   Tsegundos = Tsegundos - 1
   If (Tsegundos = 300) Then FgMsgBox "5"
   If (Tsegundos = 600) Then FgMsgBox "10"
   LblTime.Caption = TiempoRestante(0, Tsegundos)
   Grabar_Tiempo_Regedit Trim(LblTime.Caption), Format(Now, "dd/mm/yyyy hh:mm:ss am/pm")
   LblTime.Refresh
   Me.Picture1.Visible = False
   'lcdTest
   'lcdTest.Caption = LblTime.Caption
End Sub

Private Function FgMsgBox(TextoMsje)
On Error Resume Next
  TxtMsgBox = Trim(TextoMsje)
  FRMTIMEREST.Show vbModal
  TxtMsgBox = ""
  MousePointer = vbDefault
End Function

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim Result, Action As Long
    
    'there are two display modes and we need to find out
    'which one the application is using
    
    If Me.ScaleMode = vbPixels Then
        Action = X
    Else
        Action = X / Screen.TwipsPerPixelX
    End If
    
Select Case Action
    Case WM_LBUTTONDBLCLK 'Left Button Double Click
    Case WM_RBUTTONUP 'Right Button Up
        PopupMenu MNU
    End Select
End Sub

Private Sub LoadSystray()
        Me.Show
        Me.Refresh
        With nid 'with system tray
            .cbSize = Len(nid)
            .hwnd = Me.hwnd
            .uId = vbNull
            .uflags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
            .uCallBackMessage = WM_MOUSEMOVE
            .hIcon = Me.Icon 'use form's icon in tray
            .szTip = "SISCAB - CABINET" & vbNullChar 'tooltip text
        End With
    Shell_NotifyIcon NIM_ADD, nid 'add to tray
End Sub

Private Sub LblTime_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
DoEvents
If Button = 1 Then 'si es el botón izquierdo
   Call ReleaseCapture
   lngReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift And KeyCode = vbKeyF9 Then
   MsgBox "IP : " & Winsock1.LocalIP & Chr(13) & "Nombre Maquina: " & Winsock1.LocalHostName & Chr(13) & "Puerto : " & Me.Winsock1.LocalPort, vbInformation, "Mensaje"
End If
End Sub

Comenzamos con los modulos del cliente / Primer Modulo (MODBLOQTECLAS)

Código:

'------------------------------------------------------------------------------
' Para bloquear algunas teclas en Windows NT/2000/XP                (08/Mar/03)
' Para NT debe tener el SP3 como mínimo
'
' ¡¡¡ NO FUNCIONA para Ctrl+Alt+Supr !!!
'
' En este ejemplo se bloquean las siguientes teclas:
'   Ctrl+Esc, Alt+Tab y Alt+Esc
'
' ©Guillermo 'guille' Som, 2003
'------------------------------------------------------------------------------
Option Explicit

' para guardar el gancho creado con SetWindowsHookEx
Private mHook As Long

'
' para indicar a SetWindowsHookEx que tipo de gancho queremos instalar
Private Const WH_KEYBOARD_LL As Long = 13&
' este es para el ratón
'Private Const WH_MOUSE_LL As Long = 14&
'
Private Type tagKBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
'
Private Const VK_TAB As Long = &H9
Private Const VK_CONTROL As Long = &H11     ' tecla Ctrl
'Private Const VK_MENU As Long = &H12        ' tecla Alt
Private Const VK_ESCAPE As Long = &H1B
'Private Const VK_DELETE As Long = &H2E      ' tecla Supr (Del)
Private Const VK_WIMENU As Long = &H5B
Private Const VK_TASKBAR As Long = 32

Private Const LLKHF_ALTDOWN As Long = &H20&
'
' códigos para los ganchos (la acción a tomar en el gancho del teclado)
Private Const HC_ACTION As Long = 0&


'-----------------------------
' Funciones del API de Windows
'-----------------------------

' para asignar un gancho (hook)
Private 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

' para quitar el gancho creado con SetWindowsHookEx
Private Declare Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As Long) As Long

' para llamar al siguiente gancho
Private Declare Function CallNextHookEx Lib "user32" _
    (ByVal hHook As Long, ByVal nCode As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

' para saber si se ha pulsado en una tecla
Private Declare Function GetAsyncKeyState Lib "user32" _
    (ByVal vKey As Long) As Integer

' para copiar la estructura en un long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)

' La función a usar para el gancho del teclado
Public Function LLKeyBoardProc(ByVal nCode As Long, _
                               ByVal wParam As Long, _
                               ByVal lParam As Long _
                               ) As Long
    Dim pkbhs As tagKBDLLHOOKSTRUCT
    Dim ret As Long
    '
    ret = 0
    '
    ' copiar el parámetro en la estructura
    CopyMemory pkbhs, ByVal lParam, Len(pkbhs)
    '
    If nCode = HC_ACTION Then
        '
        ' si se pulsa Ctrl+Esc
        If pkbhs.vkCode = VK_ESCAPE Then
            If (GetAsyncKeyState(VK_CONTROL) And &H8000) Then
                ret = 1
            End If
        End If
        '
        ' si se pulsa Alt+Tab
        If pkbhs.vkCode = VK_TAB Then
            If (pkbhs.flags And LLKHF_ALTDOWN) <> 0 Then
                ret = 1
            End If
        End If
        '
        ' si se pulsa Alt+Esc
        If pkbhs.vkCode = VK_ESCAPE Then
            If (pkbhs.flags And LLKHF_ALTDOWN) <> 0 Then
                ret = 1
            End If
        End If
        
        'SI SE PULSA TECLA WINDOWS
        If pkbhs.vkCode = VK_WIMENU Then
            ret = 1
        End If
        
         If pkbhs.vkCode = VK_TASKBAR Then
            ret = 1
        End If
        
    End If
    '
    If ret = 0 Then
        ret = CallNextHookEx(mHook, nCode, wParam, lParam)
    End If
    LLKeyBoardProc = ret
End Function

Public Sub HookKeyB(ByVal hMod As Long)
    ' instalar el gancho para el teclado
    ' hMod será el valor de App.hInstance de la aplicación
    mHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LLKeyBoardProc, hMod, 0&)
End Sub

Public Sub UnHookKeyB()
    ' desinstalar el gancho para el teclado
    ' Es importante hacerlo antes de finalizar la aplicación,
    ' normalmente en el evento Unload o QueryUnload
    If mHook <> 0 Then
        UnhookWindowsHookEx mHook
    End If
End Sub

Segundo modulo (MODSYSTRAY)

Código:

'------------ variables de resolucion de pantalla ---------------------------'
Public m_Resolucion As Variant  ' almacena resolucion original
Public mResAlto As Long
Public mResAncho As Long
Public mResBits As Long
Public DevM As DevMode

' API para cambiar la resolución de la pantalla
Public Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
    (lpDevMode As Any, ByVal dwFlags As Long) As Long

' API para saber los formatos de resoluciones posibles
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
    (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, _
    lpDevMode As DevMode) As Boolean

Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
'Las declaraciones de estas constantes están en: Wingdi.h
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000

Const ENUM_CURRENT_SETTINGS As Long = -1&
Const ENUM_REGISTRY_SETTINGS As Long = -2&

Private Type tResol
    Width As Long
    Height As Long
    Bits As Integer
End Type

Public Type DevMode
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    '
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    '
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
'----------------------------------------------------------------------------------------------'
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uflags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Public Const NIM_ADD = &H0 'Add to Tray
Public Const NIM_MODIFY = &H1 'Modify Details
Public Const NIM_DELETE = &H2 'Remove From Tray
Public Const NIF_MESSAGE = &H1 'Message
Public Const NIF_ICON = &H2 'Icon
Public Const NIF_TIP = &H4 'TooTipText
Public Const WM_MOUSEMOVE = &H200 'On Mousemove
Public Const WM_LBUTTONDOWN = &H201 'Left Button Down
Public Const WM_LBUTTONUP = &H202 'Left Button Up
Public Const WM_LBUTTONDBLCLK = &H203 'Left Double Click
Public Const WM_RBUTTONDOWN = &H204 'Right Button Down
Public Const WM_RBUTTONUP = &H205 'Right Button Up
Public Const WM_RBUTTONDBLCLK = &H206 'Right Double Click

Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
      
Public nid As NOTIFYICONDATA

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Function GetSysDir() As String
    Dim Temp As String * 256
    Dim X As Integer
    X = GetSystemDirectory(Temp, Len(Temp)) ' Make API Call (Temp will hold return value)
    GetSysDir = Left$(Temp, X)              ' Trim Buffer and return string
End Function

Function CrearIni()
    Dim nFreeFile As Long
    Dim sDir As String

    nFreeFile = FreeFile
    sDir = GetSysDir + "\PUERTOS.INI"
    Open sDir For Output As #nFreeFile
        For i = 1066 To 5066
            Print #nFreeFile, Trim$(i)
        Next i
    Close #nFreeFile
End Function

Function LeerPuerto() As String
    Dim nFreeFile As Long
    Dim sDir As String
    Dim xPort As String
    
    sDir = GetSysDir + "\Puertos.ini"
    nFreeFile = FreeFile
    
    Open sDir For Input As #nFreeFile
        Do While Not EOF(nFreeFile)
            Line Input #nFreeFile, xPort
            If Not PortInUse(Trim(xPort)) Then
                Grabar_Puerto_Regedit Trim((xPort))
                MsgBox "Nro de Puerto a usar : " + xPort
                Exit Do
            End If
        Loop
    Close #nFreeFile
    LeerPuerto = Trim(xPort)
End Function

Function ExistsIni()
    Dim sDir As String
    sDir = GetSysDir + "\PUERTO.INI"
    
    If Not DirExists(sDir) Then
        CrearIni
        Exit Function
    End If
End Function

Public Function Leer_Puerto_Regedit()
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    Leer_Puerto_Regedit = Obj.ReadSettings(C_APPNAME, "Puerto", "Puerto")
    Set Obj = Nothing
End Function

Private Function Grabar_Puerto_Regedit(ByVal iPuerto As String)
    Dim Obj As ClsRegistry
    Set Obj = New ClsRegistry
    
    Obj.WriteSettings C_APPNAME, "Puerto", "Puerto", Trim(iPuerto)
    Set Obj = Nothing
End Function

Public Function DirExists(ByVal sDirName As String) As Boolean
    Dim sDir As String
    On Error Resume Next

    DirExists = False
    sDir = Dir$(sDirName, vbDirectory)
    If (Len(sDir) > 0) And (Err = 0) Then
        DirExists = True
    End If
End Function

Public Function GetResolutionScreen() As Variant
    DevM.dmSize = Len(DevM)
    Call EnumDisplaySettings(0&, ENUM_CURRENT_SETTINGS, DevM)
    mResAncho = DevM.dmPelsWidth
    mResAlto = DevM.dmPelsHeight
    mResBits = DevM.dmBitsPerPel
    GetResolutionScreen = CStr(mResAncho) + " x " + CStr(mResAlto) + " x " + CStr(mResBits)
End Function

Public Function SetResolutionScreen(ByVal sResol As String)
    'Si sólo se quiere cambiar la resolución,
    'manteniendo los colores:
    Dim xCad As String
    Dim iWidth As Variant
    Dim iHeight As Variant
    Dim iBits As Variant
    xCad = Trim$(sResol)
    iWidht = Trim(Mid(xCad, 1, Val(Trim$(InStr(1, xCad, "x"))) - 1))
    iHeight = Trim(Mid(xCad, Len(iWidht) + 4, Val(Trim$(InStr(1, xCad, "x"))) - 1))
    iBits = Right(xCad, 2)
    
    xCad = ""
    
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
    'Si se quiere cambiar también los colores
    DevM.dmFields = DevM.dmFields Or DM_BITSPERPEL
   
    DevM.dmPelsWidth = iWidht
    DevM.dmPelsHeight = iHeight
    DevM.dmBitsPerPel = iBits
    
    Call ChangeDisplaySettings(DevM, 0)
End Function

Tercer modulo (MODVIEWFORM)

Código:

' Este módulo fue creado por PcBike a partir del ejemplo "CallDlls" de Microsoft Visual Basic 5.0
Option Explicit

Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40

' Esta rutina vuelve "SiempreVisible" a 'Formulario' si Estado es verdader, y le quita esta propiedad si Estado es Falso
Public Sub SiempreVisible(Formulario As Form, Estado As Boolean)
    
    If Estado Then
       SetWindowPos Formulario.hwnd, HWND_TOPMOST, Formulario.Left / 15, _
                    Formulario.Top / 15, Formulario.Width / 15, _
                    Formulario.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
    Else
       SetWindowPos Formulario.hwnd, HWND_NOTOPMOST, Formulario.Left / 15, _
                    Formulario.Top / 15, Formulario.Width / 15, _
                    Formulario.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
    End If

End Sub

Cuarto modulo (MODWINTXP)

Código:

Option Explicit
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName _
             As String, ByVal lpWindowName As String) As Long
Global Ventana As Long
Global Const Muestra = &H40
Global Const Oculta = &H80

Public Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Public Const TOKEN_QUERY As Long = &H8
Public Const SE_PRIVILEGE_ENABLED As Long = &H2

Public Const EWX_LOGOFF As Long = &H0
Public Const EWX_SHUTDOWN As Long = &H1
Public Const EWX_REBOOT As Long = &H2
Public Const EWX_FORCE As Long = &H4
Public Const EWX_POWEROFF As Long = &H8
Public Const EWX_FORCEIFHUNG As Long = &H10 '2000/XP only

Public Const VER_PLATFORM_WIN32_NT As Long = 2

Public Type OSVERSIONINFO
  OSVSize         As Long
  dwVerMajor      As Long
  dwVerMinor      As Long
  dwBuildNumber   As Long
  PlatformID      As Long
  szCSDVersion    As String * 128
End Type

Public Type LUID
   dwLowPart As Long
   dwHighPart As Long
End Type

Public Type LUID_AND_ATTRIBUTES
   udtLUID As LUID
   dwAttributes As Long
End Type

Public Type TOKEN_PRIVILEGES
   PrivilegeCount As Long
   laa As LUID_AND_ATTRIBUTES
End Type
      
Public Declare Function ExitWindowsEx Lib "user32" _
   (ByVal dwOptions As Long, _
   ByVal dwReserved As Long) As Long

Public Declare Function GetCurrentProcess Lib "kernel32" () As Long

Public Declare Function OpenProcessToken Lib "advapi32" _
  (ByVal ProcessHandle As Long, _
   ByVal DesiredAccess As Long, _
   TokenHandle As Long) As Long

Public Declare Function LookupPrivilegeValue Lib "advapi32" _
   Alias "LookupPrivilegeValueA" _
  (ByVal lpSystemName As String, _
   ByVal lpName As String, _
   lpLuid As LUID) As Long

Public Declare Function AdjustTokenPrivileges Lib "advapi32" _
  (ByVal TokenHandle As Long, _
   ByVal DisableAllPrivileges As Long, _
   NewState As TOKEN_PRIVILEGES, _
   ByVal BufferLength As Long, _
   PreviousState As Any, _
   ReturnLength As Long) As Long

Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Public Function IsWinNTPlus() As Boolean
  'returns True if running Windows NT,
  'Windows 2000, Windows XP, or .net server
   #If Win32 Then
      Dim OSV As OSVERSIONINFO
      OSV.OSVSize = Len(OSV)
      If GetVersionEx(OSV) = 1 Then
         IsWinNTPlus = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And _
                      (OSV.dwVerMajor >= 4)
      End If
   #End If
End Function

'Oculta la barra de tareas
Public Function HideTaskBar()
    Ventana = FindWindow("Shell_traywnd", "")
    SetWindowPos Ventana, 0, 0, 0, 0, 0, Oculta
End Function

'Muestra la barra de tareas
Public Function ShowTaskBark()
    SetWindowPos Ventana, 0, 0, 0, 0, 0, Muestra
End Function

Quinto modulo (MTimer)

Código:

Option Explicit

Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

'each timer class registers an obj instance in this collection
'key= "id:" & timerID , item = reference to live class object
Public timers As New Collection

'each CTimers class registers itself by its class key here
'key= "key:" & intID , item = reference to live class object
Public CTimersCol As New Collection

Private mTimersColCount As Integer

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
              ByVal idEvent As Long, ByVal dwTime As Long)
    
    Dim t As CTimer
    Dim c As CTimers
    
    On Error Resume Next
    Set t = timers("id:" & idEvent)
    If t Is Nothing Then
        KillTimer 0&, idEvent
    Else
        If t.ParentsColKey > 0 Then  'this timer is an index in CTimers
            Set c = CTimersCol("key:" & t.ParentsColKey)
            If c Is Nothing Then
                 KillTimer 0&, idEvent
                 Debug.Print "THIS SHOULDNT HAPPEN: parent collection died?"
            Else
                'raise the event in the parent collection class instead of timer class
                c.RaiseTimer_Event t.Index
            End If
        Else
            t.RaiseTimer_Event
        End If
    End If
    Set t = Nothing
    
End Sub

'returns key to this class in collection
Function RegisterTimerCollection(c As CTimers) As Integer
    Dim key As String

    mTimersColCount = mTimersColCount + 1
    key = "key:" & mTimersColCount 'will always be unique because counting
    CTimersCol.Add c, key
    RegisterTimerCollection = mTimersColCount

End Function

Del Cliente Falta 1 modulo y 4 De clase Posteados posteriormente