PORT PARALLÈLE : PILOTER UNE SIRÈNE D'ENTRÉE SORTIE D'OUVRIERS D'UNE USINE

---

Commentaire sur cette source (5)
Ajouter un commentaire et/ou une note

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

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)

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

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip

05 août 2006 14:30:09 :

je vien d'ajouter le zip et le code :)

06 août 2006 13:03:31 :

supppression copyright

07 août 2006 00:27:01 :

modification présentation

12 août 2006 18:22:10 :

modification presentaion

13 août 2006 14:28:39 :

modification presentation

• PHOTOCOPIEUR
• COMMANDE D'UNE CARTE D'INTERFACE PARALLELE À BASE D'UN PPI 8255 D'INTEL
• PORT PARALLÈLE VS2008
• LISTE HARD
• TESTER VOTRE ÉCRAN DE POCKET PC (COMPACT FRAMEWORK)

• SIMULATION D'UNE CONNEXION NETBUS
• PORT PARALLÈLE VS2008
• COMMUNICATION SERIE PROTOCOL MODBUS ASCII
• SCANNER DE PORT VB.NET
• UTILISATION FACILE DU PORT PARALLÈLE