Compteur internet

Soyez le premier à donner votre avis sur cette source.

Vue 19 458 fois - Téléchargée 1 258 fois

Télécharger le projet

Commenter

Description

Un petit compteur internet sympa sans fonctions superflues.
Des améliorations seront surement apportées plus tard.
Voila les sources qu'on me demandait. Y a beaucoup d'objets donc il vaut mieux télécharger le ZIP. La DECO AUTOMATIQUE est arrivée :
Instructions :
Placer sur le Form :
- 3 comboBox : Cboavert, Cboforfait, Cbotarif
- 2 boutons : Command1 et Command2
- 1 Frame : Framepayer dans lequel vous placerez : 4 labels : Labelfrancs(0), Labelfrancs(1), Label4(0), Label4(1)
- 1 Image : Image 1
- 17 labels : Label1, Label2, Lbl11, Lbl12, Lbl21, Lbl22, Lbl31,Lbl32, Lbl4, Lbldeconnect, LbldurmoisN, LbldurmoisR, Lble, Lblmois, Lblsecu, Lbltype, Lblvia
- 2 TextBox : Textconnect, Txtavert
- 3 timer :Timer, Timerconnect, Timersecu
Créer 3 menus : - Menu et 3 sous-menu : mnuaffich, mnuapropos, mnuquit
- Mnuopt et 4 sous-menu : mnumois, mnuenr, mnudemar, mnusecu
- Mnured
Donner la propriété Style = 2 aux 3 ComboBox
Copier le code à l'endroit précisé
S'il y a des problèmes dans les compteur mettez Heure comme propriété DataFormat des Label Lbl12, Lbl22, Lbl32, LbldurmoisN, LbldurmoisR

Source / Exemple :

'DANS LE FORM
Private Type IconeTray
    cbSize As Long      'Taille de l'icône (en octets)
    hwnd As Long        'Handle de la fenêtre chargée de recevoir les messages envoyés lors des évènements sur l'icône (clics, doubles-clics...)
    uID As Long         'Identificateur de l'icône
    uFlags As Long
    uCallbackMessage As Long    'Messages à renvoyer
    hIcon As Long               'Handle de l'icône
    szTip As String * 64        'Texte à mettre dans la bulle d'aide
End Type
Dim IconeT As IconeTray

'Constantes nécessaires
Private Const AJOUT = &H0
Private Const MODIF = &H1
Private Const SUPPRIME = &H2
Private Const MOUSEMOVE = &H200
Private Const MESSAGE = &H1
Private Const Icone = &H2
Private Const TIP = &H4

Private Const DOUBLE_CLICK_GAUCHE = &H203
Private Const BOUTON_GAUCHE_POUSSE = &H201
Private Const BOUTON_GAUCHE_LEVE = &H202
Private Const DOUBLE_CLICK_DROIT = &H206
Private Const BOUTON_DROIT_POUSSE = &H204
Private Const BOUTON_DROIT_LEVE = &H205

'API nécessaire
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As IconeTray) As Boolean
Private Declare Function InternetDial Lib "wininet.dll" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As String, ByRef pldwConnection As String, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long

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 HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Private Sub RendreFormTjsVisible(MonForm As Object)
    SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

Private Sub Cboforfait_Click()
'Affichage des images en fonction des forfaits
Select Case Cboforfait.Text
Case "AOL"
    Set Img = LoadPicture(App.Path & "\aol.gif")
Case "France Explorer"
    Set Img = LoadPicture(App.Path & "\frexpl.gif")
Case "Freesbee"
    Set Img = LoadPicture(App.Path & "\freesbee.gif")
Case "Infonie"
    Set Img = LoadPicture(App.Path & "\infonie.gif")
Case "Wanadoo"
    Set Img = LoadPicture(App.Path & "\wanadoo.gif")
Case "World On Line"
    Set Img = LoadPicture(App.Path & "\wol.gif")
End Select
Image1.Picture = Img
End Sub

