Il s'agit d'une application qui sert à faire sonner une sirène d'une usine pour l'entrée et la sortie des ouvriers.
Pour cela j'utilise le port série
Il est possible de sélectionner une saison.
la sonnerie ne sonne pas les dimanches.
L'avant dernière sonnerie de chaque journée est celle du nettoyage
------------
bonjour
voila c'est mon premier code
je l'ai réalisé avec en qque sorte l'aide du forum et des codes du site.
Je suis débutant, le développement de cette application s'est fait sur 2 ans de facon discontinu.
Son développement et les modifications des horaires et leurs nombre se fait encore car ceci n'a pas été prévu dès le début .C'est pour cela qu'il faut modifier le code si on veut ajouter une case d'un nouveau temps.
----
j'ai emprunté:
-le module d'un projet esistant sur le site
-le code qui sert a réduire l'application au niveau de la barre des tache d'un autre projet existant sur le site
_______________________________
j'attend vos commmnetaires
merci
Source / Exemple :
Dim tps(31) As Date
Dim duree As Integer
Dim durnet As Integer
Dim saison As Integer
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 MOUSEMOVE = &H200
Private Const MESSAGE = &H1
Private Const Icone = &H2
Private Const DOUBLE_CLICK_GAUCHE = &H203
'API nécessaire
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As IconeTray) As Boolean
Private Sub cboSeat_Click()
Dim index As Integer
For index = 0 To 2
If cboSeat.Text = Opt(index).Caption Then Opt(index).Value = True
Next index
End Sub
Private Sub chkmanuel_Click()
If chkmanuel.Value = vbChecked Then
'cmdalarm.Visible = False 'plus nesacessaire puisqu'on a cacher le bouton appliquer
cmdsonner.Enabled = True
Timer1.Enabled = False
Timer2.Enabled = False
lblduree.Visible = False
lbldurnet.Visible = False
Dim INT_For1 As Integer
For INT_For1 = 0 To 32
Text1(INT_For1).Visible = False
Next INT_For1
Text1(36).Visible = False 'pour la text box de txtdurnet
'Frame1.Visible = False
'Dim index As Integer 'plus nécessaire car on a remplacé
'For index = 0 To 2 'le option pour saison par le combobox
' Opt(index).Visible = False
'Next index
cboSeat.Visible = False
Else
'cmdalarm.Visible = True 'plus nesacessaire puisqu'on a cacher le bouton appliquer
cmdsonner.Enabled = False
Timer1.Enabled = True
Timer2.Enabled = True
lblduree.Visible = True
lbldurnet.Visible = True
For INT_For1 = 0 To 32
Text1(INT_For1).Visible = True
Next INT_For1
Text1(36).Visible = True
'Frame1.Visible = True 'plus nécessaire car on a remplacé
'For index = 0 To 2 'le option pour saison par le combobox
' Opt(index).Visible = True
'Next index
cboSeat.Visible = True
End If
End Sub
Private Sub Cmdabout_Click()
Dim response As Integer
response = MsgBox(" Copyright (c) 2004,2005 Rami Bouattour - All Right Reserved [01/08/06]", vbOKOnly + vbApplicationModal, "A propos de Sirène")
End Sub
Private Sub cmdcacher_Click()
'Exécuter la même commande que le bouton "appliquer"
cmdalarm.Value = 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 = "Pour Afficher,Double click" & 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 cmdquit_Click()
Unload Me
End
End Sub
Private Sub cmdsonner_Click()
If cmdsonner.Caption = "Sonner" Then
cmdsonner.Caption = "Arrêter"
chkmanuel.Enabled = False
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
cmdcacher.Visible = False
save.Visible = False
cmdalarm.Visible = False
form1.Visible = False
Dim response As Integer
response = MsgBox("Arrêter la sirène", vbOKOnly + vbCritical + vbSystemModal, "Sirène")
If vbOK Then
PortAddress = &H378
Out PortAddress, 0
Beep
form1.Visible = True
cmdsonner.Caption = "Sonner"
chkmanuel.Enabled = True
cmdcacher.Visible = True
save.Visible = True
End If
End If
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.Hide
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 cmdalarm_Click()
Dim INT_For1 As Integer
For INT_For1 = 0 To 31
tps(INT_For1) = Text1(INT_For1).Text
Next INT_For1
duree = Text1(32).Text
durnet = Text1(36).Text
Dim index As Integer
For index = 0 To 2
If Opt(index).Value = True Then saison = index
Next index
Text1(33).Text = saison
'valider ounon l'option démarrer réduit
Dim red As Integer
If Chkred.Value = vbChecked Then
red = 1
Else
red = 0
End If
Text1(34).Text = red
'valider ou non l'option démarrer en mode manuel
Dim man As Integer
If chkmanuel.Value = vbChecked Then
man = 1
Else
man = 0
End If
Text1(35).Text = man
End Sub
Private Sub Form_Load()
cboSeat.AddItem "Double Séance"
cboSeat.AddItem "Séance Unique"
cboSeat.AddItem "Ramadan"
Dim INT_For1 As Integer
Dim STR_texte As String
Timer1.Enabled = True
cmdsonner.Caption = "Sonner"
Open "alarm.txt" For Input As #1
For INT_For1 = 0 To 36
Input #1, STR_texte
Text1(INT_For1).Text = STR_texte
Next INT_For1
Close #1
'retenir la valeur des saisons
Dim index As Integer
For index = 0 To 2
If Text1(33).Text = index Then saison = index
Next index
Text1(33).Text = saison
'retenir la case des saisons
For index = 0 To 2
If saison = index Then
Opt(index).Value = True
cboSeat.ListIndex = saison
End If
Next index
'retenir la valeur de la case démarrer en mode manuel
If Text1(35).Text = 1 Then
chkmanuel.Value = vbChecked
Else
chkmanuel.Value = vbUnchecked
End If
'retenir la valeur de la case démarrer réduit
If Text1(34).Text = 1 Then
Chkred.Value = vbChecked
cmdcacher.Value = True
Else
Chkred.Value = vbUnchecked
End If
'pour confirmer la durée par le bouton appliquer
cmdalarm.Value = True
'pour désactiver le port si il fctne déjà à l'ouverture
PortAddress = &H378
Out PortAddress, 0
Beep
End Sub
Private Sub save_Click()
cmdalarm.Value = True
'SAUVEGARDE:
Dim INT_For1 As Integer
Open "alarm.txt" For Output As #1
For INT_For1 = 0 To 36
Print #1, Text1(INT_For1).Text
Next INT_For1
Close #1
MsgBox "Vos horaires sont enregistré", vbOKOnly + vbApplicationModal, "Sirène"
End Sub
Private Sub Text1_KeyPress(index As Integer, KeyAscii As Integer)
If (KeyAscii >= vbKey0 And KeyAscii <= vbKey9) Or KeyAscii = vbKeyBack Or KeyAscii = vbKeyDelete Or KeyAscii = 58 Then
Exit Sub
Else
KeyAscii = 0
Beep
End If
End Sub
Private Sub Timer1_Timer()
Dim dt As Date
dt = Time$
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If saison = 0 Then
Dim INT_For1 As Integer
If Weekday(Now, vbSunday) <> 7 Then
For INT_For1 = 0 To 3
If dt = tps(INT_For1) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(INT_For1)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Next INT_For1
If dt = tps(4) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(4)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(5) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(5)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Else
For INT_For1 = 6 To 8
If dt = tps(INT_For1) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(INT_For1)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Next INT_For1
If dt = tps(9) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(9)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(10) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(10)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
End If
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If saison = 1 Then
If Weekday(Now, vbSunday) = 6 Then
For INT_For1 = 16 To 18
If dt = tps(INT_For1) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(INT_For1)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Next INT_For1
If dt = tps(19) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(19)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(20) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(20)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
ElseIf Weekday(Now, vbSunday) = 7 Then
For INT_For1 = 21 To 23
If dt = tps(INT_For1) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(INT_For1)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Next INT_For1
If dt = tps(24) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(24)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(25) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(25)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Else
For INT_For1 = 11 To 13
If dt = tps(INT_For1) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(INT_For1)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Next INT_For1
If dt = tps(14) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(14)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(15) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(15)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If saison = 2 Then
If Weekday(Now, vbSunday) <> 7 Then
If dt = tps(26) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(26)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(27) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(27)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(28) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(28)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
Else
If dt = tps(29) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(29)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(30) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", durnet, tps(30)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
If dt = tps(31) Then
PortAddress = &H378
Out PortAddress, 2 ^ 0
Beep
End If
If dt = DateAdd("s", duree, tps(31)) Then
PortAddress = &H378
Out PortAddress, 0
Beep
End If
End If
End If
'''''change la couleur des textbox qd
' on choisi la saison(couleur de fond de l'espace text)
''''1
If Opt(0).Value = False Then
For INT_For1 = 0 To 10
Text1(INT_For1).BackColor = &HFFC0C0
Text1(INT_For1).ForeColor = &HFFFFFF
Next INT_For1
Else
For INT_For1 = 0 To 10
Text1(INT_For1).BackColor = &HFFFFFF
Text1(INT_For1).ForeColor = &H80000008
Next INT_For1
End If
'''2
If Opt(1).Value = False Then
For INT_For1 = 11 To 25
Text1(INT_For1).BackColor = &HFFC0C0
Text1(INT_For1).ForeColor = &HFFFFFF
Next INT_For1
Else
For INT_For1 = 11 To 25
Text1(INT_For1).BackColor = &HFFFFFF
Text1(INT_For1).ForeColor = &H80000008
Next INT_For1
End If
'''3
If Opt(2).Value = False Then
For INT_For1 = 26 To 31
Text1(INT_For1).BackColor = &HFFC0C0
Text1(INT_For1).ForeColor = &HFFFFFF
Next INT_For1
Else
For INT_For1 = 26 To 31
Text1(INT_For1).BackColor = &HFFFFFF
Text1(INT_For1).ForeColor = &H80000008
Next INT_For1
End If
End Sub
Private Sub Timer2_Timer()
If Weekday(Now, vbSunday) = vbSunday Then
Timer1.Enabled = False
Else
Timer1.Enabled = True
End If
End Sub
---------------------
voici le module
----------------
'Inp and Out declarations for direct port I/O
'in 32-bit Visual Basic 4+ programs.
Public Declare Function Inp Lib "inpout32.dll" _
Alias "Inp32" (ByVal PortAddress As Integer) As Integer
Public Declare Sub Out Lib "inpout32.dll" _
Alias "Out32" (ByVal PortAddress As Integer, ByVal Value As Integer)
Conclusion :
pour des mises à jours ou des informations sur le montage,veuillez consulter mon site
http://rami3b.iquebec.com/vb.htm
vos commentaires sont les bienvenu
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.