SIPRO15/Form2.frm0000755000000000000000000026020313730575261010520 0ustar VERSION 5.00 Begin VB.Form Service BackColor = &H00000080& Caption = "Tests et maintenance" ClientHeight = 7200 ClientLeft = 60 ClientTop = 345 ClientWidth = 9435 LinkTopic = "Form2" ScaleHeight = 489.172 ScaleMode = 0 'User ScaleWidth = 640 StartUpPosition = 3 'Windows Default Begin VB.TextBox Spy BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 2040 TabIndex = 111 Top = 6840 Width = 2775 End Begin VB.CommandButton BtPanique Caption = "PANIQUE" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 7200 TabIndex = 108 Top = 6120 Width = 2055 End Begin VB.CommandButton btT1 Caption = "Programmation" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 7200 TabIndex = 103 Top = 6720 Width = 2055 End Begin VB.CommandButton BtSync Caption = "SYNC" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1575 Left = 4560 TabIndex = 102 Top = 4440 Visible = 0 'False Width = 375 End Begin VB.Timer Timer1 Enabled = 0 'False Interval = 100 Left = 4560 Top = 6240 End Begin VB.CheckBox Check1 Caption = "FinCycle" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 4920 TabIndex = 81 Top = 6840 Width = 2055 End Begin VB.CommandButton BtPowMotOff Caption = "Pas d'alim Moteurs" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 4920 TabIndex = 80 Top = 6360 Width = 2055 End Begin VB.CommandButton BtPwrMotOn Caption = "Alim Moteurs" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 4920 TabIndex = 79 Top = 6120 Width = 2055 End Begin VB.CheckBox Check5 Caption = "Frein" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 4920 TabIndex = 74 Top = 6600 Width = 2055 End Begin VB.Frame Frame1 BackColor = &H00C0FFC0& Caption = "Translation / Guide" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 5880 Left = 4920 TabIndex = 50 Top = 120 Width = 4300 Begin VB.CommandButton BtRSTIT Caption = "RSTI" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 110 Top = 5520 Width = 1095 End Begin VB.TextBox TxCPmm Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 95 Text = "0" Top = 5160 Width = 735 End Begin VB.CheckBox CkDirT BackColor = &H00C0FFC0& Caption = "Direction" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 91 Top = 4920 Width = 1215 End Begin VB.CheckBox CkModeVeloT BackColor = &H00C0FFC0& Caption = "Mode Vélocité" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 89 Top = 4680 Width = 1575 End Begin VB.CommandButton BtFilterT Caption = "Test filtre" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 3000 TabIndex = 87 Top = 5520 Width = 1215 End Begin VB.CommandButton BtHResetT Caption = "RAZ" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 85 Top = 3240 Width = 975 End Begin VB.TextBox TxFilkpT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 20 Text = "0" Top = 3960 Width = 735 End Begin VB.CommandButton BtMajT Caption = "M.A.J Fichier" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 24 Top = 3240 Width = 1335 End Begin VB.TextBox TxIET Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 19 Text = "0" Top = 3600 Width = 735 End Begin VB.CommandButton BtTRJT Caption = "Test trajectoire" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 25 Top = 5520 Width = 1575 End Begin VB.TextBox TxFilkiT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 21 Text = "0" Top = 4320 Width = 735 End Begin VB.TextBox TxFilkdT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 22 Text = "0" Top = 4680 Width = 735 End Begin VB.TextBox TxFililT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 23 Text = "0" Top = 5040 Width = 735 End Begin VB.TextBox TxAccelT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 13 Text = "0" Top = 3600 Width = 735 End Begin VB.TextBox TxVeloT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 15 Text = "0" Top = 3960 Width = 735 End Begin VB.TextBox TxPosT Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 17 Text = "0" Top = 4320 Width = 735 End Begin VB.CheckBox CkAccelRelT BackColor = &H00C0FFC0& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 14 Top = 3600 Width = 735 End Begin VB.CheckBox CkVeloRelT BackColor = &H00C0FFC0& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 16 Top = 3960 Width = 855 End Begin VB.CheckBox CkPosRelT BackColor = &H00C0FFC0& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 18 Top = 4320 Width = 855 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "1 mm =" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 9 Left = 240 TabIndex = 94 Top = 5205 Width = 615 End Begin VB.Label Label2 Alignment = 2 'Center AutoSize = -1 'True BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Tests manuels" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 25 Left = 1320 TabIndex = 83 Top = 3240 Width = 1305 End Begin VB.Line Line2 X1 = 0 X2 = 4320 Y1 = 3120 Y2 = 3120 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "IE" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 23 Left = 3000 TabIndex = 78 Top = 3600 Width = 195 End Begin VB.Label LbIntegrationT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 73 Top = 1920 Visible = 0 'False Width = 1305 End Begin VB.Label Label2 Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Vélocité lue" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 20 Left = 1560 TabIndex = 72 Top = 2280 Width = 1695 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Intég:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 19 Left = 2280 TabIndex = 71 Top = 1920 Visible = 0 'False Width = 510 End Begin VB.Label Label2 Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Position lue" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 18 Left = 1560 TabIndex = 70 Top = 1200 Width = 1695 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Désiré:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 17 Left = 120 TabIndex = 69 Top = 1920 Width = 615 End Begin VB.Label LbDesiredPosT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 68 Top = 1920 Width = 1545 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Index:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 16 Left = 2280 TabIndex = 67 Top = 1560 Visible = 0 'False Width = 540 End Begin VB.Label LbIndexPosT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 66 Top = 1560 Visible = 0 'False Width = 1305 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Réèl:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 15 Left = 120 TabIndex = 65 Top = 1560 Width = 465 End Begin VB.Label LbRealPosT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 64 Top = 1560 Width = 1545 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Désiré:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 14 Left = 2280 TabIndex = 63 Top = 2640 Width = 615 End Begin VB.Label LbDesiredVeloT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 62 Top = 2640 Width = 1305 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Etat:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 10 Left = 1680 TabIndex = 61 Top = 240 Width = 420 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "kp:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 8 Left = 3000 TabIndex = 60 Top = 3960 Width = 285 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "ki:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 7 Left = 3000 TabIndex = 59 Top = 4320 Width = 225 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "kd:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 6 Left = 3000 TabIndex = 58 Top = 4680 Width = 285 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "il:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 5 Left = 3000 TabIndex = 57 Top = 5040 Width = 165 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Accel:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 3 Left = 120 TabIndex = 56 Top = 3600 Width = 555 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Vélocité:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 2 Left = 120 TabIndex = 55 Top = 3960 Width = 765 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Position" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 1 Left = 120 TabIndex = 54 Top = 4320 Width = 690 End Begin VB.Label LbStatT Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1440 TabIndex = 53 Top = 510 Width = 915 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Réèl:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 0 Left = 120 TabIndex = 52 Top = 2640 Width = 465 End Begin VB.Label LbReaelVeloT Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 51 Top = 2640 Width = 1305 End End Begin VB.Frame Frame2 BackColor = &H00C0FFFF& Caption = "Rotation / Broche" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 5880 Left = 240 TabIndex = 26 Top = 120 Width = 4300 Begin VB.CommandButton Command1 Caption = "Command1" Height = 255 Left = 360 TabIndex = 112 Top = 720 Visible = 0 'False Width = 1095 End Begin VB.CommandButton BtRSTIR Caption = "RSTI" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 109 Top = 5520 Width = 1095 End Begin VB.TextBox TxCPTR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 93 Text = "0" Top = 5160 Width = 735 End Begin VB.CheckBox CkDirR BackColor = &H00C0FFFF& Caption = "Direction" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 90 Top = 4920 Width = 1215 End Begin VB.CheckBox CkModeVeloR BackColor = &H00C0FFFF& Caption = "Mode Vélocité" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 88 Top = 4680 Width = 1575 End Begin VB.CommandButton BtFilterR Caption = "Test filtre" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 3000 TabIndex = 86 Top = 5520 Width = 1215 End Begin VB.CommandButton BtHResetR Caption = "RAZ" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 84 Top = 3240 Width = 975 End Begin VB.TextBox TxIER Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 6 Text = "0" Top = 3600 Width = 735 End Begin VB.CheckBox CkPosRelR BackColor = &H00C0FFFF& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 5 Top = 4320 Width = 855 End Begin VB.CheckBox CkVeloRelR BackColor = &H00C0FFFF& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 3 Top = 3960 Width = 855 End Begin VB.CheckBox CkAccelRelR BackColor = &H00C0FFFF& Caption = "Rel." BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1800 TabIndex = 1 Top = 3600 Width = 735 End Begin VB.TextBox TxPosR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 4 Text = "0" Top = 4320 Width = 735 End Begin VB.TextBox TxVeloR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 2 Text = "0" Top = 3960 Width = 735 End Begin VB.TextBox TxAccelR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 960 TabIndex = 0 Text = "0" Top = 3600 Width = 735 End Begin VB.TextBox TxFililR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 10 Text = "0" Top = 5040 Width = 735 End Begin VB.TextBox TxFilkdR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 9 Text = "0" Top = 4680 Width = 735 End Begin VB.TextBox TxFilkiR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 8 Text = "0" Top = 4320 Width = 735 End Begin VB.CommandButton BtTRJR Caption = "Test trajectoire" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 12 Top = 5520 Width = 1575 End Begin VB.TextBox TxFilkpR Alignment = 1 'Right Justify BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Left = 3360 TabIndex = 7 Text = "0" Top = 3960 Width = 735 End Begin VB.CommandButton BtMajR Caption = "M.A.J Fichier" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 11 Top = 3240 Width = 1335 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "1 Tour =" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 4 Left = 120 TabIndex = 92 Top = 5205 Width = 735 End Begin VB.Label Label2 Alignment = 2 'Center AutoSize = -1 'True BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Tests manuels" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 24 Left = 1320 TabIndex = 82 Top = 3240 Width = 1305 End Begin VB.Line Line1 X1 = 0 X2 = 4320 Y1 = 3120 Y2 = 3120 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "IE" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 22 Left = 3000 TabIndex = 77 Top = 3600 Width = 195 End Begin VB.Label LbReaelVeloR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 49 Top = 2640 Width = 1300 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Réèl:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 64 Left = 120 TabIndex = 48 Top = 2640 Width = 465 End Begin VB.Label LbStatR Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 1680 TabIndex = 47 Top = 510 Width = 915 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Position:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 63 Left = 120 TabIndex = 46 Top = 4320 Width = 750 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Vélocité:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 62 Left = 120 TabIndex = 45 Top = 3960 Width = 765 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Accel:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 61 Left = 120 TabIndex = 44 Top = 3600 Width = 555 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "il:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 59 Left = 3000 TabIndex = 43 Top = 5040 Width = 165 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "kd:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 58 Left = 3000 TabIndex = 42 Top = 4680 Width = 285 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "ki:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 57 Left = 3000 TabIndex = 41 Top = 4320 Width = 225 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "kp:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 56 Left = 3000 TabIndex = 40 Top = 3960 Width = 285 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Etat:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 54 Left = 1920 TabIndex = 39 Top = 240 Width = 420 End Begin VB.Label LbDesiredVeloR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 38 Top = 2640 Width = 1305 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Désiré:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 50 Left = 2280 TabIndex = 37 Top = 2640 Width = 615 End Begin VB.Label LbRealPosR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 36 Top = 1560 Width = 1545 WordWrap = -1 'True End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Réèl:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 49 Left = 120 TabIndex = 35 Top = 1560 Width = 465 End Begin VB.Label LbIndexPosR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 34 Top = 1560 Visible = 0 'False Width = 1305 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Index:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 48 Left = 2280 TabIndex = 33 Top = 1560 Visible = 0 'False Width = 540 End Begin VB.Label LbDesiredPosR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 720 TabIndex = 32 Top = 1920 Width = 1545 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Désiré:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 47 Left = 120 TabIndex = 31 Top = 1920 Width = 615 End Begin VB.Label Label2 Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Position lue" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 46 Left = 1560 TabIndex = 30 Top = 1200 Width = 1695 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Intég:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Index = 45 Left = 2280 TabIndex = 29 Top = 1920 Visible = 0 'False Width = 510 End Begin VB.Label Label2 Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Vélocité lue" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Index = 41 Left = 1560 TabIndex = 28 Top = 2280 Width = 1695 End Begin VB.Label LbIntegrationR Alignment = 1 'Right Justify BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2880 TabIndex = 27 Top = 1920 Visible = 0 'False Width = 1305 End End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "E/S C" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 12 Left = 240 TabIndex = 107 Top = 6720 Width = 525 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "E/S B" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 11 Left = 240 TabIndex = 106 Top = 6480 Width = 525 End Begin VB.Label LbESC Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 960 TabIndex = 105 Top = 6720 Width = 915 End Begin VB.Label LbESB Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 960 TabIndex = 104 Top = 6480 Width = 915 End Begin VB.Label LbMotB Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 2160 TabIndex = 101 Top = 6480 Visible = 0 'False Width = 915 End Begin VB.Label LbMotC Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 3480 TabIndex = 100 Top = 6480 Visible = 0 'False Width = 915 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "IF Mot.Pc" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 30 Left = 1920 TabIndex = 99 Top = 6480 Visible = 0 'False Width = 840 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "IF Mot.Pb" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 29 Left = 1920 TabIndex = 98 Top = 6240 Visible = 0 'False Width = 840 End Begin VB.Label LbMotA Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 3480 TabIndex = 97 Top = 6240 Width = 915 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "IF Mot.Pa" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 28 Left = 2520 TabIndex = 96 Top = 6240 Width = 840 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "E/S A" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 195 Index = 21 Left = 240 TabIndex = 76 Top = 6240 Width = 525 End Begin VB.Label LbESA Alignment = 1 'Right Justify AutoSize = -1 'True BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Caption = "00000000" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 960 TabIndex = 75 Top = 6240 Width = 915 End End Attribute VB_Name = "Service" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Sub BtFilterR_Click() SetFilterR End Sub Public Sub SetFilterR() LoadFilters RAxis, Val(TxIER.Text), Val(TxFilkpR.Text), _ Val(TxFilkiR.Text), Val(TxFilkdR.Text), Val(TxFililR) ' GetToken RAxis LM628Poke1 RAxis, UDF 'Apply immediatly ' FreeToken RAxis End Sub Private Sub BtFilterT_Click() SetFilterT End Sub Public Sub SetFilterT() LoadFilters TAxis, Val(TxIET.Text), Val(TxFilkpT.Text), _ Val(TxFilkiT.Text), Val(TxFilkdT.Text), Val(TxFililT) ' GetToken TAxis LM628Poke1 TAxis, UDF 'Apply immediatly ' FreeToken TAxis End Sub Private Sub BtHResetR_Click() DisableDriverR Wait 100 HReset RAxis MoveR 0, RELATIVE EnableDriverR BtTRJR.Enabled = True End Sub Private Sub BtHResetT_Click() DisableDriverT Wait 100 HReset TAxis MoveT 0, RELATIVE EnableDriverT BtTRJT.Enabled = True End Sub Private Sub BtMajR_Click() 'Save current Rotation values. SetLFILR App.Path & "\LM628R.ini" SetLTRJR App.Path & "\LM628R.ini" End Sub Private Sub BtPanique_Click() 'Just Motor Power OFF ? ? PwrMotOff DisableDriverT DisableDriverR End Sub Private Sub BtMajT_Click() 'Save current Translation values. SetLFILT App.Path & "\LM628T.ini" SetLTRJT App.Path & "\LM628T.ini" End Sub Private Sub SetLFILR(File As String) WriteIniString File, "LFIL", "IE", TxIER.Text WriteIniString File, "LFIL", "kp", TxFilkpR.Text WriteIniString File, "LFIL", "ki", TxFilkiR.Text WriteIniString File, "LFIL", "kd", TxFilkdR.Text WriteIniString File, "LFIL", "il", TxFililR.Text End Sub Private Sub SetLTRJR(File As String) WriteIniString File, "LTRJ", "Acceleration", TxAccelR.Text WriteIniString File, "LTRJ", "RelAcceleration", CkAccelRelR.Value WriteIniString File, "LTRJ", "Velocity", TxVeloR.Text WriteIniString File, "LTRJ", "RelVelocity", CkVeloRelR.Value WriteIniString File, "LTRJ", "Position", TxPosR.Text WriteIniString File, "LTRJ", "RelPosition", CkPosRelR.Value WriteIniString File, "LTRJ", "ModeVelocity", CkModeVeloR.Value WriteIniString File, "LTRJ", "Direction", CkDirR.Value WriteIniString File, "LTRJ", "CountsPerTurn", TxCPTR.Text End Sub Private Sub SetLFILT(File As String) WriteIniString File, "LFIL", "IE", TxIET.Text WriteIniString File, "LFIL", "kp", TxFilkpT.Text WriteIniString File, "LFIL", "ki", TxFilkiT.Text WriteIniString File, "LFIL", "kd", TxFilkdT.Text WriteIniString File, "LFIL", "il", TxFililT.Text End Sub Private Sub SetLTRJT(File As String) WriteIniString File, "LTRJ", "Acceleration", TxAccelT.Text WriteIniString File, "LTRJ", "RelAcceleration", CkAccelRelT.Value WriteIniString File, "LTRJ", "Velocity", TxVeloT.Text WriteIniString File, "LTRJ", "RelVelocity", CkVeloRelT.Value WriteIniString File, "LTRJ", "Position", TxPosT.Text WriteIniString File, "LTRJ", "RelPosition", CkPosRelT.Value WriteIniString File, "LTRJ", "ModeVelocity", CkModeVeloT.Value WriteIniString File, "LTRJ", "Direction", CkDirT.Value WriteIniString File, "LTRJ", "CountsPermm", TxCPmm.Text End Sub Private Sub BtPowMotOff_Click() PwrMotOff End Sub Private Sub BtPwrMotOn_Click() PwrMotOn End Sub Private Sub BtRSTIR_Click() DoRSTI RAxis End Sub Private Sub BtRSTIT_Click() DoRSTI TAxis End Sub Private Sub BtSync_Click() Dim Target As Long 'Use displayed parameters and start both axis simultaneously 'LoadTrajectory function get and free tokens themselves Poke MOTB, ENMOTR + ENMOTT 'Motors enable Target = DPR + Val(TxPosR.Text) * Val(TxCPTR.Text) LoadTrajectory RAxis, _ CkDirR.Value, _ Val(TxAccelR.Text), _ CkAccelRelR.Value, _ Val(TxVeloR.Text), _ CkVeloRelR.Value, _ Target, _ CkPosRelR.Value, _ CkModeVeloR.Value Target = DPT + Val(TxPosT.Text) * Val(TxCPmm.Text) LoadTrajectory TAxis, _ CkDirT.Value, _ Val(TxAccelT.Text), _ CkAccelRelT.Value, _ Val(TxVeloT.Text), _ CkVeloRelT.Value, _ Target, _ CkPosRelT.Value, _ CkModeVeloT.Value GetToken RAxis GetToken TAxis LM628Poke1 RAxis, STT 'Start moving both LM628Poke1 TAxis, STT FreeToken RAxis FreeToken TAxis End Sub Private Sub btT1_Click() Form1.Show Programing = True End Sub Private Sub BtTRJR_Click() Dim Target As Long BtTRJR.Enabled = False Target = Val(TxPosR.Text) * Val(TxCPTR.Text) 'DPR + Val(TxPosR.Text) * Val(TxCPTR.Text) LoadTrajectory RAxis, _ CkDirR.Value, _ Val(TxAccelR.Text), _ CkAccelRelR.Value, _ Val(TxVeloR.Text), _ CkVeloRelR.Value, _ Target, _ CkPosRelR.Value, _ CkModeVeloR.Value GetToken RAxis LM628Poke1 RAxis, STT 'Start moving immediatly ! FreeToken RAxis WaitRtrajectoryComplete BtTRJR.Enabled = True End Sub Private Sub BtTRJT_Click() Dim Target As Long BtTRJT.Enabled = False Target = Val(TxPosT.Text) * Val(TxCPmm.Text) ' + DPT LoadTrajectory TAxis, _ CkDirT.Value, _ Val(TxAccelT.Text), _ CkAccelRelT.Value, _ Val(TxVeloT.Text), _ CkVeloRelT.Value, _ Target, _ CkPosRelT.Value, _ CkModeVeloT.Value GetToken TAxis LM628Poke1 TAxis, STT 'Start moving immediatly ! FreeToken TAxis WaitTtrajectoryComplete BtTRJT.Enabled = True End Sub Private Sub Check1_Click() ' EndCycle Dim X As Byte X = Peek(GIOA) If Check1.Value Then Poke GIOA, X Or ENDCYCLE Else Poke GIOA, X And BRAKEON + MOTPWRON + MOTPWROFF End If End Sub Private Sub Check5_Click() ' Brake Dim X As Byte X = Peek(GIOA) If Check5.Value = 0 Then Poke GIOA, X Or BRAKEON 'Set to disable brake Else Poke GIOA, X And MOTPWRON + MOTPWROFF + ENDCYCLE End If End Sub Private Sub Command1_Click() ReadLM628s UpdateReadValues End Sub Private Sub Form_Load() #If Nohard Then Command1.Visible = True Debug.Print Debug.Print Debug.Print "***************** Service Form Load " TestPeekPoke.Show #End If Timer1.Enabled = False CenterForm Me Me.Show GetLFILR App.Path & "\LM628R.ini" GetLTRJR App.Path & "\LM628R.ini" GetLFILT App.Path & "\LM628T.ini" GetLTRJT App.Path & "\LM628T.ini" Kaccel = 2000 'Default until specified by OP. InitIO HReset RAxis HReset TAxis ' Dummy move once to reset Motor Off flag in LM628 MoveT 0, RELATIVE MoveR 0, RELATIVE EnableDriverR EnableDriverT #If Nohard = 0 Then Timer1.Enabled = True #End If PwrMotOn AllowsFreeShaft = True Me.BackColor = RGB(0, 180, 0) End Sub Private Sub Timer1_Timer() Static AutoExclude As Boolean Static VGuideStep As Integer Static FootStopped As Boolean 'Static BlinkRate As Integer 'Static Blink As Boolean If (Rtoken = True) Or (Ttoken = True) Then ' Debug.Print "Token in use" Exit Sub 'A LM628 multi bytes command is while loading, try later. End If If AutoExclude Then Exit Sub 'Do not reenter AutoExclude = True IOSwitchesA = Peek(GIOA) IOSwitchesB = Peek(GIOB) If IOSwitchesB And FOOTSWITCH Then 'Op is now allowed to press footswitch to free shaft If Not ShaftFree Then ShaftFree = True FootStopped = True DisableDriverR End If Else If ShaftFree And FootStopped Then ShaftFree = False FootStopped = False HReset RAxis MoveR 0, RELATIVE EnableDriverR End If End If FCButtonState = IOSwitchesB And FCBUTTON IOSwitchesC = Peek(GIOC) MotCtrlStat = Peek(MOTA) If Not SuspendPoll Then ReadLM628s 'Get as many infos as possible about hardware state UpdateReadValues 'Show collected If Not Simulate Then SetRef.FollowRPT (-RPT / CNTPERMM) SetRef.LbTurns.Caption = Format(Abs(RPR / CNTPERTURN), "#.0") End If End If ' BlinkRate = BlinkRate + 1 ' If BlinkRate > 3 Then ' BlinkRate = 0 ' Blink = Not Blink ' If Blink Then SetEndCycleOn ' Else: SetEndCycleOff ' End If '' TO DO and TEST WHEN HARDWARE AVAILABLE '' ' If VGuideStep = 0 Then 'Check for move ' If GuideTarget > GuideCurrent Then 'Do move ' MoveVUp ' End If ' If GuideTarget < GuideCurrent Then ' MoveVDown ' End If ' VGuideStep = VGUIDEPERIOD 'Reload interval ' Else ' VGuideStep = VGuideStep - 1 ' End If AutoExclude = False End Sub Private Sub GetLFILR(File As String) TxIER.Text = GetIniString(File, "LFIL", "IE") TxFilkpR.Text = GetIniString(File, "LFIL", "kp") TxFilkiR.Text = GetIniString(File, "LFIL", "ki") TxFilkdR.Text = GetIniString(File, "LFIL", "kd") TxFililR.Text = GetIniString(File, "LFIL", "il") End Sub Private Sub GetLFILT(File As String) TxIET.Text = GetIniString(File, "LFIL", "IE") TxFilkpT.Text = GetIniString(File, "LFIL", "kp") TxFilkiT.Text = GetIniString(File, "LFIL", "ki") TxFilkdT.Text = GetIniString(File, "LFIL", "kd") TxFililT.Text = GetIniString(File, "LFIL", "il") End Sub Private Sub GetLTRJR(File As String) TxAccelR.Text = GetIniString(File, "LTRJ", "Acceleration") CkAccelRelR.Value = Val(GetIniString(File, "LTRJ", "RelAcceleration")) TxVeloR.Text = GetIniString(File, "LTRJ", "Velocity") CkVeloRelR.Value = Val(GetIniString(File, "LTRJ", "RelVelocity")) TxPosR.Text = GetIniString(File, "LTRJ", "Position") CkPosRelR.Value = Val(GetIniString(File, "LTRJ", "Relposition")) CkModeVeloR.Value = Val(GetIniString(File, "LTRJ", "ModeVelocité")) CkDirR.Value = Val(GetIniString(File, "LTRJ", "Direction")) TxCPTR.Text = GetIniString(File, "LTRJ", "CountsPerTurn") End Sub Private Sub GetLTRJT(File As String) TxAccelT.Text = GetIniString(File, "LTRJ", "Acceleration") CkAccelRelT.Value = Val(GetIniString(File, "LTRJ", "RelAcceleration")) TxVeloT.Text = GetIniString(File, "LTRJ", "Velocity") CkVeloRelT.Value = Val(GetIniString(File, "LTRJ", "RelVelocity")) TxPosT.Text = GetIniString(File, "LTRJ", "Position") CkPosRelT.Value = Val(GetIniString(File, "LTRJ", "Relposition")) CkModeVeloT.Value = Val(GetIniString(File, "LTRJ", "ModeVelocité")) CkDirT.Value = Val(GetIniString(File, "LTRJ", "Direction")) TxCPmm.Text = GetIniString(File, "LTRJ", "CountsPermm") End Sub Public Sub UpdateReadValues() LbDesiredPosR.Caption = Format(DPR) LbDesiredPosT.Caption = Format(DPT) LbDesiredVeloR.Caption = Str(DVR) LbDesiredVeloT.Caption = Str(DVT) LbIndexPosR.Caption = Str(IPR) LbIndexPosT.Caption = Str(IPT) LbIntegrationR.Caption = "?" LbIntegrationT.Caption = "?" LbReaelVeloR.Caption = Str(RVR) LbReaelVeloT.Caption = Str(RVT) LbRealPosR.Caption = Format(RPR) LbRealPosT.Caption = Format(RPT) LbMotA.Caption = LongToSBin(MotCtrlStat) LbStatR.Caption = LongToSBin(STATR) LbStatT.Caption = LongToSBin(STATT) LbESA.Caption = LongToSBin(IOSwitchesA) LbESB.Caption = LongToSBin(IOSwitchesB) LbESC.Caption = LongToSBin(IOSwitchesC) End Sub Private Sub TxAccelR_Change() RealAccelR = Val(TxAccelR.Text) End Sub Private Sub TxAccelT_Change() RealAccelT = Val(TxAccelT.Text) End Sub Private Sub TxVeloR_Change() RealVeloR = Val(TxVeloR.Text) End Sub Private Sub TxVeloT_Change() RealVeloT = Val(TxVeloT.Text) End Sub SIPRO15/Global.bas0000755000000000000000000010403613730575264010720 0ustar Attribute VB_Name = "Global" Option Explicit Global Machine As Integer 'The attached machine Public Const NOMACHINE = 0 Public Const SIPROMACHINE = 1 Public Const TESTMACHINE = 2 Public Programing As Boolean ''' Some GLOBAL VARIABLES to control execution ' Global AbortExec As Boolean Global Stepping As Integer Global Simulate As Boolean Global Pause As Boolean Global Suspended As Boolean Global InMacro As Integer Global FootSwitchState As Boolean Global FCButtonState As Boolean 'The physical button Global VButtonState As Boolean 'The Virtual (on screen) button Public ProgCopy As String ' Copy for redo Public SilentRun As Boolean Public SuspendLine As Integer Public SuspendStep As Integer Public RunList As String Public Running As String Public BreakLine As Integer Public Const BYSTEP = 1 'Constants for run mode Public Const SIMUL = 2 Public Const TOSTOP = 4 Public TheCaption As String Public LineNo As Integer 'To show current program line Public StepNo As Integer 'To show current program step Public LastPosDone As String Public PrgFile As String 'Path to files Public CcxFile As String Public GgxFile As String Public PrjFile As String ''' For X (carriage ) axis Public Type DChamber 'Pos and size for a chamber Org As Single Width As Single Free As Single End Type Public Chambers(1 To 4) As DChamber Public Chamber As Integer 'Current chamber( or former) 'Dim ChamberFree As Single 'Space remaining in the current chamber '' Moved in DChamber Public RefOffset As Single 'Actual reference offset from ZERO Public PosT As Single 'Actual carriage location relative to reference (in mm)'' Why not a long ? Public Direction As Integer '(1 = to right, -1 = to left) Const TORIGHT = 1 Const TOLEFT = -1 ''' For Y (shaft) axis Dim PosR As Single '' Why not a long ? Public ShaftFree As Boolean ''' For V (carriage lift) axis Global Const GUIDETRAVEL = 200 Public Guide As Integer ' Current guide Public Guides(1 To 4) As Single 'Offset for guides Public GuideTarget As Single ' Where it should be Public GuideCurrent As Single ' Where it really is Public GuideFromPark As Single ' Where it was before parking Global Const GUIDESTEPPERMM = 10 ' Steps per mm Global Const VGUIDEPERIOD = 100 ' Times Service.Timer1 interval Public TbVstep(0 To 7) As Byte 'Steps for the motors (10, 8, 9, 1, 5, 4, 6, 2) Public CurVstep As Integer Public GDone As Boolean Dim Turns As Single 'Last know values. Used by default if not specified Dim Pitch As Single Dim Layers As Single Global RealVeloR As Long Global RealVeloT As Long Global RealAccelR As Long Global RealAccelT As Long Public Sub Main() Dim S As String Machine = 0 S = LCase(Command$) If Len(S) Then Else StartForm.Show End If Select Case Machine Case NOMACHINE Form1.Show Case SIPROMACHINE Service.Show Case TESTMACHINE Exit Sub End Select End Sub Public Sub InitSpVars() 'Initialize the four special variables Dim I As Integer '' TODO '' Add Guides ? SetNVar ":LargeurC1", Chambers(1).Width SetNVar ":LargeurC2", Chambers(2).Width SetNVar ":LargeurC3", Chambers(3).Width SetNVar ":LargeurC4", Chambers(4).Width Form1.RefreshNVars End Sub Public Sub ProgExec(S As String) Dim LLen As Integer Dim I As Integer Dim Sleft As String Dim Command As String Form1.BtDummy.SetFocus 'Immune default button While Suspended 'Panic ! Stay here Wait 100 Wend If AbortExec Then ShowFatal "--- Exécution abandonnée ---" S = "" Exit Sub End If If Len(S) = 0 Then If InMacro Then ShowInfo "--- Fin de macro ---" Else ShowInfo "--- Fin du programme ---" End If Exit Sub End If ' Debug.Print S LLen = InStr(S, vbCrLf) 'Look for a Line feed (eol) ' Beep SuspendLine = LineNo LineNo = LineNo + 1 ' If SilentRun Then ' If LineNo = SuspendLine And StepNo = SuspendStep Then 'Target reached ' SilentRun = False ' ShowInfo "Point de reprise . . ." ' End If ' End If If LLen > 1 Then SuspendStep = StepNo StepNo = StepNo + 1 ShowLineStep Sleft = Trim(Left(S, LLen)) 'Current line) #If Nohard Then Debug.Print "Current Line: "; TTrim(Sleft) #End If Form1.CurLine.Caption = Sleft S = Right(S, Len(S) - LLen) 'Remainder I = InStr(Sleft, "#") 'Look for comment If I Then Sleft = Left(Sleft, I - 1) 'Remove comment from current line If Len(Sleft) Then 'Something else ? ' Form1.BtDoProg.Enabled = False Command = GetCommand(Sleft) Sleft = TTrim(Sleft) ' Select Case UCase(Left(Trim(Command), 1)) 'Commands are not case sensitive Select Case Left(Trim(Command), 1) 'Commands ARE case sensitive Case "A" 'Acceleration Kaccel = 1 + 10000 \ EvalExp(GetParam(Sleft)) 'Can't be zero. SetNVar ":Accel", Kaccel ShowInfo "Accélération: " & Format(Kaccel) Case "C" 'Load former file LoadFormer Sleft Case "G" 'Load guide file infos LoadGuide Sleft Case "R" ' Set reference SetRefV Sleft Case "P" ' "POSITION" Position Sleft ' Add (sub) guide offset Case "B" ' "BOBINE", "BOBINER" Roll Sleft ', 0 Case "V" 'Rotation speed in rpm SetRpm Sleft Case "H", "^" ShowInfo "Positionne l'ascenseur" PosVGuide Sleft ' Case "Z" ' ShowInfo "Recherche du zéro, patientez !" ' GoToZero Case "[", "D", "T" BlocBegin Sleft, S 'Will not return before end of bloc Case "]", "F" 'End of bloc, exit Exit Sub Case "S" '"IF" command. . . IfBegin Sleft, S Case "!", "I" If Len(Sleft) Then ShowInfo Left(Sleft, Len(Sleft)) Else ShowInfo "Presser bouton" End If WaitFCbutton Case "(", "{", "M" 'Insert/execute another program (macro) DoMacro Sleft, S Case "E", "§", "X" StopOrSetMode Sleft Case Else 'Not a command, may be a variable affectation with or without spaces Sleft = Command & Sleft If Len(Sleft) <> 0 Then 'Empty line, ignore I = InStr(Sleft, "=") If I <> 0 Then 'OK, it is an affectation If IsVar(Left(Sleft, I - 1)) Then AffectVar Sleft Else ShowFatal "Mauvais nom de variable" End If Else ShowFatal "Commande inconnue" End If End If End Select End If Else S = Right(S, Len(S) - LLen) 'Eat the line If Len(S) < 2 Then S = "" 'Too short ! End If If Len(Trim(S)) Then ProgExec S 'Up to end of string End Sub Private Sub StopOrSetMode(S As String) Dim Mode As Single Mode = EvalExp(S) '' Set chkboxes according to mode Form1.SetCkMode Mode If SilentRun Then ShowInfo "STOP ATTEIND" End If End Sub Private Sub WaitStep() 'Returns immediatly if not stepping, else wait . . . If AbortExec Then Exit Sub If SilentRun Then Exit Sub If Stepping Then Pause = True While Pause And Not AbortExec Wait 100 Wend End If End Sub Private Sub WaitFCbutton() If AbortExec Then Exit Sub If SilentRun Then Exit Sub Form1.BtFcbutton.Enabled = True 'Enable Virtual button SetEndCycleOn 'Light ON physical button Form1.BtDoProg.Enabled = False VButtonState = False While (Not (FCButtonState Or VButtonState)) And (Not AbortExec) 'Until someone else set it true Wait 100 If IOSwitchesB And FOOTSWITCH Then 'Op is now allowed to press footswitch to free shaft If Not ShaftFree Then ShaftFree = True DisableDriverR End If Else If ShaftFree Then ShaftFree = False HReset RAxis MoveR 0, RELATIVE EnableDriverR End If End If Wend If ShaftFree Then 'Insure shaft is not free ShaftFree = False HReset RAxis MoveR 0, RELATIVE EnableDriverR End If SetEndCycleOff 'Light OFF physical button While FCButtonState ' Wait for OP releases the button Wait 100 Wend ' FCButtonState = False Form1.BtFcbutton.Enabled = False ' SetEndCycleOff 'Light OFF physical button Form1.BtDoProg.Enabled = True End Sub Public Sub ShowInfo(S As String) If SilentRun Then Exit Sub Form1.TxInfo.Text = ExpandExp(S) WaitStep End Sub Public Function ExpandExp(S As String) As String 'Expand expressions included in curly brackets Dim I As Integer Dim T As String Dim L As Integer Dim E As String I = InStr(S, "{") 'Look for an open curly brace If I Then E = Left(S, I - 1) 'Get the left part T = Mid(S, I + 1) L = InStr(T, "}") - 1 'and a balanced closing one If L Then E = E & EvalExp(Left(T, L)) & Right(T, Len(T) - L - 1) ExpandExp = ExpandExp(E) 'More expressions to extend ? Exit Function End If Else ExpandExp = S End If End Function Public Sub ShowFatal(S As String) Beep Form1.TxInfo.Text = Str(LineNo) & " in " & Running & " Erreur: " & S ' AbortExec = True ' Pause = True 'Force pause ' While Pause And Not AbortExec ' Wait 100 ' Wend AbortExec = True End Sub Private Sub IfBegin(Sleft As String, S As String) Dim Condition As Single Condition = EvalExp(Sleft) ShowInfo "Début bloc à exécuter si <" & Sleft & "> différent de zéro" If Condition > 0 Then ProgExec S Else EatBloc S 'skip ShowLineStep End If ShowInfo "Fin SI" End Sub Private Sub BlocBegin(Sleft As String, S As String) Dim Cline As Integer 'Line number at call Dim LastLine As Integer 'Line number at end of loop Dim CE As String 'Dim Count As Integer Dim Bloc As String Dim TFool As Single Cline = LineNo 'Get the current line number ' CE = GetEndOfLine(S) ' CE = GetCommand(s) CE = Sleft TFool = EvalExp(CE) Bloc = S 'To be repeated ShowInfo "Début bloc à exécuter tant que <" & CE & "> différent de zéro" If AbortExec Then Exit Sub While EvalExp(CE) > 0 If AbortExec Then Exit Sub ProgExec Bloc ' Will return at end of THIS bloc Bloc = S ' ready for repeat If EvalExp(CE) >= TFool Then ShowFatal "< " & CE & "> n'évolue pas correctement" End If LastLine = LineNo LineNo = Cline StepNo = StepNo - 1 ' ?? Wend EatBloc S ' LineNo = LastLine StepNo = StepNo + 1 ' ?? again ?? ShowLineStep ShowInfo "Fin TANT QUE" End Sub Private Sub EatBloc(S As String) Dim Command As String Dim L As String Dim I As Integer While Len(S) L = GetEndOfLine(S) If Len(L) Then LineNo = LineNo + 1 Command = GetCommand(L) Select Case Left(Trim(Command), 1) Case "[", "D", "T", "S" I = I + 1 Case "]", "F" I = I - 1 End Select End If If I < 0 Then LineNo = LineNo - 1 ' Ooops ! Exit Sub End If Wend End Sub Private Sub Roll(S As String) Dim X As Single Dim T As String Dim P As String Dim L As String Dim W As Single Dim TLeft As Single Dim TC As Single Dim Diff As Single Dim CTurns As Single Dim N As Integer Dim Reverse As Integer #If Nohard Then Debug.Print "Roll "; S #End If T = GetParam(S) '1st is turns P = GetParam(S) '2nd is pitch L = GetParam(S) '3rd is layers If T = "?" Then 'Get the two other parameters and compute missing If P <> "_" Then Pitch = EvalExp(P) If L <> "_" Then Layers = EvalExp(L) Turns = Layers * Chambers(Chamber).Free / Pitch ' Turns that will fits ' If Turns < 1 Then Turns = Layers * Chambers(Chamber).Width / Pitch 'Less than one: next layer ElseIf P = "?" Then If T <> "_" Then Turns = EvalExp(T) If L <> "_" Then Layers = EvalExp(L) Pitch = Layers * Chambers(Chamber).Free / Turns ' Pitch to use to fill a layer ElseIf L = "?" Then If P <> "_" Then Pitch = EvalExp(P) If T <> "_" Then Turns = EvalExp(T) Layers = Pitch * Turns / Chambers(Chamber).Width End If ' All parameters are know ShowInfo Str(Turns) & " tour(s) au pas de" & Str(Pitch) & "mm en" & Str(Layers) & " couche(s)" If AbortExec Then Exit Sub 'Don't do more SetNVar ":Tours", Turns SetNVar ":Pas", Pitch SetNVar ":Couches", Layers Form1.RefreshNVars SetRef.LbTurns.Caption = "0.0" If Not Simulate Then LM628Poke1 RAxis, DFH 'Voids accumulation in positions register ' CTurns = 0 If Pitch = 0 Or Turns = 0 Or Layers = 0 Then 'No travel, just rotate shaft If Not Simulate Then Form1.BtDoProg.Enabled = False MoveR Turns, RELATIVE Form1.BtDoProg.Enabled = True End If CTurns = Turns ' ShowTurns CTurns Exit Sub End If '' TODO : Since total turns and total layers are know, count layers remaining rather than turns. '' While Layers . . . '' TLeft = Turns 'Local turns counter While TLeft <> 0 If AbortExec Then Form1.BtDoProg.Enabled = True Exit Sub End If Reverse = 1 If Pitch < 0 Then Reverse = -1 Pitch = Abs(Pitch) End If If Chambers(Chamber).Free <= Abs(Pitch) Then 'No enough room Chambers(Chamber).Free = Chambers(Chamber).Width 'A new layer Direction = -Direction End If TC = Chambers(Chamber).Free / Pitch 'How many turns could fits in this layer If TLeft < TC Then TC = TLeft 'But no more than specified ! DisableOp 'Voids operator intervention while motors move Form1.BtDoProg.Enabled = False If Not Simulate Then W = TC * Pitch 'Width to use If W > Chambers(Chamber).Free Then W = Chambers(Chamber).Free MoveSync Reverse * Direction * W, TC Else W = TC * Pitch 'Width to use If W > Chambers(Chamber).Free Then W = Chambers(Chamber).Free SetRef.CarLoc = SetRef.CarLoc + Reverse * Direction * W SetRef.WaitMe SetRef.LbTurns.Caption = Format(TC, "#.0") End If EnableOp Chambers(Chamber).Free = Chambers(Chamber).Free - TC * Pitch * Reverse If Chambers(Chamber).Free <= Pitch Then 'No enough room Chambers(Chamber).Free = Chambers(Chamber).Width 'A new layer Direction = -Direction End If TLeft = TLeft - TC Wend ' SetNVar ":CCN", CSng(Chamber) 'now in position SetNVar ":DChambre", Chambers(Chamber).Width - Chambers(Chamber).Free SetNVar ":SBobinage", CSng(Direction) Form1.RefreshNVars Form1.BtDoProg.Enabled = True ' ShowTurns CTurns End Sub Private Function WidePitch(Pitch As Single, Turns As Single, CWidth As Single) As Single ' Increase pitch so that Turns fit in an integral number of layers having a width of CWidth Dim L As Single 'Layers needed WidePitch = Pitch 'May be we are lucky ! L = Turns * Pitch / CWidth 'How many layers needed ? If L - Int(L) <> 0 Then 'Not an integer L = Int(L) + 1 'Add one layer WidePitch = L * CWidth / Turns 'Total available space divided by turns. End If End Function Public Function Reposition() As Boolean If Len(LastPosDone) Then Position LastPosDone LastPosDone = "" Reposition = True End If End Function Private Sub Position(S As String) ' Up to 4 params: guide, chamber, origin (side)and offset separated by any no print char ' W/O parameters: Park up and Right Dim X As Single Dim V As Single Dim P As String Dim Offset As Single Dim O As String Dim HG As Single ' LastPosDone = S ParkVguides If Len(S) <= 1 Then 'Only one or no parameter at all: park '' TODO '' Check Simulation Select Case UCase(S) Case "D" ShowInfo "Dégagement à droite" If AbortExec Then Exit Sub Form1.BtDoProg.Enabled = False If Not Simulate Then MoveTAbs TOTALTRAVEL Else SetRef.CarLoc = TOTALTRAVEL SetRef.WaitMe End If Case "G" ShowInfo "Dégagement à gauche" If AbortExec Then Exit Sub Form1.BtDoProg.Enabled = False If Not Simulate Then MoveTAbs 0 Else SetRef.CarLoc = 0 SetRef.WaitMe End If Case "H" ShowInfo "Dégagement en haut" If AbortExec Then Exit Sub Case Else ShowInfo "Parking" If AbortExec Then Exit Sub Form1.BtDoProg.Enabled = False If Not Simulate Then MoveTAbs TOTALTRAVEL Else SetRef.CarLoc = TOTALTRAVEL SetRef.WaitMe End If End Select Form1.BtDoProg.Enabled = True Exit Sub End If Chamber = 1 'Default values if not specified. Guide = 1 X = EvalExp(GetParam(S)) If X > 0 And X < 5 Then Guide = Int(X) HG = EvalExp(GetParam(S)) SetNVar ":HGuide", HG X = EvalExp(GetParam(S)) If X > 0 And X < 5 Then Chamber = Int(X) SetNVar ":NChambre", CSng(Chamber) V = Chambers(Chamber).Org - Guides(Guide) 'Add Guide offset wich is negative ! P = GetParam(S) Offset = EvalExp(GetParam(S)) Chambers(Chamber).Free = Chambers(Chamber).Width - Offset SetNVar ":NDispo", Chambers(Chamber).Free Select Case P 'May be litteral "G" or "D" Case "D" Direction = TOLEFT V = V + Chambers(X).Width - Offset P = "à droite" O = " -" & Format(Offset) & "mm" Case "G" Direction = TORIGHT V = V + Offset 'EvalExp(GetParam(S)) P = "à gauche" O = " +" & Format(Offset) & "mm" Case Else If EvalExp(P) >= 0 Then 'Any positive value means relative to LEFT Direction = TORIGHT V = V + Offset P = "à gauche" O = " +" & Format(Offset) & "mm" Else Direction = TOLEFT V = V + Chambers(X).Width - Offset P = "à droite" O = " -" & Format(Offset) & "mm" End If End Select ShowInfo "Positionnement guide" & Str(Guide) & " " & P & " de chambre" & Str(Chamber) & O & " (" & Format(V + RefOffset) & "mm)" If AbortExec Then Exit Sub Form1.BtDoProg.Enabled = False If Not Simulate Then '''' Use absolute positionning to move carriage alone MoveTRef V 'MoveTRef absolute relative to RefOffset Else SetRef.CarLoc = V + RefOffset SetRef.WaitMe End If SetNVar ":NGuide", CSng(Guide) Form1.RefreshNVars Form1.BtDoProg.Enabled = True End Sub Private Sub SetRpm(S As String) Dim X As Single X = EvalExp(GetParam(S)) ShowInfo "Vitesse broche " & X & " tours minute" Form1.HsRotate.Value = Int(X) SetNVar ":Vitesse", X End Sub Private Function GetCommand(S As String) ' Remove the command string from S and returns it Dim I As Integer Dim L As Integer I = 1 While IsWhite(Mid(S, I, 1)) And I <= Len(S) 'Skip leading white spaces I = I + 1 Wend L = I While Not IsWhite(Mid(S, L, 1)) And L <= Len(S) 'to next space L = L + 1 Wend GetCommand = Mid(S, I, L - I) If Len(GetCommand) = 0 Then S = "" Exit Function End If ' Returns remaining of the line (if any) If Len(S) > Len(GetCommand) Then S = Right(S, Len(S) - L) Else S = "" End If End Function Private Function GetEndOfLine(S As String) Dim I As Integer I = InStr(S, Chr(10)) If 1 = 0 Then Exit Function GetEndOfLine = Left(S, I) S = Mid(S, I + 1) ', Len(S) - 1) End Function Public Function NotWhite(S) As String ' Returns the first notwhite string found in S Dim I As Integer Dim L As Integer I = 1 While IsWhite(Mid(S, I, 1)) And I <= Len(S) 'Skip leading white spaces I = I + 1 Wend L = I While Not IsWhite(Mid(S, L, 1)) And L <= Len(S) 'to next space L = L + 1 Wend NotWhite = Mid(S, I, L - I) End Function Private Function GetParam(S As String) As String 'Extract /remove and returns param in param from S. 'S truncated. Dim I As Integer I = 1 While IsWhite(Mid(S, I, 1)) And I <= Len(S) 'Skip leading white spaces I = I + 1 Wend While Not IsWhite(Mid(S, I, 1)) And I <= Len(S) GetParam = GetParam & Mid(S, I, 1) I = I + 1 Wend If Len(S) >= I - 1 Then S = Right(S, Len(S) - (I - 1)) End Function Private Function IsWhite(S As String) As Boolean If S = " " Or S = Chr(9) Or S = Chr(10) Or S = Chr(13) Then IsWhite = True 'space, tab, lf or cr End Function Private Sub AffectVar(S As String) 'Affect a value to a variable and return value Dim I As Integer Dim Var As String Dim Value As String Dim V As Single I = InStr(S, "=") If I > 0 Then Var = TTrim(Left(S, I - 1)) Value = TTrim(Right(S, Len(S) - I)) SetNVar Var, EvalExp(Value) Form1.RefreshNVars ShowInfo "La variable '" & Var & "' vaut " & Str(GetNVar(Var)) End If End Sub Public Function IsVar(S As String) As Boolean Dim C As Integer Dim I As Integer IsVar = False If Len(S) = 0 Then Exit Function C = Asc(Left(S, 1)) 'Check for first letter to be lower case or an underscore or an ":" If C >= Asc("a") And C <= Asc("z") Or C = Asc(":") Or C = Asc("_") Then 'Good candidate For I = 1 To Len(S) 'Let's check remaining C = Asc(Mid(S, I, 1)) If C < Asc("0") Then Exit Function If C > Asc("z") Then Exit Function If (C > Asc("Z") And C < Asc("_")) Then Exit Function If (C > Asc(":") And C < Asc("A")) Then Exit Function If C = Asc("'") Then Exit Function Next IsVar = True 'No forbiden character found End If End Function Public Function EvalExp(Exp As String) As Single ' Recursive expression parser ' Credits to Jos de Jong Dim P As Integer Dim E As String Dim I As Integer Dim J As Integer Dim SRight As String Dim Sleft As String Dim Op As String Dim Temp As Single E = TTrimAll(Exp) 'Remove all spaces. Better to do that before initial call ! ! ! Debug.Print "EvalExp "; E If IsVar(E) Then EvalExp = GetNVar(E) 'just get variable value as string Exit Function End If For J = 1 To 11 Op = Mid("?<>-+\%/*^E", J, 1) P = InP(UCase(E), Op, 255) While P > 0 If IsOp(E, Op, P) Then Sleft = Left(E, P - 1) SRight = Right(E, Len(E) - P) Select Case Op Case "?" 'Force any non nul value to be 1 Temp = EvalExp(SRight) If Temp <> 0 Then Temp = 1 EvalExp = Temp Exit Function Case "<" 'Floor EvalExp = Int(EvalExp(SRight)) Exit Function Case ">" 'Ceil Temp = Int(EvalExp(SRight)) If Temp < EvalExp(SRight) Then EvalExp = Temp + 1 Else EvalExp = Temp End If Exit Function Case "-" EvalExp = EvalExp(Sleft) - EvalExp(SRight) Exit Function Case "+" EvalExp = EvalExp(Sleft) + EvalExp(SRight) Exit Function Case "*" EvalExp = EvalExp(Sleft) * EvalExp(SRight) Exit Function Case "/" If EvalExp(SRight) = 0 Then ' ShowInfo "FATAL: " & Str(Sleft) & " / " & Str(SRight) & ": Division par 0" Exit Function End If EvalExp = EvalExp(Sleft) / EvalExp(SRight) Exit Function Case "\" 'Integer division If EvalExp(SRight) = 0 Then 'Divide by 0 Exit Function End If EvalExp = EvalExp(Sleft) \ EvalExp(SRight) Exit Function Case "%" 'Division remainder If EvalExp(SRight) = 0 Then 'Divide by 0 Exit Function End If EvalExp = Int(EvalExp(Sleft) Mod EvalExp(SRight)) Exit Function Case "^" EvalExp = EvalExp(Sleft) ^ EvalExp(SRight) Exit Function Case "E" EvalExp = EvalExp(Sleft) * 10 ^ EvalExp(SRight) Exit Function End Select End If If P > 0 Then P = InP(E, Op, P - 1) 'not an operator, search for another before Wend Next 'Check if expression starts and ends with parenthesis If Left(E, 1) = "(" And Right(E, 1) = ")" Then E = Mid(E, 2, Len(E) - 2) 'Remove them EvalExp = EvalExp(E) 'And evaluate Exit Function End If ' No more operator, evaluates and returns the operand EvalExp = Val(E) Exit Function End Function Private Function InP(Source As String, Search As String, start As Integer) As Integer ' Search backward for "Search" in "String" returning where it was found. Dim N As Integer Dim Bopen As Integer Dim Bclose As Integer Dim Sign As String N = start If N > Len(Source) Then N = Len(Source) - Len(Search) + 1 Bopen = 0 Bclose = 0 ' Do While N Sign = Mid(Source, N, Len(Search)) If (Sign = Search) And (Bopen = Bclose) Then InP = N Exit Function End If If Left(Sign, 1) = "(" Then Bopen = Bopen + 1 If Left(Sign, 1) = ")" Then Bopen = Bopen - 1 N = N - 1 Wend ' Loop Until N <= 0 InP = 0 End Function Private Function IsOp(expr As String, Op As String, N As Integer) As Boolean Dim Sign As String Select Case Op Case "+" If N = 1 Then IsOp = False Exit Function End If If Mid(expr, N - 1, 1) = "E" Then 'Do not accept lower case e wich can be a variable If N > 2 Then If InStr("1234567890.", Mid(expr, N - 2, 1)) > 0 Then IsOp = False Exit Function End If End If End If IsOp = True Exit Function Case "-" If N = 1 Then IsOp = False Exit Function Else Sign = Left(expr, N - 1) Sign = Right(RTrim(Sign), 1) If InStr("=?<>+-/*\%^", Sign) > 0 Then IsOp = False Exit Function End If If Mid(expr, N - 1, 1) = "E" And N > 2 Then If InStr("1234567890.", Mid(expr, N - 2, 1)) > 0 Then IsOp = False Exit Function End If End If End If IsOp = True Exit Function End Select IsOp = True End Function Public Sub ShowLineStep() Form1.LbShowLS.Caption = "Line: " & Str(LineNo) & " Pas: " & Str(StepNo) Form1.SelectLine LineNo End Sub Private Sub DisableOp() '' TODO '' Disable pertinent buttons ' Form1.MousePointer = vbHourglass End Sub Private Sub EnableOp() ' Form1.MousePointer = vbDefault End Sub Private Sub SetRefV(S As String) RefOffset = EvalExp(GetParam(S)) ShowInfo "La référence est " & Format(RefOffset, "0.0##") End Sub Public Sub ParkVGuide(Guide As Integer) Lift.MoveGuide Guide, 0 While Not GDone Wait 100 Wend End Sub Public Sub ParkVguides() Lift.MoveGuide 0, 0 Lift.MoveGuide 1, 0 While Not GDone Wait 100 Wend End Sub Public Sub UnparkVGuide() GuideTarget = GuideFromPark End Sub Public Sub PosVGuide(S As String) Dim G As Single Dim H As Single G = EvalExp(GetParam(S)) H = EvalExp(GetParam(S)) If G < 0 Or G > 1 Then ShowFatal "Pas cet ascenseur !" Exit Sub End If If H < 0 Or H > GUIDETRAVEL Then ShowFatal "Pas cet étage" Exit Sub End If Lift.MoveGuide Int(G), Int(H) While Not GDone Wait 100 Wend End Sub Public Sub WaitForPark() While GuideTarget <> GuideCurrent 'Camp here Wait 100 Wend End Sub Public Sub DisableDriverV() 'poke 0 . . . End Sub Public Sub EnableDriverV() 'Poke TbVstep(CurVstep) End Sub Public Sub MoveVUp() CurVstep = CurVstep + 1 If CurVstep > 4 Then CurVstep = 0 EnableDriverV End Sub Public Sub MoveVDown() CurVstep = CurVstep - 1 If CurVstep < 1 Then CurVstep = 4 EnableDriverV End Sub Private Sub DoMacro(Sleft As String, S As String) Dim SaveLineno As Integer Dim SaveTxProg Dim SaveS As String Dim File As String Dim F As Integer Dim T As String Dim Macro As String Dim Path As String If Not MarkRunning(Sleft) Then ShowFatal Sleft & " ne peut s'appeler lui même" Exit Sub End If SaveLineno = LineNo ' Save caller's context SaveTxProg = Form1.TxProg.Text SaveS = S Path = GetIniString(INIFILE, "PATH", "PROGRAM") If Len(Path) = 0 Then Path = App.Path File = Path & "\" & NotWhite(Sleft) & ".prg" F = IsOpen(File, "R", 10) If F = 0 Then ShowFatal "--- " & GetFname(File) & " introuvable ---" Exit Sub End If Running = GetFname(File) ShowInfo "Exécution de " & GetFname(File) If AbortExec Then Exit Sub '' TODO Restore current before ? While Not EOF(F) Line Input #F, T Macro = Macro & T & vbCrLf Wend XClose F, 10 InMacro = InMacro + 1 Form1.TxProg.Text = Macro 'This trigs TxProg change etc .... Form1.Caption = TheCaption & "( Exécution macro: " & Running & ")" LineNo = 0 ProgExec Macro ' Execute content of the "macro" file LineNo = SaveLineno 'At return, restore context Form1.TxProg.Text = SaveTxProg Form1.Caption = TheCaption & "(" & GetFname(PrgFile) & ")" S = SaveS InMacro = InMacro - 1 FreeRunning Sleft End Sub Private Sub LoadFormer(Sleft As String) Dim F As Integer Dim I As Integer Dim File As String Dim T As String Dim Path As String Path = GetIniString(INIFILE, "PATH", "FORMER") If Len(Path) = 0 Then Path = App.Path File = Path & "\" & TTrim(Sleft) & ".ccx" ShowInfo "Chargement des infos carcasse " & GetFname(File) F = IsOpen(File, "R", 10) If F = 0 Then ShowFatal "--- " & GetFname(File) & " introuvable ---" Exit Sub End If For I = 0 To 7 Line Input #F, T Form1.TxC(I) = T Next XClose F, 10 Form1.SetupChambers End Sub Private Sub LoadGuide(Sleft As String) Dim F As Integer Dim I As Integer Dim File As String Dim T As String Dim Path As String Path = GetIniString(INIFILE, "PATH", "GUIDE") If Len(Path) = 0 Then Path = App.Path File = Path & "\" & TTrim(Sleft) & ".ggx" ShowInfo "Chargement des infos guide " & GetFname(File) F = IsOpen(File, "R", 10) If F = 0 Then ShowFatal "--- " & GetFname(File) & " introuvable ---" Exit Sub End If For I = 0 To 3 Line Input #F, T Form1.TxG(I) = T Next XClose F, 10 Form1.SetupGuides End Sub Private Function MarkRunning(ToAdd As String) If InStr(RunList, UCase(ToAdd)) <> 0 Then ' Already running MarkRunning = False Exit Function Else RunList = RunList & UCase(ToAdd) & "," 'Add in list MarkRunning = True End If End Function Private Sub FreeRunning(ToRemove As String) Dim I As Integer I = InStr(RunList, UCase(ToRemove)) If I > 0 Then RunList = Left(RunList, Len(RunList) - Len(ToRemove)) End Sub SIPRO15/HelpFile.txt0000755000000000000000000001733213730575262011262 0ustar ==== RESUME DES COMMANDES DE PROGRAMMATION ==== # Commentaire sans effet. ! (ou I) Pause suivi d'instructions pour l'opérateur. [ (ou D ou T) Début bloc à répéter (Imbricables) . ] (ou F) Fin bloc à répeter ou à exécuter (voir commande S). ( (ou M) Appel sous programme. Suivi de nom de fichier "x.prg". A Acceleration . B Bobiner . C Suivi de nom de fichier "x.ccx" E Test et change le mode d'Exécution du programme. G Suivi de nom de fichier "x.ggx". H (ou ^) Hauteur du guide . P Positionner chariot et guide R Définir la Référence. S Si :Debut d'un bloc de commandes à exécuter (Imbricables) . Z Cherche la limite gauche (Zéro). ==== SYNTAXE GENERALE ==== Le premier caractère d'une commande DOIT toujours être majuscule. Il DOIT exister un espace entre la commande et ses paramètres ainsi qu'entre les paramètres eux mêmes. Le nom de la commande peut être rallongé à volonté afin d'améliorer la lisibilité mais SANS espaces. Exemples: Bobiner ou BOBINER est equivalent à B Carcasse est équivalent à C Debut ou DebutBloc est équivalent à D etc... Représente un NOMBRE, une VARIABLE ou une EXPRESSION. Un NOMBRE ne doit contenir que des chiffres, le séparateur décimal est le point (.). Un nom de VARIABLE DOIT commencer par une lettre minuscule ou le signe _. Il peut contenir un nombre quelconque de chiffres, de lettres minuscules ou majuscules ou le signe _ mais PAS d'espaces. Le contenu d'une VARIABLE est un NOMBRE. Une EXPRESSION DOIT contenir des NOMBRES ou des VARIABLES séparés par des opérateurs et renvoie un NOMBRE. Les espaces sont facultatifs. Les opérateurs + - / * ^ et E sont supportés ainsi que : \ Division entière. % Reste de la division. > Qui renvoie le nombre entier immédiatement supérieur. < Qui renvoie le nombre entier immédiatement inférieur. ? Qui renvoie la valeur 1 pour toute valeur différente de 0 (zéro). Les parenthèses sont supportées. ==== DETAIL DE LA SYNTAXE DE CHAQUE COMMANDE dans l'ordre logique d'emploi.==== == Syntaxe Z (Zero) Déplace le chariot vers sa position extrème gauche et l'enregistre. DOIT être effectuée à chaque mise sous tension. Le bouton "Zéro" de la zône verte (chariot) dans la fenêtre de programation a le même effet. == Syntaxe R (Référence) Distance entre la position ZERO du chariot et le bord gauche de la première chambre/carcasse pour le premier guide. Sert de base de calcul pour toutes les commandes P suivantes. Le bouton "Référence" de la zône verte (chariot) dans la fenètre de programmation autorise le positionnement visuel de la référence. == Syntaxe P (Position) sans paramètre ou P D Dégage le guide vers le haut et le chariot vers la droite. P G Dégage le guide vers le haut et le chariot vers la gauche. P H Dégage le guide vers le haut, ne déplace pas le chariot. P Déplace le chariot pour faire coïncider un guide avec une chambre/carcasse. est le numéro du guide de 1 à 4. est la profondeur du guide dans la chambre en millimètres. est le numéro de la chambre de 1 à 4. Si < 0, positionne le guide à gauche de la chambre. Le bobinage suvant se fera vers la droite. Si > 0, positionne le guide à droite de la chambre. Le bobinage suivant se fera vers la gauche. Les lettres "G" ou "D" majuscules sont aussi acceptées. (facultatif, 0 par défaut). En millimètres. Si positif, corrige la position vers l'intérieur de la chambre. Si négatif, corrige la position vers l'extérieur de la chambre. Variables affectée. L'exécution de cette commande met à jour les variables suivantes: :NChambre = N° de la chambre :LDispo = Largeur dispo dans la chambre :NGuide = N° du Guide NOTE ::: Les raccourcis P G, P D et P H n'affectent pas ces variables. == Syntaxe H ou ^ (Hauteur guides) en mms. 0 est la position haute. == Syntaxe A (Acceleration) Ajuste la valeur de l'accélération en début et en fin de couche. == Syntaxe B (Bobine) Seulement deux paramètres doivent être spécifiés, le troisième (indiqué par un ?) est calculé en fonction des deux autres et de la largeur de la chambre/carcasse. NOTE ::: Un pas spécifié 0 fait tourner la broche du nombre de tours spécifié, le paramètre est ignoré. NOTE ::: Si les trois paramètres sont spécifiés, le nombre de couches est ignoré. Variables affectées. L'exécution de cette commande met à jour les variables suivantes: :DChambre = Decalage dans la chambre :SBobinage = Sens du bobinage, +1 vers la gauche, -1 vers la droite. :Tours = Nombre de tours efectivement bobinés. :Pas = Pas effectivement utilisé. :Couches = Nombre de couches effectivement bobinées Après exécution, les trois valeurs réellement utilisées sont disponibles dans les variables ":Tours", ":Pas" et ":Couches". Elles sont remises à jour à chaque exécution de la commande. == Syntaxe D (DébutBloc) ou T (Tantque) Début de bloc de commande à itérer tant que est supérieure à zéro. est une expression réévaluée à chaque itération. Une erreur est signalée si la valeur de condition ne diminue pas ce qui aboutirait à un nombre infini de répétitions. Les blocs à répéter sont imbricables. F (Finbloc) : Fin du bloc à répéter. == Syntaxe S (Si) Debut de bloc de commande à exécuter si est supèrieure a zéro. F (FinSi) : Fin du bloc a exécuter. == Syntaxe M (Macro ou sous programme) Fichier Fichier est le nom du fichier.prg à exécuter qui peut lui même invoquer une autre macro mais ne doit JAMAIS aboutir à s'invoquer elle même ce qui céerait une boucle infinie. Les macros héritent des variables, c'est la seule façon de les paramétrer. == Syntaxe E (Exécution) Définit et teste le mode d'exécution du programme. Il y a trois modes d'exécution combinables et définissables par cette commande comme par les trois cases à cocher suivantes: - Pas à pas: (Valeur 1) Le programme s'arrète à chaque ligne en détaillant les effets de la commande. - Simulation: (Valeur 2) Les moteurs ne sont pas pilotés, les mouvements du chariot sont simulés dans la fenêtre "Définir la référence" - Coi: (Valeur 4) Le programme s'exécute sans effets apparents mais exécute tous les calculs intèrmédiares. Le mode pas à pas est ignoré La valeur donnée à la commande E est la somme des valeurs individuelles, les valeurs les plus utiles sont: 0 : Exécution Normale. 1 : Exécution pas à pas. 2 : Exécution simulée. 3 : Exécution pas à pas simulée. 6 : Exécution coite simulée. La commande E est exécutée quel que soit le mode courant puis l'exécution se poursuit dans le nouveau mode spécifié. La combinaison de ces trois modes facilite la mise au point d'un programme ainsi que la reprise après un incident. IMPORTANT: les mouvements du chariot n'étant pas effectués en mode Coi, la commande E provoquant la reprise DOIT préceder une commande de positionnement. SIPRO15/LM628.bas0000755000000000000000000005336613730575263010300 0ustar Attribute VB_Name = "LM628" Option Explicit ''''''''''''''''''''''''''''''''''''''''''' ''' Hardware adresses and usage ''' 'LM628s Base addresses Global Const RAxis = &H100 'Rotation(W) Global Const TAxis = &H104 'Translation(X) Global Const RELATIVE = True 'Set corresponding bit to 1 Global Const ABSOLUTE = False 'Set corresponding bit to 0 Global Const CNTPERTURN = 720 Global Const CNTPERMM = 1000 Global Const TOTALTRAVEL = 160 'As Charly said Public Kaccel As Single 'Global Const KACCEL = 200 'Global Ports(1 To 2) As Long 'LM628 command codes Global Const RESET = 0 'As expected ! Global Const PORT8 = 5 '8 bits output (not used) Global Const PORT12 = 6 '12 bits output Global Const DFH = 2 'Define Home Global Const SIP = 3 'Set Index Position Global Const LPEI = &H1B 'Interrupt On Error Global Const LPES = &H1A 'Stop on Error Global Const SBPA = &H20 'Set Breakpoint Absolute Global Const SBPR = &H21 'Set Breakpoint Relative Global Const MSKI = &H1C 'Mask Interrupt Global Const RSTI = &H1D 'Reset Interrupt Global Const LFIL = &H1E 'Load Filter 'Bits allocation in Control Word for LFIL command Global Const LDil = 1 Global Const LDkd = 2 Global Const LDki = 4 Global Const LDkp = 8 Global Const UDF = 4 'Update Filter Global Const LTRJ = &H1F 'Load Trajectory 'Bits allocation in Control Word for LTRJ command Global Const POSREL = 1 Global Const LDPOS = 2 Global Const VELOREL = 4 Global Const LDVELO = 8 Global Const ACCREL = 16 Global Const LDACC = 32 Global Const TMOTOFF = 256 Global Const STOPABRUPT = 512 Global Const STOPSOFT = 1024 Global Const VELOMODE = 2048 Global Const FWD = 4096 Global Const STT = 1 'Start Trajectory Global Const RDSTAT = 0 'Read Satus adress 'Bits allocation in RDSTAT: Global Const Busy = 1 Global Const CmdError = 2 Global Const TrajectComplete = 4 Global Const IndexPulse = 8 Global Const WrapAround = 16 Global Const ExessivePos = 32 Global Const BkPointReached = 64 Global Const MototOff = 128 Global Const RDSIGS = &HC 'Read Signals Register Global Const RDIP = 9 'Read Index Position Global Const RDDP = 8 'Read Desired Position Global Const RDRP = &HA 'Read Real Position Global Const RDDV = 7 'Read Desired Velocity Global Const RDRV = &HB 'Read Real Velocity Global Const RDSUM = &HD 'Read Integration Sum '8255 IO Board Global Const GIOA = &H300 'Bit alocation in GIOA Global Const BRAKEON = 8 'output 1 to release brake Global Const MOTPWRON = 1 'output: Pulse to switch Motors Supply On Global Const MOTPWROFF = 2 'output: Pulse to switch Motors Supply Off Global Const ENDCYCLE = 4 'output: ? Global Const GIOB = &H301 'Bit allocation in GIOB Global Const PROTECT = 4 'input: Protection Open Global Const GENPWR = 1 'input: Main Power On Global Const MOTPWR = 2 'input: Motors Powered Global Const FCBUTTON = 8 'input: Fin Cycle Global Const FOOTSWITCH = 16 'input: FootSwitch Global Const GIOC = &H302 'Bit allocation in GIOC Global Const GIOCreg = &H303 'Bit allocation in GIOCreg 'Control PP3 on Motor Control Board Global Const MOTA = &H110 'Bit allocation in MOTA Global Const OneTurn = 1 'Input (Latched ?) Global Const OneStep = &H10 'Input (Latched ?) Global Const ENDT = &H20 'Input: Carriage End of Travel Global Const DRVTOK = &H40 'Input: ? Global Const DRVROK = &H4 'Input: ? Global Const MOTB = &H111 'Bit allocationin MOTB Global Const ENMOTR = 1 ' output: Enable Rotation Global Const ENMOTT = 2 ' output: Enable Translation Global Const MOTC = &H112 'Bit allocation in MOTC ' UNUSED ' Global Const MOTCreg = &H113 'Bit allocation in MOTCreg ' UNUSED ' ''' End of Hardware adresses and usage ''' ''''''''''''''''''''''''''''''''''''''''''''''''' '' Some variables to emulate peek an poke when debging w/o hardware Public vGIOA As Byte Public vGIOB As Byte Public vGIOC As Byte Public vMOTA As Byte Public vMOTB As Byte Public vMOTC As Byte Public vMOTCreg As Byte Public vRaxis As Byte Public vTaxis As Byte 'Some current values updated by the timer Public STATR As Long Public STATT As Long Public SIGSR As Long Public SIGST As Long Public IPR As Long Public IPT As Long Public DPR As Long Public DPT As Long Public DVR As Long Public DVT As Long Public RVR As Long Public RVT As Long Public RPR As Long Public RPT As Long Public SUMR As Long Public SUMT As Long Public IOSwitchesA As Long 'Integer Public IOSwitchesB As Long Public IOSwitchesC As Long Public MotCtrlStat As Long Public IOSwitchesP As Long 'Previously read values to detect changes Public MotCtrlStatP As Long Global Rpm As Long ' Rotation speed Global RStoppedAt As Single Global TStoppedAt As Single Global Zeroed As Boolean Public CurrentVG As Integer 'Location of the vertical guide Public TargetVG As Integer 'from 0 (up) to MAXVG Public Const MAXVG = 1000 'Steps to move full range ' InterLock flags Global SuspendPoll As Boolean Global Rtoken As Boolean 'Dialog pending when true Global Ttoken As Boolean Global AllowsFreeShaft As Boolean Public Sub SetEndCycleOn() Poke GIOA, Peek(GIOA) Or ENDCYCLE End Sub Public Sub SetEndCycleOff() Poke GIOA, Peek(GIOA) And Not ENDCYCLE ' Debug.Print "SetEndCycleOff "; Hex(Not ENDCYCLE) End Sub Public Function AdjustFormat(X As Long) As Long 'Returns a 30bits signed value as expected by LM628 AdjustFormat = X 'Except if ... If X < &HC0000000 Then AdjustFormat = &HC0000000 End If If X > &H3FFFFFFF Then AdjustFormat = &H3FFFFFFF End If ' Debug.Print "Adjust", X, Hex(AdjustFormat) End Function Public Sub InitIO() #If Nohard = 1 Then Debug.Print "****************** Public Sub InitIO()" #End If Poke GIOCreg, &H8A 'Affect pins direction ? Poke MOTCreg, &H91 'Affect pins direction ? Poke GIOA, BRAKEON ' + MOTPWRON ' Release brake only, no power applied Poke MOTB, 0 'Disable motor drivers End Sub Public Sub EnableDriverR() Poke MOTB, Peek(MOTB) Or ENMOTR End Sub Public Sub EnableDriverT() Poke MOTB, Peek(MOTB) Or ENMOTT If Programing Then Form1.TOnOff.Visible = True End Sub Public Sub DisableDriverR() Poke MOTB, Peek(MOTB) And Not ENMOTR End Sub Public Sub DisableDriverT() Poke MOTB, Peek(MOTB) And Not ENMOTT If Programing Then Form1.TOnOff.Visible = False End Sub Public Sub PwrMotOff() Poke GIOA, Peek(GIOA) Or MOTPWROFF Wait 100 Poke GIOA, Peek(GIOA) And Not MOTPWROFF Wait 100 End Sub Public Sub PwrMotOn() Poke GIOA, Peek(GIOA) Or MOTPWRON Wait 100 Poke GIOA, Peek(GIOA) And Not MOTPWRON Wait 100 End Sub Public Sub ReadLM628s() '' TODO '' Remove calls to unused registers #If Nohard = 1 Then Debug.Print "****************** ReadLM628s " ' MsgBox "", vbOKOnly, "Public Sub ReadLM628s()" ' Exit Sub #End If STATR = Peek(RAxis) 'read base adress W/O any test STATT = Peek(TAxis) ' SIGSR = ReadData(RAxis, RDSIGS, 2) ' SIGST = ReadData(TAxis, RDSIGS, 2) ' IPR = ReadData(RAxis, RDIP, 4) ' IPT = ReadData(TAxis, RDIP, 4) DPR = ReadData(RAxis, RDDP, 4) DPT = ReadData(TAxis, RDDP, 4) RPR = ReadData(RAxis, RDRP, 4) RPT = ReadData(TAxis, RDRP, 4) DVR = ReadData(RAxis, RDDV, 4) DVT = ReadData(TAxis, RDDV, 4) RVR = ReadData(RAxis, RDRV, 2) RVT = ReadData(TAxis, RDRV, 2) ' SUMR = ReadData(RAxis, RDSUM, 2) ' SUMT = ReadData(TAxis, RDSUM, 2) End Sub Public Function ReadData(Port As Long, Cmde As Byte, Bytes As Integer) As Long ' Obtain values from LM628 readable registers. ' Cmde is the command code, Bytes is the length of data to be read. ' #If Nohard = 1 Then ' MsgBox "Axis: " & Axis & vbCrLf & "Code: " & Str(Code) & vbCrLf & "Bytes: " & Str(Bytes) ' Exit Function ' #End If GetToken Port LM628Poke1 Port, Cmde ReadData = RcvData(Port, Bytes) FreeToken Port End Function Public Function RcvData(Port As Long, Bytes As Integer) As Long Dim B As Byte Dim I As Integer Dim J As Integer Dim X As Double Dim T(1 To 4) As Integer ' #If Nohard = 1 Then ' T(1) = &H0 ' T(2) = &H0 ' T(3) = &H0 ' T(4) = &H1 ' ' For I = 1 To Bytes ' B = T(I) 'Simulate peek a byte ' X = X * 256 'Accumulate in a double to void sign interpretation ' X = X + B ' Debug.Print I, X ' Next ' If X >= 2 ^ 31 Then 'Too large for a signed long ' X = X - 2 ^ 32 'Convert to a signed long ' End If ' RcvData = X ' Debug.Print RcvData, Hex(RcvData) ' Exit Function ' #End If ' GetToken Port Wbusy Port For I = 1 To Bytes / 2 For J = 1 To 2 B = Peek(Port + 1) ' Data address is at port+1 X = X * 256 X = X + B Next Wbusy Port Next If X >= 2 ^ 31 Then 'Too large for a signed long X = X - 2 ^ 32 'Convert to a signed long End If RcvData = X #If Nohard Then Debug.Print "Read value "; X #End If ' FreeToken Port End Function Public Sub HReset(Port As Long) ' Reset the LM628 and reload filter parameters. Dim R As Byte #If Nohard = 1 Then Debug.Print "****************** HReset "; Hex(Port) Exit Sub #End If SuspendPoll = True Wait 100 'Alow current poll to finish While R <> &HC0 'Or R <> &HC0 While R <> &HC4 'Or R <> &HC4 Poke Port, RESET 'Or a software RESET if hardware not available Wait 2 'Wait for LM628 terminates internal reset sequence. R = Peek(Port) Or &H40 'Read STSAT Wend LM628Poke1 Port, RSTI LM628Poke2 Port, 0 'Disable all interrupts Wait 2 R = Peek(Port) Or &H40 Wend Wait 2 LM628Poke1 Port, PORT12 LM628Poke1 Port, RSTI LM628Poke2 Port, 0 'Disable all interrupts LM628Poke1 Port, MSKI LM628Poke2 Port, 0 'Mask all interrupts If Port = RAxis Then Service.SetFilterR If Port = TAxis Then Service.SetFilterT SuspendPoll = False End Sub Public Sub LoadFilters(Port As Long, SI As Byte, kp As Long, ki As Long, kd As Long, il As Long) #If Nohard = 1 Then ' MsgBox "Port: " & Str(Port) & vbCrLf & "SI: " & Str(SI) & vbCrLf & "kp: " & Str(kp) & vbCrLf & "kd: " & Str(kd) & vbCrLf & "ki: " & Str(ki) & vbCrLf & "il: " & Str(ki), _ vbOKOnly, "Public Sub LoadFilters(Port As Long, SI As Byte, kp As Long, kd As Long, ki As Long, il As Long)" Debug.Print "LoadFilters "; Port, Hex(SI), Hex(kp), Hex(ki), Hex(kd), Hex(il) Exit Sub #End If ' GetToken Port LM628Poke1 Port, LFIL LM628Poke2 Port, SI * 256 + LDil + LDkd + LDki + LDkp 'Load all parameters LM628Poke2 Port, kp LM628Poke2 Port, ki LM628Poke2 Port, kd LM628Poke2 Port, il ' FreeToken Port End Sub Public Sub LoadTrajectory(Port As Long, _ Dir As Boolean, _ Acc As Long, _ RelAcc As Boolean, _ Velov As Long, _ RelVelo As Boolean, _ Pos As Long, _ RelPos As Boolean, _ Velom As Boolean) Dim ControlWord As Long #If Nohard = 1 Then Static N As Integer N = N + 1 Debug.Print "LoadTrajectory (" & Format(N) & ") Port :", Port, N Debug.Print "Dir", "Acc", "RelAcc", "VeloV", "RelVelo", "Pos", "RelPos", "Velom" Debug.Print Dir, Acc, RelAcc, Velov, RelVelo, AdjustFormat(Pos), RelPos, Velom Exit Sub #End If GetToken Port LM628Poke1 Port, LTRJ 'Send command code ControlWord = LDPOS + LDVELO + LDACC 'Build Control Word If Dir Then ControlWord = ControlWord + FWD If RelAcc Then ControlWord = ControlWord + ACCREL If RelVelo Then ControlWord = ControlWord + VELOREL If RelPos Then ControlWord = ControlWord + POSREL If Velom Then ControlWord = ControlWord + VELOMODE ' Debug.Print Hex(ControlWord) Service.Spy.Text = LongToSBin(ControlWord) LM628Poke2 Port, ControlWord ''''''Theese Parameters have to be formated . . . LM628Poke4 Port, Acc LM628Poke4 Port, Velov LM628Poke4 Port, AdjustFormat(Pos) FreeToken Port End Sub Public Sub DoRSTI(Port As Long) LM628Poke1 Port, RSTI LM628Poke2 Port, 0 End Sub Public Function Peek(Port As Long) As Byte #If Nohard = 1 Then ' Debug.Print "peek "; Hex(Port) Select Case Port Case GIOA Peek = vGIOA Case GIOB Peek = vGIOB Case GIOC Peek = vGIOC Case MOTA Peek = vMOTA Case MOTB Peek = vMOTB Case MOTC Peek = vMOTC Case vMOTCreg Peek = vMOTCreg ' Case RAxis ' Peek = vRaxis ' Case TAxis ' Peek = vTaxis Case Else Peek = &HFF End Select Debug.Print "peek "; Hex(Port), Peek Exit Function #End If Peek = DlPortReadPortUchar(Port) End Function Public Sub Poke(Port As Long, V As Byte) 'don't care if busy ' Send a single byte to an IO. #If Nohard = 1 Then Debug.Print "Poke "; Hex(Port), Hex(V) Select Case Port Case GIOA vGIOA = V TestPeekPoke.Text1 = Str(V) Case GIOB vGIOB = V TestPeekPoke.Text2 = Str(V) Case GIOC vGIOC = V TestPeekPoke.Text3 = Str(V) Case MOTA vMOTA = V TestPeekPoke.Text4 = Str(V) Case MOTB vMOTB = V TestPeekPoke.Text4 = Str(V) Case MOTC vMOTC = V TestPeekPoke.Text5 = Str(V) Case vMOTCreg vMOTCreg = V TestPeekPoke.Text6 = Str(V) Case RAxis vRaxis = V TestPeekPoke.Text7 = Str(V) Case TAxis vTaxis = V TestPeekPoke.Text8 = Str(V) End Select Exit Sub #End If DlPortWritePortUchar Port, V End Sub Public Sub LM628Poke1(Port As Long, V As Byte) ' Send a single byte (command) to one LM628 waiting for not busy. #If Nohard = 1 Then ' Just skip Debug.Print "LM628Poke1 "; Hex(Port), Hex(V) Exit Sub #End If #If Nohard = 2 Then ' Show where we are MsgBox "Port: " & Hex(Port) & vbCrLf & "V: " & Hex(V), vbOKOnly, "Public Sub LM628Poke1(Port As Long, V As Byte)" Exit Sub #End If Wbusy Port DlPortWritePortUchar Port, V End Sub Public Sub LM628Poke2(Port As Long, V As Long) 'when busy free ' Send a 16 bit data word as two 8 bits, MSB first into LM628. #If Nohard Then Debug.Print "Poke2", Hex(V), Hex(V \ 256), Hex(V And 255) #End If Wbusy Port Poke Port + 1, (V \ 256) 'Shift right Poke Port + 1, V And 255 'Mask End Sub Public Sub LM628Poke4(Port As Long, V As Long) ' Send a 32 bits data word to one LM628. Dim Y As Long Y = V \ 65536 'Right shift 16bits but sign is lost ! If V < 0 Then Y = Y - 1 'Restore it. Y = Y And 65535 'And truncate. Funny isn't it #If Nohard Then Debug.Print "Poke4", Hex(V), Hex(Y), Hex(V And 65535) #End If LM628Poke2 Port, Y 'Send 16 msb checking busy LM628Poke2 Port, V And 65535 End Sub Public Sub Wbusy(Port As Long) 'Wait for LM628 not busy #If Nohard = 1 Then Exit Sub #End If While Peek(Port) And Busy 'Stay here ! 'Should be (Port + RDSTAT) but since RDSTAT is 0 . . . Wend End Sub Public Sub GetToken(Port As Long) ' Wait for token free then get it #If Nohard = 1 Then Debug.Print "---- GetToken", Port ' Exit Sub #End If If Port = RAxis Then While Rtoken = True DoEvents 'Camp here until token free Wend Rtoken = True 'mark not free ' Debug.Print Port & " Token in use" End If If Port = TAxis Then While Ttoken = True DoEvents Wend Ttoken = True ' Debug.Print Port & " Token in use" End If End Sub Public Sub FreeToken(Port As Long) ' Release token #If Nohard Then Debug.Print "---- FreeToken", Port #End If If Port = RAxis Then Rtoken = False ' Debug.Print Port & " Token free" End If If Port = TAxis Then Ttoken = False ' Debug.Print Port & " Token free" End If End Sub Public Sub MoveSync(mms As Single, Turns As Single) ' Move both axis simultaneously using relative positioning. ' It rolls the specified turns number at Rpm (global) speed ' while simultaneously moving the carriage by the specified number of millimeters. ' Positive turns values mean clockwise rotation (when looking to the shaft) ' Positive mms values mean the carriage moves to the right. ' Returns only after the command in completed and the hardware is ' ready to accept a new order ' With the mecanical constants of the Sipro hardware, we have a pitch of ' 1mm per turn when the rotation velocity is 0.72 times the translation velocity. ' Thus, VeloT = VeloR / 0.72 * pitch (in mms). Pitch being mms / Turns. Dim V As Long EnableDriverT V = RealVeloR / 0.72 * (Abs(mms) / Abs(Turns)) 'Must be positive. LoadTrajectory RAxis, False, 1 + RealVeloR / Kaccel, False, RealVeloR, False, -Turns * CNTPERTURN, True, False LoadTrajectory TAxis, False, 1 + V / Kaccel, False, V, False, -mms * CNTPERMM, True, False DoRSTI RAxis DoRSTI TAxis LM628Poke1 RAxis, STT LM628Poke1 TAxis, STT WaitTrajectoriesComplete '' TODO '' Replace by read RPT when hard available #If Nohard Then SetRef.CarLoc = SetRef.CarLoc + mms 'Show in SetRef SetRef.WaitMe #End If DisableDriverT End Sub Public Sub WaitTrajectoriesComplete() #If Nohard Then Debug.Print "WaitTrajectoriesComplete" ' Wait 500 ' Exit Sub #End If While 1 If ((Peek(RAxis) And TrajectComplete) = TrajectComplete) And ((Peek(TAxis) And TrajectComplete) = TrajectComplete) Then Exit Sub ' Both terminate End If DoEvents ' Wait 100 Sleep 100 Wend End Sub Public Sub WaitRtrajectoryComplete() #If Nohard Then Debug.Print "WaitRtrajectoryComplete" ' Wait 500 ' Exit Sub #End If While 1 If ((Peek(RAxis) And TrajectComplete) = TrajectComplete) Then Exit Sub DoEvents ' Wait 100 Sleep 100 Wend End Sub Public Sub WaitTtrajectoryComplete() #If Nohard Then Debug.Print "WaitTtrajectoryComplete" ' Wait 500 ' Exit Sub #End If While 1 If ((Peek(TAxis) And TrajectComplete) = TrajectComplete) Then Exit Sub DoEvents ' Wait 100 Sleep 100 Wend End Sub Public Sub MoveTRel(mms As Single) MoveT mms, RELATIVE End Sub Public Sub MoveTAbs(mms As Single) MoveT mms, ABSOLUTE End Sub Public Sub MoveT(mms As Single, AR As Boolean) EnableDriverT LoadTrajectory TAxis, False, 1 + RealVeloT / Kaccel, False, RealVeloT, False, -mms * CNTPERMM, AR, False DoRSTI TAxis 'Clear pending status LM628Poke1 TAxis, STT WaitTtrajectoryComplete #If Nohard Then If AR = ABSOLUTE Then 'To show carriage move in SetRef SetRef.CarLoc = mms Else SetRef.CarLoc = SetRef.CarLoc + mms End If SetRef.WaitMe #End If DisableDriverT End Sub Public Sub MoveR(Turns As Single, AR As Boolean) LoadTrajectory RAxis, False, 1 + RealVeloR / Kaccel, False, RealVeloR, False, -Turns * CNTPERTURN, AR, False DoRSTI RAxis 'Clear pending status LM628Poke1 RAxis, STT WaitRtrajectoryComplete End Sub Public Sub MoveTRef(mms As Single) ' Go to mms from reference #If Nohard Then Debug.Print "MoveTRef "; RefOffset - mms #End If MoveT mms + RefOffset, ABSOLUTE End Sub Public Sub GoToZero() 'Move carriage slowly just away from ENDT switch '' TODO '' Permettre abandon si pb Dim SaveVeloT As Long #If Nohard Then Debug.Print "GoToZero " Zeroed = True ParkVguides Exit Sub #End If SaveVeloT = RealVeloT RealVeloT = 100000 'Slow while searching for zero ParkVguides If (Peek(MOTA) And ENDT) <> ENDT Then 'We are not already past ENDT While (Peek(MOTA) And ENDT) <> ENDT MoveTRel -2 ' move to the left in ?? mms steps up to ENDT DoEvents Wend End If While (Peek(MOTA) And ENDT) = ENDT 'We are past ENDT MoveTRel 0.05 ' move to the right in small steps DoEvents Wend LM628Poke1 TAxis, DFH 'Define home here Zeroed = True RealVeloT = SaveVeloT End Sub SIPRO15/Math.bas0000755000000000000000000002055313730575260010406 0ustar Attribute VB_Name = "Module1" '========================================================== ' Muhammad Abubakar ' ' '========================================================== 'You can use the code as u like in your projects but please 'give credit where credit is due :) ' '======================================= November 14th 2014 ' Added operators: ' "\" (integer division) and "%" (division remainder) ' By y.monmagnon@wanadoo.fr '=========================================================== Option Explicit Public Function parse(expr As String) As Double Dim i As Double, a As String Dim start As Double, endat As Double expr = Trim(expr) If InStr(expr, "(") <> 0 Then i = 1 While (InStr(expr, "(") <> 0) a = Mid(expr, i, 1) If a = "(" Then start = i ElseIf a = ")" Then If start = 0 Then MsgBox "Invalid Syntax." Exit Function End If endat = i i = Val(givePrecedence(Mid(expr, start + 1, endat - start - 1))) expr = Left(expr, start - 1) & Str(i) & Right(expr, Len(expr) - endat) start = 0: endat = 0 i = 0 End If i = i + 1 Wend End If If expr <> "" Then parse = Val(givePrecedence(expr)) Else parse = i End If End Function Private Function Eval(temp As String, sign As String, prevExpr As String) As String Select Case sign Case "+": Eval = Str(Val(prevExpr) + Val(temp)) Case "-": Eval = Str(Val(prevExpr) - Val(temp)) Case "*": Eval = Str(Val(prevExpr) * Val(temp)) Case "/": If Val(temp) = 0 Then MsgBox "Divide by zero" & vbCrLf & "Ignored", vbCritical, "MathParser" Else Eval = Str(Val(prevExpr) / Val(temp)) End If Case "^": Eval = Str(Val(prevExpr) ^ Val(temp)) Case "\": Eval = Str(Val(prevExpr) \ Val(temp)) Case "%": Eval = Str(Val(prevExpr) Mod Val(temp)) End Select End Function Private Function givePrecedence(expr As String) As String Dim X As Integer, temp As String Do While (InStr(expr, "!") <> 0 Or InStr(expr, "*") <> 0 Or InStr(expr, "/") <> 0 Or InStr(expr, "^") <> 0 _ Or InStr(expr, "+") <> 0 Or InStr(expr, "-") <> 0 Or InStr(expr, "\") <> 0 Or InStr(expr, "%") <> 0) DoEvents X = InStr(expr, "!") If X <> 0 Then temp = solveFor("!", expr) Else X = InStr(expr, "^") If X <> 0 Then temp = solveFor("^", expr) Else X = InStr(expr, "/") If X <> 0 Then temp = solveFor("/", expr) Else X = InStr(expr, "\") If X <> 0 Then temp = solveFor("\", expr) Else X = InStr(expr, "%") If X <> 0 Then temp = solveFor("%", expr) Else X = InStr(expr, "*") If X <> 0 Then temp = solveFor("*", expr) Else X = InStr(expr, "+") If X <> 0 Then temp = solveFor("+", expr) Else X = InStr(expr, "-") If X <> 0 Then temp = solveFor("-", expr) End If End If End If End If End If End If End If End If If temp = "" Then Exit Do Else expr = temp End If Loop givePrecedence = expr End Function Private Function GetNumFrom(Pos As Integer, expr As String) As String Dim i As Integer, temp As String Dim a As String If Pos <= Len(expr) Then For i = Pos To Len(expr) '{ a = Mid(expr, i, 1) If Asc(a) >= 48 And Asc(a) <= 58 Or a = " " Or a = "." _ Or ((a = "-" Or a = "+") And Trim(temp) = "") Then temp = temp & a Else If LCase(a) = "e" Then temp = temp & "E" & GetNumFrom(i + 1, expr) 'Recursion i = Len(expr) Else ' MsgBox "Invalid syntax", vbCritical, "MathParser" 'wrong syntax, u can handle error as you like End If i = Len(expr) End If Next '} GetNumFrom = temp End If End Function Private Function solveFor(sign As String, expr As String) As String '{ Dim X As Integer, start As Integer, endat As Integer Dim temp As String, a As String, i As Integer start = 1 X = InStr(expr, sign) If sign <> "!" Then If sign = "+" Or sign = "-" Then a = GetNumFrom(1, expr) If Len(a) = Len(expr) Then solveFor = "" Exit Function End If temp = GetNumFrom(Len(a) + 1, expr) If Sgn(Val(temp)) < 0 Then sign = "-" Else: sign = "+" End If X = InStr(Len(a), expr, sign) endat = Len(a) + Len(temp) temp = Eval(GetNumFrom(X + 1, expr), sign, a) expr = Left(expr, start - 1) & temp & Right(expr, Len(expr) - endat) solveFor = expr Exit Function End If End If 'i = InStr(x + 1, expr, sign) For i = X - 1 To 1 Step -1 'going back a = Mid(expr, i, 1) If Asc(a) >= 48 And Asc(a) <= 58 Or a = " " Or a = "." Or LCase(a) = "e" Then temp = a & temp Else If (a = "-" Or a = "+") And i - 1 > 0 Then If Mid(expr, i - 1, 1) = "e" Then temp = a & temp Else start = i + 1 i = 1 End If Else start = i + 1 i = 1 End If End If Next If Trim(temp) <> "" Then 'solving for factorial If sign = "!" Then If Int(Val(temp)) <> Val(temp) Then MsgBox "Invalid syntax", vbCritical, "MathParser" 'wrong syntax, handle it in whatever way u awnt Else expr = Left(expr, start - 1) & Str(fact(Val(temp))) & Right(expr, Len(expr) - X) solveFor = expr End If Else 'its not a factorial calculations endat = X + Len(GetNumFrom(X + 1, expr)) temp = Eval(GetNumFrom(X + 1, expr), sign, temp) expr = Left(expr, start - 1) & temp & Right(expr, Len(expr) - endat) 'Job done, go back solveFor = expr End If Else solveFor = "" End If '} End Function 'Algo for factorial Private Function fact(num As Integer) As Double Dim b As Double b = 1 For num = 1 To num b = b * num 'I wish I could write it as b * = num :( Next fact = b End Function SIPRO15/MesGuides0000755000000000000000000000000013730575265010631 5ustar SIPRO15/SetRef.frm0000755000000000000000000002276013730575262010730 0ustar VERSION 5.00 Begin VB.Form SetRef Caption = "Définir la référence" ClientHeight = 1800 ClientLeft = 60 ClientTop = 345 ClientWidth = 11070 ClipControls = 0 'False ControlBox = 0 'False LinkTopic = "Form2" ScaleHeight = 1800 ScaleMode = 0 'User ScaleWidth = 100 StartUpPosition = 3 'Windows Default Visible = 0 'False Begin VB.CommandButton BtCancel Caption = "Annuler" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 8880 TabIndex = 8 Top = 1320 Width = 975 End Begin VB.PictureBox PsetTTrim AutoRedraw = -1 'True BackColor = &H00FF8080& BorderStyle = 0 'None ForeColor = &H00FFFFFF& Height = 255 Left = 120 ScaleHeight = 255 ScaleMode = 0 'User ScaleWidth = 25.343 TabIndex = 5 Top = 960 Width = 10815 End Begin VB.CommandButton BtFixRef Caption = "Appliquer" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 9960 TabIndex = 2 Top = 1320 Width = 975 End Begin VB.PictureBox PsetT AutoRedraw = -1 'True BackColor = &H00C00000& BorderStyle = 0 'None DrawMode = 7 'Invert DrawWidth = 4 ForeColor = &H00C0C0FF& Height = 255 Left = 120 ScaleHeight = 4.498 ScaleMode = 0 'User ScaleWidth = 10 TabIndex = 0 Top = 360 Width = 10815 End Begin VB.Label LbTurns Alignment = 1 'Right Justify AutoSize = -1 'True Caption = "0.0" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 300 Left = 1920 TabIndex = 10 Top = 1360 Width = 390 End Begin VB.Label Label5 Alignment = 2 'Center AutoSize = -1 'True Caption = "0" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 5424 TabIndex = 9 Top = 720 Width = 120 End Begin VB.Label Label4 Alignment = 2 'Center AutoSize = -1 'True Caption = "+10 mm" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 10305 TabIndex = 7 Top = 720 Width = 660 End Begin VB.Label Label3 Alignment = 2 'Center AutoSize = -1 'True Caption = "160 mm" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 10335 TabIndex = 6 Top = 120 Width = 660 End Begin VB.Label Label2 Alignment = 2 'Center AutoSize = -1 'True Caption = "-10 mm" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 120 TabIndex = 4 Top = 720 Width = 630 End Begin VB.Label Label1 Alignment = 2 'Center AutoSize = -1 'True Caption = "0 mm" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 120 TabIndex = 3 Top = 120 Width = 450 End Begin VB.Label LbPosRef Alignment = 1 'Right Justify AutoSize = -1 'True Caption = "0.000" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 345 Left = 8040 TabIndex = 1 Top = 1360 Width = 690 End End Attribute VB_Name = "SetRef" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim FTop As Single Dim FLeft As Single Public CarLoc As Single Public CarNow As Single Dim Cpos As Single Dim Prev As Single Public Sub FollowRPT(P As Single) If P = Prev Then Exit Sub SetCarriage P End Sub Public Sub SetCarriage(P As Single) PsetT.Line (Prev, 0)-(Prev, 255) 'Once to erase Prev = P PsetT.Line (Prev, 0)-(Prev, 255) 'Once to redraw LbPosRef.Caption = Format(Prev, "0.0##") End Sub Private Sub BtCancel_Click() Me.Hide End Sub Private Sub BtFixRef_Click() RefOffset = Cpos Me.Hide End Sub Private Sub Form_Load() ' CenterForm Me Me.Top = Val(GetIniString(INIFILE, "FormsLoc", "SetRefTop")) Me.Left = Val(GetIniString(INIFILE, "FormsLoc", "SetRefLeft")) FTop = Me.Top FLeft = Me.Left PsetT.ScaleWidth = TOTALTRAVEL PsetTTrim.ScaleWidth = 20 '+ - 1 cm PsetTTrim.Line (10, 0)-(10, 255) 'Show middle Cpos = RefOffset LbPosRef.Caption = Format(Cpos, "0.0##") End Sub Private Sub PsetT_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) #If Nohard Then Debug.Print "PsetT "; X; Y #End If MoveTAbs X Cpos = X LbPosRef.Caption = Format(Cpos, "0.0##") SetCarriage Cpos End Sub Private Sub PsetTTrim_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim T As Single T = X - PsetTTrim.ScaleWidth / 2 If Shift Then T = T / 10 'Very small steps if shift hold down If Cpos + T >= 0 Then Cpos = Cpos + T Else Cpos = 0 'Not past ENDT End If MoveTAbs Cpos LbPosRef.Caption = Format(Cpos, "0.0##") SetCarriage Cpos End Sub Public Sub WaitMe() If SilentRun Then CarNow = CarLoc SetCarriage CarNow Exit Sub End If While CarLoc <> CarNow ' Sleep 10 '1000 / (Rpm + 1) 'Simulate speed ' Wait 1000 / (Rpm + 1) 'Simulate speed Wait 1 'DO NOT simulate speed, go fast If CarLoc > CarNow Then CarNow = CarNow + 0.1 If CarLoc < CarNow Then CarNow = CarNow - 0.1 If Abs(CarLoc - CarNow) < 0.1 Then CarNow = CarLoc SetCarriage CarNow Wend Cpos = CarNow End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' Debug.Print "MouseMove" If FTop <> Me.Top Or FLeft <> Me.Left Then WriteIniString INIFILE, "FormsLoc", "SetRefTop", Str(Me.Top) WriteIniString INIFILE, "FormsLoc", "SetRefLeft", Str(Me.Left) FTop = Me.Top FLeft = Me.Left End If End Sub SIPRO15/Sipro.INI0000755000000000000000000000040613730575264010462 0ustar [FormsLoc] LiftTop= 2535 Liftleft= 4815 SetRefTop= 960 SetRefLeft= 7635 [PATH] PROGRAM=\\VBOXSVR\Public\SIPRO15\Programs FORMER=E:\SIPRO\MesCarcasses GUIDE=E:\SIPRO\MesGuides [MRU] Last=\\VBOXSVR\Public\SIPRO15\Programs\MSpiraleDerniereAvecpapier.prg SIPRO15/Sipro.vbw0000755000000000000000000000067113730575262010643 0ustar Form1 = 54, 25, 756, 838, , 346, 90, 1382, 732, C Global = 896, 15, 1629, 884, LM628 = 152, 7, 811, 890, Service = 9, 45, 784, 916, , 164, 106, 893, 651, C TOOLS = 201, 106, 780, 886, DLPortIO = 154, 154, 1517, 775, C SetRef = 116, 82, 697, 862, , 611, 293, 1453, 488, C Lift = -1, 10, 722, 874, C, 1267, 180, 1463, 806, C TestPeekPoke = 0, 0, 0, 0, C, 198, 198, 1401, 755, C StartForm = 70, 64, 793, 638, , 22, 77, 745, 651, C SIPRO15/TOOLS.BAS0000755000000000000000000013345213730575265010265 0ustar Attribute VB_Name = "TOOLS" Option Explicit Public Type NVar 'A named variable Name As String Value As Single End Type Global NVars() As NVar 'A redimable array of Named Variables Dim Rstring As String * 1024 Global Manquants As String Global GereManque As Boolean Global DureeMsg As Integer Global NivTrace As Integer Global FicTrace As String Global F_INI As String Global INIFILE As String Public Const HFILE_ERROR = -1 Dim S As String Dim Chronos(10) As Long Global Pass As Boolean Private Type LUID UsedPart As Long IgnoredForNowHigh32BitPart As Long End Type Private Type TOKEN_PRIVILEGES PrivilegeCount As Long TheLuid As LUID Attributes As Long End Type Private Const EWX_SHUTDOWN As Long = 1 Private Const EWX_FORCE As Long = 4 Private Const EWX_REBOOT = 2 Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" _ (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, _ ByVal dwRefData As Long) As Long Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" _ (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, _ pdwRefData As Long) As Long Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" _ (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) _ As Long Declare Function DefSubclassProc Lib "comctl32" Alias "#413" _ (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Declare Function ExitWindowsEx Lib "User32" ( _ ByVal dwOptions As Long, ByVal dwReserved As Long) As Long Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Declare Function GetHandleInformation Lib "kernel32" (ByVal hObject As Long, lpdwFlags As Long) As Boolean Declare Function GetTickCount Lib "kernel32" () As Long Declare Function GetActiveWindow Lib "kernel32" () As Integer Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal SName As String, KName As Any, SString As Any, ByVal FName As String) As Integer Declare Function GetProfileString Lib "kernel32" (ByVal lpAppName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long Declare Function lread Lib "kernel32" Alias "_lread" (ByVal hFile As Long, lpBuffer As Any, ByVal wBytes As Long) As Long Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long Declare Function hread Lib "kernel32" Alias "_hread" (ByVal hFile As Long, lpBuffer As Any, ByVal lBytes As Long) As Long Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long Declare Function GetProcessVersion Lib "kernel32" (ByVal hModule As Long) As Long Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Single) As Long Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Declare Function PostMessage Lib "User32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParams As Long, ByVal lParam As Long) As Long Declare Function IsWindow Lib "User32" (ByVal hWnd As Long) As Long Declare Function GetCurrentProcess Lib "kernel32" () As Long Declare Function OpenProcessToken Lib "advapi32" ( _ ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, _ TokenHandle As Long) As Long Declare Function LookupPrivilegeValue Lib "advapi32" _ Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, _ ByVal lpName As String, lpLuid As LUID) As Long Declare Function AdjustTokenPrivileges Lib "advapi32" ( _ ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _ NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _ PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Const SND_ASYNC = &H1 ' play asynchronously Type RingBuffer B As String * 32000 Nb As Long Wp As Long Rp As Long End Type ' Added 21/10/2006 Da Silva Serge Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessID As Long dwThreadID As Long End Type ' ShellAndWait Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String dwX As Long dwY As Long dwXSize As Long dwYSize As Long dwXCountChars As Long dwYCountChars As Long dwFillAttribute As Long dwFlags As Long wShowWindow As Integer cbReserved2 As Integer lpReserved2 As Long hStdInput As Long hStdOutput As Long hStdError As Long End Type Public Const NORMAL_PRIORITY_CLASS = &H20& Public Const INFINITE = -1& Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long 'Déclaration des fonctions API Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCTYPE As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long Private Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCTYPE As Long, ByVal lpLCData As String) As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long 'Déclaration de la constante séparateur décimal Global DecSep As String Private Const LOCALE_SDECIMAL = &HE Public Property Get DecimalSeparator() As String Dim nLength As Long Dim nLocale As Long nLocale = GetUserDefaultLCID() nLength = GetLocaleInfo(nLocale, LOCALE_SDECIMAL, vbNullString, 0) - 1 DecimalSeparator = Space$(nLength) GetLocaleInfo nLocale, LOCALE_SDECIMAL, DecimalSeparator, nLength End Property Public Property Let DecimalSeparator(ByRef Value As String) Dim nLocale As Long If Value <> DecimalSeparator Then If Value = "." Or Value = "," Then nLocale = GetUserDefaultLCID() SetLocaleInfo nLocale, LOCALE_SDECIMAL, Value End If End If End Property Sub ForceLignes(Fichier As String, MaxLignes As Integer, NbLignes As Integer) ' Si plus de MaxLignes, ne garde que les Nblignes dernières lignes du fichier texte Dim Fs As Integer Dim Fo As Integer Dim L As String Dim I As Integer Dim Temp As String If Not FileExists(Fichier) Then Exit Sub If MaxLignes <= NbLignes Then MaxLignes = NbLignes * 2 Fs = FreeFile Open Fichier For Input As Fs Do While Not EOF(Fs) Line Input #Fs, L I = I + 1 'Compte les lignes Loop If I > MaxLignes Then Seek #Fs, 1 'Rewind I = I - NbLignes 'Nombre de lignes à supprimer For NbLignes = 1 To I Line Input #Fs, L Next NbLignes Fo = FreeFile Temp = App.Path & "\" & Format(Now, "ddhhmmss") & "." & Format(Fo, "000") Open Temp For Output As Fo Do While Not EOF(Fs) Line Input #Fs, L Print #Fo, L Loop Close Fs Close Fo Kill Fichier Name Temp As Fichier Else Close Fs End If End Sub Function WriteRb(RB As RingBuffer, C As String) As Long ' Ecrit un caractère dans buffer. ' Retourne le nombre de caractères en attente ou 0 si buffer plein With RB If .Nb < 32000 Then .Nb = .Nb + 1 If .Wp > 32000 Then .Wp = 0 .Wp = .Wp + 1 Mid(.B, .Wp, 1) = C WriteRb = .Nb End If End With End Function Function ReadRb(RB As RingBuffer, N As Integer) As String 'Retourne les N caractères suivants du buffer Dim NN As Integer With RB If N > .Nb Then N = .Nb If .Nb Then .Nb = .Nb - N If .Rp + N > 32000 Then 'On va wrapper avant NN = 32000 - .Rp ReadRb = Mid(.B, .Rp, NN) .Rp = 1 End If N = N - NN ReadRb = ReadRb & Mid(.B, .Rp, N) .Rp = .Rp + N End If End With End Function Function ShowRb(RB As RingBuffer, N As Integer) As String 'Montre les N caractères suivants du buffer sans les retirer Dim Tp As Long 'Pointeur temporaire With RB If N > .Nb Then N = .Nb If .Nb Then Tp = .Rp Do While N > 0 If Tp > 32000 Then Tp = 0 Tp = Tp + 1 ShowRb = ShowRb & Mid(.B, Tp, 1) N = N - 1 Loop End If End With End Function Sub ClearRb(RB As RingBuffer) 'Réinitialse le buffer With RB .Nb = 0 .Wp = 1 .Rp = 1 End With End Sub Sub OpenSection(Section As String) S = "[" & UCase(Trim$(Section)) & "]" & Chr$(13) & Chr$(10) End Sub Sub AddKey(key As String, Value As String) S = S & Trim$(key) & "=" & Trim$(Value) & Chr$(13) & Chr$(10) End Sub Sub CloseSection(FicNum As Integer) Print #FicNum, S End Sub Function GetFname(FullPath As String) As String 'Retourne le nom du fichier sans le chemin Dim I As Integer Dim J As Integer Dim Sep As String Sep = "\" 'Assume Windows style If InStr(FullPath, "/") Then Sep = "/" 'Set Unix style Do J = InStr(I + 1, FullPath, Sep) If J = 0 Then Exit Do I = J Loop GetFname = Right$(FullPath, Len(FullPath) - I) End Function Function GetFnameWOext(FullPath As String) As String 'Retourne le nom du fichier sans le chemin ni l'extension Dim S As String Dim I As String S = GetFname(FullPath) I = InStr(S, ".") If I Then GetFnameWOext = Left(S, I - 1) End Function Function GetParams(Section As String, Cle As String) As String Dim S As String Dim Substitute As String S = GetIniString(F_INI, Section, Cle) If Len(S) Then GetParams = S Substitute = GetIniString(F_INI, "DEFINE", S) If Len(Substitute) Then GetParams = Substitute Else GetParams = GetIniString(F_INI, "DEFAUT", Cle) End If End Function Function Get_Start_Params() As String Dim S As String Dim P As String S = LCase$(Command$) If Len(S) = 0 Then S = InputBox$("Entrer les parametres", "Pas de parametres") If Len(S) = 0 Then End End If INIFILE = Substring(S, 1, " ") P = GetPath(INIFILE) If InStr(P, ".") = 1 Then INIFILE = App.Path & Mid$(INIFILE, 2) If Len(P) = 0 Then INIFILE = App.Path & "\" & INIFILE Get_Start_Params = S End Function Sub Set_StartParams() Dim S As String S = Command$ If Len(S) Then INIFILE = Substring(S, 1, " ") Exit Sub 'utilise 1er paramètre ligne commande End If INIFILE = App.Path & "\" & App.EXEName & ".INI" 'utilise fichier par défaut End Sub Function GetIniString(Fichier As String, Section As String, Cle As String) As String Dim S As String Dim X As Integer If Not FileExists(Fichier) Then Exit Function X = GetPrivateProfileString(ByVal Section, ByVal Cle, ByVal "", ByVal Rstring, ByVal Len(Rstring), ByVal Fichier) S = Left$(Rstring, X) If InStr(S, "'") = 1 Then S = Right$(S, Len(S) - 1) GetIniString = S End Function Function GetSystemString(SName As String, Section As String, Cle As String) As String Dim Rstring As String Dim X As Integer Rstring = String$(256, 0) X = GetPrivateProfileString(ByVal Section, ByVal Cle, ByVal "", ByVal Rstring, ByVal Len(Rstring), ByVal SName) GetSystemString = Left$(Rstring, X) End Function Sub SetTrace() NivTrace = 0 FicTrace = GetIniString(INIFILE, "DEBUG", "Trace") If Len(FicTrace) Then If GetPath(FicTrace) = "." Or Len(GetPath(FicTrace)) = 0 Then FicTrace = App.Path & "\" & GetFname(FicTrace) End If NivTrace = Val(GetIniString(INIFILE, "DEBUG", "Niveau")) End If End Sub Function GetPath(FullPath As String) As String 'Retourne le chemin sans le nom du fichier Dim I As Integer Dim J As Integer Dim Sep As String GetPath = "" If Len(FullPath) Then If InStr(FullPath, "/") Then Sep = "/" 'Set Unix style ElseIf InStr(FullPath, "\") Then Sep = "\" 'May be Windows style Else Exit Function 'None, nothing to return End If Do J = InStr(I + 1, FullPath, Sep) If J = 0 Then Exit Do I = J Loop GetPath = Left$(FullPath, I - 1) End If End Function Function GetExtension(Fichier As String) As String 'Retourne l'extension de fichier (sans le point !) GetExtension = Substring(GetFname(Fichier), 2, ".") End Function Function Substring(Texte As String, Item As Integer, Separateur As String) As String Dim D As Integer Dim F As Integer Dim I As Integer D = 1 I = 1 Do F = InStr(D, Texte, Separateur) If F = 0 Then F = Len(Texte) + 1 If I = Item Then Exit Do I = I + 1 D = F + Len(Separateur) If D > Len(Texte) Then Substring = "" Exit Function End If Loop Substring = Mid$(Texte, D, F - D) ' If Len(Substring) = 0 Then Substring = " " End Function Function SubStringVal(Texte As String, Item As Integer, Separateur As String) As Integer SubStringVal = Val(Substring(Texte, Item, Separateur)) End Function Sub Trace(Niveau As Integer, Message As String) Dim I As Integer Dim F As Integer Dim C As String Dim S As String If (Niveau And NivTrace) = 0 Then Exit Sub Do While Niveau Niveau = Niveau \ 2 Message = " " & Message Loop S = Format(Now, "dd/mm/yyyy hh:mm:ss") & " " & Message F = FreeFile On Error Resume Next Open FicTrace For Append As F If Err Then Exit Sub Print #F, S Close #F End Sub Sub WriteIniString(Fichier As String, Section As String, Cle As String, Texte As String) Dim X As Integer ' Debug.Print Texte X = WritePrivateProfileString(ByVal Section, ByVal Cle, ByVal Texte, ByVal Fichier) End Sub Function FileCopyDiff(Source As String, Destin As String) As Boolean 'Copie source dans destination seulement si contenus differents Dim Fs As Integer Dim FD As Integer If Not FileExists(Source) Then Exit Function If FileExists(Destin) Then If FileLen(Destin) <> FileLen(Source) Then Copy Source, Destin, 1, True FileCopyDiff = True Else Fs = FreeFile Open Source For Input As Fs FD = FreeFile Open Destin For Input As FD If Input(LOF(Fs), Fs) <> Input(LOF(FD), FD) Then Close Fs Close FD Copy Source, Destin, 1, True FileCopyDiff = True Else Close Fs Close FD End If End If Else Copy Source, Destin, 1, True FileCopyDiff = True End If End Function Sub MarkActivity(MarkFile As String) Dim F As Integer F = FreeFile Open MarkFile For Output As F Print #F, Format(Now, "ddmmyyyyhhmmss") Close F End Sub Function PathExists(ThisPath As String) As Boolean Dim Temp As String PathExists = True Temp = CurDir On Error Resume Next ChDir ThisPath If Err Then PathExists = False End If On Error GoTo 0 ChDir Temp End Function Function GetFileListe(Masque) As String 'Retourne la liste de tous les fichiers correspondants au masque sous ' la forme de chaines séparées par des virgules. Dim S As String On Error Resume Next S = Dir$(Masque, vbHidden + vbSystem + vbReadOnly) Do While Len(S) GetFileListe = GetFileListe & S & "," S = Dir$ Loop End Function Function GetDirListe(Masque As String) As String 'Retourne la liste de tous les sous répertoires correspondant au masque ' sous la forme de chaines séparées par des virgules. Dim S As String S = Dir$(Masque, vbDirectory + vbHidden + vbSystem + vbReadOnly) Do While Len(S) If PathExists(Masque & S) Then GetDirListe = GetDirListe & S & "," S = Dir$ Loop ' #If Win32 Then If Len(Masque) > 3 Then ' GetDirListe = Mid$(GetDirListe, 6) 'Enlève '.' et '..' ' #End If End If End Function Function IsTimeValid(T As String) As Boolean IsTimeValid = False If IsDate(T) Then T = Format$(CDate(T), "hh:mm") IsTimeValid = True End If End Function Sub RemoveDuplicate(S As String, Sep As String) Dim I As Integer Dim J Dim S1 As String Dim S2 As String I = InStr(S, Sep) While I S1 = Left(S, I) S2 = Right(S, Len(S) - I) J = InStr(S1, S2) If J Then S = S2 End If I = InStr(S, Sep) Wend End Sub Function ReplaceString(Source As String, Match As String, Replace As String, NoWhite As Boolean) As Integer 'Remplace dans la chaine source les occurences de 'Match' par 'Replace' et retourne ' le nombre de remplacements effectués. 'Si le flag NoWhite est spécifié, les codes contrôles ( < 31 décimal) sont 'éliminés de la chaine de sortie AVANT l'insertion de 'Replace'. ' Ex: X = ReplaceString(S, Chr$(10), Chr$(10), True) retourne le nombre de lignes ' non vides de S, et remplace les cr/lf par lf. Dim I As Integer Dim J As Integer Dim S As String Dim T As String If InStr(Source, Match) = 0 Then Exit Function J = 1 ' Debug.Print Source ' Debug.Print "-------------------" S = Substring(Source, J, Match) Do While Len(S) If NoWhite Then S = TTrim(S) If Len(S) Then T = T & S & Replace I = I + 1 End If Else T = T & S & Replace I = I + 1 End If J = J + 1 S = Substring(Source, J, Match) Loop ReplaceString = I Source = T ' Debug.Print Source End Function Function TTrim(S As String) As String 'Total Trim: Elimine tous les caractères non imprimables ( 0 à 32 décimal) 'Conserve les espaces entre les mots Dim I As Integer Dim C As String ' S = Trim(S) 'Supprime espaces de début et de fin For I = 1 To Len(S) C = Mid$(S, I, 1) If C > Chr$(31) Then TTrim = TTrim & C Next I TTrim = Trim(TTrim) 'Supprime espaces de début et de fin End Function Function TTrimAll(S As String) As String 'Total Trim: Elimine tous les caractères non imprimables et les espaces ( 0 à 32 décimal) Dim I As Integer Dim C As String S = Trim$(S) 'Supprime espaces de début et de fin For I = 1 To Len(S) C = Mid$(S, I, 1) If C > Chr$(32) Then TTrimAll = TTrimAll & C Next I End Function Sub ShowError(ErrDescription As String, Message As String) ' MsgBox "(" & ErrDescription & ")" & vbCrLf & Message MsgBox ErrDescription, , Message End Sub Function IsSameFile(F1 As String, F2 As String) As Boolean 'Compare nom et date de deux fichiers avec chemins '** Rajouter comparaison de la taille ? IsSameFile = False If FileExists(F1) And FileExists(F2) Then If GetFname(F1) = GetFname(F2) And FileDateTime(F1) = FileDateTime(F2) Then IsSameFile = True End If End If End Function Function GetNextInList(List As String, Sep As String) As String ' Retourne la sous chaine suivante de la liste de chaines 'List' séparées par 'Sep' ' Réinitialisé si appelé avec un nom de liste différent ou de longueur nulle ' Retourne une chaine vide quand liste épuisée ' Non reéntrant !!! Static I As Integer Static LastList As String If List <> LastList Then LastList = List I = 0 End If I = I + 1 GetNextInList = Substring(List, I, Sep) End Function Sub MakeDirTree(Tree As String) ' format de Tree: "x:\a\b\c.." ou ".\a\b\c.." ou "a\b\c.." ou "\a\b\c.." ' Crée tout l'arbre avec les sous répertoires i.e. md a, md a\b, md a\b\c, etc... Dim I As Integer Dim S As String Dim T As String I = 1 S = Substring(Tree, I, "\") If InStr(S, ":") Or InStr(S, ".") Or _ (Len(S) = 0 And Len(Tree) > 0) Then 'Récupère le premier chemin complet: "x:\a" I = I + 1 S = S & "\" & Substring(Tree, I, "\") End If T = S On Error Resume Next Do While Len(T) MkDir S If Err = 0 Or Err = 75 Then 'Reussi ou déja créé I = I + 1 T = Substring(Tree, I, "\") S = S & "\" & T Err.Clear Else MsgBox "MakeDirTree " & Tree & " " & S & vbCrLf & _ "Erreur " & Err, vbCritical, App.EXEName End If Loop ' On Error GoTo 0 End Sub Function GetKeysInSection(Fichier As String, Section As String) As String 'Retourne la liste des clés trouvées dans la section spécifiée. ' Ignore les entrées commençant par ';' Dim F As Integer Dim Ligne As String Dim InSection As Boolean If FileExists(Fichier) Then F = FreeFile Open Fichier For Input As F Do While Not EOF(F) Line Input #F, Ligne If InSection Then If InStr(Trim(Ligne), "[") = 1 Then Close F Exit Function End If ' S = UCase(Trim$(Substring(Ligne, 1, "="))) S = Trim$(Substring(Ligne, 1, "=")) If Len(S) And InStr(S, ";") = 0 Then GetKeysInSection = GetKeysInSection & S & "," Else If InStr(Ligne, "[" & UCase(Section) & "]") = 1 Then InSection = True End If End If Loop Close F End If End Function Function GetSections(Fichier As String) As String 'Retourne la liste des sections trouvées dans le fichier spécifié ' Ignore les entrées commeçant par ';' Dim F As Integer Dim Ligne As String F = IsOpen(Fichier, "Input", 1000) If F Then Do While Not EOF(F) Line Input #F, Ligne If InStr(Trim(Ligne), "[") = 1 Then Ligne = Mid$(Ligne, 2, InStr(Ligne, "]") - 2) GetSections = GetSections & Ligne & "," End If Loop Close F End If End Function Sub Wait(ByVal Millisecs As Double) ' Ne retourne qu'après 'Millisecs' en millisecondes ou si Unsign(GetTickCount) wrappe (le 49 ème jour) Dim Day49 As Double Dim M As Double Day49 = Unsign(GetTickCount) M = Day49 + Millisecs 'Unsign(GetTickCount) + Millisecs Do DoEvents Sleep 1 'This voids hanging full CPU usage. Why ?? Loop While Unsign(GetTickCount) < M Or Unsign(GetTickCount) < Day49 ' bug du 49 ème jour, tant pis ! End Sub Function WaitFor(Something As Boolean, Delai As Long) As Boolean ' Wait for 'something' be true while 'Delai' milliseconds' ' Returns the value of 'Something' as soon it becomes true or ' False if Delai elapsed before Dim Day49 As Double Dim D As Double 'Ne pas modifier le parametre ! Day49 = Unsign(GetTickCount) D = Day49 + Delai 'Unsign(GetTickCount) + Millisecs Do DoEvents Sleep 1 If Something Then WaitFor = Something Exit Function End If Loop While Unsign(GetTickCount) < D Or Unsign(GetTickCount) < Day49 ' bug du 49 ème jour, tant pis ! End Function Sub ShowMsg(Message As String, Titre As String) ' Affiche une boite de message pendant 'Duree' x millisecondes Trace 128, Titre & Chr$(9) & Message #If ShowMsg Then If MyMsg.Visible Or DureeMsg = 0 Then Exit Sub MyMsg.LblDelai.Caption = Str$(DureeMsg) MyMsg.Caption = Titre MyMsg.LblMsg.Caption = Message MyMsg.Show 0 #End If End Sub Function Copy(Org As String, Dest As String, Delai As Integer, TouchDate As Boolean) As Boolean 'Recopie Org sous un nouveau nom (duplique) Dim W As Double Dim Day49 As Double Copy = False Day49 = Unsign(GetTickCount) W = Day49 + Delai On Error Resume Next Do Err.Clear FileCopy Org, Dest If Err = 0 Then If TouchDate Then Touch Dest, 0 Copy = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't copy " & Org & " in " & Dest, "Copy Error N°" & Str(Err) & " " & Err.Description End Function Function IsOpen(File As String, Mode As String, Delai As Integer) As Integer ' Retourne un numéro de fichier si ouverture possible dans les delais, sinon 0 Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai On Error Resume Next Select Case UCase(Mode) Case "INPUT", "READ", "R" Do If Not FileExists(File) Then Exit Function Err.Clear IsOpen = FreeFile Open File For Input Access Read As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "OUTPUT", "WRITE", "W" Do Err.Clear IsOpen = FreeFile Open File For Output Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "APPEND", "A" Do Err.Clear IsOpen = FreeFile Open File For Append Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "BINARY", "B" Do Err.Clear IsOpen = FreeFile Open File For Binary Access Read Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "READBINARY", "RB" If Not FileExists(File) Then Exit Function Do Err.Clear IsOpen = FreeFile Open File For Binary Access Read As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "WRITEBINARY", "WB" Do Err.Clear IsOpen = FreeFile Open File For Binary Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case Else Mode = "Unknow mode" Error 55 End Select If Err Then ShowMsg "Can't open " & File & " for " & Mode, "IsOpen Error N°" & Str(Err) & _ " " & Err.Description IsOpen = 0 End If Err.Clear End Function Function Delete(File As String, Delai As Integer) As Boolean ' Détruit le fichier si possible sinon renvoie 'False' Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai Delete = False On Error Resume Next Do Err.Clear Kill File If Err = 0 Or Err = 53 Then 'Accepter sans râler si fichier inexistant Delete = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't delete " & File, "Delete Error N°" & Str(Err) & _ " " & Err.Description End Function Function DelTree(Path As String) As Boolean 'Vide et détruit le répertoire spécifié. Dim RList As String Dim Flist As String Dim R As String Dim F As String Dim I As Integer If Not PathExists(Path) Then Exit Function Flist = GetFileListe(Path & "\*.*") 'Obtiend la liste des fichiers I = 1 F = Substring(Flist, I, ",") Do While Len(F) Delete Path & "\" & F, 1 'Efface tous les fichiers I = I + 1 F = Substring(Flist, I, ",") Loop RList = GetDirListe(Path & "\") 'Obtiend la liste des sous répertoires I = 1 R = Substring(RList, I, ",") Do While Len(R) 'pour chaque sous répertroire DelTree Path & "\" & R 'Récursif I = I + 1 R = Substring(RList, I, ",") Loop RmDir Path End Function Function ExecOnTree(Path As String, Action As Long) As Boolean End Function Function Rename(OldName As String, NewName As String, Delai As Integer, TouchDate As Boolean) As Boolean 'Renomme le fichier si possible 'Si 'TouchDate', met NewName à la date courante 'Remplace 'NewName' si existe déjà 'Si lecteurs différents, copie puis détruit ancien If Copy(OldName, NewName, Delai, TouchDate) Then Rename = Delete(OldName, 0) End If End Function Function CheckIfFiles(Liste As String, Path As String, Sep As String) As String 'Retourne 'Liste' sans les fichiers introuvables dans 'Path' Dim I As Integer Dim S As String Dim T As String If Len(Liste) Then I = 1 T = Substring(Liste, I, Sep) Do While Len(T) If FileExists(Path & "\" & T) Then S = S & T & Sep I = I + 1 T = Substring(Liste, I, Sep) Loop CheckIfFiles = S End If End Function Function FileExists(File As String) As Boolean ' Indique si le fichier existe If Len(File) = 0 Then Exit Function On Error Resume Next FileDateTime (File) If Err Then If GereManque Then Manque File Else FileExists = True End If End Function Sub Manque(S As String) If Len(Manquants) < 32000 Then If InStr(Manquants, S) = 0 Then Manquants = Manquants & S & "," 'Sans dupliquer ! End If End Sub Function Touch(File As String, Delai As Integer) As Boolean ' Change la date du fichier par la date courante Dim F As Integer Dim X As String * 1 Touch = False F = IsOpen(File, "Binary", Delai) If F Then If LOF(F) Then Get #F, 1, X Put #F, 1, X Touch = True Else ShowMsg "Can't change date if file is empty " & File, "Touch Error N°" & Str(Err) & _ " " & Err.Description End If Close F End If End Function Function XClose(FileNum As Integer, Delai As Integer) As Boolean Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai XClose = False On Error Resume Next Do Err.Clear Close FileNum If Err = 0 Then XClose = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't close" & Str(FileNum), "Close Error N°" & Str(Err) & _ " " & Err.Description End Function Function CountFileLines(Fichier As String) As Integer 'Retourne le nombre de lignes non vides de 'Fichier' '0 si fichier inaccessible Dim L As String Dim F As Integer F = IsOpen(Fichier, "Input", 1000) If F Then While Not EOF(F) Line Input #F, L If Len(L) Then CountFileLines = CountFileLines + 1 Wend XClose F, 1000 End If End Function Function CountStringLines(S As String) As Integer 'Retourne le nombre de lignes non vides de S ' *** (Voir CountStrings dans ce même module) End Function Function TrieListeChaine(Liste As String, Mode As Integer, Sens As Integer) As String ' Retourne la liste triée dans le sens spécifié (1 = Croissant, 0 = Décroissant) ' selon Mode (1= Texte(Alphabétique), 0 = Binaire) Dim S As String Dim S1 As String Dim S2 As String Dim I As Integer Dim J As Integer Dim T() As String I = 1 S = Trim$(Substring(Liste, I, ",")) While Len(S) 'On rempli le tableau I = I + 1 ReDim Preserve T(I) T(I - 1) = S 'L'indice 0 n'est pas utilisé ! S = Substring(Liste, I, ",") Wend If I > 2 Then 'Il y a qqchose à trier I = I - 1 J = 1 While J < I If StrComp(T(J + 1), T(J), Mode) = -Sens Then 'Permuter S1 = T(J + 1) T(J + 1) = T(J) T(J) = S1 If J > 1 Then J = J - 1 'Retester le précédent Else J = J + 1 End If Wend For J = 1 To I 'Crée la chaine en sortie TrieListeChaine = TrieListeChaine & T(J) & "," Next J Else TrieListeChaine = Liste End If End Function Function TrieTableau(T(), Col As Integer, Mode As Integer) As Integer ' Ordonne les lignes d'un tableau à 2 dimension selon le contenu de la colonne spécifiée ' Mode = 0: Binaire, 1: Alphabétique, 2: Numérique ' Sens = Toujours croissant ' Retourne <> 0 si anomalie. Dim L As Integer Dim C As Integer Dim I As Integer Dim J As Integer Dim Swaped As Boolean L = UBound(T, 1) C = UBound(T, 2) ReDim TT(1, C) If L > 1 Then 'S'il y a au moins 2 lignes If C >= Col Then 'et si la colonne spécifiée existe I = 1 While I < UBound(T, 1) Swaped = False If Mode = 2 Then If T(I + 1, Col) < T(I, Col) Then Swaped = True For J = 0 To C TT(0, J) = T(I + 1, J) 'Permuter T(I + 1, J) = T(I, J) T(I, J) = TT(0, J) Next If I > 0 Then I = I - 1 'Retester le précédent End If Else If StrComp(T(I + 1, Col), T(I, Col), Mode) = -1 Then Swaped = True For J = 0 To C TT(0, J) = T(I + 1, J) 'Permuter T(I + 1, J) = T(I, J) T(I, J) = TT(0, J) Next If I > 0 Then I = I - 1 'Retester le précédent End If End If If Not Swaped Then I = I + 1 End If Wend Else TrieTableau = -1 End If Else TrieTableau = -2 End If End Function Sub StartChrono(Chrono As Integer) ' Lance un chrono On Error Resume Next Chronos(Chrono) = Unsign(GetTickCount) End Sub Sub ShowChrono(Chrono As Integer) 'Affiche un chrono Dim TT As Long On Error Resume Next TT = Unsign(GetTickCount) MsgBox Format$((TT - Chronos(Chrono)) / 1000, "0.000") & " secondes", 0, "Chrono" & Str$(Chrono) ' ShowMsg Str$(TT - Chronos(Chrono)) & " Millisecondes", "Chrono" & Str$(Chrono) End Sub Function UnsignedTovbInteger(ByVal Unsigned As Long) As Integer 'Convertit un long représentant entier non signé (retourné par un appel à un API par exemple) en 'entier non signé à passer à une fonction externe If (Unsigned And &H8000&) = 0 Then UnsignedTovbInteger = Unsigned And &HFFFF& Else UnsignedTovbInteger = &H8000 Or (Unsigned And &H7FFF&) End If End Function Function CountStrings(S As String, SubS As String) As Integer 'Retourne le nombre de 'SubS'contenues dans 'S'. Dim D As Long Dim F As Long D = 1 Do F = InStr(D + 1, S, SubS) If F Then CountStrings = CountStrings + 1 D = F Loop While D End Function Public Function GetFileSpecs(Objet, DefPath As String, DefFichier As String, Titre As String, Mode As String) As String ' Interface pour CommonDialog 'Ouvrir / Enregistrer sous' 'DefPath ne doit pas inclure le "\" terminal Dim S As String Dim E As String With Objet .CancelError = True .Filter = "Tous fichiers (*.*)|*.*" .FilterIndex = 1 E = GetExtension(DefFichier) If Len(E) Then .Filter = .Filter & "|Fichiers " & App.EXEName & " (*." & E & ")|*." & E .FilterIndex = 2 End If .Flags = &H804 .DialogTitle = Titre .InitDir = DefPath .FileName = DefFichier On Error Resume Next If Mode Like "Open" Then .ShowOpen If Mode Like "Save" Then .ShowSave S = .FileName If (Len(S) <> 0) And Err = 0 Then GetFileSpecs = S End If End With End Function Public Function ChoosePrinter(Object) As Boolean With Object .CancelError = True ' .PrinterDefault = True ' .Orientation = cdlPortrait .Flags = &H40& .DialogTitle = "Printer" .ShowPrinter .Orientation = cdlPortrait End With End Function Public Function GetFileDate(Fichier As String) As Date GetFileDate = "00:00" On Error Resume Next GetFileDate = FileDateTime(Fichier) End Function Public Function HexDump(S As String, Bloc As Long) As String ' Retourne un dump Hexadécimal de 256 octets de S. Dim Debut As Integer Dim Ligne As Integer Dim Colonne As Integer Dim C(1 To 16) As String Dim H As String For Ligne = 1 To 16 H = Hex((16 * (Ligne - 1)) + (256 * Bloc)) If Len(H) < 8 Then H = String(8 - Len(H), "0") & H HexDump = HexDump & H & ": " For Colonne = 1 To 16 ' les valeurs hexadéciamales C(Colonne) = Mid$(S, Debut + 1, 1) If Len(C(Colonne)) Then H = Hex(Asc(C(Colonne))) If Len(H) < 2 Then H = "0" & H Else H = ".." End If Debut = Debut + 1 HexDump = HexDump & H & " " Next Colonne HexDump = HexDump & " " For Colonne = 1 To 16 'les caractères ascii imprimables If C(Colonne) < " " Then C(Colonne) = " " HexDump = HexDump & C(Colonne) Next Colonne HexDump = HexDump & vbCrLf Next Ligne HexDump = HexDump & vbCrLf End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Public Function Unsign(X As Long) As Double ' Retourne un single représentant un entier non signé. ' Utile pour traiter les valeurs retournées par des DLL qui renvoient un ULong 'Dim XX As Double ' XX = X ' If XX < 0 Then ' Unsign = 2147483647 + XX ' Unsign = Unsign + 2147483648# ' Else ' If XX = 0 Then ' Unsign = XX + 1 ' End If ' Unsign = XX ' End If 'End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Unsign(X As Long) As Long 'Retourne X sans le signe Unsign = X And &H7FFFFFFF End Function Public Sub CenterForm(F As Form) F.Top = (Screen.Height - F.Height) / 2 F.Left = (Screen.Width - F.Width) / 2 End Sub Public Function Crc(S As String, Debut As Integer) As String 'Retourne le CRC (Xor) de S Dim I As Integer Dim X As Integer For I = Debut To Len(S) X = X Xor Asc(Mid$(S, I, 1)) Next I Crc = Chr$(X) End Function Public Function FormatTexte(S As String, C As Integer, Tableau() As String) As Integer ' Rempli le tableau avec des lignes de longueur 'C' extraites de S et centrées ' *** S ne doit pas contenir de caractères de contrôle *** ' Retourne le nombre de lignes (Taille du tableau) Dim Lignes As Integer Dim Debut As Integer Dim T As String Dim U As String Dim L As Integer Debut = 1 S = Trim$(S) T = Substring(S, Debut, " ") Do While Len(T) T = Trim$(T) Do While Len(T) < C 'Il reste de la place U = Trim$(Substring(S, Debut + 1, " ")) 'Essaie le suivant Debut = Debut + 1 If Len(U) + Len(T) < C Then 'C'est bon T = T & " " & U Else Exit Do End If Loop T = Trim$(T) L = Len(T) If L = C Then Debut = Debut + 1 L = C - L If L > 1 Then 'Centrer L = L \ 2 T = String(L, " ") & T & String(L, " ") End If Lignes = Lignes + 1 ReDim Preserve Tableau(Lignes) Tableau(Lignes - 1) = T T = Substring(S, Debut, " ") Loop FormatTexte = Lignes End Function Public Sub AdjustToken() Const TOKEN_ADJUST_PRIVILEGES = &H20 Const TOKEN_QUERY = &H8 Const SE_PRIVILEGE_ENABLED = &H2 Dim hdlProcessHandle As Long Dim hdlTokenHandle As Long Dim tmpLuid As LUID Dim tkp As TOKEN_PRIVILEGES Dim tkpNewButIgnored As TOKEN_PRIVILEGES Dim lBufferNeeded As Long hdlProcessHandle = GetCurrentProcess() OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _ TOKEN_QUERY), hdlTokenHandle ' Get the LUID for shutdown privilege. LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid tkp.PrivilegeCount = 1 ' One privilege to set tkp.TheLuid = tmpLuid tkp.Attributes = SE_PRIVILEGE_ENABLED ' Enable the shutdown privilege in the access token of this ' process. AdjustTokenPrivileges hdlTokenHandle, False, tkp, _ Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded End Sub Public Sub SystemRestart() #If NT Then AdjustToken #End If ExitWindowsEx (EWX_SHUTDOWN Or EWX_FORCE Or EWX_REBOOT), &HFFFF End Sub Public Sub ShowTrace(T As String, F As Form) 'Montre T dans l'objet texte 'Voir' de la feuille F si elle est visible If F.WindowState <> 1 Then If Len(F.Voir.Text) > 16000 Then 'Void overflow F.Voir.Text = "" End If F.Voir.SelText = T & vbCrLf End If Trace 1, T End Sub Public Sub ClearTrace(F As Form) F.Voir.Text = "" End Sub Public Sub PlaySound(Wavefile As String) If Len(Wavefile) > 0 And FileExists(Wavefile) Then sndPlaySound Wavefile, SND_ASYNC End If End Sub Public Function AdjustText(V As Variant, Lenght As Integer) 'Retourne une chaine de longueur 'Lenght' contenant V et paddée avec des espaces Dim S As String Dim L As Integer S = Format$(V) 'Regle le pb du NULL L = Len(S) If L < Lenght Then 'Trop court AdjustText = S & String$(Lenght - L, " ") Else AdjustText = Mid$(S, 1, Lenght) 'Trop long End If End Function Public Function ForceDp(V As String) As String 'Remplace la virgule par le point dans un variant représentant un nombre Dim VPos As Integer VPos = InStr(V, ",") If VPos Then 'Y'en a ForceDp = Substring(V, 1, ",") & "." & Substring(V, 2, ",") Else ForceDp = V End If End Function 'Public Function SpawnObject(Fichier As String) As Long ' ' If FileExists(Fichier) Then ' SpawnObject = ShellExecute(0, "Open", Fichier, "", App.Path, 0) 'SW_SHOWNORMAL) ' DoEvents ' End If 'End Function Public Function LongToSBin(X As Long) As String ' Returns a string of 0 and 1 showing V in binary form Dim I As Integer Dim V As Long V = X 'Preserve parameter Do For I = 0 To 7 If V Mod 2 Then LongToSBin = "1" & LongToSBin Else LongToSBin = "0" & LongToSBin End If V = V \ 2 Next LongToSBin = " " & LongToSBin 'a space every 8 bits Loop While V End Function Public Sub SwapStrings(S1 As String, S2 As String) Dim S As String S = S1 S1 = S2 S2 = S End Sub Public Sub SetNVar(Name As String, Value As Single) 'Assign a value to the named variable. 'Create it if needed Dim I As Integer For I = 0 To UBound(NVars) If Name = NVars(I).Name Then 'Found NVars(I).Value = Value 'Update value Exit Sub End If Next ReDim Preserve NVars(I) 'Does not exists, create NVars(I).Name = Name 'And setup. NVars(I).Value = Value End Sub Public Function GetNVar(Name As String) As Single 'Returns the value of this variable. 'Create it and returns 0 if needed Dim I As Integer For I = 0 To UBound(NVars) If Name = NVars(I).Name Then 'Found GetNVar = NVars(I).Value Exit Function 'Returns value End If Next 'Does not exists .. yet ReDim Preserve NVars(I) NVars(I).Name = Name NVars(I).Value = 0 GetNVar = 0 End Function Public Sub InitNVars() 'Destroys all variables ReDim NVars(0) End Sub