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
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.