File "Prog_Frm.frm"
Full Path: /home/analogde/www/DEV/Prog_Frm.frm
File size: 23.46 KB
MIME-type: text/plain
Charset: 8 bit
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Prog_Frm
Caption = "Bonding diagram"
ClientHeight = 9630
ClientLeft = 165
ClientTop = 735
ClientWidth = 12855
Icon = "Prog_Frm.frx":0000
LinkTopic = "Form2"
ScaleHeight = 9630
ScaleWidth = 12855
StartUpPosition = 3 'Windows Default
Begin VB.Timer Timer1
Interval = 50
Left = 10800
Top = 7800
End
Begin MSComDlg.CommonDialog CmDlg
Left = 11280
Top = 6720
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.TextBox txt_Grille_X
Alignment = 2 'Center
BackColor = &H00FFC0C0&
Height = 285
Left = 720
TabIndex = 11
Text = "5"
Top = 7320
Width = 495
End
Begin VB.TextBox txt_Grille_Y
Alignment = 2 'Center
BackColor = &H00FFC0C0&
Height = 285
Left = 1200
TabIndex = 10
Text = "5"
Top = 7320
Width = 495
End
Begin VB.CheckBox Grille_Check
BackColor = &H00E0E0E0&
Caption = "Grille"
Height = 285
Left = 240
Style = 1 'Graphical
TabIndex = 9
Top = 7320
Value = 1 'Checked
Width = 540
End
Begin VB.CheckBox Chk_AfficheGrille
Caption = "Afficher Grille"
Height = 375
Left = 7320
TabIndex = 8
Top = 720
Width = 2295
End
Begin VB.CommandButton Supprimer_Lien
Caption = "Supprimer un lien"
Height = 495
Left = 120
TabIndex = 7
Top = 4560
Width = 1095
End
Begin VB.CommandButton Supprimer
Caption = "Supprimer "
Height = 495
Left = 120
TabIndex = 5
Top = 2400
Width = 1095
End
Begin VB.CommandButton Creer_Lien
Caption = "Crer un lien"
Height = 495
Left = 120
TabIndex = 4
Top = 3960
Width = 1095
End
Begin VB.CommandButton Deplace
Caption = "Deplacer "
Height = 495
Left = 120
TabIndex = 3
Top = 3000
Width = 1095
End
Begin VB.CommandButton Ajouter
Caption = "Ajouter"
Height = 495
Left = 120
TabIndex = 1
Top = 1800
Width = 1095
End
Begin VB.PictureBox Schema_Box
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
Height = 6855
Left = 1920
ScaleHeight = 6795
ScaleWidth = 7995
TabIndex = 0
Top = 1560
Width = 8055
End
Begin MSComctlLib.ImageList Icones_Barre
Left = 240
Top = 5760
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 18
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":08CA
Key = "New"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":09DC
Key = "Open"
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":0AEE
Key = "Save"
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":0C00
Key = "Print"
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":0D12
Key = "Excel"
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1064
Key = "Cut"
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1176
Key = "Copy"
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1288
Key = "Paste"
EndProperty
BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":139A
Key = "Bold"
EndProperty
BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":14AC
Key = "Italic"
EndProperty
BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":15BE
Key = "Underline"
EndProperty
BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":16D0
Key = "Align Left"
EndProperty
BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":17E2
Key = "Center"
EndProperty
BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":18F4
Key = "Align Right"
EndProperty
BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1A06
Key = "FitToScreen"
EndProperty
BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1C5A
Key = "ZoomIn"
EndProperty
BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":1EAE
Key = "ZoomOut"
EndProperty
BeginProperty ListImage18 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "Prog_Frm.frx":2102
Key = "ZoomWindow"
EndProperty
EndProperty
End
Begin MSComctlLib.StatusBar Status_Barre
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 12
Top = 9375
Width = 12855
_ExtentX = 22675
_ExtentY = 450
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 5
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
Object.Width = 1058
MinWidth = 1058
Key = "Info_X"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
Object.Width = 873
MinWidth = 882
Key = "Info_Y"
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 17412
MinWidth = 2
Key = "rien"
EndProperty
BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Style = 6
AutoSize = 2
Object.Width = 1693
MinWidth = 1499
TextSave = "06/03/2007"
Key = "Date"
EndProperty
BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Style = 5
AutoSize = 2
Object.Width = 1058
MinWidth = 1058
TextSave = "23:47"
Key = "Heure"
EndProperty
EndProperty
End
Begin VB.Label Lbl_Y
Caption = "Label2"
Height = 495
Left = 480
TabIndex = 14
Top = 8760
Width = 1575
End
Begin VB.Label Lbl_X
Caption = "Label1"
Height = 375
Left = 480
TabIndex = 13
Top = 8040
Width = 1335
End
Begin VB.Image PAD
Height = 660
Left = 1800
Picture = "Prog_Frm.frx":2356
Top = 600
Width = 945
End
Begin VB.Image PAD_Actif
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Height = 735
Left = 240
Top = 600
Width = 855
End
Begin VB.Label Type_PAD_Lbl
Alignment = 2 'Center
Caption = "Type"
Height = 255
Left = 240
TabIndex = 6
Top = 960
Width = 855
End
Begin VB.Label ActionEnCours
Height = 255
Left = 2640
TabIndex = 2
Top = 8760
Width = 5775
End
Begin VB.Menu Fichier
Caption = "Fichier"
Begin VB.Menu Mnu_Import_Pad
Caption = "Importer pad"
End
Begin VB.Menu Mnu_Import_Template
Caption = "Importer Template"
End
Begin VB.Menu Sauver
Caption = "Sauver"
End
End
Begin VB.Menu Mnu_Affichage
Caption = "Affichage"
Begin VB.Menu Mnu_PleineFenetre
Caption = "Pleine Fenetre"
End
Begin VB.Menu Mnu_ZoomPlus
Caption = "Zoom +"
End
Begin VB.Menu Mnu_ZoomMoins
Caption = "Zoom -"
End
End
Begin VB.Menu Composants
Caption = "Composants"
Begin VB.Menu Ouvrir
Caption = "Ouvrir"
End
Begin VB.Menu Detecteurs
Caption = "Detecteurs de Front"
End
Begin VB.Menu OutPut
Caption = "OutPut"
End
End
Begin VB.Menu APropos
Caption = "A Propos"
End
End
Attribute VB_Name = "Prog_Frm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Ajouter_Click() ' ajouter un nouveau pad
ActionEnCours.Caption = "Ajoute un pad"
Action = "ajout"
End Sub
Private Sub APropos_Click()
MsgBox "En cours de dveloppement (Fvrier 2007)" & vbNewLine & "Par Patrice" & vbNewLine & vbNewLine & "Freeware - OpenSource" & vbNewLine & "Vous pouvez modifier ce logiciel librement," & vbNewLine & "mais tenez-moi au courant de vos volutions !" & vbNewLine & "Sbastien LADEN - seb79fr@yahoo.fr"
End Sub
Private Sub ChangeEtat_Click() ' change manuellement un etat en cliquant sur un objet
ActionEnCours.Caption = "Change un etat"
Action = "changeetat"
End Sub
Private Sub Creer_Lien_Click() ' creer un nouveau lien
ActionEnCours.Caption = "Creer un lien"
Action = "lien"
End Sub
Private Sub Deplace_Click() ' deplace un pad
ActionEnCours.Caption = "Deplace un pad"
Action = "deplace"
End Sub
Private Sub Detecteurs_Click() ' ouvre la form de selection de detecteur de front
DetecteursFrm.Show
End Sub
Private Sub Form_Load()
PinNumSelectionnee = -1 ' Ne selectionne rien par defaut
PinPorteSelectionnee = -1
PinTypeSelectionnee = -1
PAD_Actif.Picture = PAD.Picture ' PAD actif par dfaut
Type_PAD_Lbl.Caption = "PAD"
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' propose de sauvegarder avant de quitter
If NBGates > 0 Then
reponse = MsgBox("Voulez-vous sauvegarder avant de quitter?", vbYesNo)
If reponse = vbYes Then
Cancel = 1
Sauvegarde
End If
End If
End Sub
Private Sub Form_Resize() ' redimmensionne la picture box avec la fenetre
'Schema_Box.Width = Prog_Frm.Width - 1600
'Schema_Box.Height = Prog_Frm.Height - 2150
'ActionEnCours.Top = Prog_Frm.Height - 1050
ReDraw Me.Schema_Box
End Sub
Private Sub Minuterie_Timer()
Dim nt As POINTAPI
GetCursorPos nt
'Etiquette1.Caption = "x=" + Str$(lppt.X) + ";y=" + Str$(lppt.Y)
End Sub
Private Sub Mnu_Import_Pad_Click()
Call Ouvrir_Document
End Sub
Private Sub Mnu_Import_Template_Click()
Dim X1 As Integer
Dim Y1 As Integer
Dim X2 As Integer
Dim Y2 As Integer
Dim temp As Integer
X1 = 200
Y1 = 200
X2 = 100
Y2 = 100
temp = calculer_angle(X1, Y1, X2, Y2)
Call Import_Template
End Sub
Private Sub PAD_Click() ' selectionne un pad
PAD_Actif.Picture = PAD.Picture
Type_PAD_Lbl.Caption = "bidule"
End Sub
Private Sub OutPut_Click()
Outputfrm.Show
End Sub
Private Sub Ouvrir_Click()
tmp = Charge()
End Sub
Private Sub Sauver_Click() ' Sauvegarde le Schema_Box
tmp = Sauvegarde()
End Sub
Private Sub Schema_Box_DblClick() ' annule le lien en cours
PinNumSelectionnee = -1
PinPorteSelectionnee = -1
PinTypeSelectionnee = -1
End Sub
Private Sub Schema_Box_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
' variables communes
Dim PAD As Long, Pinnum As Long
Dim PinType As String
Dim Etat As Long
Dim angle As String
' mode ajout un pad
If Action = "ajout" Then
Titre$ = "Orientation du pad"
Message$ = "Tapez N pour normal et R pour une rotation de 90"
angle$ = InputBox$(Message$, Titre$)
angle = LCase(angle)
If (angle <> "n") And (angle <> "r") Then
' avorter
Exit Sub
End If
'Instructions (autoriser l'accs)
'Else
'Instructions (refuser l'accs et quitter le programme) 'Fin de la procdure
'End If
Type_PAD = Type_PAD_Lbl.Caption
' insert un pad
PAD_Ref = Insert(X, Y, Type_PAD, angle)
ReDraw Prog_Frm.Schema_Box
End If
' deplace un pad
If Action = "deplace" Then
' on enregistre les valeurs de depart, pour comparer a l'arrive et bouger le pad
MouseX = X
MouseY = Y
' cherche le pad qui vient d'tre slctionner
PorteSelectionnee = Trouve_PAD(X, Y, DifX, DifY)
End If
' mode suppression de porte
If Action = "supprime" Then
PorteSelectionnee = Trouve_PAD(X, Y)
If PorteSelectionnee <> -1 Then
' arrete l'horloge si on efface la derniere horloge
If Objet_PAD(PorteSelectionnee).GetType = "Clock" Then
For i = 0 To NBGates - 1
If PAD_Status(i) = 1 And i <> PorteSelectionnee Then
If Objet_PAD(i).GetType() = "Clock" Then horlogepresente = 1
End If
Next i
End If
' detruit l'objet, et indique le tag effac(0) dans le tableau
Set Objet_PAD(PorteSelectionnee) = Nothing
PAD_Status(PorteSelectionnee) = 0
ReDraw Prog_Frm.Schema_Box
End If
End If
' mode suppression de lien
If Action = "suplien" Then
Dim LienPorteNum As Long
Dim LienPinNum As Long
tmp = TrouveLien(X, Y, LienPorteNum, LienPinNum)
If LienPorteNum <> -1 Then
tmp = Objet_PAD(LienPorteNum).SetParent(LienPinNum, -1)
ReDraw Me.Schema_Box
End If
End If
' creer un lien
If Action = "lien" Then
' trouve la pin cliquee
tmp = Trouve_Gravite(X, Y, PAD, Pinnum, PinType)
' elle est reconnue
If PAD <> -1 Then
If PinNumSelectionnee = -1 Then ' si c'est le debut du lien
PinNumSelectionnee = Pinnum ' on sauvegarde la puce
PinPorteSelectionnee = Porte
PinTypeSelectionnee = PinType
Else ' c'est la fin du lien, on le creer
If PinTypeSelectionnee <> PinType Then ' on connect une entree a une sortie, pas de type identique
If PinType = "sortie" Then
tmp = Objet_PAD(PinPorteSelectionnee).SetParent(PinNumSelectionnee, PAD)
Else
tmp = Objet_PAD(Porte).SetParent(Pinnum, PinPorteSelectionnee)
End If
PinNumSelectionnee = -1 ' on deselectionne tout
PinPorteSelectionnee = -1
PinTypeSelectionnee = -1
Else ' impossible de creer le lien
MsgBox "Deux " & PinType & "s ne peuvent pas etre connectes ensemble !"
End If
End If
ReDraw Prog_Frm.Schema_Box
End If
End If
End Sub
Private Sub Schema_Box_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'hors des limites de la picturebox
If X <= 0 Or Y <= 0 Then Exit Sub
If X >= Schema_Box.Width Or Y >= Schema_Box.Height Then Exit Sub
' on deplace le pad
If Action = "deplace" And Button = 1 Then
deltaX = X - MouseX
deltaY = Y - MouseY
MouseX = X
MouseY = Y
' on bouge le pad
If PorteSelectionnee <> -1 Then
tmp = bouger(X - DifX + deltaX, Y - DifY + deltaY, PorteSelectionnee)
ReDraw Prog_Frm.Schema_Box
End If
End If
' on creer un lien
If Action = "lien" Then
If PinPorteSelectionnee <> -1 Then
Dim PosX As Integer, PosY As Integer
Dim Gravite_Pos_X As Integer, Gravite_Pos_Y As Integer
Dim PinPos() As Integer
tmp = Objet_PAD(PinPorteSelectionnee).GetPosition(PosX, PosY, Gravite_Pos_X, Gravite_Pos_Y)
ReDraw Prog_Frm.Schema_Box
' on trace une ligne de la pin au curseur
If PinTypeSelectionnee = "entree" Then
Prog_Frm.Schema_Box.Line (PinPos(0, PinNumSelectionnee), PinPos(1, PinNumSelectionnee))-(X, Y), RGB(255, 0, 0)
Else
Prog_Frm.Schema_Box.Line (Gravite_Pos_X, Gravite_Pos_Y)-(X, Y), RGB(255, 0, 0)
End If
End If
End If
End Sub
Private Sub Schema_Box_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
' on leve le clic, on deselectionne tout
MouseX = -1
MouseY = -1
PorteSelectionnee = -1
ReDraw Me.Schema_Box
End Sub
Private Sub Supprimer_Lien_Click()
'on supprime un lien
ActionEnCours.Caption = "Supprimer un lien"
Action = "supprime_lien"
End Sub
Private Sub Supprimer_Click()
'on supprime une pad
ActionEnCours.Caption = "Supprimer une porte"
Action = "supprime"
End Sub
Private Sub Main_Toolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
'Quand on clique sur un bouton de la toolbar, on appelle les sub definient par le menu
On Error Resume Next
Select Case Button.Key
Case "FitToScreen"
Mnu_PleineFenetre_Click
Case "ZoomIn"
Mnu_ZoomPlus_Click
Case "ZoomOut"
Mnu_ZoomMoins_Click
End Select
End Sub
Private Sub Mnu_PleineFenetre_Click()
'======================================================================================
'Mettre l'image en pleine fenetre
'======================================================================================
Call FitChildToParentScreen(Pct_Main_Parent, Pct_Main_Child, Img_Photo, _
Hsb_Main_Parent, Vsb_Main_Parent)
End Sub
Private Sub Mnu_ZoomMoins_Click()
'======================================================================================
'Zoom -
'======================================================================================
'on diminue la photo --> multiplie sa taille par un coeff de 0.8 Verticalement et
'Horizontalement
Call Zoom(Pct_Main_Parent, Pct_Main_Child, Img_Photo, Hsb_Main_Parent, _
Vsb_Main_Parent, 0.8, 0.8, FlagDrawGrid)
End Sub
Private Sub Mnu_ZoomPlus_Click()
'======================================================================================
'Zoom +
'======================================================================================
'on augmente la photo --> multiplie sa taille par un coeff de 1.2 Verticalement et
'Horizontalement
Call Zoom(Pct_Main_Parent, Pct_Main_Child, Img_Photo, Hsb_Main_Parent, _
Vsb_Main_Parent, 1.2, 1.2, FlagDrawGrid)
End Sub
Private Sub Dessine_Grille()
Dim i As Single
Dim j As Single
Schema_Box.DrawWidth = 1
Schema_Box.DrawMode = 6
Schema_Box.DrawStyle = 0
Schema_Box.PSet (0, 0), vbBlack
Echelle_X = CSng(txt_Grille_X.Text)
Echelle_Y = CSng(txt_Grille_Y.Text)
If Schema_Box.ScaleX(Echelle_X, vbUser, vbPixels) < 2 Then Exit Sub
If Schema_Box.ScaleY(Echelle_Y, vbUser, vbPixels) < 2 Then Exit Sub
Schema_Box.DrawWidth = 1
Schema_Box.DrawMode = 13
Schema_Box.DrawStyle = 0
For i = GridStart.X To Schema_Box.ScaleWidth + Schema_Box.ScaleLeft Step Echelle_X
For j = GridStart.Y To Schema_Box.ScaleHeight + Schema_Box.ScaleTop Step Echelle_Y
Schema_Box.PSet (i, j), vbBlack
Next j
Next i
For i = GridStart.X To Schema_Box.ScaleLeft Step -Echelle_X
For j = GridStart.Y To Schema_Box.ScaleTop Step -Echelle_Y
Schema_Box.PSet (i, j), vbBlack
Next j
Next i
For i = GridStart.X + CSng(txtGridX) To Schema_Box.ScaleWidth + Schema_Box.ScaleLeft Step Echelle_X
For j = GridStart.Y - CSng(txtGridY) To Schema_Box.ScaleTop Step -Echelle_Y
Schema_Box.PSet (i, j), vbBlack
Next j
Next i
For i = GridStart.X - CSng(txtGridX) To Schema_Box.ScaleLeft Step -Echelle_X
For j = GridStart.Y + CSng(txtGridY) To Schema_Box.ScaleHeight + Schema_Box.ScaleTop Step Echelle_Y
Schema_Box.PSet (i, j), vbBlack
Next j
Next i
End Sub
Private Sub Timer1_Timer()
Dim rect As POINTAPI
Call GetCursorPos(rect)
ScreenToClient Schema_Box.hwnd, rect
Prog_Frm.Lbl_X = rect.X
Lbl_Y = rect.Y
End Sub