Private Sub Cbotarif_Click()
If Cbotarif.Text = "Local" Then
    'mise a jour du prix mensuel
    mois = LbldurmoisN.Caption
    tps = Hour(mois) * 3600 + Minute(mois) * 60 + Second(mois)
    Lblfrancs(1).Caption = Round(0.00233333 * tps, 2)
        
    Set Img = LoadPicture() 'Efface l'emplacement de l'image
    Image1.Picture = Img
    Cboforfait.Visible = False
    Cboavert.Locked = False
    Framepayer.Visible = True
ElseIf Cbotarif.Text = "Forfait" Then
    Cboforfait.Visible = True
    Cboavert.Text = "Heures"
    Cboavert.Locked = True
    Framepayer.Visible = False
End If
End Sub

Private Sub Command2_Click()
'Si form petit => agrandissement
If Form1.Width = 4770 Then
    For i = 0 To 100
    Form1.Width = Form1.Width + 50
    Form1.Left = Form1.Left - 25
    Next i
    Command2.Caption = "Mode réduit :"
'Si form grand => rétrécissement
ElseIf Form1.Width = 9820 Then
    confirm = MsgBox("Etes-vous sûr de vouloir revenir en mode réduit et de désactiver l'avertissement ?", vbExclamation + vbYesNo + vbDefaultButton2, "Retourner en mode réduit ?")
    If confirm = vbNo Then Exit Sub
    For i = 0 To 100
    Form1.Width = Form1.Width - 50
    Form1.Left = Form1.Left + 25
    Next i
    Command2.Caption = "Mode complet :"
    Txtavert.Text = ""
End If
End Sub

Private Sub Form_Activate()

'Cboavert.ListIndex = 1
'Lecture dans le registre pour savoir si mnudemar doit etre coché ou non
demar = getstring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", "CompteurInternet")
If demar = "" Then mnudemar.Checked = False
mnumois.Checked = True
'\/\/\/\/\/\/\/ A ENREGISTRER DANS CONNECT.TPS \/\/\/\/\/\/\/
mnusecu.Checked = False
Timersecu.Enabled = False

'Recherche du fichier de sauvegarde
If Dir$(App.Path & "\connect.tps") <> vbNullString Then
'LECTURE DU FICHIER DE SAUVEGARDE
Open App.Path & "\connect.tps" For Input As #1
Input #1, duree$
Input #1, mois
Input #1, aspect$
Input #1, secu$
LbldurmoisN.Caption = duree$
If secu$ = "SECU=OUI" Then mnusecu.Checked = True
'Lecture de l'aspect du compteur si demandé
If aspect$ = "ASPECT=OUI" Then
    Input #1, cmd2$
    Input #1, tarif%
Command2.Caption = cmd2$
Cbotarif.ListIndex = tarif%
mnuenr.Checked = True

    If tarif% = 0 Then
        Input #1, Comboavert%
    Cboavert.ListIndex = Comboavert%
    Else
        Input #1, forfait%
    Cboforfait.ListIndex = forfait%
    End If
Input #1, Avert$
Txtavert.Text = Avert$
End If
Close #1
Else
End If

If Command2.Caption = "Mode complet :" Then
    Form1.Width = 4770
ElseIf Command2.Caption = "Mode réduit :" Then
    Form1.Width = 9820
End If

'Si on a changé de mois on remet le compteur à zéro
If Month(Date) <> mois Then
    LbldurmoisN.Caption = "00:00:00"
    LbldurmoisR.Caption = "00:00:00"
Else
LbldurmoisN.Caption = duree
LbldurmoisR.Caption = duree
End If
'Conversion du mois chiffre en lettre avec changement du "de" ou "d'"

Select Case Month(Date)
    Case 1
        Lble.Caption = "e"
        mois = " Janvier"
    Case 2
        Lble.Caption = "e"
        mois = " Février"
    Case 3
        Lble.Caption = "e"
        mois = " Mars"
    Case 4
        Lblmois.Left = 1850
        Lble.Caption = "'"
        mois = "Avril"
    Case 5
        Lble.Caption = "e"
        mois = " Mai"
    Case 6
        Lble.Caption = "e"
        mois = " Juin"
    Case 7
        Lble.Caption = "e"
        mois = " Juillet"
    Case 8
        Lble.Caption = "'"
        mois = "Août"
    Case 9
        Lble.Caption = "e"
        mois = " Septembre"
    Case 10
        Lble.Caption = "'"
        mois = "Octobre"
    Case 11
        Lble.Caption = "e"
        mois = " Novembre"
    Case 12
        Lble.Caption = "e"
        mois = " Décembre"
