Programación

Visual Basic

Cronómetro

Última actualización: 21-10-2017 16:15

Cuando lo necesite no encontré uno a mano, entonces me lo fabriqué...

Índice

• Notas preliminares
• Código fuente
  • Módulo M_Gral
  • Formulario FChronos
  • Formulario FSplash
• Descarga de ejecutable y código fuente

Notas preliminares

Está desarrollado en VB6 utilizando algunas funciones del API:

• GetTickCount
  Devuelve la cantidad de milisegundos transcurridos desde el el arranque del sistema operativo.
• SetWindowPos
  Permite poner una ventana por encima de cualquier otra.
• ShellExecute
  Sirve para ejecutar comandos. Se utiliza para abrir el navegador al dar click sobre el enlace a este sitio web.

Para hacer menos complejo este ejemplo el código ha quedado distribuido en 3 archivos:

• Módulo M_Gral
  Funciones y procedimientos generales.
• Formulario FChronos
  El cronómetro.
• Formulario frmSplash
  La ventana de presentación que expongo por si a alguien quiere saber como se ha conseguido ese comportamiento.

Código fuente

Módulo M_Gral

Option Explicit

'****************************************************************
' Para poner un formulario por encima de cualquier otra ventana
'****************************************************************
Private Declare Function SetWindowPos Lib "user32" ( _
            ByVal hwnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal X As Long, _
            ByVal Y As Long, _
            ByVal cx As Long, _
            ByVal cy As Long, _
            ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40

Private Const SWP_FLAGS = SWP_NOMOVE _
                            Or SWP_NOSIZE _
                            Or SWP_SHOWWINDOW _
                            Or SWP_NOACTIVATE

Public Sub Put_Window_On_Top(FormX As Form)
    If SetWindowPos(FormX.hwnd, -1, 0, 0, 0, 0, SWP_FLAGS) Then
    End If
End Sub

'Verificación de caracter de cierre de formulario.  (El ASCII 27 es «ESC»)
Public Function KeyToExit(ByVal KeyAscii As Integer) As Boolean
    KeyToExit = (KeyAscii = 27)
End Function

'Rutina que se ejecuta en común para todos los formularios en el evento Load
Public Sub CommonToForms(F As Form)
    If F.Name <> "FChronos" Then F.Icon = FChronos.Icon
    F.Caption = App.Title
    F.KeyPreview = True
End Sub

'Llamada a formulario de inicio
Public Sub Main()
    FChronos.Show
End Sub

Formulario FChronos

Option Explicit

'Función que devuelve en milisegundos cuanto ha transcurrido desde
'que se inicio el sistema operativo
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Inicio As Long  'Para marcar cuando se inicio el cronómetro
Private iLast As Long   'Para marcar cuanto iba antes de detener el cronómetro

'Los botones:
Private Sub cmd_Click(Index As Integer)
    Select Case Index
        Case 0 'Iniciar/detener cronómetro
            If cmd(Index).Caption = "&Iniciar" Then
                    cmd(Index).Caption = "&Parar"
                    If Inicio = -1 Then
                                Inicio = GetTickCount()
                            Else
                                Inicio = GetTickCount() - iLast
                    End If
                    iLast = Inicio
                    Timer1.Enabled = True
                Else
                    cmd(Index).Caption = "&Iniciar"
                    Timer1.Enabled = False
            End If
            CambiarEtiqueta

        Case 1 'Poner tiempo a cero
            Inicio = GetTickCount()
            iLast = 0
            CambiarEtiqueta

        Case 2 'Acerca de...
            frmSplash.ShowAbout

        Case 3 'Final de programa
            End
    End Select
End Sub

'Carga del formulario
Private Sub Form_Load()
    CommonToForms Me
    frmSplash.ShowAbout 2
    Inicio = -1
End Sub

'Para poner la ventana encima de todas, se utiliza el API en los
'eventos Activate, Deactivate y Lostfocus del formulario
Private Sub Form_Activate()
    Put_Window_On_Top Me
End Sub

Private Sub Form_Deactivate()
    Put_Window_On_Top Me
End Sub

Private Sub Form_LostFocus()
    Put_Window_On_Top Me
End Sub

'Si se presiona ESC se detiene el cronómetro si esta corriendo
'o se sale del programa si no.
Private Sub Form_KeyPress(KeyAscii As Integer)
    If Not KeyToExit(KeyAscii) Then Exit Sub
    If Timer1.Enabled Then cmd_Click 0 Else cmd_Click 3
End Sub

'Se impide el cambio de dimensiones de la ventan por cuestió de estética
Private Sub Form_Resize()
    If Not Me.WindowState = vbNormal Then Exit Sub
    On Error Resume Next
        Me.Width = 4515
        Me.Height = 1710
End Sub

'Si el cronómetro esta corriendo, se anula la orden de cerrar el programa
Private Sub Form_Unload(Cancel As Integer)
    If Timer1.Enabled Then Cancel = 1
End Sub

'Cada milisegundo en el que el timer este activo se cambia el
'contenido de las etiquetas
Private Sub Timer1_Timer()
    CambiarEtiqueta
End Sub

'Cambia el contenido de las etiquetas
Private Sub CambiarEtiqueta()
Dim Milliseconds As Long

    If Timer1.Enabled Then
            Milliseconds = GetTickCount() - Inicio
            iLast = Milliseconds
        Else
            Milliseconds = iLast
    End If

    Label1.Caption = GetTimeFormat(Milliseconds)
    Label2.Caption = "." & ForzarLongitud(CStr(Milliseconds Mod 1000), 3)

End Sub

'Devuelve los milisegundos en formato HH:mm:ss
Private Function GetTimeFormat(ByVal xMilliseconds As Long) As String
Dim xSeconds As Long
    xSeconds = xMilliseconds \ 1000
    GetTimeFormat = ForzarLongitud(CStr((xSeconds \ 60) \ 60))
    GetTimeFormat = GetTimeFormat & ":" & ForzarLongitud(CStr((xSeconds \ 60) Mod 60))
    GetTimeFormat = GetTimeFormat & ":" & ForzarLongitud(CStr(xSeconds Mod 60))
End Function

'Obliga la longitud de una cadena con el "relleno" a la izquierda
Private Function ForzarLongitud(ByVal vData As String, _
                                    Optional ByVal Longitud As Integer = 2, _
                                    Optional ByVal Relleno As String = "0") As String

    ForzarLongitud = Right(Replace(Space(Longitud), " ", Relleno) & vData, Longitud)
End Function

Formulario FSplash

Option Explicit

'Para levantar el navegador al hacer click sobre www.xpcid.com
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long

Private NSeconds As Integer
Private i As Integer

Private Sub OpenX(ByVal PFN As String, hwnd As Long)
    On Error GoTo e_Msg
        ShellExecute hwnd, "open", PFN, "", "", 4
        Exit Sub
e_Msg:
        MsgBox Err.Description & Chr(10) & Chr(10) & "#: " & Err.Number
        Resume Next
End Sub



Private Sub Form_KeyPress(KeyAscii As Integer)
    Unload Me
End Sub

Private Sub Form_Load()
    lblVersion.Width = imgLogo.Width
    Screen.MouseIcon = Label1.MouseIcon
    lblVersion.BackColor = &HEAEAEA
    Label1.BackColor = &HEAEAEA
    lblVersion.Caption = "Versión " & App.Major & "." & App.Minor & "." & App.Revision
End Sub

Private Sub Frame1_Click()
    Unload Me
End Sub

Private Sub Form_Terminate()
    Screen.MousePointer = vbNormal
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Screen.MousePointer = vbNormal
End Sub

Private Function IsInCoordinates(ByVal CX1 As Long, ByVal CY1 As Long, _
                                ByVal CX2 As Long, ByVal CY2 As Long, _
                                ByVal X As Long, ByVal Y As Long) As Boolean

    IsInCoordinates = (X >= CX1 And X <= CX2 And Y >= CY1 And Y <= CY2)
End Function


Private Sub imgLogo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If IsInCoordinates(150, 195, 1695, 585, X, Y) _
        Or IsInCoordinates(168, 825, 2145, 975, X, Y) Then
            Screen.MousePointer = vbCustom
        Else
            Screen.MousePointer = vbNormal
    End If
End Sub

Private Sub imgLogo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)


    If Not Button = 1 Then Exit Sub
    If Screen.MousePointer = vbNormal Then
            Form_KeyPress 0
        Else
            OpenX "http://www.xpcid.com", FChronos.hwnd

    End If

End Sub

Private Sub lblVersion_Click()
    Form_KeyPress 0
End Sub

Public Sub ShowAbout(Optional ByVal Seconds_ As Integer = 0)
    NSeconds = Seconds_
    If NSeconds > 0 Then Timer1.Enabled = True
    Me.Show 1
End Sub

Private Sub Timer1_Timer()
    i = i + 1
    If i >= NSeconds Then Unload Me
End Sub

Descarga de ejecutable y código fuente

Código fuente , Ejecutable