File "VB12D.tmp"
Full Path: /home/analogde/www/Documents/DEV2/VB12D.tmp
File size: 6.18 KB
MIME-type: text/plain
Charset: 8 bit
Attribute VB_Name = "Module4"
Option Explicit
Dim Num As Integer
Dim Pos_X As Integer
Dim Pos_Y As Integer
Dim Type_Instance As String
Dim Orientation As String
Dim tmp As Long
' Filter
Public Const filtre_champ = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*|"
Public Function Ouvrir_Document()
' ouvrir un document existant
On Error GoTo OpenError
Dim Fichier_Nom As String
Dim Data As String
Dim chaine(200) As String
Dim nbre_ligne As Integer
Dim position As Integer
Dim cpt_PAD As Integer
nbre_ligne = 1
With Prog_Frm
.CmDlg.CancelError = True
.CmDlg.DialogTitle = "Selection du fichier ouvrir"
.CmDlg.Filter = filtre_champ
.CmDlg.FilterIndex = 1
.CmDlg.ShowOpen
End With
Fichier_Nom = Prog_Frm.CmDlg.FileName
' lecture du fichier
Open Fichier_Nom For Input As #1
' Dim intFic As Integer
'Dim client As tClient
'intFic = FreeFile
'Open "c:\pad.txt" For Random As intFic Len = Len(client)
'Get intFic, 1, client
'MsgBox client.Num
'Get intFic, 2, client
'MsgBox client.Num
'Close intFic
Dim temp As String
Dim PAD_toto As Integer
While Not EOF(1)
Input #1, Data$
cpt_PAD = cpt_PAD + 1
chaine(nbre_ligne) = Data$ ' + Chr$(13) + Chr$(10)
temp = chaine(nbre_ligne)
temp = extraction_champ(temp, "PAD")
' insert un pad
PAD_toto = Insert(Pos_X, Pos_Y, Type_Instance, Orientation)
ReDraw Prog_Frm.Schema_Box
nbre_ligne = nbre_ligne + 1
Wend
Close #1
OpenError:
'If Err.Number = 32755 Then Exit Function 'If canceled then exit function
'ErrorLog "modDocument/OpenDocument"
End Function
Public Function extraction_champ(chaine As String, type_objet As String)
Dim Tableau() As String
Dim i As Integer
'dcoupe la chaine en fonction des espaces " "
'le rsultat de la fonction Split est stock dans un tableau
Tableau = Split(chaine, " ")
'boucle sur le tableau pour visualiser le rsultat
For i = 0 To UBound(Tableau)
'Le rsultat s'affiche dans la fentre d'execution de l'diteur de macros
Debug.Print Tableau(i)
Next i
Num = Tableau(0)
Pos_X = Tableau(1)
Pos_Y = Tableau(2)
If (type_objet = "PAD") Then
Type_Instance = Tableau(3)
Orientation = LCase(Tableau(4))
End If
End Function
Public Property Get CancelError() As Boolean
CancelError = m_CancelError
End Property
Public Property Let CancelError(ByVal New_CancelError As Boolean)
m_CancelError = New_CancelError
PropertyChanged "CancelError"
End Property
Public Property Get Filter() As String
Filter = m_Filter
End Property
Public Property Let filtre(ByVal New_Filter As String)
m_Filter = New_Filter
PropertyChanged "Filtre"
End Property
Public Property Get FilterIndex() As Integer
FilterIndex = m_FilterIndex
End Property
Public Property Let FilterIndex(ByVal New_FilterIndex As Integer)
m_FilterIndex = New_FilterIndex
PropertyChanged "FilterIndex"
End Property
Public Property Get DialogTitle() As String
DialogTitle = m_DialogTitle
End Property
Public Property Let DialogTitle(ByVal New_DialogTitle As String)
m_DialogTitle = New_DialogTitle
PropertyChanged "DialogTitle"
End Property
Public Function Import_Template()
On Error GoTo OpenError
Dim Fichier_Nom As String
Dim Data As String
Dim chaine(200) As String
Dim nbre_ligne As Integer
Dim position As Integer
Dim cpt_PAD As Integer
nbre_ligne = 1
With Prog_Frm
.CmDlg.CancelError = True
.CmDlg.DialogTitle = "Selection du fichier ouvrir"
.CmDlg.Filter = filtre_champ
.CmDlg.FilterIndex = 1
.CmDlg.ShowOpen
End With
Fichier_Nom = Prog_Frm.CmDlg.FileName
' lecture du fichier
Open Fichier_Nom For Input As #1
Dim temp As String
Dim PAD_toto As Integer
While Not EOF(1)
Input #1, Data$
cpt_PAD = cpt_PAD + 1
chaine(nbre_ligne) = Data$
temp = chaine(nbre_ligne)
temp = extraction_champ(temp, "PIN")
' ajouter la pin
PAD_toto = Insert_Pin(Pos_X, Pos_Y, Num)
Affiche_PIN Prog_Frm.Schema_Box
nbre_ligne = nbre_ligne + 1
Wend
Close #1
OpenError:
End Function
Public Function Insert_Pin(ByVal cX As Integer, ByVal cY As Integer, ByVal Num) As Long
' incrmente le nombre de pin
NB_PIN = NB_PIN + 1
' redimensionne le tableau de liens
ReDim Preserve Objet_PIN(NB_PIN - 1)
' instancie une nouvelle pin
Set Objet_PIN(NB_PIN - 1) = New Broche
' defini les parametres de la nouvelle pin
tmp = Objet_PIN(NB_PIN - 1).Set_PIN_Parametres(NB_PIN - 1, cX, cY)
' retourne l'ID de la pin
Insert_Pin = NB_PIN - 1
End Function
Public Sub Affiche_PIN(pic As PictureBox)
Dim i As Integer
Dim PosX As Integer
Dim PosY As Integer
PosX = 0
PosY = 0
pic.Cls
For i = 0 To NB_PIN - 1
' recupere la position de la pin
tmp = Objet_PIN(i).Get_PIN_Position(PosX, PosY)
'dessine la pin
tmp = Dessine_PIN(PosX, PosY, pic)
Next i
End Sub
Public Function Dessine_PIN(ByVal X As Integer, ByVal Y As Integer, pic As PictureBox)
Dim i As Integer
'couleurboite = RGB(0, 0, 0)
'couleur = RGB(255, 0, 0)
'Trace des croix centres sur le curseur
For i = -5 To 5
pic.PSet (X - 66 + i, Y - 48), couleur
pic.PSet (X - 66, Y - 48 + i), couleur
'Trace des croix centres sur le curseur
Next i
' dessine une croix pour indiquer la position dans le plan
'pic.Line (X, Y)-(X + 50, Y), couleurboite
'pic.Line (X + 25, Y - 25)-(X, Y + 25), couleurboite
' dessine le point de gravit
' pic.Circle (X + largeur / 2, Y + hauteur / 2), taillepuce, couleur
'For i = 0 To 50
'pic.PSet (X, Y + i), couleurboite
'Next i
'For i = 0 To 50
'pic.PSet (X + 25, Y - 25 + i), couleurboite
'Next i
End Function