End Select
Lblmois.Caption = mois
End Sub

Private Sub Form_Load()
Call InitForm
If App.PrevInstance Then
MsgBox "L'application est déjà lancée", vbCritical, "Erreur..."
End
End If
RendreFormTjsVisible (Form1)
'Préparation de la variable IconeT
IconeT.cbSize = Len(IconeT) 'Taille de l'icône en octet
IconeT.hwnd = Me.hwnd       'Handle de l'application (pour qu'elle reçoive les messages envoyés lors d'un clic, double-clic...
IconeT.uID = 1&             'Identificateur de l'icône
IconeT.uFlags = Icone Or TIP Or MESSAGE
IconeT.uCallbackMessage = MOUSEMOVE     'Renvoyer les messages concernant l'action de la souris
IconeT.hIcon = Form1.Icon   'Mettre en icône l'icone du Form
IconeT.szTip = "Compteur Internet" & Chr$(0)    'Texte de la bulle d'aide

'Appel de la fonction pour mettre l'icône dans le système tray
Shell_NotifyIcon AJOUT, IconeT

Me.Hide     'Cache la fenêtre
App.TaskVisible = False     'Retire le bouton de l'application de la barre
                            'des tâches
    

End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Static rec As Boolean, msg As Long

'Se produit lorsque l'utilisateur agit avec la souris sur
'l'icône placée dans le système tray

msg = x / Screen.TwipsPerPixelX
If rec = False Then
    rec = True
    Select Case msg     'Différentes possibilité d'action
        Case DOUBLE_CLICK_GAUCHE:   'mettez
            mnuaffich.Enabled = False
            Load Me
            Form1.Show (vbNormalFocus)
        Case BOUTON_GAUCHE_POUSSE:  'ce
        Case BOUTON_GAUCHE_LEVE:    'que
        Case DOUBLE_CLICK_DROIT:    'vous
        Case BOUTON_DROIT_POUSSE:   'voudrez
        Case BOUTON_DROIT_LEVE:     'qu'il se passe
            PopupMenu menu, , , , mnuaffich     'fait apparaitre le menu
            
    End Select
    rec = False
End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

'Refait appel à l'API pour retirer l'icône du système tray
'lorsque le programme se ferme, en utilisant cette fois la constante SUPPRIME
'au lieu de AJOUT

IconeT.cbSize = Len(IconeT)
IconeT.hwnd = Me.hwnd
IconeT.uID = 1&
Shell_NotifyIcon SUPPRIME, IconeT

'Enregistrement de la connexion dans le fichier de sauvegarde
Enregistre

End Sub
Private Sub Command1_Click()
If Command1.Caption = "Se connecter" Then
    'se connecte
    Dim lResult As Boolean
    lResult = InternetDial(Me.hwnd, "INTERNET_CONNECTION_MODEM", "INTERNET_AUTODIAL_FORCE_ONLINE", "", 0)
    'If lResult = True Then Command1.Caption = "Se déconnecter"
ElseIf Command1.Caption = "Se déconnecter" Then
    'se déconnecte
    Dim Result As Long
    Result = InternetAutodialHangup(0&)
    Command1.Caption = "Se connecter"
End If
End Sub

Private Sub LbldurmoisR_Change()
'Vérification qu'on dépasse pas la limite de temps fixée
If Cboavert.Text = "Heures" Then
    If Txtavert.Text <> "" Then
        Dim Heures As Date, Avert As Date
        Heures = Val(Txtavert.Text)
        Avert = LbldurmoisR.Caption
        If Hour(Avert) >= Heures Then
            MsgBox "Votre limite fixée à " & Txtavert.Text & " " & Cboavert.Text & " vient d'être atteinte !", vbCritical, "Attention !"
            LbldurmoisR.ForeColor = vbRed
            Txtavert.Text = ""
            If mnuaffich.Enabled = True Then Form1.Show vbNormafocus
        End If
    End If
End If
End Sub

Private Sub Lblfrancs_Change(Index As Integer)
'Vérification qu'on dépasse pas la limite d'heures fixée
If Cboavert.Text = "Francs" Then
    If Txtavert.Text <> "" Then
        Dim Francs As String, Avert As String
        Francs = Lblfrancs(1).Caption
        Avert = Txtavert.Text
        Fr = Val(Francs)
        Av = Val(Avert)
        If Francs >= Avert Then
            MsgBox "Votre limite fixée à " & Txtavert.Text & " " & Cboavert.Text & " vient d'être atteinte !", vbCritical, "Attention !"
            Lblfrancs(1).ForeColor = vbRed
            Txtavert.Text = ""
            If mnuaffich.Enabled = True Then Form1.Show vbNormalFocus
        End If
    End If
End If
End Sub

Private Sub mnuaffich_Click()
mnuaffich.Enabled = False
Load Me
Form1.Show (vbNormalFocus)
End Sub

Private Sub mnuapropos_Click()
MsgBox "Pour tous renseignements ou problèmes envoyez moi un mail à surf11@caramail.com ou écrivez moi depuis mon site Steffiaume's Page : http://perso.wanadoo.fr/steffiaume/", vbInformation, "A propos..."
'Création d'un raccourci sur le bureau
bureau = getstring(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", "Desktop")
Open bureau & "\Steffiaume's Page.url" For Append As #1
Print #1, "[InternetShortcut]"
Print #1, " URL=http://perso.wanadoo.fr/steffiaume/"
Close #1
End Sub

Private Sub mnudemar_Click()
'Si l'option lancer au démarrage est
If mnudemar.Checked = True Then     'cochée
    'Confirmer sa désactivation
    demar = MsgBox("Voulez vous désactiver le lancement du Compteur Internet au démarrage de Windows ?", vbQuestion + vbYesNo + vbDefaultButton2, "Démarrage")
    If demar = vbYes Then
        mnudemar.Checked = False
        'Efface la valeur dans le registre
        DeleteValue HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", "CompteurInternet"
    Else: Exit Sub
    End If
Else:                               'pas cochée
    'Confirmer son activation
    demar = MsgBox("Voulez vous activer le lancement du Compteur Internet au démarrage de Windows ?", vbQuestion + vbYesNo + vbDefaultButton1, "Démarrage")
    If demar = vbYes Then
        mnudemar.Checked = True
        'Ecriture dans le registre
        savestring HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", "CompteurInternet", App.Path & "\" & App.EXEName & ".exe"
    Else: Exit Sub
    End If
End If
End Sub

Private Sub mnuenr_Click()
If mnuenr.Checked = True Then
    mnuenr.Checked = False
ElseIf mnuenr.Checked = False Then
    mnuenr.Checked = True
End If
End Sub

Private Sub mnumois_Click()
If mnumois.Checked = True Then
    mnumois.Checked = False
    LbldurmoisN.Visible = True      'Affichage du compteur normal
    LbldurmoisR.Visible = False
ElseIf mnumois.Checked = False Then
    mnumois.Checked = True
    LbldurmoisN.Visible = False
    LbldurmoisR.Visible = True      'Affichage du compteur en temps réel
End If
End Sub

Private Sub mnuquit_Click()
msg = MsgBox("Etes vous sûr de vouloir quitter le Compteur Internet ?", vbYesNo + vbDefaultButton2 + vbQuestion, "Quitter ?")
If msg = vbYes Then
    Unload Me
    End
End If
End Sub

Private Sub mnured_Click()
mnuaffich.Enabled = True
'Préparation de la variable IconeT
IconeT.cbSize = Len(IconeT) 'Taille de l'icône en octet
IconeT.hwnd = Me.hwnd       'Handle de l'application (pour qu'elle reçoive les messages envoyés lors d'un clic, double-clic...
IconeT.uID = 1&             'Identificateur de l'icône
IconeT.uFlags = Icone Or TIP Or MESSAGE
IconeT.uCallbackMessage = MOUSEMOVE     'Renvoyer les messages concernant l'action de la souris
IconeT.hIcon = Form1.Icon   'Mettre en icône l'icone du Form
IconeT.szTip = "Icône dans le system tray" & Chr$(0)    'Texte de la bulle d'aide

'Appel de la fonction pour mettre l'icône dans le système tray
Shell_NotifyIcon AJOUT, IconeT

Me.Hide                     'Cache la fenêtre
App.TaskVisible = False     'Retire le bouton de l'application de la barre
                            'des tâches

End Sub

Private Sub mnusecu_Click()
secu = MsgBox("En activant cette sécurité, le compteur sauvegarde le temps de connexion mensuelle toutes les 5 minutes au lieu de le sauvegarder en fin de connexion. Si un plantage survient, votre compteur sera donc juste à 5 minutes près" & Chr(10) & "Activer la sécurité ?", vbDefaultButton1 + vbInformation + vbYesNo, "Sécurité")
If secu = vbYes Then
    mnusecu.Checked = True
    Lblsecu.Caption = "1"   'Met le compteur à 1 quand il aura atteind 5 (5 minutes) il enregistrera
    Timersecu.Enabled = True
ElseIf secu = vbNo Then
    mnusecu.Checked = False
    Timersecu.Enabled = False
End If
End Sub

Private Sub Timer_Timer()
'   Affichage de l'heure actuelle
lbl12.Caption = Time
'   Affichage du temps de connexion en cours
Dim fin As Date, debut As Date, duree As Date
debut = lbl22.Caption
fin = Time
duree = fin - debut
lbl32.Caption = duree
'   Affichage du temps de connexion mensuel
Dim mois As Date
mois = LbldurmoisR.Caption
LbldurmoisR.Caption = mois + "00:00:01"
'   Calcul du prix à payer
tps0 = Hour(duree) * 3600 + Minute(duree) * 60 + Second(duree)
Lblfrancs(0).Caption = Round(0.00233333 * tps0, 2)  'Prix actuel
mois = LbldurmoisR.Caption
tps1 = Hour(mois) * 3600 + Minute(mois) * 60 + Second(mois)
Lblfrancs(1).Caption = Round(0.00233333 * tps1, 2)  'Prix mensuel
End Sub

Private Sub Timerconnect_Timer()
If IsNetConnectOnline() = True Then
    Textconnect.Text = "Connecté"
    Connect
    If IsNetConnectViaLAN() = True Then
        Textconnect.Text = "LAN"
    ElseIf IsNetConnectViaModem() = True Then
        lbltype.Caption = "Modem"
    ElseIf IsNetConnectViaProxy() = True Then
        lblype.Caption = "Proxy"
    Else
        lbltype.Caption = "Inconnu"
    End If

Timer.Enabled = True
Else
    Timer.Enabled = False
    Textconnect.Text = "Non connecté"
    lbl11.Visible = False
    lbl12.Visible = False
    Lbl21.Caption = "  Heure actuelle :"
    lbl22.Caption = Time
    lbl31.Caption = "  Dernière connexion :"
    lblvia.Caption = ""
    lbltype.Caption = ""
Deconnect
End If

End Sub

Private Sub Deconnect()
Lbldeconnect.Caption = Lbldeconnect.Caption + 1
If Lbldeconnect.Caption = 1 Then
    Dim mois As Date, last As Date
    mois = LbldurmoisN.Caption
    last = lbl32.Caption
    LbldurmoisN.Caption = mois + last
    Command1.Caption = "Se connecter"
End If
End Sub

Private Sub Connect()
Command1.Caption = "Se déconnecter"
Lbldeconnect.Caption = 0
Lbl21.Caption = "  Heure de connexion :"
lbl31.Caption = "  Durée de la connexion actuelle :"
lbl11.Visible = True
lbl12.Visible = True
lbl31.Visible = True
lbl32.Visible = True
lblvia.Caption = "Connexion par :"
End Sub

Private Sub Enregistre()
'Enregistrement dans le fichier du temps de connexion et du mois actuel
Open App.Path & "\connect.tps" For Output As #1
Print #1, LbldurmoisN.Caption
Print #1, Month(Date)

'Enregistrement de l'aspect du compteur si demandé
If mnuenr.Checked = True Then
    Print #1, "ASPECT=OUI"
Else
    Print #1, "ASPECT=NON"
End If
If mnusecu.Checked = True Then
    Print #1, "SECU=OUI"
Else
    Print #1, "SECU=NON"
End If
    Print #1, Command2.Caption
    Print #1, Cbotarif.ListIndex
    If Cbotarif.ListIndex = 0 Then
        Print #1, Cboavert.ListIndex
    Else
        Print #1, Cboforfait.ListIndex
    End If
    Print #1, Txtavert.Text
Close #1
End Sub

Private Sub Timersecu_Timer()
cinq = Lblsecu.Caption
If cinq = 5 Then    'Si ca fait 5 minutes
     cinq = "0"
     'Enregistrement de la connexion dans le fichier de sauvegarde
    Open App.Path & "\connect.tps" For Output As #1
    'Open "c:\recherche\Compteur temps" & "\connect.tps" For Output As #1
    Print #1, LbldurmoisN.Caption
    Print #1, Month(Date)
    Close #1
End If
Lblsecu.Caption = cinq + 1
End Sub

Private Sub Txtavert_Click()
LbldurmoisR.ForeColor = vbBlack
Lblfrancs(1).ForeColor = vbBlack
End Sub

Private Sub InitForm()
With Cboavert
    .Left = 8640
    .Top = 240
    .List(0) = "Francs"
    .List(1) = "Heures"
End With
With Cboforfait
    .Left = 4800
    .Top = 960
    .List(0) = "AOL"
    .List(1) = "France Explorer"
    .List(2) = "Freesbee"
    .List(3) = "Infonie"
    .List(4) = "Wanadoo"
    .List(5) = "World on Line"
    .List(6) = "Autres"
    .Visible = False
End With
With Cbotarif
    .Left = 4800
    .Top = 240
    .List(0) = "Local"
    .List(1) = "Forfait"
End With
With Command1
    .Left = 840
    .Top = 2280
    .Height = 375
    .Width = 1335
    .Caption = "Se connecter"
End With
With Command2
    .Left = 2400
    .Top = 2280
    .Height = 375
    .Width = 1335
    .Caption = "Mode complet :"
End With
With Framepayer
    .Left = 4800
    .Top = 720
    .Height = 1455
    .Width = 1575
    .Caption = "A payer"
    .Font = "Arial"
    .Font.Size = 10
End With
With Image1
    .Left = 6600
    .Top = 720
    .Height = 2295
    .Width = 3015
End With
With Label1
    .Left = 0
    .Top = 2880
    .Height = 285
    .Width = 735
    .BorderStyle = 1
    .Caption = "Statut :"
End With
With Label2
    .Left = 6600
    .Top = 240
    .Height = 315
    .Width = 1575
    .BorderStyle = 1
    .Caption = "Avertir au bout de :"
    .BackColor = &H80000009
End With
With Label4(0)
    .Left = 960
    .Top = 480
    .Height = 285
    .Width = 315
    .Caption = "Frs"
    .Font = "Arial"
    .Font.Size = 10
End With
With Label4(1)
    .Left = 960
    .Top = 960
    .Height = 285
    .Width = 315
    .Caption = "Frs"
    .Font = "Arial"
    .Font.Size = 10
End With
With lbl11
    .Left = 120
    .Top = 240
    .Height = 285
    .Width = 3075
    .Caption = "  Heure actuelle :"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With lbl12
    .Left = 3480
    .Top = 240
    .Height = 285
    .Width = 795
    .BorderStyle = 1
    .Caption = "00:00:00"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lbl21
    .Left = 120
    .Top = 720
    .Height = 285
    .Width = 3075
    .Caption = "  "
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With lbl22
    .Left = 3480
    .Top = 720
    .Height = 285
    .Width = 795
    .BorderStyle = 1
    .Caption = "00:00:00"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With lbl31
    .Left = 120
    .Top = 1200
    .Height = 285
    .Width = 3075
    .Caption = "  Durée de la connexion actuelle :"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With lbl32
    .Left = 3480
    .Top = 1200
    .Height = 285
    .Width = 795
    .BorderStyle = 1
    .Caption = "00:00:00"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lbl4
    .Left = 120
    .Top = 1680
    .Height = 285
    .Width = 1960
    .Caption = "  Connexion du mois d"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lbldeconnect
    .Left = 600
    .Top = 2280
    .Height = 255
    .Width = 135
    .Caption = "0"
End With
With LbldurmoisN
    .Left = 3480
    .Top = 1680
    .Height = 285
    .Width = 795
    .BorderStyle = 1
    .Caption = "00:00:00"
    .BackColor = &H80000009
    .Visible = False
    .Font = "Arial"
    .Font.Size = 10
End With
With LbldurmoisR
    .Left = 3480
    .Top = 1680
    .Height = 285
    .Width = 795
    .BorderStyle = 1
    .Caption = "00:00:00"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lble
    .Left = 2080
    .Top = 1680
    .Height = 285
    .Width = 120
    .Caption = ""
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lblfrancs(0)
    .Left = 120
    .Top = 480
    .Height = 285
    .Width = 675
    .Caption = "0"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lblfrancs(1)
    .Left = 120
    .Top = 960
    .Height = 285
    .Width = 675
    .Caption = "0"
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lblmois
    .Left = 2205
    .Top = 1680
    .Height = 285
    .Width = 975
    .Caption = ""
    .BackColor = &H80000009
    .Font = "Arial"
    .Font.Size = 10
End With
With Lblsecu
    .Left = 4800
    .Top = 2400
    .Height = 255
    .Width = 135
    .Caption = "1"
End With
With lbltype
    .Left = 3480
    .Top = 2880
    .Height = 285
    .Width = 1215
    .BorderStyle = 1
    .Caption = ""
End With
With lblvia
    .Left = 2160
    .Top = 2880
    .Height = 285
    .Width = 1335
    .BorderStyle = 1
    .Caption = "Connexion par :"
End With

With Textconnect
    .Left = 720
    .Top = 2880
    .Height = 285
    .Width = 1455
    .BorderStyle = 1
    .Text = ""
    .BackColor = &H80000000
End With
With Txtavert
    .Left = 8160
    .Top = 240
    .Height = 315
    .Width = 495
    .BorderStyle = 1
    .Text = ""
End With
Timer.Interval = 1000
Timerconnect.Interval = 10
Timersecu.Interval = 60000
menu.Caption = "Menu"
mnuaffich.Caption = "Afficher"
mnuapropos.Caption = "A propos..."
mnudemar.Caption = "Lancer au démarrage"
mnudemar.Checked = True
mnuenr.Caption = "Enregistrer l'aspect du compteur en quittant"
mnumois.Caption = "Calculer la durée mensuelle en temps réel"
mnuopt.Caption = "Options"
mnuquit.Caption = "Quitter"
mnured.Caption = "Réduire dans la barre des tâches"
mnusecu.Caption = "Sécurité"
End Sub

'DANS UN MODULE
Public Declare Function InternetGetConnectedState _
    Lib "wininet.dll" (ByRef lpdwFlags As Long, _
    ByVal dwReserved As Long) As Long
    'Local system uses a modem to connect to
    ' the Internet.

    Public Const INTERNET_CONNECTION_MODEM As Long = &H1
    'Local system uses a LAN to connect to the Internet.
    Public Const INTERNET_CONNECTION_LAN As Long = &H2
    'Local system uses a proxy server to connect to the Internet.
    Public Const INTERNET_CONNECTION_PROXY As Long = &H4
    'No longer used.
    Public Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8
    Public Const INTERNET_CONNECTION_OFFLINE As Long = &H20
    Public Const INTERNET_CONNECTION_CONFIGURED As Long = &H40
    'InternetGetConnectedState wrapper functions
    
    'Registre pour lancement au démarrage ------------

    Public Const HKEY_CURRENT_USER = &H80000001
    Public Const HKEY_LOCAL_MACHINE = &H80000002
    Public Const ERROR_SUCCESS = 0&

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
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
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
    Public Const REG_SZ = 1 ' Unicode nul terminated String
    Public Const REG_DWORD = 4 ' 32-bit number

'-----------------------------------------------------
Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
    Dim keyhand As Long
    Dim r As Long
    r = RegCreateKey(Hkey, strPath, keyhand)
    r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
    r = RegCloseKey(keyhand)
End Sub
Public Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)
   
    Dim keyhand As Long
    r = RegOpenKey(Hkey, strPath, keyhand)
    r = RegDeleteValue(keyhand, strValue)
    r = RegCloseKey(keyhand)
End Function
Public Function getstring(Hkey As Long, strPath As String, strValue As String)
    
    Dim keyhand As Long
    Dim datatype As Long
    Dim lResult As Long
    Dim strBuf As String
    Dim lDataBufSize As Long
    Dim intZeroPos As Integer
    r = RegOpenKey(Hkey, strPath, keyhand)
    lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)

    If lValueType = REG_SZ Then
        strBuf = String(lDataBufSize, " ")
        lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)

        If lResult = ERROR_SUCCESS Then
            intZeroPos = InStr(strBuf, Chr$(0))

            If intZeroPos > 0 Then
                getstring = Left$(strBuf, intZeroPos - 1)
            Else
                getstring = strBuf
            End If
        End If
    End If
End Function

Public Function IsNetConnectViaLAN() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the API will
    'return the flags associated with the connection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a LAN connection
    IsNetConnectViaLAN = dwFlags And INTERNET_CONNECTION_LAN
End Function

Public Function IsNetConnectViaModem() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the API will
    'return the flags associated with the connection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a modem connection
    IsNetConnectViaModem = dwFlags And INTERNET_CONNECTION_MODEM
End Function

Public Function IsNetConnectViaProxy() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the API will
    'return the flags associated with the connection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a proxy connection
    IsNetConnectViaProxy = dwFlags And INTERNET_CONNECTION_PROXY
End Function

Public Function IsNetConnectOnline() As Boolean
    'no flags needed here - the API returns True
    'if there is a connection of any type
    IsNetConnectOnline = InternetGetConnectedState(0&, 0&)
End Function

Public Function GetNetConnectString() As String
    Dim dwFlags As Long

    If InternetGetConnectedState(dwFlags, 0&) Then
        GetNetConnectString = "Connecté"
    Else
        GetNetConnectString = "Non connecté"
    End If
    
End Function

Conclusion :

Pensez à visiter nos sites :
http://perso.wanadoo.fr/steffiaume/
http://troccd.ifrance.com

Télécharger le projet

Codes Sources

A voir également

Compteur internet
Compteur de caracteres ✓ - Forum Delphi / Pascal
Compteur java - Forum Java
Compteur mots ✓ - Forum Visual Basic
Compteur sql - Conseils pratiques -SQL
Modele site internet - Conseils pratiques -PHP

Ajouter un commentaire Commentaires

sergess Messages postés 9 Date d'inscription vendredi 8 avril 2005 Statut Membre Dernière intervention 16 mai 2005
22 avril 2005 à 11:43

je suis débutant en Vb.net, et je veux faire un compteur mais j'ai 3 pb:
- bloquer la commande crtl alt suppr
- fermer le bureau et la barre des tâches avec ma fénêtre de connection
- avoir accès aux paramètres des postes client à partir du serveur pour avoir les clients en ligne
merci dee m'aider
a+

cs_Booster Messages postés 235 Date d'inscription mercredi 30 octobre 2002 Statut Membre Dernière intervention 6 octobre 2009
29 mai 2003 à 20:18

ce compteur me plait mais je ne serai po pret a mettre 10 car le design n'est po au top mais je v qd mm m'en servire pour y rejouter des fonction pour moi voila ++

Guidelor Messages postés 236 Date d'inscription jeudi 31 octobre 2002 Statut Membre Dernière intervention 18 août 2006
22 déc. 2002 à 01:21

T'apelle ca "Un PETIT compteur internet sympa SANS FONCTIONS SUPERFLUES" ???

3612
19 août 2001 à 12:00

J'ai vu ton site il est exellent !
Je le recomande :
http://perso.wanadoo.fr/steffiaume

steff422
17 août 2001 à 17:47

il est vraiment niquel ce compteur, je vous le conseille !
Bravo à steffiaume !

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Compteur internet

Description

Source / Exemple :

Conclusion :

Codes Sources

A voir également

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (Steffiaume)

Id3tag xp gestionnaire de tag pour fichiers mp3

Alarme/reveil

Source / Exemple :

Conclusion :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (Steffiaume)

Id3tag xp gestionnaire de tag pour fichiers mp3

Alarme/reveil

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !