VBBrainBox v1.0.1.*Table des procédures 1 - AssemblyInfo.vb 2 - frmVBBrainBox.vb 2.1 - Private Function sApplicationSelectionnee$ 2.2 - Private Sub AfficherConclusions 2.3 - Private Sub AfficherErreurs 2.4 - Private Sub chkFaitsJustes_CheckedChanged 2.5 - Private Sub cmdAPropos_Click 2.6 - Private Sub cmdDBToFile_Click 2.7 - Private Sub cmdExporter_Click 2.8 - Private Sub cmdRapport_Click 2.9 - Private Sub cmdSauverApplication_Click 2.10 - Private Sub Expertiser 2.11 - Private Sub frmTExpert_Load 2.12 - Private Sub frmVBBrainBox_Closing 2.13 - Private Sub GestionDBToFile 2.14 - Private Sub Initialiser 2.15 - Private Sub lbApplications_SelectedIndexChanged 2.16 - Private Sub lbFichiersBF_SelectedIndexChanged 2.17 - Private Sub lbFichiersBR_SelectedIndexChanged 2.18 - Private Sub lbFichiersDico_SelectedIndexChanged 2.19 - Private Sub lbSessions_SelectedIndexChanged 2.20 - Private Sub llblTous_LinkClicked 2.21 - Private Sub tcEntrees_SelectedIndexChanged 2.22 - Private Sub tcExpertises_SelectedIndexChanged 2.23 - Private SubInitializeComponent 2.24 - Protected Overloads Overrides Sub Dispose 2.25 - Public Sub New 3 - VBBrainBox.vb 3.1 - Friend Function bBDChargerDico 3.2 - Friend Function bBDRemplirApplications 3.3 - Friend Function bBDRemplirFaits 3.4 - Friend Function bBDRemplirRegles 3.5 - Friend Function bBDVerifierVersion 3.6 - Friend Function bChargerBR 3.7 - Friend Function bChargerDico 3.8 - Friend Function bExpertiser 3.9 - Friend Function bRemplirSessions 3.10 - Friend Function colLireMessages 3.11 - Friend Sub ArchivageApplication 3.12 - Friend Sub CreerCompteRendu 3.13 - Friend Sub ExporterPourTurboExpert12 3.14 - Friend Sub InitialiserApplication 3.15 - Friend Sub New 3.16 - Friend Sub RemplirListesFichiers 3.17 - Private Function bChainageAvant 3.18 - Private Function bConclusions 3.19 - Private Function bDeduction 3.20 - Private Function bRemplirListeRegles 3.21 - Private Function bTraduireRegles 3.22 - Private Sub AjouterMsg 3.23 - Private Sub ExporterBilan 3.24 - Private Sub ExporterDescrApplication 3.25 - Private Sub ExporterDescrApplication 3.26 - Private Sub ExporterDico 3.27 - Private Sub ExporterFaitsInitiaux 3.28 - Private Sub ExporterRegles 3.29 - Private Sub FixerStyleTableauBilan 3.30 - Private Sub FixerStyleTableauDico 3.31 - Private Sub FixerStyleTableauFaits 3.32 - Private Sub FixerStyleTableauRegles 3.33 - Private Sub InitialiserConfigApp 3.34 - Private Sub InitialiserExpertise 3.35 - Private Sub InitMessages 3.36 - Private Sub ListerRegle 3.37 - Private Sub RemplirBilan 3.38 - Private Sub RemplirTableauRegles 4 - clsBF.vb 4.1 - Friend Function bChargerFaitsInitiauxSession 4.2 - Friend Function bExisteDansBF 4.3 - Friend Function bGestionConfig 4.4 - Friend Function bMAJFait 4.5 - Friend Function bPremisseVraieDansBF 4.6 - Friend Function bTrouverVar 4.7 - Friend Function bVarExisteDansBF 4.8 - Friend Function bVerifieeDansBF 4.9 - Friend Function fait 4.10 - Friend Sub AjouterFait 4.11 - Friend Sub New 4.12 - Private Function bDiff 4.13 - Private Function bEgal 4.14 - Private Function bExaminerPremisse 4.15 - Private Function bInfEgal 4.16 - Private Function bInfer 4.17 - Private Function bSupEgal 4.18 - Private Function bSuper 4.19 - Private Function iLireValeurPremisse% 4.20 - Private Function iValeurFait% 4.21 - Private Function MAJPremisse 4.22 - Private Sub AjouterMsg 5 - clsBR.vb 5.1 - Friend Function bBDChargerBR 5.2 - Friend Function bChargerBR 5.3 - Friend Sub ExprimerRegleOk 5.4 - Friend Sub InitDeductions 5.5 - Friend Sub Initialiser 5.6 - Friend Sub New 5.7 - Private Sub AjouterMsg 5.8 - Private Sub extraire_alors 5.9 - Private Sub ExtraireEt 5.10 - Private Sub ExtraireSi 5.11 - Private Sub StockerConclusion 5.12 - Private Sub StockerPremisse 6 - clsDico.vb 6.1 - Friend Function bChargerDico 6.2 - Friend Function bConfig 6.3 - Friend Function bConstante 6.4 - Friend Function bIntermediaire 6.5 - Friend Function bNomVarConfig 6.6 - Friend Function bVarExiste 6.7 - Friend Function ConvOper 6.8 - Friend Function DecomposerHypothese 6.9 - Friend Function rFiabDef! 6.10 - Friend Function sComposerHypothese$ 6.11 - Friend Function sConvOper$ 6.12 - Friend Function sNomVar$ 6.13 - Friend Function sTraiterGuillemets$ 6.14 - Friend Function sValDefVar$ 6.15 - Friend Sub ChargerDico 6.16 - Friend Sub New 6.17 - Private Sub AjouterMsg 6.18 - Private Sub InitDico 7 - modUtil.vb 7.1 - Public Shared Function bCleRegistreExiste 7.2 - Public Shared Function bEnregistrerDllActiveX 7.3 - Public Shared Function bEstVide 7.4 - Public Shared Function bInverserDate 7.5 - Public Shared Function bNonVide 7.6 - Public Shared Function bValeurNulleOuVrai 7.7 - Public Shared Function rNonVide! 7.8 - Public Shared Function sDLookUp$ 7.9 - Public Shared Function sDLookUp$ 7.10 - Public Shared Function sNonVide$ 7.11 - Public Shared Function sParametrerRq$ 7.12 - Public Shared Function sTraiterHyperlienAccess$ 7.13 - Public Shared Sub AjouterMsg 7.14 - Public Shared Sub JolieTransitionTaDaaa AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection Imports System.Runtime.InteropServices ' General Information about an assembly is controlled through the following ' set of attributes. Change these attribute values to modify the information ' associated with an assembly <Assembly: AssemblyTitle("VBBrainBox")> <Assembly: AssemblyDescription("Un système-expert d'ordre 0+ en VB .NET")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("VBBrainBox")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2015, " & _ "d'après Turbo-Expert 1.2 de Philippe Larvet")> <Assembly: AssemblyTrademark("VBBrainBox")> <Assembly: AssemblyCulture("")> ' Version information for an assembly consists of the following four values: ' Major version ' Minor Version ' Revision ' Build Number ' You can specify all the values or you can default the Revision and Build Numbers ' by using the '*' as shown below <Assembly: AssemblyVersion("1.0.1.*")> frmVBBrainBox.vb ' VBBrainBox : un système expert d'ordre 0+ en VB .NET ' ---------------------------------------------------- ' ------------------------------------------------------------------- ' Créé à partir de TExpert (Turbo-Expert 1.2 en VB6) : ' (c) Philippe LARVET <ph_larvet@yahoo.fr> Avril 1996. ' Prog "one shot" du 28 mai 96 avec paramètre de ligne de commande ' Version VB6 mai 02, revu en tant que moteur TExpert janvier 03 ' ------------------------------------------------------------------- ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' Version 1.01 du 15/03/2015 Visual Studio 2013 sous Windows 64 : forcer 32 bits ' Version 1.0 du 02/05/2003 ' Documentation : VBBrainBox.html, en ligne : ' http://patrice.dargenton.free.fr/ia/vbbrainbox/index.html ' Fichier frmVBBrainBox.vb ' ------------------------ ' Conventions de nommage des variables : ' b pour Boolean (booléen vrai ou faux) ' i pour Integer (%) et Short (System.Int16) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' a pour Array (tableau) : () ' o pour Object (objet ou classe) ' m_ pour variable Membre de la classe (mais pas pour les constantes) ' Syntaxe plus stricte, surtout pour les conversions de type ' qui doivent être explicites Option Strict On Option Explicit On ' Toute variable doit être déclarée (non mais sans blagues !) Namespace VBBrainBox ' Utile si plusieurs projets sont intégrés Friend Class frmVBBrainBox Inherits Form #Region "Déclarations" Private Const sNomFichierRapport$ = "Rapport.txt" ' Rapport d'expertise Private m_bInit As Boolean = False ' Attendre l'initialisation des composants Private m_bConnexion As Boolean ' Connexion à la base de données ' Afficher l'erreur au lancement de l'application le cas échéant Private m_bErr As Boolean = False Private m_oSE As New clsVBBBox() ' C'est le système expert ' Onglet de sélection des applications Private Const iPageBD% = 0 Private Const iPageFichiers% = 1 ' Onglet de l'expertise Private Const iPageVariables% = 0 Private Const iPageRegles% = 1 Private Const iPageReglesListe% = 2 Private Const iPageFaits% = 3 Private Const iPageExpertise% = 4 Private Const iPageBilan% = 5 Private Const iPageAPropos% = 6 ' Niveaux d'initialisation Private Const iTypeInitTout% = 0 Private Const iTypeInitApplication% = 1 Private Const iTypeInitDico% = 2 Private Const iTypeInitBR% = 3 Private Const iTypeInitBF% = 4 'Private Const iTypeInitSessions% = 5 Private Const iTypeInitExpertise% = 6 Private couleurErr As Color = Color.LightCoral Private couleurInit As Color = Color.DarkGray Private couleurOk As Color = Color.White #End Region #Region "Windows Form Designer generated code " Public Sub New() MyBase.New() 'This call is required by the Windows Form Designer. InitializeComponent() End Sub 'Form overrides dispose to clean up the component list. Protected Overloads Overrides Sub Dispose(ByVal Disposing As Boolean) If Disposing Then If Not components Is Nothing Then components.Dispose() End If End If MyBase.Dispose(Disposing) End Sub 'Required by the Windows Form Designer Private components As System.ComponentModel.IContainer Public ToolTip1 As System.Windows.Forms.ToolTip 'NOTE: The following procedure is required by the Windows Form Designer 'It can be modified using the Windows Form Designer. 'Do not modify it using the code editor. Friend WithEvents tcEntrees As System.Windows.Forms.TabControl Friend WithEvents tpBD As System.Windows.Forms.TabPage Friend WithEvents lbApplications As System.Windows.Forms.ListBox Friend WithEvents lbFichiersDico As System.Windows.Forms.ListBox Friend WithEvents tpFichiers As System.Windows.Forms.TabPage Friend WithEvents lbFichiersBR As System.Windows.Forms.ListBox Friend WithEvents lbFichiersBF As System.Windows.Forms.ListBox Friend WithEvents tcExpertises As System.Windows.Forms.TabControl Friend WithEvents tpRegles As System.Windows.Forms.TabPage Friend WithEvents tpExpertises As System.Windows.Forms.TabPage Friend WithEvents tpBilanSession As System.Windows.Forms.TabPage Friend WithEvents dgBilanSession As System.Windows.Forms.DataGrid Friend WithEvents lbFaits As System.Windows.Forms.ListBox Friend WithEvents lbConclusions As System.Windows.Forms.ListBox Friend WithEvents lbFaitsJustes As System.Windows.Forms.ListBox Friend WithEvents tpVariables As System.Windows.Forms.TabPage Friend WithEvents lbReglesListe As System.Windows.Forms.ListBox Friend WithEvents tpReglesListe As System.Windows.Forms.TabPage Friend WithEvents tpFaits As System.Windows.Forms.TabPage Friend WithEvents dgFaits As System.Windows.Forms.DataGrid Friend WithEvents dgRegles As System.Windows.Forms.DataGrid Friend WithEvents chkFaitsJustes As System.Windows.Forms.CheckBox Friend WithEvents lblFaitsInitiaux As System.Windows.Forms.Label Friend WithEvents lblExpertise As System.Windows.Forms.Label Friend WithEvents lblSessions As System.Windows.Forms.Label Friend WithEvents lbSessions As System.Windows.Forms.ListBox Friend WithEvents cmdRapport As System.Windows.Forms.Button Friend WithEvents lblDico As System.Windows.Forms.Label Friend WithEvents lblBaseFaits As System.Windows.Forms.Label Friend WithEvents lblRegles As System.Windows.Forms.Label Friend WithEvents dgVariables As System.Windows.Forms.DataGrid Friend WithEvents cmdArchivage As System.Windows.Forms.Button Friend WithEvents cmdExporter As System.Windows.Forms.Button Friend WithEvents tpAPropos As System.Windows.Forms.TabPage Friend WithEvents cmdAPropos As System.Windows.Forms.Button Friend WithEvents lblVBBrainBox As System.Windows.Forms.Label Friend WithEvents llblORS As System.Windows.Forms.LinkLabel Friend WithEvents llblVBBrainBoxEnLigne As System.Windows.Forms.LinkLabel Friend WithEvents llblVBBrainBox As System.Windows.Forms.LinkLabel Friend WithEvents llblContribVBF As System.Windows.Forms.LinkLabel Friend WithEvents lblArchivage As System.Windows.Forms.Label Friend WithEvents cmdDBToFile As System.Windows.Forms.Button Friend WithEvents llblEMail As System.Windows.Forms.LinkLabel Friend WithEvents lblInfoDBToFile As System.Windows.Forms.Label Friend WithEvents llblMdb As System.Windows.Forms.LinkLabel <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent() Me.components = New System.ComponentModel.Container() Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(frmVBBrainBox)) Me.ToolTip1 = New System.Windows.Forms.ToolTip(Me.components) Me.chkFaitsJustes = New System.Windows.Forms.CheckBox() Me.lbSessions = New System.Windows.Forms.ListBox() Me.tcEntrees = New System.Windows.Forms.TabControl() Me.tpBD = New System.Windows.Forms.TabPage() Me.cmdExporter = New System.Windows.Forms.Button() Me.cmdArchivage = New System.Windows.Forms.Button() Me.lbApplications = New System.Windows.Forms.ListBox() Me.tpFichiers = New System.Windows.Forms.TabPage() Me.lblRegles = New System.Windows.Forms.Label() Me.lbFichiersBR = New System.Windows.Forms.ListBox() Me.lbFichiersBF = New System.Windows.Forms.ListBox() Me.lblBaseFaits = New System.Windows.Forms.Label() Me.lblDico = New System.Windows.Forms.Label() Me.lbFichiersDico = New System.Windows.Forms.ListBox() Me.tcExpertises = New System.Windows.Forms.TabControl() Me.tpVariables = New System.Windows.Forms.TabPage() Me.dgVariables = New System.Windows.Forms.DataGrid() Me.tpRegles = New System.Windows.Forms.TabPage() Me.dgRegles = New System.Windows.Forms.DataGrid() Me.tpReglesListe = New System.Windows.Forms.TabPage() Me.lbReglesListe = New System.Windows.Forms.ListBox() Me.tpFaits = New System.Windows.Forms.TabPage() Me.dgFaits = New System.Windows.Forms.DataGrid() Me.tpExpertises = New System.Windows.Forms.TabPage() Me.lbFaitsJustes = New System.Windows.Forms.ListBox() Me.lbFaits = New System.Windows.Forms.ListBox() Me.cmdRapport = New System.Windows.Forms.Button() Me.lbConclusions = New System.Windows.Forms.ListBox() Me.lblExpertise = New System.Windows.Forms.Label() Me.lblFaitsInitiaux = New System.Windows.Forms.Label() Me.tpBilanSession = New System.Windows.Forms.TabPage() Me.dgBilanSession = New System.Windows.Forms.DataGrid() Me.tpAPropos = New System.Windows.Forms.TabPage() Me.llblMdb = New System.Windows.Forms.LinkLabel() Me.lblInfoDBToFile = New System.Windows.Forms.Label() Me.llblEMail = New System.Windows.Forms.LinkLabel() Me.cmdDBToFile = New System.Windows.Forms.Button() Me.lblArchivage = New System.Windows.Forms.Label() Me.llblContribVBF = New System.Windows.Forms.LinkLabel() Me.llblVBBrainBox = New System.Windows.Forms.LinkLabel() Me.llblORS = New System.Windows.Forms.LinkLabel() Me.lblVBBrainBox = New System.Windows.Forms.Label() Me.cmdAPropos = New System.Windows.Forms.Button() Me.llblVBBrainBoxEnLigne = New System.Windows.Forms.LinkLabel() Me.lblSessions = New System.Windows.Forms.Label() Me.tcEntrees.SuspendLayout() Me.tpBD.SuspendLayout() Me.tpFichiers.SuspendLayout() Me.tcExpertises.SuspendLayout() Me.tpVariables.SuspendLayout() CType(Me.dgVariables, System.ComponentModel.ISupportInitialize).BeginInit() Me.tpRegles.SuspendLayout() CType(Me.dgRegles, System.ComponentModel.ISupportInitialize).BeginInit() Me.tpReglesListe.SuspendLayout() Me.tpFaits.SuspendLayout() CType(Me.dgFaits, System.ComponentModel.ISupportInitialize).BeginInit() Me.tpExpertises.SuspendLayout() Me.tpBilanSession.SuspendLayout() CType(Me.dgBilanSession, System.ComponentModel.ISupportInitialize).BeginInit() Me.tpAPropos.SuspendLayout() Me.SuspendLayout() ' 'chkFaitsJustes ' Me.chkFaitsJustes.Checked = True Me.chkFaitsJustes.CheckState = System.Windows.Forms.CheckState.Checked Me.chkFaitsJustes.Location = New System.Drawing.Point(112, 16) Me.chkFaitsJustes.Name = "chkFaitsJustes" Me.chkFaitsJustes.Size = New System.Drawing.Size(56, 16) Me.chkFaitsJustes.TabIndex = 19 Me.chkFaitsJustes.Text = "Vrais" Me.ToolTip1.SetToolTip(Me.chkFaitsJustes, "Afficher seulement les faits initiaux Vrais ou bien définis autre que Faux") ' 'lbSessions ' Me.lbSessions.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) Me.lbSessions.BackColor = System.Drawing.SystemColors.Window Me.lbSessions.BorderStyle = System.Windows.Forms.BorderStyle.FixedSingle Me.lbSessions.Cursor = System.Windows.Forms.Cursors.Default Me.lbSessions.Enabled = False Me.lbSessions.ForeColor = System.Drawing.SystemColors.WindowText Me.lbSessions.Location = New System.Drawing.Point(8, 280) Me.lbSessions.Name = "lbSessions" Me.lbSessions.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lbSessions.Size = New System.Drawing.Size(168, 210) Me.lbSessions.TabIndex = 4 Me.ToolTip1.SetToolTip(Me.lbSessions, "Liste des sessions expertisables") ' 'tcEntrees ' Me.tcEntrees.Controls.AddRange(New System.Windows.Forms.Control() {Me.tpBD, Me.tpFichiers}) Me.tcEntrees.Location = New System.Drawing.Point(8, 8) Me.tcEntrees.Name = "tcEntrees" Me.tcEntrees.SelectedIndex = 0 Me.tcEntrees.Size = New System.Drawing.Size(168, 248) Me.tcEntrees.TabIndex = 21 Me.ToolTip1.SetToolTip(Me.tcEntrees, "Sélection de la source des applications") ' 'tpBD ' Me.tpBD.Controls.AddRange(New System.Windows.Forms.Control() {Me.cmdExporter, Me.cmdArchivage, Me.lbApplications}) Me.tpBD.Location = New System.Drawing.Point(4, 22) Me.tpBD.Name = "tpBD" Me.tpBD.Size = New System.Drawing.Size(160, 222) Me.tpBD.TabIndex = 1 Me.tpBD.Text = "Base de données" ' 'cmdExporter ' Me.cmdExporter.Enabled = False Me.cmdExporter.Location = New System.Drawing.Point(88, 192) Me.cmdExporter.Name = "cmdExporter" Me.cmdExporter.Size = New System.Drawing.Size(64, 24) Me.cmdExporter.TabIndex = 23 Me.cmdExporter.Text = "Exporter" Me.ToolTip1.SetToolTip(Me.cmdExporter, "Exporter l'application sélectionnée en fichiers Turbo-Expert 1.2") ' 'cmdArchivage ' Me.cmdArchivage.Location = New System.Drawing.Point(8, 192) Me.cmdArchivage.Name = "cmdArchivage" Me.cmdArchivage.Size = New System.Drawing.Size(64, 24) Me.cmdArchivage.TabIndex = 22 Me.cmdArchivage.Text = "Archivage" Me.ToolTip1.SetToolTip(Me.cmdArchivage, "Sauver l'application sélectionnée ou bien toutes les applications dans un fichier" & _ " d'archive, ou bien importer une archive") ' 'lbApplications ' Me.lbApplications.Location = New System.Drawing.Point(8, 8) Me.lbApplications.Name = "lbApplications" Me.lbApplications.Size = New System.Drawing.Size(144, 173) Me.lbApplications.TabIndex = 21 Me.ToolTip1.SetToolTip(Me.lbApplications, "Liste des applications de la base de données VBBrainBox.mdb") ' 'tpFichiers ' Me.tpFichiers.Controls.AddRange(New System.Windows.Forms.Control() {Me.lblRegles, Me.lbFichiersBR, Me.lbFichiersBF, Me.lblBaseFaits, Me.lblDico, Me.lbFichiersDico}) Me.tpFichiers.Location = New System.Drawing.Point(4, 22) Me.tpFichiers.Name = "tpFichiers" Me.tpFichiers.Size = New System.Drawing.Size(160, 222) Me.tpFichiers.TabIndex = 0 Me.tpFichiers.Text = "Fichiers" ' 'lblRegles ' Me.lblRegles.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblRegles.Cursor = System.Windows.Forms.Cursors.Default Me.lblRegles.ForeColor = System.Drawing.SystemColors.WindowText Me.lblRegles.Location = New System.Drawing.Point(8, 80) Me.lblRegles.Name = "lblRegles" Me.lblRegles.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblRegles.Size = New System.Drawing.Size(137, 16) Me.lblRegles.TabIndex = 28 Me.lblRegles.Text = "Base de règles :" ' 'lbFichiersBR ' Me.lbFichiersBR.Enabled = False Me.lbFichiersBR.Location = New System.Drawing.Point(8, 96) Me.lbFichiersBR.Name = "lbFichiersBR" Me.lbFichiersBR.Size = New System.Drawing.Size(144, 43) Me.lbFichiersBR.Sorted = True Me.lbFichiersBR.TabIndex = 27 ' 'lbFichiersBF ' Me.lbFichiersBF.Enabled = False Me.lbFichiersBF.Location = New System.Drawing.Point(8, 168) Me.lbFichiersBF.Name = "lbFichiersBF" Me.lbFichiersBF.Size = New System.Drawing.Size(144, 43) Me.lbFichiersBF.Sorted = True Me.lbFichiersBF.TabIndex = 26 ' 'lblBaseFaits ' Me.lblBaseFaits.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblBaseFaits.Cursor = System.Windows.Forms.Cursors.Default Me.lblBaseFaits.ForeColor = System.Drawing.SystemColors.WindowText Me.lblBaseFaits.Location = New System.Drawing.Point(8, 152) Me.lblBaseFaits.Name = "lblBaseFaits" Me.lblBaseFaits.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblBaseFaits.Size = New System.Drawing.Size(137, 16) Me.lblBaseFaits.TabIndex = 25 Me.lblBaseFaits.Text = "Base de faits :" ' 'lblDico ' Me.lblDico.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblDico.Cursor = System.Windows.Forms.Cursors.Default Me.lblDico.ForeColor = System.Drawing.SystemColors.WindowText Me.lblDico.Location = New System.Drawing.Point(8, 8) Me.lblDico.Name = "lblDico" Me.lblDico.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblDico.Size = New System.Drawing.Size(137, 16) Me.lblDico.TabIndex = 24 Me.lblDico.Text = "Dico des variables :" ' 'lbFichiersDico ' Me.lbFichiersDico.Location = New System.Drawing.Point(8, 24) Me.lbFichiersDico.Name = "lbFichiersDico" Me.lbFichiersDico.Size = New System.Drawing.Size(144, 43) Me.lbFichiersDico.Sorted = True Me.lbFichiersDico.TabIndex = 23 ' 'tcExpertises ' Me.tcExpertises.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.tcExpertises.Controls.AddRange(New System.Windows.Forms.Control() {Me.tpVariables, Me.tpRegles, Me.tpReglesListe, Me.tpFaits, Me.tpExpertises, Me.tpBilanSession, Me.tpAPropos}) Me.tcExpertises.Location = New System.Drawing.Point(184, 8) Me.tcExpertises.Name = "tcExpertises" Me.tcExpertises.SelectedIndex = 0 Me.tcExpertises.Size = New System.Drawing.Size(582, 490) Me.tcExpertises.TabIndex = 28 Me.ToolTip1.SetToolTip(Me.tcExpertises, "Présentation des données de l'application") ' 'tpVariables ' Me.tpVariables.Controls.AddRange(New System.Windows.Forms.Control() {Me.dgVariables}) Me.tpVariables.Location = New System.Drawing.Point(4, 22) Me.tpVariables.Name = "tpVariables" Me.tpVariables.Size = New System.Drawing.Size(574, 464) Me.tpVariables.TabIndex = 4 Me.tpVariables.Text = "Variables" ' 'dgVariables ' Me.dgVariables.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.dgVariables.DataMember = "" Me.dgVariables.HeaderForeColor = System.Drawing.SystemColors.ControlText Me.dgVariables.Location = New System.Drawing.Point(8, 8) Me.dgVariables.Name = "dgVariables" Me.dgVariables.ReadOnly = True Me.dgVariables.Size = New System.Drawing.Size(558, 450) Me.dgVariables.TabIndex = 0 ' 'tpRegles ' Me.tpRegles.Controls.AddRange(New System.Windows.Forms.Control() {Me.dgRegles}) Me.tpRegles.Location = New System.Drawing.Point(4, 22) Me.tpRegles.Name = "tpRegles" Me.tpRegles.Size = New System.Drawing.Size(574, 464) Me.tpRegles.TabIndex = 1 Me.tpRegles.Text = "Règles (tableau)" ' 'dgRegles ' Me.dgRegles.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.dgRegles.DataMember = "" Me.dgRegles.HeaderForeColor = System.Drawing.SystemColors.ControlText Me.dgRegles.Location = New System.Drawing.Point(8, 8) Me.dgRegles.Name = "dgRegles" Me.dgRegles.ReadOnly = True Me.dgRegles.Size = New System.Drawing.Size(558, 450) Me.dgRegles.TabIndex = 0 ' 'tpReglesListe ' Me.tpReglesListe.Controls.AddRange(New System.Windows.Forms.Control() {Me.lbReglesListe}) Me.tpReglesListe.Location = New System.Drawing.Point(4, 22) Me.tpReglesListe.Name = "tpReglesListe" Me.tpReglesListe.Size = New System.Drawing.Size(574, 464) Me.tpReglesListe.TabIndex = 3 Me.tpReglesListe.Text = "Règles (liste)" ' 'lbReglesListe ' Me.lbReglesListe.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.lbReglesListe.Location = New System.Drawing.Point(8, 8) Me.lbReglesListe.Name = "lbReglesListe" Me.lbReglesListe.Size = New System.Drawing.Size(558, 433) Me.lbReglesListe.TabIndex = 0 ' 'tpFaits ' Me.tpFaits.Controls.AddRange(New System.Windows.Forms.Control() {Me.dgFaits}) Me.tpFaits.Location = New System.Drawing.Point(4, 22) Me.tpFaits.Name = "tpFaits" Me.tpFaits.Size = New System.Drawing.Size(574, 464) Me.tpFaits.TabIndex = 0 Me.tpFaits.Text = "Faits" ' 'dgFaits ' Me.dgFaits.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.dgFaits.DataMember = "" Me.dgFaits.HeaderForeColor = System.Drawing.SystemColors.ControlText Me.dgFaits.Location = New System.Drawing.Point(8, 8) Me.dgFaits.Name = "dgFaits" Me.dgFaits.ReadOnly = True Me.dgFaits.Size = New System.Drawing.Size(558, 450) Me.dgFaits.TabIndex = 28 ' 'tpExpertises ' Me.tpExpertises.Controls.AddRange(New System.Windows.Forms.Control() {Me.chkFaitsJustes, Me.lbFaitsJustes, Me.lbFaits, Me.cmdRapport, Me.lbConclusions, Me.lblExpertise, Me.lblFaitsInitiaux}) Me.tpExpertises.Location = New System.Drawing.Point(4, 22) Me.tpExpertises.Name = "tpExpertises" Me.tpExpertises.Size = New System.Drawing.Size(574, 464) Me.tpExpertises.TabIndex = 2 Me.tpExpertises.Text = "Expertises" ' 'lbFaitsJustes ' Me.lbFaitsJustes.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) Me.lbFaitsJustes.BackColor = System.Drawing.SystemColors.Window Me.lbFaitsJustes.Cursor = System.Windows.Forms.Cursors.Default Me.lbFaitsJustes.ForeColor = System.Drawing.SystemColors.WindowText Me.lbFaitsJustes.Location = New System.Drawing.Point(8, 40) Me.lbFaitsJustes.Name = "lbFaitsJustes" Me.lbFaitsJustes.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lbFaitsJustes.Size = New System.Drawing.Size(175, 407) Me.lbFaitsJustes.TabIndex = 18 ' 'lbFaits ' Me.lbFaits.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) Me.lbFaits.BackColor = System.Drawing.SystemColors.Window Me.lbFaits.Cursor = System.Windows.Forms.Cursors.Default Me.lbFaits.ForeColor = System.Drawing.SystemColors.WindowText Me.lbFaits.Location = New System.Drawing.Point(8, 40) Me.lbFaits.Name = "lbFaits" Me.lbFaits.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lbFaits.Size = New System.Drawing.Size(175, 407) Me.lbFaits.TabIndex = 17 Me.lbFaits.Visible = False ' 'cmdRapport ' Me.cmdRapport.Anchor = (System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Right) Me.cmdRapport.BackColor = System.Drawing.SystemColors.Control Me.cmdRapport.Cursor = System.Windows.Forms.Cursors.Default Me.cmdRapport.Enabled = False Me.cmdRapport.ForeColor = System.Drawing.SystemColors.ControlText Me.cmdRapport.Location = New System.Drawing.Point(462, 8) Me.cmdRapport.Name = "cmdRapport" Me.cmdRapport.RightToLeft = System.Windows.Forms.RightToLeft.No Me.cmdRapport.Size = New System.Drawing.Size(104, 24) Me.cmdRapport.TabIndex = 15 Me.cmdRapport.Text = "Créer Rapport.txt" Me.ToolTip1.SetToolTip(Me.cmdRapport, "Créer un fichier Rapport.txt avec les conclusions obtenues") ' 'lbConclusions ' Me.lbConclusions.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.lbConclusions.BackColor = System.Drawing.Color.LightCoral Me.lbConclusions.Cursor = System.Windows.Forms.Cursors.Default Me.lbConclusions.ForeColor = System.Drawing.Color.Black Me.lbConclusions.Location = New System.Drawing.Point(192, 40) Me.lbConclusions.Name = "lbConclusions" Me.lbConclusions.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lbConclusions.Size = New System.Drawing.Size(376, 407) Me.lbConclusions.TabIndex = 13 ' 'lblExpertise ' Me.lblExpertise.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblExpertise.Cursor = System.Windows.Forms.Cursors.Default Me.lblExpertise.ForeColor = System.Drawing.SystemColors.ControlText Me.lblExpertise.Location = New System.Drawing.Point(192, 16) Me.lblExpertise.Name = "lblExpertise" Me.lblExpertise.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblExpertise.Size = New System.Drawing.Size(200, 16) Me.lblExpertise.TabIndex = 14 Me.lblExpertise.Text = "Rapport d'expertise :" ' 'lblFaitsInitiaux ' Me.lblFaitsInitiaux.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblFaitsInitiaux.Cursor = System.Windows.Forms.Cursors.Default Me.lblFaitsInitiaux.ForeColor = System.Drawing.SystemColors.WindowText Me.lblFaitsInitiaux.Location = New System.Drawing.Point(8, 16) Me.lblFaitsInitiaux.Name = "lblFaitsInitiaux" Me.lblFaitsInitiaux.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblFaitsInitiaux.Size = New System.Drawing.Size(72, 16) Me.lblFaitsInitiaux.TabIndex = 12 Me.lblFaitsInitiaux.Text = "Faits initiaux" ' 'tpBilanSession ' Me.tpBilanSession.Controls.AddRange(New System.Windows.Forms.Control() {Me.dgBilanSession}) Me.tpBilanSession.Location = New System.Drawing.Point(4, 22) Me.tpBilanSession.Name = "tpBilanSession" Me.tpBilanSession.Size = New System.Drawing.Size(574, 464) Me.tpBilanSession.TabIndex = 5 Me.tpBilanSession.Text = "Bilan" ' 'dgBilanSession ' Me.dgBilanSession.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.dgBilanSession.DataMember = "" Me.dgBilanSession.HeaderForeColor = System.Drawing.SystemColors.ControlText Me.dgBilanSession.Location = New System.Drawing.Point(8, 8) Me.dgBilanSession.Name = "dgBilanSession" Me.dgBilanSession.ReadOnly = True Me.dgBilanSession.Size = New System.Drawing.Size(558, 450) Me.dgBilanSession.TabIndex = 0 ' 'tpAPropos ' Me.tpAPropos.Controls.AddRange(New System.Windows.Forms.Control() {Me.llblMdb, Me.lblInfoDBToFile, Me.llblEMail, Me.cmdDBToFile, Me.lblArchivage, Me.llblContribVBF, Me.llblVBBrainBox, Me.llblORS, Me.lblVBBrainBox, Me.cmdAPropos, Me.llblVBBrainBoxEnLigne}) Me.tpAPropos.Location = New System.Drawing.Point(4, 22) Me.tpAPropos.Name = "tpAPropos" Me.tpAPropos.Size = New System.Drawing.Size(574, 464) Me.tpAPropos.TabIndex = 6 Me.tpAPropos.Text = "A propos" ' 'llblMdb ' Me.llblMdb.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblMdb.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblMdb.Location = New System.Drawing.Point(23, 96) Me.llblMdb.Name = "llblMdb" Me.llblMdb.Size = New System.Drawing.Size(528, 32) Me.llblMdb.TabIndex = 30 Me.llblMdb.TabStop = True Me.llblMdb.Text = "VBBrainBox.mdb" Me.llblMdb.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblMdb, "Base de données de VBBrainBox pour créer ou modifier des applications") ' 'lblInfoDBToFile ' Me.lblInfoDBToFile.Font = New System.Drawing.Font("Microsoft Sans Serif", 9.75!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.lblInfoDBToFile.Location = New System.Drawing.Point(32, 368) Me.lblInfoDBToFile.Name = "lblInfoDBToFile" Me.lblInfoDBToFile.Size = New System.Drawing.Size(160, 16) Me.lblInfoDBToFile.TabIndex = 29 Me.lblInfoDBToFile.Text = "Utilitaire pour l'archivage :" ' 'llblEMail ' Me.llblEMail.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblEMail.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblEMail.Location = New System.Drawing.Point(24, 296) Me.llblEMail.Name = "llblEMail" Me.llblEMail.Size = New System.Drawing.Size(528, 32) Me.llblEMail.TabIndex = 28 Me.llblEMail.TabStop = True Me.llblEMail.Text = "mailto:Patrice.Dargenton@Free.Fr" Me.llblEMail.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblEMail, "Vos suggestions sont les bienvenues !") ' 'cmdDBToFile ' Me.cmdDBToFile.Location = New System.Drawing.Point(24, 392) Me.cmdDBToFile.Name = "cmdDBToFile" Me.cmdDBToFile.Size = New System.Drawing.Size(176, 32) Me.cmdDBToFile.TabIndex = 27 Me.cmdDBToFile.Text = "?" Me.ToolTip1.SetToolTip(Me.cmdDBToFile, "Inscrire/désinscrire le contrôle DBToFile.ocx dans la base de registre (inutile s" & _ "i vous avez installé le logiciel via le package .msi)") ' 'lblArchivage ' Me.lblArchivage.Font = New System.Drawing.Font("Microsoft Sans Serif", 9.75!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.lblArchivage.Location = New System.Drawing.Point(216, 400) Me.lblArchivage.Name = "lblArchivage" Me.lblArchivage.Size = New System.Drawing.Size(336, 24) Me.lblArchivage.TabIndex = 26 Me.lblArchivage.Text = "Enregistrement de DBTofIle.ocx" ' 'llblContribVBF ' Me.llblContribVBF.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblContribVBF.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblContribVBF.Location = New System.Drawing.Point(24, 216) Me.llblContribVBF.Name = "llblContribVBF" Me.llblContribVBF.Size = New System.Drawing.Size(528, 32) Me.llblContribVBF.TabIndex = 25 Me.llblContribVBF.TabStop = True Me.llblContribVBF.Text = "Mes contributions sur VBFrance.com" Me.llblContribVBF.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblContribVBF, "Mes contributions en VB .NET et VB6 sur VBFrance.com, la plus grande communauté f" & _ "rancophone de partage de code source en Visual Basic") ' 'llblVBBrainBox ' Me.llblVBBrainBox.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblVBBrainBox.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblVBBrainBox.Location = New System.Drawing.Point(24, 136) Me.llblVBBrainBox.Name = "llblVBBrainBox" Me.llblVBBrainBox.Size = New System.Drawing.Size(528, 32) Me.llblVBBrainBox.TabIndex = 24 Me.llblVBBrainBox.TabStop = True Me.llblVBBrainBox.Text = "Documentation : VBBrainBox.html" Me.llblVBBrainBox.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblVBBrainBox, "Documentation locale de VBBrainBox") ' 'llblORS ' Me.llblORS.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblORS.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblORS.Location = New System.Drawing.Point(24, 256) Me.llblORS.Name = "llblORS" Me.llblORS.Size = New System.Drawing.Size(528, 32) Me.llblORS.TabIndex = 23 Me.llblORS.TabStop = True Me.llblORS.Text = "http://patrice.dargenton.free.fr/index.html" Me.llblORS.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblORS, "ORS Production : mon site perso (que c'est moi qui l'ai fait)") ' 'lblVBBrainBox ' Me.lblVBBrainBox.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.lblVBBrainBox.Font = New System.Drawing.Font("Courier New", 18.0!, System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.lblVBBrainBox.Location = New System.Drawing.Point(88, 24) Me.lblVBBrainBox.Name = "lblVBBrainBox" Me.lblVBBrainBox.Size = New System.Drawing.Size(240, 32) Me.lblVBBrainBox.TabIndex = 22 Me.lblVBBrainBox.Text = "VBBrainBox 1.0" Me.lblVBBrainBox.TextAlign = System.Drawing.ContentAlignment.MiddleCenter ' 'cmdAPropos ' Me.cmdAPropos.Image = CType(resources.GetObject("cmdAPropos.Image"), System.Drawing.Bitmap) Me.cmdAPropos.Location = New System.Drawing.Point(16, 16) Me.cmdAPropos.Name = "cmdAPropos" Me.cmdAPropos.Size = New System.Drawing.Size(56, 40) Me.cmdAPropos.TabIndex = 21 Me.ToolTip1.SetToolTip(Me.cmdAPropos, "A propos...") ' 'llblVBBrainBoxEnLigne ' Me.llblVBBrainBoxEnLigne.Anchor = ((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.llblVBBrainBoxEnLigne.Font = New System.Drawing.Font("Microsoft Sans Serif", 12.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.llblVBBrainBoxEnLigne.Location = New System.Drawing.Point(24, 176) Me.llblVBBrainBoxEnLigne.Name = "llblVBBrainBoxEnLigne" Me.llblVBBrainBoxEnLigne.Size = New System.Drawing.Size(528, 32) Me.llblVBBrainBoxEnLigne.TabIndex = 0 Me.llblVBBrainBoxEnLigne.TabStop = True Me.llblVBBrainBoxEnLigne.Text = "http://patrice.dargenton.free.fr/ia/vbbrainbox/index.html" Me.llblVBBrainBoxEnLigne.TextAlign = System.Drawing.ContentAlignment.MiddleCenter Me.ToolTip1.SetToolTip(Me.llblVBBrainBoxEnLigne, "Documentation en ligne de VBBrainBox") ' 'lblSessions ' Me.lblSessions.BackColor = System.Drawing.SystemColors.ActiveBorder Me.lblSessions.Cursor = System.Windows.Forms.Cursors.Default Me.lblSessions.ForeColor = System.Drawing.SystemColors.WindowText Me.lblSessions.Location = New System.Drawing.Point(8, 264) Me.lblSessions.Name = "lblSessions" Me.lblSessions.RightToLeft = System.Windows.Forms.RightToLeft.No Me.lblSessions.Size = New System.Drawing.Size(160, 17) Me.lblSessions.TabIndex = 5 Me.lblSessions.Text = "Sessions :" ' 'frmVBBrainBox ' Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13) Me.BackColor = System.Drawing.SystemColors.ActiveBorder Me.ClientSize = New System.Drawing.Size(768, 501) Me.Controls.AddRange(New System.Windows.Forms.Control() {Me.tcExpertises, Me.tcEntrees, Me.lbSessions, Me.lblSessions}) Me.ForeColor = System.Drawing.SystemColors.WindowText Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon) Me.Location = New System.Drawing.Point(40, 64) Me.Name = "frmVBBrainBox" Me.Text = "VBBrainBox" Me.tcEntrees.ResumeLayout(False) Me.tpBD.ResumeLayout(False) Me.tpFichiers.ResumeLayout(False) Me.tcExpertises.ResumeLayout(False) Me.tpVariables.ResumeLayout(False) CType(Me.dgVariables, System.ComponentModel.ISupportInitialize).EndInit() Me.tpRegles.ResumeLayout(False) CType(Me.dgRegles, System.ComponentModel.ISupportInitialize).EndInit() Me.tpReglesListe.ResumeLayout(False) Me.tpFaits.ResumeLayout(False) CType(Me.dgFaits, System.ComponentModel.ISupportInitialize).EndInit() Me.tpExpertises.ResumeLayout(False) Me.tpBilanSession.ResumeLayout(False) CType(Me.dgBilanSession, System.ComponentModel.ISupportInitialize).EndInit() Me.tpAPropos.ResumeLayout(False) Me.ResumeLayout(False) End Sub #End Region #Region "Initialisation" Private Sub frmTExpert_Load(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles MyBase.Load Initialiser(iTypeInitTout) m_bInit = True Me.tcEntrees.SelectedIndex = iPageFichiers ' Pour générer un év. changed Me.tcEntrees.SelectedIndex = iPageBD Me.llblVBBrainBoxEnLigne.Links.Add(0, Me.llblVBBrainBoxEnLigne.Text.Length, _ "http://patrice.dargenton.free.fr/ia/vbbrainbox/index.html") Me.llblVBBrainBox.Links.Add(0, Me.llblVBBrainBox.Text.Length, _ "file://" & Application.StartupPath & "\VBBrainBox.html") Me.llblMdb.Links.Add(0, Me.llblMdb.Text.Length, _ "file://" & Application.StartupPath & _ clsVBBBox.sRepertoireApplications & "\" & clsVBBBox.sFichierVBBBoxMDB) Me.llblORS.Links.Add(0, Me.llblORS.Text.Length, _ "http://patrice.dargenton.free.fr/index.html") Me.llblContribVBF.Links.Add(0, Me.llblContribVBF.Text.Length, _ "http://codes-sources.commentcamarche.net/profile/user/cs_Patrice99") Me.llblEMail.Links.Add(0, Me.llblContribVBF.Text.Length, _ "mailto:patrice.dargenton@free.fr?subject=VBBrainBox&" & _ "Body=Ton logiciel est vraiment super !") If Not m_bErr Then Me.tcExpertises.SelectedIndex = iPageAPropos clsUtil.JolieTransitionTaDaaa(Me) End Sub Private Sub frmVBBrainBox_Closing(ByVal sender As Object, _ ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing clsUtil.JolieTransitionTaDaaa(Me, bFermeture:=True) End Sub Private Sub Initialiser(ByVal iTypeInit%) ' Initialisation d'une expertise Me.cmdRapport.Enabled = False Me.lbFaits.Items.Clear() Me.lbFaitsJustes.Items.Clear() Me.lbConclusions.Items.Clear() Me.lbConclusions.BackColor = couleurInit If iTypeInit = iTypeInitExpertise Then Exit Sub ' Initialisation des sessions et des fichiers BF Me.lbSessions.Enabled = False Me.lbSessions.Items.Clear() Me.dgFaits.DataSource = Nothing Me.dgBilanSession.DataSource = Nothing 'If iTypeInit = iTypeInitSessions Then Exit Sub If iTypeInit = iTypeInitBF Then Exit Sub ' Initialisation des fichiers BR Me.lbFichiersBF.Enabled = False ' Ne pas sélectionner un fichier BF If Me.lbFichiersBF.SelectedIndex >= 0 Then _ Me.lbFichiersBF.SetSelected(Me.lbFichiersBF.SelectedIndex, False) Me.lbReglesListe.Items.Clear() Me.lbReglesListe.BackColor = couleurInit Me.dgRegles.DataSource = Nothing If iTypeInit = iTypeInitBR Then Exit Sub ' Initialisation des dictionnaires Me.lbFichiersBR.Enabled = False ' Ne pas sélectionner un fichier BR If Me.lbFichiersBR.SelectedIndex >= 0 Then _ Me.lbFichiersBR.SetSelected(Me.lbFichiersBR.SelectedIndex, False) Me.dgVariables.DataSource = Nothing Me.dgVariables.BackColor = couleurInit If iTypeInit = iTypeInitDico Then Exit Sub ' Initialisation d'une application ' Ne pas sélectionner un fichier dico If Me.lbFichiersDico.SelectedIndex >= 0 Then _ Me.lbFichiersDico.SetSelected(Me.lbFichiersDico.SelectedIndex, False) m_oSE.InitialiserApplication() If iTypeInit = iTypeInitApplication Then Exit Sub ' Initialisation des applications : de tout ! Me.cmdExporter.Enabled = False ' Ne pas sélectionner une application If Me.lbApplications.SelectedIndex >= 0 Then _ Me.lbApplications.SetSelected(Me.lbApplications.SelectedIndex, False) 'If iTypeInit = iTypeInitTout Then Exit Sub End Sub #End Region #Region "Gestion du mode base de données ou fichier" Private Sub tcEntrees_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles tcEntrees.SelectedIndexChanged m_bConnexion = False If Not m_bInit Then Exit Sub Initialiser(iTypeInitTout) If Me.tcEntrees.SelectedIndex = iPageFichiers Then m_oSE.RemplirListesFichiers(Me.lbFichiersDico, _ Me.lbFichiersBR, Me.lbFichiersBF) Else 'If Me.tcEntrees.SelectedIndex = iPageBD Then Cursor.Current = Cursors.WaitCursor If Not m_oSE.bBDVerifierVersion() Then _ AfficherErreurs() : GoTo Fin ' Page base de données selectionnée If Not m_oSE.bBDRemplirApplications(Me.lbApplications) Then _ AfficherErreurs() : GoTo Fin m_bConnexion = True Fin: Cursor.Current = Cursors.Default End If End Sub #End Region #Region "Sélection d'une application" Private Sub lbApplications_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles lbApplications.SelectedIndexChanged If Not m_bInit Then Exit Sub If Not m_bConnexion Then Exit Sub Cursor.Current = Cursors.WaitCursor Initialiser(iTypeInitApplication) If Me.tcExpertises.SelectedIndex >= iPageExpertise Then _ Me.tcExpertises.SelectedIndex = iPageVariables ' Sélection d'une application If Me.lbApplications.SelectedIndex < 0 Then GoTo fin ' Récupération de l'IdApplication Dim obj As Object = Me.lbApplications.Items( _ Me.lbApplications.SelectedIndex) Dim iIdApp% = CInt(CType(obj, DataRowView).Item(0)) If Not m_oSE.bBDChargerDico(iIdApp, Me.dgVariables) Then _ AfficherErreurs() : GoTo fin Me.dgVariables.BackColor = couleurOk If Not m_oSE.bBDRemplirRegles(iIdApp, Me.dgRegles, Me.lbReglesListe) Then _ AfficherErreurs() : GoTo fin Me.lbReglesListe.BackColor = couleurOk If Not m_oSE.bBDRemplirFaits(iIdApp, Me.dgFaits, Me.lbSessions) Then _ AfficherErreurs() : GoTo fin Me.lbSessions.Enabled = True Me.cmdExporter.Enabled = True Me.cmdRapport.Enabled = True ' Activation pour faire le rapport des sessions m_bErr = False Fin: Cursor.Current = Cursors.Default End Sub Private Sub cmdSauverApplication_Click(ByVal sender As Object, _ ByVal e As EventArgs) Handles cmdArchivage.Click m_oSE.ArchivageApplication(Me.lbApplications) GestionDBToFile() End Sub Private Sub cmdExporter_Click(ByVal sender As Object, _ ByVal e As EventArgs) Handles cmdExporter.Click m_oSE.ExporterPourTurboExpert12(Me.lbApplications) End Sub #End Region #Region "Sélection d'un fichier" Private Sub lbFichiersDico_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles lbFichiersDico.SelectedIndexChanged ' Dico des variables de la BR If Me.lbFichiersDico.SelectedIndex < 0 Then Exit Sub ' Répertoire de l'application : Dim sCheminFichier$ = Application.StartupPath & _ ClsVBBBox.sRepertoireApplicationsTxt & "\" & _ Me.lbFichiersDico.Items(Me.lbFichiersDico.SelectedIndex).ToString Initialiser(iTypeInitDico) Me.tcExpertises.SelectedIndex = iPageVariables If Not m_oSE.bChargerDico(sCheminFichier, Me.dgVariables) Then _ AfficherErreurs() : Exit Sub Me.dgVariables.BackColor = couleurOk Me.lbFichiersBR.Enabled = True ' Essayer de sélectionner automatiquement la BR correspondante ' (Ok s'il y a le même nombre de fichiers de chaque type) If Me.lbFichiersBR.Items.Count >= Me.lbFichiersDico.SelectedIndex Then _ Me.lbFichiersBR.SelectedIndex = Me.lbFichiersDico.SelectedIndex End Sub Private Sub lbFichiersBR_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles lbFichiersBR.SelectedIndexChanged If Me.lbFichiersBR.SelectedIndex < 0 Then Exit Sub Dim sCheminFichier$ = Application.StartupPath & _ ClsVBBBox.sRepertoireApplicationsTxt & "\" & _ Me.lbFichiersBR.Items(Me.lbFichiersBR.SelectedIndex).ToString Initialiser(iTypeInitBR) If Not (Me.tcExpertises.SelectedIndex = iPageRegles Or _ Me.tcExpertises.SelectedIndex = iPageReglesListe) Then _ Me.tcExpertises.SelectedIndex = iPageReglesListe If Not m_oSE.bChargerBR(sCheminFichier, Me.lbReglesListe, Me.dgRegles) Then _ AfficherErreurs() : Exit Sub Me.lbReglesListe.BackColor = couleurOk Me.lbFichiersBF.Enabled = True ' Essayer de sélectionner automatiquement la BF correspondante If Me.lbFichiersBF.Items.Count >= Me.lbFichiersBR.SelectedIndex Then _ Me.lbFichiersBF.SelectedIndex = Me.lbFichiersBR.SelectedIndex End Sub Private Sub lbFichiersBF_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles lbFichiersBF.SelectedIndexChanged If Me.lbFichiersBF.SelectedIndex < 0 Then Exit Sub Dim sFichierBF$ = Me.lbFichiersBF.Items( _ Me.lbFichiersBF.SelectedIndex).ToString Initialiser(iTypeInitBF) Me.tcExpertises.SelectedIndex = iPageFaits If Not m_oSE.bRemplirSessions(sFichierBF, Me.lbSessions, Me.dgFaits) Then _ AfficherErreurs() : Exit Sub Me.lbSessions.Enabled = True End Sub #End Region #Region "Expertise" Private Sub lbSessions_SelectedIndexChanged(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles lbSessions.SelectedIndexChanged Expertiser() End Sub Private Sub Expertiser() If Me.tcExpertises.SelectedIndex <> iPageBilan Then _ Me.tcExpertises.SelectedIndex = iPageExpertise Initialiser(iTypeInitExpertise) Dim sApplication$ = sApplicationSelectionnee() Dim sSession$ = Me.lbSessions.Items( _ Me.lbSessions.SelectedIndex).ToString Dim bConclusions, bAvertissements As Boolean If Not m_oSE.bExpertiser(sApplication, sSession, _ Me.lbFaits, Me.lbFaitsJustes, Me.dgBilanSession, _ bConclusions, bAvertissements) Then _ AfficherErreurs() : Exit Sub If bConclusions Then Me.lbConclusions.BackColor = Color.Cyan If bAvertissements Then Me.lbConclusions.BackColor = Color.Beige End If AfficherConclusions() Me.cmdRapport.Enabled = True ' Tjrs actif pour aff les msg d'err End Sub Private Sub cmdRapport_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles cmdRapport.Click Dim iIdApplication% = 0, sApplication$ = "", sSession$ = "" If Me.lbApplications.SelectedIndex >= 0 Then Dim drw As DataRowView = CType(Me.lbApplications.Items( _ Me.lbApplications.SelectedIndex), DataRowView) iIdApplication = CInt(drw.Item(0)) ' Colonne 0 sApplication = sApplicationSelectionnee() End If If Me.lbSessions.SelectedIndex >= 0 Then _ sSession = Me.lbSessions.Items( _ Me.lbSessions.SelectedIndex).ToString() m_oSE.CreerCompteRendu(sNomFichierRapport, _ iIdApplication, sApplication, sSession) End Sub Private Function sApplicationSelectionnee$() Dim sApplication$ = "" If Me.tcEntrees.SelectedIndex = iPageBD Then If Me.lbApplications.SelectedIndex >= 0 Then Dim drw As DataRowView = CType(Me.lbApplications.Items( _ Me.lbApplications.SelectedIndex), DataRowView) sApplication = CStr(drw.Item(1)) ' Colonne 1 End If Else If Me.lbFichiersDico.SelectedIndex >= 0 Then _ sApplication = Me.lbFichiersDico.Items( _ Me.lbFichiersDico.SelectedIndex).ToString() End If sApplicationSelectionnee = sApplication End Function Private Sub chkFaitsJustes_CheckedChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles chkFaitsJustes.CheckedChanged If Me.chkFaitsJustes.Checked Then Me.lbFaits.Visible = False Me.lbFaitsJustes.Visible = True Else Me.lbFaits.Visible = True Me.lbFaitsJustes.Visible = False End If End Sub Private Sub AfficherErreurs() ' Afficher les messages d'erreur Me.lbConclusions.BackColor = couleurErr m_bErr = True Me.tcExpertises.SelectedIndex = iPageExpertise AfficherConclusions() Me.cmdRapport.Enabled = True ' Pour imprimer les msg d'err End Sub Private Sub AfficherConclusions() Dim sItem$ Me.lbConclusions.Items.Clear() Me.lbConclusions.BeginUpdate() For Each sItem In m_oSE.colLireMessages Me.lbConclusions.Items.Add(sItem) Next sItem Me.lbConclusions.EndUpdate() End Sub #End Region #Region "Divers" Private Sub cmdAPropos_Click(ByVal sender As Object, _ ByVal e As EventArgs) Handles cmdAPropos.Click Dim sMsg$ sMsg = "VBBrainBox 1.0 par Patrice Dargenton" & vbLf & vbLf sMsg &= "d'après Turbo-Expert 1.2 pour Windows" & vbLf sMsg &= "(c) Philippe Larvet 1996, 2003" & vbLf & vbLf sMsg &= "Documentation : VBBrainBox.html" MsgBox(sMsg, MsgBoxStyle.Information) End Sub Private Sub llblTous_LinkClicked(ByVal sender As Object, _ ByVal e As LinkLabelLinkClickedEventArgs) _ Handles llblORS.LinkClicked, llblContribVBF.LinkClicked, _ llblVBBrainBox.LinkClicked, llblVBBrainBoxEnLigne.LinkClicked, _ llblEMail.LinkClicked, llblMdb.LinkClicked On Error Resume Next ' Exemple d'erreur : Fichier introuvable Process.Start(e.Link.LinkData.ToString) End Sub Private Sub tcExpertises_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles tcExpertises.SelectedIndexChanged If Me.tcExpertises.SelectedIndex <> iPageAPropos Then Exit Sub GestionDBToFile() End Sub Private Sub GestionDBToFile() Dim sCheminDBToFile$ = Application.StartupPath & _ clsVBBBox.sRepertoireApplications & "\" & clsVBBBox.sFichierDBToFile Dim bModePackage As Boolean = _ (Application.StartupPath.IndexOf("ORS Production") >= 0) If IO.File.Exists(sCheminDBToFile) And Not bModePackage Then Me.cmdDBToFile.Enabled = True Else Me.cmdDBToFile.Enabled = False End If If clsUtil.bCleRegistreExiste(clsVBBBox.sCleRegistreDBToFile) Then Me.lblArchivage.Text = "Le contrôle DBToFile.ocx est inscrit" Me.cmdDBToFile.Text = "Désinscrire DBToFile" Else Me.lblArchivage.Text = "Le contrôle DBToFile.ocx n'est pas inscrit" Me.cmdDBToFile.Text = "Inscrire DBToFile" End If End Sub Private Sub cmdDBToFile_Click(ByVal sender As Object, _ ByVal e As EventArgs) Handles cmdDBToFile.Click Dim sRepertoireDll$ = Application.StartupPath & _ clsVBBBox.sRepertoireApplications If clsUtil.bCleRegistreExiste(clsVBBBox.sCleRegistreDBToFile) Then clsUtil.bEnregistrerDllActiveX(clsVBBBox.sFichierDBToFile, _ sRepertoireDll, bDesenregistrer:=True) Else clsUtil.bEnregistrerDllActiveX(clsVBBBox.sFichierDBToFile, _ sRepertoireDll) End If GestionDBToFile() End Sub #End Region End Class End Namespace VBBrainBox.vb ' VBBrainBox : un système expert d'ordre 0+ en VB .NET ' ---------------------------------------------------- ' ------------------------------------------------------------------- ' Créé à partir de TExpert (Turbo-Expert 1.2 en VB6) : ' (c) Philippe LARVET <ph_larvet@yahoo.fr> Avril 1996. ' Prog "one shot" du 28 mai 96 avec paramètre de ligne de commande ' Version VB6 mai 02, revu en tant que moteur TExpert janvier 03 ' ------------------------------------------------------------------- ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' Version 1.0 du 2/5/2003 ' Documentation : VBBrainBox.html, en ligne : ' http://patrice.dargenton.free.fr/ia/vbbrainbox/index.html ' Fichier VBBrainBox.vb ' --------------------- Option Strict On Option Explicit On Imports System.IO ' Pour StreamWriter Imports System.Data.OleDb ' Pour les requêtes Access avec OleDbConnection Namespace VBBrainBox ' Utile si plusieurs projets sont intégrés Friend Class clsVBBBox #Region "Déclarations et initialisations" ' Dans la version .msi, on shunte le test de la version de la bd : ' ça ne marche pas dans un Windows sans l'IDE !? Private Const m_bVersionMSI As Boolean = True Private Const rVersionBDMin! = 1.0! ' Version min. de la base de données >= 1.0 Private Const rVersionBDMax! = 2.0! ' Version max. compatible : < 2.0 Private m_sConnexion$, m_sRepertoireCourant$ Private m_sCheminBaseMDB$, m_sProvenanceBR$, m_rVersionBD! Private m_oConnexion As OleDbConnection ' Regrouper les connexions ouvertes Private m_bModeBD As Boolean ' Mode base de données ' Collection d'avertissements Private m_colAvert As New Specialized.StringCollection() Private m_colCR As New Specialized.StringCollection() Private m_colSessions As New Collection() ' Collection de sessions à expertiser Private m_oDico As New clsDico(m_colCR) Private m_oBR As New clsBR(m_oDico, m_colCR) Private m_oBF As New clsBF(m_oBR, m_oDico, m_colCR) Private m_iNbAvertissements% ' Friend = Public restreint au projet Friend Structure TConfig ' Configuration de VBBrainBox ' Booléen pour autoriser le changement de valeur ' d'un fait défini par défaut (voir documentation) Dim bLogiqueNonMonotone As Boolean Dim bAutoriserReglesContradictoires As Boolean Dim bLogiqueFloue As Boolean Dim bLogiqueFloueInterpretee As Boolean End Structure Private m_config As TConfig Friend Const rCodeFiabIndefini! = -2 ' Logique floue désactivée Friend Const sFormatFiab$ = "0.##" Private Const sFormatFiabRapport$ = "0.####" Private Const sSeparation$ = _ "------------------------------------------------------------" Private Const sFinFichierTurboExpert$ = _ "============================================================" ' Pour l'archivage de VBBrainBox Friend Const sFichierDBToFile$ = "DBToFile.ocx" Friend Const sCleRegistreDBToFile$ = _ "CLSID\{A8EEB80D-9749-11D3-8214-E23042430D34}" Friend Const sPageArchivage$ = "VBBrainBoxBkUp.html" Friend Const sConf_bAutoriserReglesContr$ = _ "Config_bAutoriserReglesContradictoires" Friend Const sConf_bLogiqueNonMonotone$ = "Config_bLogiqueNonMonotone" Friend Const sConf_bLogiqueFloue$ = "Config_bLogiqueFloue" Friend Const sConf_bLogiqueFloueInterpretee$ = _ "Config_bLogiqueFloueInterpretee" Friend Const sFichierVBBBoxMDB$ = "VBBrainBox.mdb" Friend Const sRepertoireApplications$ = "\Applications" Friend Const sRepertoireApplicationsTxt$ = "\Applications\ModeFichiersTxt" Private Const sValFaitInitialDefaut$ = clsUtil.sVrai ' Autre possibilité : ClsUtil.sFaux Friend Const sValFaitInitialDefautModeFichier$ = "" Friend Const sValFaitIntermediaireDefautModeFichier$ = "" ' Autre possibilité : ClsUtil.sVrai Friend Const sValConfigDefautModeFichier$ = "" ' Indéfini Private Const sValHypRegleDef$ = clsUtil.sVrai Private Const sOperateurRegleDef$ = "=" 'Private typeBooleen As Type = Type.GetType("System.Boolean") Private typeBooleen As Type = GetType(System.Boolean) Private Const sSQLVersion$ = "SELECT Version FROM Version" Private Const sSQLApplications$ = _ "SELECT IdApplication, Application FROM Application ORDER BY Application" Private Const sChpApplication$ = "Application" Private Const sSQLApplicationsDescription$ = _ "SELECT IdApplication, Application, Description, Auteur," & _ " AuteurEMail, AuteurWeb, Date, Version, Remarque FROM Application" & _ " WHERE IdApplication = ?" Private Const iColRqAppIdApp% = 0 Private Const iColRqAppApp% = 1 Private Const iColRqAppDescr% = 2 Private Const iColRqAppAuteur% = 3 Private Const iColRqAppEMail% = 4 Private Const iColRqAppWeb% = 5 Private Const iColRqAppDate% = 6 Private Const iColRqAppVers% = 7 Private Const iColRqAppRem% = 8 Private Const sSQLDico$ = "SELECT Variable, ValeurParDef, Constante," & _ " Fiab, bConfiguration as bConfig, bConstante as bConst," & _ " bIntermediaire AS bInterm, Description" & _ " FROM RqVariables WHERE IdApplication = ?" Private Const iColRqDicoVar% = 0 Private Const iColRqDicoValDef% = 1 Private Const iColRqDicoConst% = 2 Private Const iColRqDicoFiab% = 3 Private Const iColRqDicobConfig% = 4 Private Const iColRqDicobConst% = 5 Private Const iColRqDicobInterm% = 6 Private Const iColRqDicoDescr% = 7 Private Const sChpVar$ = "Variable" Private Const sChpValDef$ = "ValeurParDef" Private Const sChpConst$ = "Constante" Private Const sChpFiab$ = "Fiab" Private Const sChpbConfig$ = "bConfig" Private Const sChpbConst$ = "bConst" Private Const sChpbInterm$ = "bInterm" Private Const sSQLRegles$ = _ "SELECT Regle, Fiab, Variable, Op, Val, Variable2, bConcl, bInterm" & _ " FROM RqRegles WHERE IdApplication = ?" & _ " ORDER BY Regle, bConcl DESC, Variable" Private Const iColRqReglRegle% = 0 Private Const iColRqReglFiab% = 1 Private Const iColRqReglVar% = 2 Private Const iColRqReglOp% = 3 Private Const iColRqReglVal% = 4 Private Const iColRqReglVar2% = 5 Private Const iColRqReglbConcl% = 6 Private Const iColRqReglbInterm% = 7 Private Const sChpRegle$ = "Regle" Private Const sChpOp$ = "Op" Private Const sChpVal$ = "Val" Private Const sChpVar2$ = "Variable2" Private Const sChpbConcl$ = "bConcl" Private Const sSQLReglesDescription$ = _ "SELECT Regle, Description, Origine, Remarque, Fiabilite, Date" & _ " FROM Regle WHERE IdApplication = ? ORDER BY Regle" Private Const iColRqReglDRegle% = 0 Private Const iColRqReglDDescr% = 1 Private Const iColRqReglDOrig% = 2 Private Const iColRqReglDRem% = 3 Private Const iColRqReglDFiab% = 4 Private Const iColRqReglDDate% = 5 Private Const sSQLFaits$ = _ "SELECT NomSession, Variable, Op, Val, Const AS Constante," & _ " Fiab, Rem, IdFait, Description FROM RqFaits WHERE IdApplication = ?" & _ " ORDER BY NomSession, Variable" Private Const iColRqFaitsSession% = 0 Private Const iColRqFaitsVar% = 1 Private Const iColRqFaitsOp% = 2 Private Const iColRqFaitsVal% = 3 Private Const iColRqFaitsConst% = 4 Private Const iColRqFaitsFiab% = 5 Private Const iColRqFaitsRem% = 6 Private Const iColRqFaitsIdFait% = 7 Private Const iColRqFaitsSessionDescr% = 8 Private Const sChpSession$ = "NomSession" Private Const sChpDebut$ = "Debut" Private Const sChpFiabOrig$ = "FiabO" Private Const sChpFin$ = "Fin" Friend Structure TFait ' Fait initial Dim sVar$, sVal$, sOp$ Dim sSession$, sRemarque$ Dim rFiab! End Structure Friend Class ClsSession ' Session à expertiser Friend sSession$, sDescription$ Friend colFaits As New Collection() End Class Friend Sub New() m_sRepertoireCourant = Application.StartupPath m_sCheminBaseMDB = m_sRepertoireCourant & _ sRepertoireApplications & "\" & sFichierVBBBoxMDB m_sConnexion = _ "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;" & _ "Data Source=" & m_sCheminBaseMDB & ";Mode=Share Deny None;" m_oConnexion = New OleDbConnection(m_sConnexion) End Sub Friend Sub InitialiserApplication() m_oBR.Initialiser() m_sProvenanceBR = "" m_bModeBD = False End Sub Private Sub InitialiserConfigApp() m_config.bLogiqueNonMonotone = False m_config.bAutoriserReglesContradictoires = False m_config.bLogiqueFloue = False m_config.bLogiqueFloueInterpretee = False End Sub #End Region #Region "Gestion du mode base de données" Friend Function bBDVerifierVersion() As Boolean InitMessages() Dim bConnexion As Boolean Try m_oConnexion.Open() bConnexion = True Catch ' Vérification si le fichier .mdb existe pour produire un ' message d'erreur plus explicite If Not File.Exists(m_sCheminBaseMDB) Then AjouterMsg("Impossible de trouver la base de données :") AjouterMsg(m_sCheminBaseMDB) Else AjouterMsg("Erreur lors de la connexion à la base :") AjouterMsg(m_sCheminBaseMDB) AjouterMsg(Err.ToString) AjouterMsg("Cause possible : MDAC 2.7 doit être installé (cf. doc. pour le lien)") AjouterMsg(" lorsque Visual Studio .NET n'est pas installé sur la machine") End If Return False End Try ' Dans la version .msi, on shunte le test de la version de la bd : ' ça ne marche pas dans un Windows sans l'IDE !? If m_bVersionMSI Then _ m_rVersionBD = 1 : bBDVerifierVersion = True : Exit Function Dim sVersion$ = clsUtil.sDLookUp(m_oConnexion, sSQLVersion) If sVersion = "" Then sVersion = "?" : GoTo Err m_rVersionBD = 0 Try m_rVersionBD = CSng(sVersion) Catch sVersion = "?" End Try If m_rVersionBD >= rVersionBDMin And m_rVersionBD < rVersionBDMax Then Return True Err: If bConnexion Then m_oConnexion.Close() MsgBox("Version de base de données " & sFichierVBBBoxMDB & _ " incompatible !" & vbCrLf & _ "Version : " & sVersion & _ ", Version min. >= " & rVersionBDMin & _ ", Version max. < " & rVersionBDMax, MsgBoxStyle.Critical) Return False End Function Friend Function bBDRemplirApplications( _ ByRef lbApplications As ListBox) As Boolean ' Rechercher les applications dans la base de données ' et remplir la ListBox passée en entrée Dim dt As New DataTable() Try Dim adp As New OleDbDataAdapter(sSQLApplications, m_oConnexion) adp.Fill(dt) ' Récupérer les applications lbApplications.DataSource = dt lbApplications.DisplayMember = sChpApplication ' Ne pas sélectionner une application If lbApplications.SelectedIndex >= 0 Then _ lbApplications.SetSelected(lbApplications.SelectedIndex, False) Return True Catch err As Exception InitMessages() AjouterMsg("Erreur lors de la connexion à la base :") AjouterMsg(m_sCheminBaseMDB) AjouterMsg("Impossible de se connecter à la table 'Application'") AjouterMsg(err.ToString) Return False Finally ' Fermer la connexion pour être sûr d'avoir tjrs les données m.a.j. m_oConnexion.Close() End Try End Function Friend Function bBDChargerDico(ByVal iIdApp%, _ ByRef dgVariables As DataGrid) As Boolean ' Rechercher les variables dans la base de données ' pour l'application iIdApp ' et remplir le DataGrid passé en entrée m_bModeBD = True InitMessages() Dim dtVariables As New DataTable() Try m_oConnexion.Open() Dim sSQL$ = clsUtil.sParametrerRq(sSQLDico, iIdApp) Dim adp As New OleDb.OleDbDataAdapter(sSQL, m_oConnexion) adp.Fill(dtVariables) ' Récupérer les variables Catch err As Exception AjouterMsg("Erreur lors de la connexion à la base :") AjouterMsg(m_sCheminBaseMDB) AjouterMsg("Impossible de se connecter à la requête 'RqVariables'") AjouterMsg(err.ToString) m_oConnexion.Close() Return False End Try ' Fabriquation d'une collection de variables pour charger le dico Dim sItem$ Dim var As clsDico.TVar Dim colVar As New Collection() Dim r As DataRow InitialiserConfigApp() For Each r In dtVariables.Rows sItem = CStr(r(iColRqDicoVar)) If InStr(sItem, " ") > 0 Then AjouterMsg("Erreur : les variables doivent être sans espace :") AjouterMsg(sItem) Return False End If var.sVariable = sItem var.sValeurDef = m_oDico.sTraiterGuillemets( _ clsUtil.sNonVide(r(iColRqDicoValDef))) var.rFiab = clsUtil.rNonVide(r(iColRqDicoFiab), rCodeFiabIndefini) var.sConstante = clsUtil.sNonVide(r(iColRqDicoConst)) var.bConst = clsUtil.bNonVide(r(iColRqDicobConst)) var.bIntermediaire = clsUtil.bNonVide(r(iColRqDicobInterm)) var.sDescription = clsUtil.sNonVide(r(iColRqDicoDescr)) ' Gestion de la configuration var.bConfig = m_oBF.bGestionConfig(sItem, var.sValeurDef, m_config) m_oBF.m_config = m_config colVar.Add(var) Next r m_oDico.ChargerDico(colVar) ' Ajustement de la largeur des colonnes FixerStyleTableauDico(dgVariables, bAfficherConst:=True) dgVariables.SetDataBinding(dtVariables, "") bBDChargerDico = True End Function Friend Function bBDRemplirRegles(ByVal iIdApp%, ByRef dgRegles As DataGrid, _ ByRef lbReglesListe As ListBox) As Boolean ' Rechercher les règles de l'application iIdApp dans la base de données ' et remplir le DataGrid et la ListBox passés en entrée InitMessages() Dim dtRegles As New DataTable() Try Dim sSQL$ = clsUtil.sParametrerRq(sSQLRegles, iIdApp) Dim adp As New OleDbDataAdapter(sSQL, m_oConnexion) adp.Fill(dtRegles) ' Récupérer les règles dgRegles.SetDataBinding(dtRegles, "") FixerStyleTableauRegles(dgRegles) Catch err As Exception AjouterMsg("Erreur lors de la connexion à la base :") AjouterMsg(m_sCheminBaseMDB) AjouterMsg("Impossible de se connecter à la requête 'RqRegles'") AjouterMsg(err.ToString) m_oConnexion.Close() Return False End Try ' Fabrication d'une collection de règles pour charger la BR Dim colRegles As New Collection() Dim bMemConclusion As Boolean Dim hyp As clsBR.THypothese Dim r As DataRow For Each r In dtRegles.Rows Dim sRegle$ = CStr(r(iColRqReglRegle)) Dim rFiab! = clsUtil.rNonVide(r(iColRqReglFiab), rCodeFiabIndefini) Dim sNomVar$ = CStr(r(iColRqReglVar)) Dim sOp$ = clsUtil.sNonVide(r(iColRqReglOp), sOperateurRegleDef) Dim sValVar$ = clsUtil.sNonVide(r(iColRqReglVal), sValHypRegleDef) Dim sNomVar2$ = clsUtil.sNonVide(r(iColRqReglVar2)) If Not clsUtil.bEstVide(r(iColRqReglVal)) And sNomVar2 <> "" Then lbReglesListe.Items.Add("Erreur dans la règle : " & sRegle) lbReglesListe.Items.Add("Deux valeurs sont présentes : " & _ sValVar & " et " & sNomVar2) Return False End If Dim bConclusion As Boolean = CBool(r(iColRqReglbConcl)) bMemConclusion = bConclusion hyp.sRegle = sRegle hyp.sVar = sNomVar hyp.sOp = sOp hyp.sVal = sValVar If sNomVar2 <> "" Then hyp.sVal = sNomVar2 hyp.bConclusion = bConclusion hyp.rFiabRegle = rFiab colRegles.Add(hyp) Next r Dim bOk1, bOk2 As Boolean bOk1 = m_oBR.bBDChargerBR(colRegles) Dim sProvenanceBR$ = m_sCheminBaseMDB & _ " (version : " & m_rVersionBD & ")" bOk2 = bRemplirListeRegles(sProvenanceBR, lbReglesListe) m_sProvenanceBR = sProvenanceBR If bOk1 And bOk2 Then Return True Return False End Function Friend Function bBDRemplirFaits(ByVal iIdApp%, _ ByRef dgFaits As DataGrid, ByRef lbSession As ListBox) As Boolean ' Rechercher les variables de sessions (faits initiaux) ' pour l'application iIdApp dans la base de données ' et remplir le DataGrid, la ListBox et la collection passés en entrée Dim dtVR As New DataTable() Try Dim sSQL$ = clsUtil.sParametrerRq(sSQLFaits, iIdApp) Dim adp As New OleDbDataAdapter(sSQL, m_oConnexion) adp.Fill(dtVR) ' Récupérer les variables des sessions dgFaits.SetDataBinding(dtVR, "") FixerStyleTableauFaits(dgFaits, bAfficherConstantes:=True) Catch err As Exception InitMessages() AjouterMsg("Erreur lors de la connexion à la base :") AjouterMsg(m_sCheminBaseMDB) AjouterMsg("Impossible de se connecter à la requête 'RqFaits'") AjouterMsg(err.ToString) m_oConnexion.Close() Return False End Try Dim sSession$ = "", sSessionDescr$ = "" Dim sMemSession$ = "" Dim sMemSessionDescr$ = "" lbSession.Items.Clear() Dim oSession As New ClsSession() m_colSessions = New Collection() Dim fait As TFait Dim r As DataRow lbSession.BeginUpdate() For Each r In dtVR.Rows sSession = CStr(r(iColRqFaitsSession)) sSessionDescr = clsUtil.sNonVide(r(iColRqFaitsSessionDescr)) If sSession <> sMemSession And sMemSession <> "" Then lbSession.Items.Add(sMemSession) oSession.sSession = sMemSession oSession.sDescription = sMemSessionDescr 'm_colSessions.Add(sMemSession, oSession) ' Hashtable m_colSessions.Add(oSession, sMemSession) ' Collection oSession = New ClsSession() End If sMemSession = sSession sMemSessionDescr = sSessionDescr ' Une session peut n'avoir aucune variable de définie If Not clsUtil.bEstVide(r(iColRqFaitsVar)) Then fait.sSession = sSession fait.sVar = CStr(r(iColRqFaitsVar)) fait.sOp = "=" ' Un fait initial qui est défini, est mis à VRAI par défaut fait.sVal = clsUtil.sNonVide(r(iColRqFaitsVal), sValFaitInitialDefaut) If Not clsUtil.bEstVide(r(iColRqFaitsConst)) Then Dim sConst$ = CStr(r(iColRqFaitsConst)) If m_oDico.bVarExiste(sConst) Then _ fait.sVal = m_oDico.sValDefVar(sConst) End If fait.rFiab = clsUtil.rNonVide(r(iColRqFaitsFiab), rCodeFiabIndefini) fait.sRemarque = clsUtil.sNonVide(r(iColRqFaitsRem)) Dim iIdFait% = CInt(clsUtil.rNonVide(r(iColRqFaitsIdFait), -1.0!)) If iIdFait > -1 Then ' Les champs mémo des requêtes Access un peu complexes sont ' parfois bogués, solution : lire directement le champ mémo ' dans la table Dim sSQL0$ = "SELECT Remarque FROM Fait WHERE IdFait = " & iIdFait Dim sRem$ = clsUtil.sDLookUp(m_oConnexion, sSQL0) ' Mais est-ce qu'il y a vraiment besoin de faire tout ça ? 'If sRem <> fait.sRemarque Then _ ' MsgBox("DLookUp : Oui, il y a besoin de faire ça !") fait.sRemarque = sRem End If oSession.colFaits.Add(fait) End If Next r m_oConnexion.Close() If sSession <> "" Then lbSession.Items.Add(sSession) oSession.sSession = sMemSession oSession.sDescription = sMemSessionDescr m_colSessions.Add(oSession, sMemSession) End If lbSession.EndUpdate() bBDRemplirFaits = True End Function #End Region #Region "Gestion du mode fichier" Friend Sub RemplirListesFichiers( _ ByRef lbFichiersDico As ListBox, _ ByRef lbFichiersBR As ListBox, _ ByRef lbFichiersBF As ListBox) ' Remplir les ListBox de fichiers passés en entrée ' avec les fichiers trouvés correspondants lbFichiersDico.Items.Clear() lbFichiersBR.Items.Clear() lbFichiersBF.Items.Clear() Dim sRepertoireAppTxt$ = Application.StartupPath & _ clsVBBBox.sRepertoireApplicationsTxt & "\" Dim i%, sCheminFichier$, sFichier$ ' Liste des fichiers du répertoire courant avec le chemin complet Dim aFichiers$() Try aFichiers = IO.Directory.GetFiles(sRepertoireAppTxt, "*.dic") Catch lbFichiersDico.Items.Add("Répertoire introuvable !") lbFichiersDico.Items.Add(clsVBBBox.sRepertoireApplicationsTxt) Exit Sub End Try Dim iNbFichiersDico% = aFichiers.GetUpperBound(0) + 1 lbFichiersDico.BeginUpdate() For i = 0 To iNbFichiersDico - 1 sCheminFichier = aFichiers(i) ' Liste des fichiers du répertoire courant sans le chemin complet sFichier = sCheminFichier.Substring( _ sCheminFichier.LastIndexOf("\") + 1) lbFichiersDico.Items.Add(sFichier) Next i lbFichiersDico.EndUpdate() aFichiers = IO.Directory.GetFiles( _ sRepertoireAppTxt, "*.brg") Dim iNbFichiersBR% = aFichiers.GetUpperBound(0) + 1 lbFichiersBR.BeginUpdate() For i = 0 To iNbFichiersBR - 1 sCheminFichier = aFichiers(i) sFichier = sCheminFichier.Substring( _ sCheminFichier.LastIndexOf("\") + 1) lbFichiersBR.Items.Add(sFichier) Next i lbFichiersBR.EndUpdate() aFichiers = IO.Directory.GetFiles( _ sRepertoireAppTxt, "*.bfa") Dim iNbFichiersBF% = aFichiers.GetUpperBound(0) + 1 lbFichiersBF.BeginUpdate() For i = 0 To iNbFichiersBF - 1 sCheminFichier = aFichiers(i) sFichier = sCheminFichier.Substring( _ sCheminFichier.LastIndexOf("\") + 1) lbFichiersBF.Items.Add(sFichier) Next i lbFichiersBF.EndUpdate() ' Sélection du premier fichier 'If iNbFichiersDico > 0 And lbFichiersDico.Enabled Then _ ' lbFichiersDico.SelectedIndex = 0 End Sub Friend Function bChargerDico(ByVal sCheminFichierDico$, _ ByRef dgVariables As DataGrid) As Boolean ' Remplir le DataGrid avec les variables trouvées dans le dico InitMessages() InitialiserConfigApp() Dim colVar As New Collection() If Not m_oDico.bChargerDico(sCheminFichierDico, colVar) Then Return False bChargerDico = True Dim dtVariables As New DataTable() dtVariables.Columns.Add(sChpVar) dtVariables.Columns.Add(sChpValDef) dtVariables.Columns.Add(sChpbInterm) dtVariables.Columns(sChpbInterm).DataType = typeBooleen dtVariables.Columns.Add(sChpbConfig) dtVariables.Columns(sChpbConfig).DataType = typeBooleen Dim sItem$ For Each sItem In colVar Dim row1 As DataRow = dtVariables.NewRow row1(sChpVar) = sItem row1(sChpValDef) = m_oDico.sValDefVar(sItem) row1(sChpbInterm) = m_oDico.bIntermediaire(sItem) Dim bConfig As Boolean = False If m_oDico.bNomVarConfig(sItem) Then bConfig = True row1(sChpValDef) = clsUtil.sVrai End If row1(sChpbConfig) = bConfig ' Gestion de la configuration If m_oBF.bGestionConfig(sItem, clsUtil.sVrai, m_config) Then ' Toujours désactivé en mode fichier : m_config.bLogiqueFloue = False m_config.bLogiqueFloueInterpretee = False m_oBF.m_config = m_config End If dtVariables.Rows.Add(row1) Next sItem FixerStyleTableauDico(dgVariables, bAfficherConst:=False) dgVariables.SetDataBinding(dtVariables, "") End Function Friend Function bChargerBR(ByVal sCheminFichierBR$, _ ByRef lbReglesListe As ListBox, ByRef dgRegles As DataGrid) As Boolean ' Remplir la ListBox et le DataGrid avec les règles trouvées dans la BR InitMessages() If Not m_oBR.bChargerBR(sCheminFichierBR) Then Return False If Not bRemplirListeRegles(sCheminFichierBR, lbReglesListe) Then Return False m_sProvenanceBR = sCheminFichierBR ' Remplissage du tableau de règles RemplirTableauRegles(dgRegles) Return True End Function Private Sub RemplirTableauRegles(ByRef dgRegles As DataGrid) ' Remplir le DataGrid contenant le tableau de règles Dim dtRegles As New DataTable() dtRegles.Columns.Add(sChpRegle) dtRegles.Columns.Add(sChpVar) dtRegles.Columns.Add(sChpOp) dtRegles.Columns.Add(sChpVal) dtRegles.Columns.Add(sChpVar2) dtRegles.Columns.Add(sChpbConcl) dtRegles.Columns(sChpbConcl).DataType = typeBooleen dtRegles.Columns.Add(sChpbInterm) dtRegles.Columns(sChpbInterm).DataType = typeBooleen Dim i%, j% For j = 1 To m_oBR.m_iNbRegles For i = 1 To m_oBR.m_aRegles(j).aPremisses.GetUpperBound(0) Dim row1 As DataRow = dtRegles.NewRow Dim prem As clsDico.TPremisse = m_oBR.m_aRegles(j).aPremisses(i) row1(sChpRegle) = m_oBR.m_aRegles(j).sRegle row1(sChpVar) = prem.sVar row1(sChpOp) = m_oDico.sConvOper(prem.oper) row1(sChpVal) = prem.sVal row1(sChpVar2) = prem.sVar2 row1(sChpbConcl) = False row1(sChpbInterm) = m_oDico.bIntermediaire(prem.sVar) dtRegles.Rows.Add(row1) Next i For i = 1 To m_oBR.m_aRegles(j).aConclusions.GetUpperBound(0) Dim row1 As DataRow = dtRegles.NewRow Dim conclus As clsDico.TPremisse = m_oBR.m_aRegles(j).aConclusions(i) row1(sChpRegle) = m_oBR.m_aRegles(j).sRegle row1(sChpVar) = conclus.sVar row1(sChpOp) = m_oDico.sConvOper(conclus.oper) row1(sChpVal) = conclus.sVal row1(sChpVar2) = conclus.sVar2 row1(sChpbConcl) = True row1(sChpbInterm) = m_oDico.bIntermediaire(conclus.sVar) dtRegles.Rows.Add(row1) Next i Next j FixerStyleTableauRegles(dgRegles) dgRegles.SetDataBinding(dtRegles, "") End Sub Friend Function bRemplirSessions(ByVal sFichierBF$, _ ByRef lbLigneFait As ListBox, ByRef dgFaits As DataGrid) As Boolean ' Remplir la collection, la ListBox et le DataGrid avec les sessions ' trouvées dans le fichier de base de faits Dim sCheminFichierBF$ = m_sRepertoireCourant & _ sRepertoireApplicationsTxt & "\" & sFichierBF Dim sr As New StreamReader(sCheminFichierBF, clsUtil.encodageVB6) ' Construire une collection de sessions = collection de faits m_colSessions = New Collection() lbLigneFait.BeginUpdate() Do Dim sLigne$ = sr.ReadLine If sLigne Is Nothing Then Exit Do ' Construire une collection de faits Dim asFaits$() = Split(sLigne, ";") If asFaits.GetUpperBound(0) < 1 Then GoTo LigneSuivante ' Extraire le nom de la session Dim sSession$ = asFaits(0) Dim session0 As New ClsSession() Dim fait0 As clsVBBBox.TFait = Nothing ' Il faut tenir compte de l'ordre de chargement : ' celui du dico Dim iNumVar% For iNumVar = 1 To m_oDico.m_iNbVarInitiales If iNumVar >= asFaits.GetUpperBound(0) Then Exit For Dim sVar$ = m_oDico.sNomVar(iNumVar) fait0.sSession = sSession fait0.sVar = sVar fait0.sOp = "=" fait0.rFiab = rCodeFiabIndefini Dim sVal$ = asFaits(iNumVar) fait0.sVal = sVal If sVal <> "" Then session0.colFaits.Add(fait0) Next iNumVar m_colSessions.Add(session0, sSession) lbLigneFait.Items.Add(sSession) LigneSuivante: Loop While True sr.Close() lbLigneFait.EndUpdate() ' Remplissage du tableau de faits initiaux Dim dtVR As New DataTable() dtVR.Columns.Add(sChpSession) dtVR.Columns.Add(sChpVar) dtVR.Columns.Add(sChpOp) dtVR.Columns.Add(sChpVal) Dim oSession As ClsSession Dim fait As TFait For Each oSession In m_colSessions For Each fait In oSession.colFaits ' Fabriquation du jeu de données Faits Dim row1 As DataRow = dtVR.NewRow row1(sChpSession) = fait.sSession row1(sChpVar) = fait.sVar row1(sChpOp) = fait.sOp row1(sChpVal) = fait.sVal dtVR.Rows.Add(row1) Next fait : Next oSession FixerStyleTableauFaits(dgFaits, bAfficherConstantes:=False) dgFaits.SetDataBinding(dtVR, "") bRemplirSessions = True End Function #End Region #Region "Gestion commune aux deux modes" Private Function bRemplirListeRegles(ByVal sProvenanceBR$, _ ByRef lbReglesListe As ListBox) As Boolean ' Remplir la ListBox avec les règles chargées dans l'un des 2 modes Dim sItem$ Dim col As New Specialized.StringCollection() bRemplirListeRegles = bTraduireRegles(sProvenanceBR, col) lbReglesListe.Items.Clear() lbReglesListe.BeginUpdate() For Each sItem In col lbReglesListe.Items.Add(sItem) Next sItem lbReglesListe.EndUpdate() End Function Private Function bTraduireRegles(ByVal sProvenanceBR$, _ ByRef col As Specialized.StringCollection, _ Optional ByVal bCompatibleTurboExpert As Boolean = False, _ Optional ByVal bDetailRegles As Boolean = False, _ Optional ByVal iIdApp% = 0, Optional ByVal sApplication$ = "") As Boolean ' Vérifier la liste des règles et remplir la collection passée en entrée Dim bConnexion As Boolean Dim dtRegles As DataTable = Nothing If bDetailRegles Then ' Rechercher les règles de l'application iIdApp dans la base de données Try Dim sSQL$ = clsUtil.sParametrerRq(sSQLReglesDescription, iIdApp) Dim adp As New OleDbDataAdapter(sSQL, m_oConnexion) dtRegles = New DataTable() m_oConnexion.Open() adp.Fill(dtRegles) ' Récupérer les règles m_oConnexion.Close() bConnexion = True Catch End Try End If If bCompatibleTurboExpert Then col.Add("* Base de règles convertie : " & sProvenanceBR) col.Add("* Date : " & DateTime.Now) col.Add("") Else col.Add("") col.Add("Base de règles : " & sProvenanceBR) If bDetailRegles Then col.Add("Date : " & DateTime.Now) col.Add("") End If Dim j% For j = 1 To m_oBR.m_iNbRegles With m_oBR.m_aRegles(j) ' Affichage de la règle j Dim sTab$ = " " Dim sPrefixe$ = "" Dim sRegle$ = .sRegle If bCompatibleTurboExpert Then sPrefixe$ = "* * " sTab = "" ' Dans Turbo-Expert, les règles doivent commencées par R Dim sRegleTE$ = sRegle If sRegle.Chars(0) <> "R" Then sRegleTE = "R_" & sRegle col.Add(sRegleTE) End If Dim sTitre$ = sPrefixe & "Règle n°" & Str(j) & " : " & sRegle If bConnexion Then Dim r As DataRow r = dtRegles.Rows(j - 1) Dim sDescription$ = clsUtil.sNonVide(r(iColRqReglDDescr)) Dim sOrigine$ = clsUtil.sNonVide(r(iColRqReglDOrig)) Dim sRemarque$ = clsUtil.sNonVide(r(iColRqReglDRem)) Dim sFiabilite$ = clsUtil.sNonVide(r(iColRqReglDFiab)) Dim sDate$ = clsUtil.sNonVide(r(iColRqReglDDate)) If sFiabilite <> "" Then sTitre &= " (" & sFiabilite & ")" If sDate <> "" Then sTitre &= " : " & sDate col.Add(sTitre) If sDescription <> "" Then _ col.Add(sPrefixe & "Description : " & sDescription) If sOrigine <> "" Then _ col.Add(sPrefixe & "Origine : " & sOrigine) If sRemarque <> "" Then _ col.Add(sPrefixe & "Remarque : " & sRemarque) col.Add("") Else If .rFiab <> rCodeFiabIndefini Then _ sTitre &= " (" & .rFiab & ")" col.Add(sTitre) End If If .aPremisses.GetUpperBound(0) = 0 Then col.Add("Erreur : la règle ne contient aucune prémisse") Return False End If If .aConclusions.GetUpperBound(0) = 0 Then col.Add("Erreur : la règle ne contient aucune conclusion") Return False End If Dim i%, sVar$, sOp$, sVal$, sDebPrem$, sPrem$, sVar2$ For i = 1 To .aPremisses.GetUpperBound(0) sVar = .aPremisses(i).sVar sOp = " " & m_oDico.sConvOper(.aPremisses(i).oper, _ bCompatibleTurboExpert) & " " sVal = .aPremisses(i).sVal sVar2 = .aPremisses(i).sVar2 If m_oDico.bVarExiste(sVar2) Then sVal = sVar2 If m_oDico.bConstante(sVar2) And bCompatibleTurboExpert Then sVal = m_oDico.sValDefVar(sVar2) End If If i > 1 Then sDebPrem = "et " Else sDebPrem = "si " sPrem = sTab & sDebPrem & sVar & sOp & sVal col.Add(sPrem) Next i Dim sDebConc$, sConc$ For i = 1 To .aConclusions.GetUpperBound(0) sVar = .aConclusions(i).sVar sOp = " " & m_oDico.sConvOper(.aConclusions(i).oper) & " " sVal = .aConclusions(i).sVal sVar2 = .aConclusions(i).sVar2 If m_oDico.bVarExiste(sVar2) Then sVal = sVar2 If i > 1 Then sDebConc = "et " Else sDebConc = "alors " sConc = sTab & sDebConc & sVar & sOp & sVal col.Add(sConc) Next i col.Add("") If bConnexion And Not bCompatibleTurboExpert Then col.Add("") If bCompatibleTurboExpert Then col.Add(sSeparation) End With Next j If bCompatibleTurboExpert Then _ col.Add(sFinFichierTurboExpert) bTraduireRegles = True End Function Private Sub InitMessages() m_colAvert.Clear() m_colCR.Clear() End Sub Friend Function colLireMessages() As Specialized.StringCollection colLireMessages = m_colCR End Function Private Sub AjouterMsg(ByVal sMessage$) clsUtil.AjouterMsg(sMessage, m_colCR) End Sub #End Region #Region "Gestion de l'expertise" Friend Function bExpertiser(ByVal sApplication$, ByVal sSession$, _ ByRef lbFaits As ListBox, ByRef lbFaitsJustes As ListBox, _ ByRef dgBilanSession As DataGrid, _ ByRef bConclusions As Boolean, _ ByRef bAvertissements As Boolean) As Boolean ' Faire l'expertise avec la collection de faits de la session et ' remplir les ListBox des faits et le DataGrid du Bilan ' Retourner bConclusions : si une conclusion à pu être tirée ' et bAvertissements : s'il y a des avertissements '========================================================================== ' MAIN DU PROGRAMME T-EXPERT "one-shot" '========================================================================== InitialiserExpertise() Dim oSession As ClsSession oSession = CType(m_colSessions(sSession), ClsSession) AjouterMsg("Rapport d'expertise de VBBrainBox") AjouterMsg(sSeparation) AjouterMsg("Application : " & sApplication) AjouterMsg("Session : " & sSession) If oSession.sDescription <> "" Then _ AjouterMsg("Descrip.: " & oSession.sDescription) AjouterMsg(sSeparation) If Not m_oBF.bChargerFaitsInitiauxSession(oSession.colFaits) Then Return False AjouterMsg("Configuration :") If m_oBF.m_config.bLogiqueNonMonotone Then AjouterMsg("Logique non monotone (les faits peuvent changer)") Else AjouterMsg("Logique monotone (les faits ne peuvent pas changer)") End If If m_oBF.m_config.bAutoriserReglesContradictoires Then AjouterMsg("Les règles contradictoires sont autorisées") Else AjouterMsg("Les règles contradictoires ne sont pas autorisées") End If If m_oBF.m_config.bLogiqueFloue Then AjouterMsg("Logique floue activée (les fiabilités sont indiquées entre parenthèses)") If m_oBF.m_config.bLogiqueFloueInterpretee Then AjouterMsg("Logique floue interprétée (les faits peuvent changer)") Else AjouterMsg("Logique floue non-interprétée (les faits ne peuvent pas changer)") End If Else AjouterMsg("Logique floue désactivée") m_oBF.m_config.bLogiqueFloueInterpretee = False End If AjouterMsg(sSeparation) AjouterMsg("") AjouterMsg("Compte-rendu d'expertise") AjouterMsg("") Dim sErr$ = "" bConclusions = bChainageAvant(sErr) ' Expertise bExpertiser = True If sErr <> "" Then AjouterMsg(sErr) : bExpertiser = False AjouterMsg("Nombre d'avertissements : " & m_iNbAvertissements) bAvertissements = CBool(m_iNbAvertissements > 0) Dim sItem$ lbFaits.BeginUpdate() lbFaitsJustes.BeginUpdate() sItem = "Nombre de faits initiaux vrais = " & m_oBF.m_colFaitsIJustes.Count lbFaits.Items.Add(sItem) lbFaitsJustes.Items.Add(sItem) sItem = "Nombre de faits initiaux définis = " & m_oBF.m_iNbFaitsInitiauxDefinis lbFaits.Items.Add(sItem) lbFaitsJustes.Items.Add(sItem) sItem = "Nombre de faits finaux = " & m_oBF.m_colFaits.Count lbFaits.Items.Add(sItem) lbFaitsJustes.Items.Add(sItem) sItem = "" lbFaits.Items.Add(sItem) lbFaitsJustes.Items.Add(sItem) For Each sItem In m_oBF.m_colFaitsI lbFaits.Items.Add(sItem) Next sItem For Each sItem In m_oBF.m_colFaitsIJustes lbFaitsJustes.Items.Add(sItem) Next sItem lbFaits.EndUpdate() lbFaitsJustes.EndUpdate() ' Remplir le tableau du bilan des variables de la session RemplirBilan(dgBilanSession) End Function Private Sub InitialiserExpertise() m_iNbAvertissements = 0 m_oBF.m_colFaitsI = New Collection() m_oBF.m_colFaitsIJustes = New Collection() ' Initialisation de la config de la session avec la config de l'application, ' la config de la session pourra éventuellement être modifiée dans le ' chargement des faits de la session m_oBF.m_config = m_config m_oBR.InitDeductions() InitMessages() End Sub Private Function bChainageAvant(ByRef sErr$) As Boolean ' Chaînage avant proprement dit ' Retourner bConclusion = bChainageAvant, et sErr Dim bAuMoinsUneConclusion As Boolean sErr = "" Do If Not bDeduction(sErr) Then Exit Do If sErr <> "" Then Return False bAuMoinsUneConclusion = True Loop While True If Not bAuMoinsUneConclusion Then AjouterMsg("Aucune conclusion n'a pu être trouvée") AjouterMsg("") Return False End If Return True End Function Private Function bDeduction(ByRef sErr$) As Boolean ' Moteur principal du chaînage avant ' Retourner bConclusion = bDeduction, et sErr bDeduction = False Dim R% sErr = "" For R = 1 To m_oBR.m_iNbRegles If m_oBR.m_aRegles(R).bDeduction Then GoTo RegleSuivante Dim sRegle$ = m_oBR.m_aRegles(R).sRegle ' Pour debug Dim P% Dim rMinFiab! = rCodeFiabIndefini Dim colFiab As New Specialized.StringCollection() ' Pour le compte rendu Dim iNbPremisses% = m_oBR.m_aRegles(R).aPremisses.GetUpperBound(0) Dim NbPremVraies% = 0 For P = 1 To iNbPremisses Dim sFait$ = "", rFiabFait! = 0 If Not m_oBF.bTrouverVar(R, P, sFait) Then GoTo PremisseSuivante If Not m_oBF.bPremisseVraieDansBF( _ R, P, sFait, rMinFiab, rFiabFait) Then GoTo PremisseSuivante NbPremVraies += 1 If m_oBF.m_config.bLogiqueFloue Then Dim sFiab$ = Format(rFiabFait, sFormatFiab) colFiab.Add(sFiab) End If PremisseSuivante: Next P If NbPremVraies = iNbPremisses Then If bConclusions(R, rMinFiab, colFiab, sErr) Then _ bDeduction = True If sErr <> "" Then Return False End If RegleSuivante: Next R End Function Private Function bConclusions(ByVal R%, ByVal rMinFiab!, _ ByVal colFiab As Specialized.StringCollection, ByRef sErr$) As Boolean ' Retourner bConclusions et sErr '-------------------------------------------------------------------------- ' CHAINAGE AVANT '-------------------------------------------------------------------------- bConclusions = False ' La règle ne peut être appliquée qu'une seule fois m_oBR.m_aRegles(R).bDeduction = True Dim iNbConclusions% = m_oBR.m_aRegles(R).aConclusions.GetUpperBound(0) Dim colFiabC As New Specialized.StringCollection() ' Pour le compte rendu Dim C% For C = 1 To iNbConclusions ' En logique floue, on affiche aussi les conclusions portant ' sur des faits déjà établis afin de préciser la mise à jour ' de leur fiabilité If Not m_oBF.m_config.bLogiqueFloue And _ m_oBF.bVerifieeDansBF(m_oBR.m_aRegles(R).aConclusions(C)) Then _ GoTo ConclusionSuivante bConclusions = True Dim sFait$ = "", sMajFiab$ = "", rFiab! = 0 If Not (m_oBF.bExisteDansBF(m_oBR.m_aRegles(R).aConclusions(C), sFait)) Then m_oBF.AjouterFait(R, C, rMinFiab, rFiab) If m_oBF.m_config.bLogiqueFloue Then Dim sFiab$ = "(" & Format(rFiab, sFormatFiab) & ")" If rFiab = rCodeFiabIndefini Then sFiab = "" colFiabC.Add(sFiab) End If Else If Not m_oBF.bMAJFait(sFait, R, C, rMinFiab, sMajFiab, sErr) Then bConclusions = False ListerRegle(R, rMinFiab, m_oBF.m_config.bLogiqueFloue, _ colFiab, colFiabC) Exit Function End If If m_oBF.m_config.bLogiqueFloue Then _ colFiabC.Add(sMajFiab) End If ' Affichage des avertissements If sErr <> "" Then clsUtil.AjouterMsg(sErr, m_colAvert) sErr = "" m_iNbAvertissements += 1 End If ' Libellé de la conséquence-conclusion Dim sConclusion$ = m_oDico.sComposerHypothese( _ m_oBR.m_aRegles(R).aConclusions(C)) ' N'afficher la règle qu'à la fin, une fois que toutes les fiab ' sont connues If C = iNbConclusions Then _ ListerRegle(R, rMinFiab, m_oBF.m_config.bLogiqueFloue, _ colFiab, colFiabC) ConclusionSuivante: Next C End Function Private Sub ListerRegle(ByVal R%, ByVal rMinFiab!, _ ByVal bLogiqueFloue As Boolean, _ ByVal colFiab As Specialized.StringCollection, _ ByVal colFiabC As Specialized.StringCollection) Dim sMsg$ = "Selon la règle " & m_oBR.m_aRegles(R).sRegle If m_oBF.m_config.bLogiqueFloue Then If m_oBR.m_aRegles(R).rFiab <> rCodeFiabIndefini Then _ sMsg &= " (" & m_oBR.m_aRegles(R).rFiab & ")" sMsg &= " :" If rMinFiab <> rCodeFiabIndefini Then _ sMsg &= " (min. fiab. faits : " & _ Format(rMinFiab, clsVBBBox.sFormatFiab) & ") :" End If AjouterMsg(sMsg) m_oBR.ExprimerRegleOk(R, m_oBF.m_config.bLogiqueFloue, colFiab, colFiabC) AjouterMsg("") End Sub #End Region #Region "Bilan, rapport et exportation" Private Sub RemplirBilan(ByRef dgBilanSession As DataGrid) ' Remplir le DataGrid contenant le tableau du ' bilan des variables de la session Dim dtBilan As New DataTable() dtBilan.Columns.Add(sChpVar) dtBilan.Columns.Add(sChpDebut) dtBilan.Columns.Add(sChpFiabOrig) dtBilan.Columns.Add(sChpFin) dtBilan.Columns.Add(sChpFiab) dtBilan.Columns.Add(sChpRegle) dtBilan.Columns.Add(sChpbInterm) dtBilan.Columns(sChpbInterm).DataType = typeBooleen 'Dim i% Dim de As DictionaryEntry For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If m_oDico.bIntermediaire(var.sVariable) Then GoTo VarSuivante If m_oDico.bConstante(var.sVariable) Then GoTo VarSuivante If Not m_oBF.bVarExisteDansBF(var.sVariable) Then GoTo VarSuivante Dim fait As clsDico.TPremisse = m_oBF.fait(var.sVariable) Dim row1 As DataRow = dtBilan.NewRow row1(sChpVar) = fait.sVar row1(sChpDebut) = IIf((fait.sValDebut Is Nothing), _ "", fait.sValDebut) row1(sChpFiabOrig) = "" If fait.rFiabOrig <> rCodeFiabIndefini Then _ row1(sChpFiabOrig) = fait.rFiabOrig row1(sChpFin) = fait.sVal row1(sChpFiab) = "" If fait.rFiab <> rCodeFiabIndefini Then _ row1(sChpFiab) = fait.rFiab row1(sChpRegle) = fait.sReglesApp row1(sChpbInterm) = False dtBilan.Rows.Add(row1) VarSuivante: Next de For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If Not m_oDico.bIntermediaire(var.sVariable) Then GoTo VarSuivante2 If Not m_oBF.bVarExisteDansBF(var.sVariable) Then GoTo VarSuivante2 Dim fait As clsDico.TPremisse = m_oBF.fait(var.sVariable) Dim row1 As DataRow = dtBilan.NewRow row1(sChpVar) = var.sVariable row1(sChpDebut) = "" row1(sChpFiabOrig) = "" row1(sChpFin) = "" row1(sChpFiab) = "" row1(sChpRegle) = "" row1(sChpbInterm) = True row1(sChpDebut) = IIf((fait.sValDebut Is Nothing), _ "", fait.sValDebut) row1(sChpFin) = fait.sVal row1(sChpRegle) = fait.sReglesApp If fait.rFiab <> rCodeFiabIndefini Then _ row1(sChpFiab) = fait.rFiab dtBilan.Rows.Add(row1) VarSuivante2: Next de FixerStyleTableauBilan(dgBilanSession) dgBilanSession.SetDataBinding(dtBilan, "") End Sub ' D'après le fichier d'origine en VB6 : ' CRD '-------------------------------------- ' Module Compte Rendu pour Turbo-EXPERT '-------------------------------------- ' version VB6 mai 02 '-------------------------------------- Friend Sub CreerCompteRendu(ByVal sCheminFichier$, _ ByVal iIdApplication%, ByVal sApplication$, ByVal sSession$) Dim sw As New StreamWriter(sCheminFichier) sw.WriteLine("Rapport d'expertise de VBBrainBox") sw.WriteLine("Date : " & DateTime.Now) sw.WriteLine(sSeparation) sw.WriteLine("Application : " & sApplication) ExporterDescrApplication(sw, iIdApplication) If sSession <> "" Then sw.WriteLine("Session : " & sSession) sw.WriteLine(sSeparation) sw.WriteLine("") If m_iNbAvertissements > 0 Then sw.WriteLine("Nombre d'avertissements : " & m_iNbAvertissements) sw.WriteLine("") End If ' Exporter la liste des faits initiaux sw.WriteLine("Faits initiaux :") sw.WriteLine("") Dim sItem$ = "Nombre de faits initiaux = " & m_oBF.m_colFaitsI.Count sw.WriteLine(sItem) sItem = "Nombre de faits initiaux définis = " & m_oBF.m_colFaitsIJustes.Count sw.WriteLine(sItem) If Not m_oBF.m_colFaits Is Nothing Then ' Si une err a eu lieu sItem = "Nombre de faits finaux = " & m_oBF.m_colFaits.Count sw.WriteLine(sItem) sw.WriteLine("") End If For Each sItem In m_oBF.m_colFaitsI sw.WriteLine(sItem) Next sItem ' Exporter les conclusions sw.WriteLine("") For Each sItem In colLireMessages() sw.WriteLine(sItem) Next sItem ' Exporter les avertissements If m_iNbAvertissements > 0 Then sw.WriteLine("") For Each sItem In m_colAvert sw.WriteLine(sItem) Next sItem Else sw.WriteLine("") End If If Not m_oBF.m_colFaits Is Nothing Then ExporterBilan(sw) Else ' Exporter les messages d'erreur s'il y en a sw.WriteLine("") Dim sItem$ For Each sItem In colLireMessages() sw.WriteLine(sItem) Next sItem ' Exporter toutes les sessions sw.WriteLine(sSeparation) sw.WriteLine("Toutes les sessions") ExporterFaitsInitiaux(sw, m_colSessions, bCompatibleTurboExpert:=False) sw.WriteLine(sSeparation) End If ExporterRegles(sw, iIdApplication, bCompatibleTurboExpert:=False) sw.WriteLine(sSeparation) sw.WriteLine("VBBrainBox 1.0 par Patrice Dargenton") sw.WriteLine("") sw.WriteLine("d'après Turbo-Expert 1.2 pour Windows") sw.WriteLine("(c) Philippe Larvet 1996, 2003") sw.WriteLine("") sw.WriteLine("Documentation : VBBrainBox.html") sw.WriteLine("http://patrice.dargenton.free.fr/ia/vbbrainbox/index.html") sw.WriteLine("http://patrice.dargenton.free.fr/index.html") sw.WriteLine("patrice.dargenton@free.fr") sw.WriteLine(sSeparation) sw.Close() ' Ancienne méthode : 'Dim iRet% = Shell("notepad " & sCheminFichier, AppWinStyle.NormalFocus) Dim startInfo As New ProcessStartInfo("notepad.exe") startInfo.Arguments = sCheminFichier startInfo.WindowStyle = ProcessWindowStyle.Normal Process.Start(startInfo) End Sub Private Sub ExporterDescrApplication(ByVal sw As StreamWriter, ByVal iIdApp%) ' Exporter la description de l'application Dim col As New Specialized.StringCollection() ExporterDescrApplication(col, iIdApp) Dim sItem$ For Each sItem In col sw.WriteLine(sItem) Next sItem End Sub Private Sub ExporterDescrApplication(ByVal col As Specialized.StringCollection, _ ByVal iIdApp%, Optional ByVal sPrefixe$ = "") ' Exporter la description de l'application dans une collection If Not m_bModeBD Then Exit Sub Dim dtApplication As DataTable Try Dim sSQL$ = clsUtil.sParametrerRq(sSQLApplicationsDescription, iIdApp) Dim adp As New OleDbDataAdapter(sSQL, m_oConnexion) dtApplication = New DataTable() m_oConnexion.Open() adp.Fill(dtApplication) ' Récupérer la description des applications m_oConnexion.Close() Catch Exit Sub End Try Dim r As DataRow For Each r In dtApplication.Rows ' Il n'y en a qu'une Dim sApp$ = CStr(r(iColRqAppApp)) Dim sDescr$ = clsUtil.sNonVide(r(iColRqAppDescr)) Dim sAuteur$ = clsUtil.sNonVide(r(iColRqAppAuteur)) Dim sEMail$ = clsUtil.sTraiterHyperlienAccess( _ clsUtil.sNonVide(r(iColRqAppEMail))) Dim sWeb$ = clsUtil.sTraiterHyperlienAccess( _ clsUtil.sNonVide(r(iColRqAppWeb))) Dim sDate$ = clsUtil.sNonVide(r(iColRqAppDate)) Dim sVersion$ = clsUtil.sNonVide(r(iColRqAppVers)) Dim sRem$ = clsUtil.sNonVide(r(iColRqAppRem)) If sDescr <> "" Then col.Add(sPrefixe & _ "Description : " & sDescr) If sAuteur <> "" Then col.Add(sPrefixe & _ "Auteur : " & sAuteur) If sEMail <> "" Then col.Add(sPrefixe & _ "EMail : " & sEMail) If sWeb <> "" Then col.Add(sPrefixe & _ "Web : " & sWeb) If sDate <> "" Then col.Add(sPrefixe & _ "Date : " & sDate) If sVersion <> "" Then col.Add(sPrefixe & _ "Version : " & sVersion) If sRem <> "" Then col.Add(sPrefixe & _ "Remarque : " & sRem) Next r End Sub Private Sub ExporterBilan(ByVal sw As StreamWriter) ' Exporter le bilan des variables de la session sw.WriteLine(sSeparation) sw.WriteLine("") sw.WriteLine("Bilan des variables : Avant : Après") sw.WriteLine("") Dim de As DictionaryEntry For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If m_oDico.bIntermediaire(var.sVariable) Then GoTo VarSuivante If m_oDico.bConstante(var.sVariable) Then GoTo VarSuivante If Not m_oBF.bVarExisteDansBF(var.sVariable) Then GoTo VarSuivante Dim fait As clsDico.TPremisse = m_oBF.fait(var.sVariable) Dim sVar$ = fait.sVar Dim sDebut$ = fait.sValDebut If sDebut = "" Then sDebut = "?" Dim sFin$ = fait.sVal Dim sRegles$ = fait.sReglesApp Dim sLigne$ = sVar & " = " & sDebut If fait.rFiabOrig <> rCodeFiabIndefini Then _ sLigne &= " (" & Format(fait.rFiabOrig, sFormatFiabRapport) & ")" If fait.rFiab <> rCodeFiabIndefini Then _ sFin &= " (" & Format(fait.rFiab, sFormatFiabRapport) & ")" If sFin <> "" Then sLigne &= " : " & sFin If sRegles <> "" Then sLigne &= " (" & sRegles & ")" sw.WriteLine(sLigne) If var.sDescription <> "" Then _ sw.WriteLine("Descrip. : " & var.sDescription) If fait.sRemarque <> "" Then sw.WriteLine("Remarque : " & fait.sRemarque) sw.WriteLine("") End If VarSuivante: Next de sw.WriteLine("") sw.WriteLine("Variables intermédiaires :") sw.WriteLine("") For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If Not m_oDico.bIntermediaire(var.sVariable) Then GoTo VarSuivante2 If Not m_oBF.bVarExisteDansBF(var.sVariable) Then GoTo VarSuivante2 Dim fait As clsDico.TPremisse = m_oBF.fait(var.sVariable) Dim sVar$ = var.sVariable Dim sDebut$ = "?" Dim sFin$ = "" Dim sRegle$ = "" sDebut = CStr(IIf((fait.sValDebut Is Nothing), _ "?", fait.sValDebut)) If fait.rFiabOrig <> rCodeFiabIndefini Then _ sDebut &= " (" & Format(fait.rFiabOrig, sFormatFiabRapport) & ")" sFin = fait.sVal If fait.rFiab <> rCodeFiabIndefini Then _ sFin &= " (" & Format(fait.rFiab, sFormatFiabRapport) & ")" sRegle = fait.sReglesApp '.sRegleApp If sDebut = "" Then sDebut = "?" Dim sLigne$ = sVar & " = " & sDebut If sFin <> "" Then sLigne &= " : " & sFin If sRegle <> "" Then sLigne &= " (" & sRegle & ")" sw.WriteLine(sLigne) If var.sDescription <> "" Then _ sw.WriteLine("Descrip. : " & var.sDescription) If fait.sRemarque <> "" Then sw.WriteLine("Remarque : " & fait.sRemarque) sw.WriteLine("") End If VarSuivante2: Next de sw.WriteLine("") sw.WriteLine(sSeparation) End Sub Private Sub ExporterRegles(ByVal sw As StreamWriter, ByVal iIdApp%, _ Optional ByVal bCompatibleTurboExpert As Boolean = False, _ Optional ByVal sApplication$ = "") ' Exporter les règles (compatibles Turbo-Expert en option) Dim col As New Specialized.StringCollection() Dim bDetailRegles As Boolean = True If Not m_bModeBD Then bDetailRegles = False If bCompatibleTurboExpert Then col.Add("R") col.Add("* Application : " & sApplication) Const sPrefixe$ = "* " ExporterDescrApplication(col, iIdApp, sPrefixe) End If bTraduireRegles(m_sProvenanceBR, col, _ bCompatibleTurboExpert, bDetailRegles, iIdApp, sApplication) Dim sItem$ For Each sItem In col sw.WriteLine(sItem) Next sItem End Sub Friend Sub ExporterPourTurboExpert12(ByVal lbApplications As ListBox) Dim drw As DataRowView = CType(lbApplications.Items( _ lbApplications.SelectedIndex), DataRowView) Dim iIdApp% = CInt(drw.Item(0)) ' Colonne 0 Dim sApplication$ = CStr(drw.Item(1)) ' Colonne 1 Dim sFichierAppli$ = sApplication Dim iPosCarInvalide% = sFichierAppli.IndexOfAny( _ New Char() {"."c, ","c, "!"c, "?"c, ":"c, ";"c, "/"c, "\"c}) If iPosCarInvalide > -1 Then sFichierAppli = sFichierAppli.Substring(0, iPosCarInvalide) If sFichierAppli = "" Then sFichierAppli = "Application1" End If sFichierAppli = sFichierAppli.Trim Dim sChemin$ = Application.StartupPath & _ sRepertoireApplicationsTxt & "\" Dim sCheminFichierDic$ = sChemin & sFichierAppli & ".dic" Dim sCheminFichierBR$ = sChemin & sFichierAppli & ".brg" Dim sCheminFichierBF$ = sChemin & sFichierAppli & ".bfa" ' Vérifier et prévenir de l'écrasement des fichiers précédants If File.Exists(sCheminFichierDic) Or _ File.Exists(sCheminFichierBR) Or _ File.Exists(sCheminFichierBF) Then _ If MsgBoxResult.Yes <> MsgBox("Attention, les fichiers :" & vbLf & _ sFichierAppli & ".dic, .brg et .bfa dans :" & vbLf & sChemin & vbLf & _ "vont être écrasés, voulez-vous continuer ?", _ MsgBoxStyle.Question Or MsgBoxStyle.YesNoCancel) Then Exit Sub Const bAjouter As Boolean = False Dim sw As New StreamWriter(sCheminFichierDic, bAjouter, clsUtil.encodageVB6) ExporterDico(sw) sw.Close() sw = New StreamWriter(sCheminFichierBR, bAjouter, clsUtil.encodageVB6) ExporterRegles(sw, bCompatibleTurboExpert:=True, _ iIdApp:=iIdApp, sApplication:=sApplication) sw.Close() sw = New StreamWriter(sCheminFichierBF, bAjouter, clsUtil.encodageVB6) ExporterFaitsInitiaux(sw, m_colSessions, bCompatibleTurboExpert:=True) sw.Close() MsgBox("Exportation réussie :" & vbLf & sChemin & sFichierAppli & _ ".dic, .brg et .bfa", MsgBoxStyle.Exclamation) End Sub Private Sub ExporterDico(ByVal sw As StreamWriter) ' Exporter le dictionnaire des variables (compatible Turbo-Expert) Dim de As DictionaryEntry Dim iPasse% For iPasse = 0 To 1 For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) ' D'abord les variables de configuration, puis les autres If (iPasse = 0 And m_oDico.bConfig(var.sVariable)) Or _ (iPasse = 1 And Not m_oDico.bConfig(var.sVariable)) Then _ If Not m_oDico.bIntermediaire(var.sVariable) Then _ sw.WriteLine(var.sVariable) Next de : Next iPasse sw.WriteLine(sSeparation) ' Variables intermédiaires For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If m_oDico.bIntermediaire(var.sVariable) Then _ sw.WriteLine(var.sVariable) Next sw.WriteLine(sFinFichierTurboExpert) End Sub Private Sub ExporterFaitsInitiaux(ByVal sw As StreamWriter, _ ByVal colSessions As Collection, ByVal bCompatibleTurboExpert As Boolean) ' Exporter le tableau des faits initiaux (compatible Turbo-Expert) Dim oSession As ClsSession For Each oSession In colSessions Dim sLigneFaits$ = "" If bCompatibleTurboExpert Then sLigneFaits$ = oSession.sSession ' Suppression des éventuels ; : ne marche pas ! 'sLigneFaits = sLigneFaits.Trim(New Char() {";"c}) 'Dim trimChar() As Char = New Char() {";"c} 'sLigneFaits = sLigneFaits.Trim(trimChar) If sLigneFaits.IndexOf(";") > -1 Then MsgBox("Le signe ';' n'est pas permis dans le nom de la session" & _ " pour l'exportation compatible Turbo-Expert 1.2", _ MsgBoxStyle.Exclamation) Exit Sub End If sLigneFaits &= ";" Else sw.WriteLine("") sw.WriteLine(sSeparation) sw.WriteLine("Session : " & oSession.sSession) If oSession.sDescription <> "" Then _ sw.WriteLine("Descrip.: " & oSession.sDescription) End If If Not m_oBF.bChargerFaitsInitiauxSession(oSession.colFaits) Then Exit Sub Dim de As DictionaryEntry Dim iPasse% For iPasse = 0 To 1 For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) Dim sVar$ = var.sVariable If m_oDico.bIntermediaire(sVar) Then GoTo VarSuivante ' D'abord les variables de configuration, puis les autres If Not ((iPasse = 0 And m_oDico.bConfig(sVar)) Or _ (iPasse = 1 And Not m_oDico.bConfig(sVar))) Then GoTo VarSuivante Dim sValFait$ = "", sRem$ = "", rFiabFait! = rCodeFiabIndefini Dim sDescrVar$ = var.sDescription If Not m_oBF.bVarExisteDansBF(sVar) Then If Not m_oDico.bConfig(sVar) Then GoTo Valeur sValFait = m_oDico.sValDefVar(sVar) If sValFait = "" Then sValFait = sValConfigDefautModeFichier rFiabFait = m_oDico.rFiabDef(sVar) Else ' L'ordre du dico n'est pas forcément celui des faits Dim prem As clsDico.TPremisse = m_oBF.fait(sVar) sValFait = prem.sValDebut If prem.sDateOrig <> "" Then sValFait = prem.sDateOrig End If If sValFait <> "" Then ' Suppression des guillemets If sValFait.Chars(0) = sGm Then sValFait = sValFait.Substring(1) End If If sValFait.Chars(sValFait.Length - 1) = sGm Then sValFait = sValFait.Substring(0, _ sValFait.Length - 1) End If End If sRem = prem.sRemarque rFiabFait = prem.rFiab End If If Not bCompatibleTurboExpert Then If sValFait = "" And m_oDico.bConfig(sVar) Then GoTo VarSuivante If sValFait = "" Then sValFait = "?" Dim sFiab$ = "" If rFiabFait <> rCodeFiabIndefini Then _ sFiab = " (" & Format(rFiabFait, sFormatFiabRapport) & ")" sw.WriteLine(sVar & " = " & sValFait & sFiab) If sDescrVar <> "" Then _ sw.WriteLine("Descrip. : " & sDescrVar) If sRem <> "" Then _ sw.WriteLine("Remarque : " & sRem) : sw.WriteLine("") End If Valeur: sLigneFaits &= sValFait & ";" VarSuivante: Next de : Next iPasse If bCompatibleTurboExpert Then sw.WriteLine(sLigneFaits) Next oSession sw.WriteLine("") End Sub Friend Sub ArchivageApplication(ByVal lbApplications As ListBox) ' Lancer la page html de gestion de l'archivage : ' elle contient le contrôle ActiveX DBToFile.ocx ' et l'IdApplication est passé en argument If Not clsUtil.bCleRegistreExiste(clsVBBBox.sCleRegistreDBToFile) Then Dim sRequis$ = "Pour pouvoir archiver et importer des applications," & _ vbLf & "VBBrainBox a besoin de l'utilitaire DBToFile" & vbLf Dim sRepertoireDll$ = Application.StartupPath & _ clsVBBBox.sRepertoireApplications Dim sCheminDBToFile$ = sRepertoireDll & "\" & clsVBBBox.sFichierDBToFile Dim sInfo$ If Not File.Exists(sCheminDBToFile) Then sInfo = sRequis & "Or DBToFile n'a pas été trouvé :" & vbLf & _ sCheminDBToFile & vbLf & _ "Vous devez le télécharger depuis :" & vbLf & _ "http://patrice.dargenton.free.fr/ia/vbbrainbox/dbtofile.zip" & _ vbLf & "Retrouvez ce lien dans la documentation : VBBrainBox.html" MsgBox(sInfo, MsgBoxStyle.Information) Exit Sub End If sInfo = sRequis & _ "Voulez-vous inscrire DBToFile.ocx dans la base de registre ?" Dim iReponse% = MsgBox(sInfo, _ MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question) If iReponse <> MsgBoxResult.Yes Then Exit Sub If Not clsUtil.bEnregistrerDllActiveX(clsVBBBox.sFichierDBToFile, _ sRepertoireDll, bDesenregistrer:=False, bConfirmer:=False) Then _ Exit Sub End If Dim sArg$ = "" If lbApplications.SelectedIndex >= 0 Then Dim drw As DataRowView = CType(lbApplications.Items( _ lbApplications.SelectedIndex), DataRowView) Dim iIdApplication% = CInt(drw.Item(0)) ' Colonne 0 sArg = "?IdApplication=" & iIdApplication End If Dim startInfo As New ProcessStartInfo("iexplore.exe") startInfo.Arguments = "file://" & Application.StartupPath & _ clsVBBBox.sRepertoireApplications & "\" & sPageArchivage & sArg startInfo.WindowStyle = ProcessWindowStyle.Normal Process.Start(startInfo) End Sub #End Region #Region "Présentation des tableaux" Private Sub FixerStyleTableauDico(ByRef dgVariables As DataGrid, _ ByVal bAfficherConst As Boolean) ' Modification du style du DataGrid passé en entrée : ' ajustement de la largeur des colonnes Dim dgts As New DataGridTableStyle() Dim dgtbc As New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 165 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpValDef dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 90 dgts.GridColumnStyles.Add(dgtbc) If bAfficherConst Then dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpConst dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 90 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFiab dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 0 If m_config.bLogiqueFloue Then dgtbc.Width = 35 dgts.GridColumnStyles.Add(dgtbc) End If Dim dgbc As New DataGridBoolColumn() dgbc.MappingName = sChpbConfig dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgbc = New DataGridBoolColumn() dgbc.MappingName = sChpbConst dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgbc = New DataGridBoolColumn() dgbc.MappingName = sChpbInterm dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgVariables.TableStyles.Clear() dgVariables.TableStyles.Add(dgts) End Sub Private Sub FixerStyleTableauRegles(ByRef dgRegles As DataGrid) ' Modification du style du DataGrid passé en entrée : ' ajustement de la largeur des colonnes Dim dgts As New DataGridTableStyle() Dim dgtbc As New DataGridTextBoxColumn() dgtbc.MappingName = sChpRegle dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 55 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFiab dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 0 If m_config.bLogiqueFloue Then dgtbc.Width = 35 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 135 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpOp dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 25 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVal dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 75 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar2 dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 90 dgts.GridColumnStyles.Add(dgtbc) Dim dgbc As New DataGridBoolColumn() dgbc.MappingName = sChpbConcl dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgbc = New DataGridBoolColumn() dgbc.MappingName = sChpbInterm dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgRegles.TableStyles.Clear() dgRegles.TableStyles.Add(dgts) End Sub Private Sub FixerStyleTableauFaits(ByRef dgFaits As DataGrid, _ ByVal bAfficherConstantes As Boolean) ' Modification du style du DataGrid passé en entrée : ' ajustement de la largeur des colonnes Dim dgts As New DataGridTableStyle() Dim dgtbc As New DataGridTextBoxColumn() dgtbc.MappingName = sChpSession dgtbc.HeaderText = "Session" 'dgtbc.MappingName dgtbc.Width = 100 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 180 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpOp dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 25 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVal dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 75 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar2 dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 100 dgts.GridColumnStyles.Add(dgtbc) If bAfficherConstantes Then dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = "Constante" dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 95 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFiab dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 0 If m_config.bLogiqueFloue Then dgtbc.Width = 35 dgts.GridColumnStyles.Add(dgtbc) End If dgFaits.TableStyles.Clear() dgFaits.TableStyles.Add(dgts) End Sub Private Sub FixerStyleTableauBilan(ByRef dgBilanSession As DataGrid) ' Modification du style du DataGrid passé en entrée : ' ajustement de la largeur des colonnes Dim dgts As New DataGridTableStyle() Dim dgtbc As New DataGridTextBoxColumn() dgtbc.MappingName = sChpVar dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 110 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpDebut dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 100 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFiabOrig dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 0 If m_config.bLogiqueFloue Then dgtbc.Width = 35 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFin dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 100 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpFiab dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 0 If m_config.bLogiqueFloue Then dgtbc.Width = 35 dgts.GridColumnStyles.Add(dgtbc) dgtbc = New DataGridTextBoxColumn() dgtbc.MappingName = sChpRegle dgtbc.HeaderText = dgtbc.MappingName dgtbc.Width = 75 dgts.GridColumnStyles.Add(dgtbc) Dim dgbc As New DataGridBoolColumn() dgbc.MappingName = sChpbInterm dgbc.HeaderText = dgbc.MappingName dgbc.Width = 40 dgts.GridColumnStyles.Add(dgbc) dgBilanSession.TableStyles.Clear() dgBilanSession.TableStyles.Add(dgts) End Sub #End Region End Class End Namespace clsBF.vb ' Fichier clsBF.vb ' ---------------- Option Strict On Option Explicit On Namespace VBBrainBox ' Utile si plusieurs projets sont intégrés Friend Class clsBF ' D'après le fichier d'origine en VB6 : ' BF ' ------------------------------------------------------------ ' Module Base de Faits pour Turbo-EXPERT ' (c) Philippe LARVET Avril 96 ' Nouvelle version du 8 juillet 96 ' ------------------------------------------------------------ ' Version reprise en VB6 - fin mai 02 ' ------------------------------------------------------------ #Region "Déclarations et initialisations" Friend m_colFaits As Hashtable Friend m_colFaitsI As New Collection() ' Faits initiaux Friend m_colFaitsIJustes As New Collection() ' Faits initiaux justes Friend m_iNbFaitsInitiauxDefinis% Private m_oBR As clsBR Private m_oDico As clsDico Private m_colCR As Specialized.StringCollection Friend m_config As clsVBBBox.TConfig ' Sert seulement pour valider le test des chaînes Private Const iCodeChaine% = -1 Friend Sub New(ByVal oBR As clsBR, ByVal oDico As clsDico, _ ByVal colCR As Specialized.StringCollection) m_oBR = oBR m_oDico = oDico m_colCR = colCR End Sub Private Sub AjouterMsg(ByVal sMessage$) m_colCR.Add(sMessage) End Sub #End Region #Region "Gestion des faits initiaux" Friend Function bChargerFaitsInitiauxSession( _ ByVal colFaits As Collection) As Boolean ' Charger les faits initiaux de la session m_colFaits = New Hashtable() Dim structfait As clsVBBBox.TFait ' Première façon d'énumérer la collection de type Hashtable 'Dim myEnumerator As IDictionaryEnumerator = myHashTable.GetEnumerator() 'While myEnumerator.MoveNext() ' myEnumerator.Key, myEnumerator.Value 'End While ' Seconde façon peut être un peu plus élégante Dim de As DictionaryEntry For Each de In m_oDico.m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) ' Pour les variables intermédiaires, on ne peut préjuger ' de leur valeur initiale que s'il y a une valeur par défaut ' dans le dictionnaire If m_oDico.bIntermediaire(var.sVariable) Then GoTo VarSuivante If m_oDico.sValDefVar(var.sVariable) = "" Then GoTo VarSuivante ' Stockage de la variable (chargement du fait dans la BF) Dim fait As clsDico.TPremisse = Nothing fait.sVar = var.sVariable fait.sVar2 = "" ' AAA fait.oper = clsDico.TOper.Egal '"=" fait.sVal = m_oDico.sValDefVar(var.sVariable) If fait.sVal <> "" AndAlso _ fait.sVal.Chars(0) = sGm Then _ fait.type = clsDico.TTypeVar.Chaine fait.sValDebut = fait.sVal fait.sRegleApp = "" fait.sReglesApp = "" Dim rFiabl! = m_oDico.rFiabDef(var.sVariable) fait.rFiab = m_oDico.rFiabDef(var.sVariable) fait.rFiabOrig = fait.rFiab fait.sRemarque = "" Dim sCle$ = var.sVariable m_colFaits.Add(sCle, fait) ' Hashtable VarSuivante: Next de For Each structfait In colFaits If Not m_oDico.bVarExiste(structfait.sVar) Then AjouterMsg("Erreur : variable inconnue : " & structfait.sVar) Return False End If If m_oDico.bIntermediaire(structfait.sVar) Then AjouterMsg("Erreur : " & structfait.sVar & _ " : les variables intermédiaires") AjouterMsg("ne peuvent être initialisées comme les faits initiaux") Return False End If ' Définition d'un fait à indéfini pour pouvoir changer ' la valeur par défaut de la variable If structfait.sVal = "?" Then If m_oDico.sValDefVar(structfait.sVar) = "" Then GoTo FaitSuivant ' On retire le fait m_colFaits.Remove(structfait.sVar) GoTo FaitSuivant End If Dim fait As clsDico.TPremisse fait.sVar2 = "" fait.oper = clsDico.TOper.Egal fait.sVal = structfait.sVal Dim rFiabl! = structfait.rFiab fait.rFiab = structfait.rFiab fait.rFiabOrig = fait.rFiab fait.sDateOrig = "" Dim StrVal$ = structfait.sVal If InStr(StrVal, "/") > 0 Then 'ici c'est une date fait.sDateOrig = StrVal If Not clsUtil.bInverserDate(StrVal) Then AjouterMsg("Erreur dans la session, variable : " & structfait.sVar & " :") AjouterMsg("Date invalide : " & StrVal) Return False End If ' On considère une date comme un numérique fait.type = clsDico.TTypeVar.Numerique Else Dim sCar$ = Left(StrVal, 1) Dim j% = InStr("0123456789-", sCar) If j > 0 Then fait.type = clsDico.TTypeVar.Numerique Else ' C'est une chaîne ; on lui rajoute des " si elle n'en a pas If sCar <> sGm Then StrVal = sGm & StrVal & sGm fait.type = clsDico.TTypeVar.Chaine End If End If fait.sVal = StrVal fait.sVar = structfait.sVar fait.sValDebut = fait.sVal ' Pour le bilan fait.sRegleApp = "" fait.sReglesApp = "" fait.sRemarque = structfait.sRemarque ' Gestion de la configuration Dim sNomVar$ = structfait.sVar Dim sVal$ = fait.sVal bGestionConfig(sNomVar, sVal, m_config) Dim sCle$ = sNomVar If bVarExisteDansBF(sNomVar) Then ' Modification du fait par rapport à sa valeur par défaut m_colFaits.Item(sCle) = fait Else ' Ajout du fait m_colFaits.Add(sCle, fait) End If FaitSuivant: Next structfait m_iNbFaitsInitiauxDefinis = 0 For Each de In m_colFaits Dim prem As clsDico.TPremisse = CType(de.Value, clsDico.TPremisse) If m_oDico.bConfig(prem.sVar) Then GoTo PremisseSuivante Dim StrFait$ = m_oDico.sComposerHypothese(prem) Dim sFiab$ = "" If prem.rFiab <> clsVBBBox.rCodeFiabIndefini Then _ sFiab = " (" & Format(prem.rFiab, clsVBBBox.sFormatFiab) & ")" StrFait &= sFiab m_colFaitsI.Add(StrFait) If prem.sVal <> "" And prem.sVal <> clsUtil.sFaux Then If Not m_oDico.bConstante(prem.sVar) Then m_colFaitsIJustes.Add(StrFait) End If End If If prem.sVal <> "" Then m_iNbFaitsInitiauxDefinis += 1 PremisseSuivante: Next de bChargerFaitsInitiauxSession = True End Function Friend Function bGestionConfig(ByVal sVarConfig$, ByVal sValeurDef$, _ ByRef config As clsVBBBox.TConfig) As Boolean ' Gestion de la configuration bGestionConfig = True Select Case sVarConfig Case clsVBBBox.sConf_bLogiqueNonMonotone config.bLogiqueNonMonotone = clsUtil.bValeurNulleOuVrai(sValeurDef) Case clsVBBBox.sConf_bAutoriserReglesContr config.bAutoriserReglesContradictoires = clsUtil.bValeurNulleOuVrai(sValeurDef) Case clsVBBBox.sConf_bLogiqueFloue config.bLogiqueFloue = clsUtil.bValeurNulleOuVrai(sValeurDef) Case clsVBBBox.sConf_bLogiqueFloueInterpretee config.bLogiqueFloueInterpretee = clsUtil.bValeurNulleOuVrai(sValeurDef) If config.bLogiqueFloueInterpretee Then config.bLogiqueFloue = True Case Else bGestionConfig = False End Select End Function #End Region #Region "Interrogation de la base de faits" Friend Function bVarExisteDansBF(ByVal sVar$) As Boolean bVarExisteDansBF = m_colFaits.ContainsKey(sVar) End Function Friend Function fait(ByVal sVar$) As clsDico.TPremisse fait = CType(m_colFaits.Item(sVar), clsDico.TPremisse) End Function Friend Function bTrouverVar(ByVal R%, ByVal P%, ByRef sFait$) As Boolean ' Retourner True s'il existe un fait de la BF de même nom de variable ' que celui de Premisse n° P de la règle R (retourner aussi la variable) Dim de As DictionaryEntry For Each de In m_colFaits Dim prem As clsDico.TPremisse = CType(de.Value, clsDico.TPremisse) If prem.sVar = m_oBR.m_aRegles(R).aPremisses(P).sVar Then _ sFait = prem.sVar : Return True Next de Return False End Function Friend Function bExisteDansBF(ByRef zon As clsDico.TPremisse, ByRef sFait$) _ As Boolean ' Vérifier si une prémisse ou une conclusion existe déjà ' telle quelle dans la BF : si oui, renvoyer le Fait Dim de As DictionaryEntry For Each de In m_colFaits Dim prem As clsDico.TPremisse = CType(de.Value, clsDico.TPremisse) If prem.sVar = zon.sVar And prem.oper = zon.oper Then _ sFait = prem.sVar : Return True Next de Return False End Function Friend Function bVerifieeDansBF(ByRef zon As clsDico.TPremisse) As Boolean ' Contrôler si une prémisse ou une conclusion est vérifiée dans la BF Dim de As DictionaryEntry For Each de In m_colFaits Dim prem As clsDico.TPremisse = CType(de.Value, clsDico.TPremisse) If prem.sVar = zon.sVar And _ prem.oper = zon.oper And _ prem.sVal = zon.sVal Then Return True Next de Return False End Function #End Region #Region "Vérification d'une prémisse de la BR dans la BF" Friend Function bPremisseVraieDansBF(ByVal R%, ByVal P%, ByVal sFait$, _ ByRef rMinFiab!, ByRef rFiabFait!) As Boolean ' Vérifier si une prémisse de la BR est vérifiée dans la BF '--------------------------------------------------------- ' On procède à des changements de variables : ' opérateur du fait -> opFait ' valeur num du fait (fait.Valeur) -> iValFait si Valeur numérique ' valeur str du fait (fait.Valeur) -> sValFait si Valeur string ' valeur num de la prém. (Premisse(R,P).Valeur) -> iValPremisse si num ' valeur str de la prém. (Premisse(R,P).Valeur) -> sValPremisse si str ' Une fonction spécifique permet de déterminer iValPremisse ' au cas où sa valeur est dans une autre variable : ' (exemple : "si max_débits > moyenne") '--------------------------------------------------------- 'rMinFiab : si un fait à une fiab < à rMinFiab, on met à jour rMinFiab Dim fait As clsDico.TPremisse = _ CType(m_colFaits.Item(sFait), clsDico.TPremisse) Dim opFait As clsDico.TOper = fait.oper Dim sValFait$ = fait.sVal Dim sValPremisse$ = m_oBR.m_aRegles(R).aPremisses(P).sVal Dim bPremisseVerifiable As Boolean Dim iValPremisse% = iLireValeurPremisse(R, P, bPremisseVerifiable) If Not bPremisseVerifiable Then Return False Dim bFaitVerifiable As Boolean Dim iValFait% = iValeurFait(sFait, bFaitVerifiable) If Not bFaitVerifiable Then Return False Dim opPremisse As clsDico.TOper = m_oBR.m_aRegles(R).aPremisses(P).oper rFiabFait = fait.rFiab ' Ce cas ne peut jamais arriver : ' - au départ, toutes les fiab. sont >= 0 dans VBBrainBox.mdb ; ' - en mode logique floue non interpretée, ' on ne change pas le cours de l'expertise ; ' - en mode logique floue interpretée, toutes les fiab. ' sont remises en >= 0 et les faits sont changés 'If rFiabFait < 0 And rFiabFait <> clsVBBBox.rCodeFiabIndefini Then ' If sValFait = clsUtil.sVrai Then ' sValFait = clsUtil.sFaux : rFiabFait *= -1 ' ElseIf sValFait = clsUtil.sFaux Then ' sValFait = clsUtil.sVrai : rFiabFait *= -1 ' End If 'End If bPremisseVraieDansBF = bExaminerPremisse( _ iValPremisse, iValFait, sValPremisse, sValFait, _ opPremisse, opFait) If Not bPremisseVraieDansBF Then Exit Function If rFiabFait <> clsVBBBox.rCodeFiabIndefini And m_config.bLogiqueFloue Then If rMinFiab = clsVBBBox.rCodeFiabIndefini Then rMinFiab = rFiabFait Else ' Si la loqique floue n'est pas interprétée, les fiab. peuvent ' être négatives, cela n'aurait pas de sens d'inverser toute ' la fiabilité du résultat de la règle pour une seule prémisse < 0 ' on calcule donc en valeur absolue If Math.Abs(rFiabFait) < rMinFiab Then rMinFiab = Math.Abs(rFiabFait) End If End If End Function Private Function iLireValeurPremisse%(ByVal R%, ByVal P%, _ ByRef bPremisseVerifiable As Boolean) ' Cette fonction intérroge la BR et la BF iLireValeurPremisse = 0 ' Test s'il n'y a pas de seconde variable If m_oBR.m_aRegles(R).aPremisses(P).type <> clsDico.TTypeVar.Reference Then ' Valeur est numérique If m_oBR.m_aRegles(R).aPremisses(P).type = clsDico.TTypeVar.Numerique Then iLireValeurPremisse = CInt(Val(m_oBR.m_aRegles(R).aPremisses(P).sVal)) Else ' Valeur est une string iLireValeurPremisse = iCodeChaine End If Else ' On recherche dans la BF si la référence (seconde variable) ' peut être remplacée par sa valeur dans la BF Dim sVar2$ = m_oBR.m_aRegles(R).aPremisses(P).sVar2 If bVarExisteDansBF(sVar2) Then iLireValeurPremisse = iValeurFait(sVar2, bPremisseVerifiable) If Not bPremisseVerifiable Then Exit Function Else ' La prémisse n'est plus vérifiable (= plus valide) ' dès lors qu'il y a bien une seconde variable, mais ' que celle-ci n'a pas de valeur affectée dans la BF bPremisseVerifiable = False : Exit Function End If End If bPremisseVerifiable = True End Function Private Function iValeurFait%(ByVal sVar$, ByRef bFaitVerifiable As Boolean) iValeurFait = 0 Dim prem As clsDico.TPremisse = _ CType(m_colFaits.Item(sVar), clsDico.TPremisse) If prem.type = clsDico.TTypeVar.Numerique Then If prem.sVal = "" Then Exit Function iValeurFait = CInt(Val(prem.sVal)) Else ' Valeur est une string iValeurFait = iCodeChaine End If bFaitVerifiable = True End Function Private Function bExaminerPremisse(ByVal iValPremisse%, ByVal iValFait%, _ ByVal sValPremisse$, ByVal sValFait$, _ ByVal opPremisse As clsDico.TOper, _ ByVal opFait As clsDico.TOper) As Boolean Dim bRes As Boolean = False Select Case opPremisse Case clsDico.TOper.Egal bRes = bEgal(iValPremisse, iValFait, sValPremisse, sValFait) Case clsDico.TOper.Sup Select Case opFait Case clsDico.TOper.Egal : bRes = bSuper(iValPremisse, iValFait) Case clsDico.TOper.Sup : bRes = bSupEgal(iValPremisse, iValFait) Case clsDico.TOper.SupEgal : bRes = bSupEgal(iValPremisse, iValFait) End Select Case clsDico.TOper.Inf Select Case opFait Case clsDico.TOper.Egal : bRes = bInfer(iValPremisse, iValFait) Case clsDico.TOper.Inf : bRes = bInfEgal(iValPremisse, iValFait) Case clsDico.TOper.InfEgal : bRes = bInfer(iValPremisse, iValFait) End Select Case clsDico.TOper.SupEgal Select Case opFait Case clsDico.TOper.Egal : bRes = bSupEgal(iValPremisse, iValFait) Case clsDico.TOper.Sup If (iValFait >= (iValPremisse - 1)) Then bRes = True Case clsDico.TOper.SupEgal : bRes = bSupEgal(iValPremisse, iValFait) End Select Case clsDico.TOper.InfEgal Select Case opFait Case clsDico.TOper.Egal : bRes = bInfEgal(iValPremisse, iValFait) Case clsDico.TOper.Inf If (iValFait <= (iValPremisse + 1)) Then bRes = True Case clsDico.TOper.InfEgal : bRes = bInfEgal(iValPremisse, iValFait) End Select Case clsDico.TOper.Different Select Case opFait Case clsDico.TOper.Egal bRes = bDiff(iValPremisse, iValFait, sValPremisse, sValFait) Case clsDico.TOper.Sup : bRes = bSupEgal(iValPremisse, iValFait) Case clsDico.TOper.Inf : bRes = bInfEgal(iValPremisse, iValFait) Case clsDico.TOper.SupEgal : bRes = bSuper(iValPremisse, iValFait) Case clsDico.TOper.InfEgal : bRes = bInfer(iValPremisse, iValFait) Case clsDico.TOper.Different bRes = bEgal(iValPremisse, iValFait, sValPremisse, sValFait) End Select End Select bExaminerPremisse = bRes End Function Private Function bEgal(ByVal iValPremisse%, ByVal iValFait%, _ ByVal sValPremisse$, ByVal sValFait$) As Boolean If iValFait = iValPremisse And sValFait = sValPremisse Then Return True Return False End Function Private Function bSuper(ByVal iValPremisse%, ByVal iValFait%) As Boolean If iValFait > iValPremisse Then Return True Return False End Function Private Function bInfer(ByVal iValPremisse%, ByVal iValFait%) As Boolean If iValFait < iValPremisse Then Return True Return False End Function Private Function bSupEgal(ByVal iValPremisse%, ByVal iValFait%) As Boolean If iValFait >= iValPremisse Then Return True Return False End Function Private Function bInfEgal(ByVal iValPremisse%, ByVal iValFait%) As Boolean If iValFait <= iValPremisse Then Return True Return False End Function Private Function bDiff(ByVal iValPremisse%, ByVal iValFait%, _ ByVal sValPremisse$, ByVal sValFait$) As Boolean If iValFait <> iValPremisse Or sValPremisse <> sValFait Then Return True Return False End Function #End Region #Region "Ajout et modification d'un fait" Friend Sub AjouterFait(ByVal R%, ByVal C%, ByVal rMinFiab!, ByRef rFiab!) ' Ajouter un fait dans la BF Dim fait As clsDico.TPremisse fait = m_oBR.m_aRegles(R).aConclusions(C) Dim sVar$ = fait.sVar Dim sRegle$ = m_oBR.m_aRegles(R).sRegle fait.sRegleApp = sRegle If fait.sReglesApp = "" Then fait.sReglesApp = sRegle Else fait.sReglesApp &= ", " & sRegle End If Dim sRegleApp$ = fait.sRegleApp Dim sReglesApp$ = fait.sReglesApp Dim rFiabRegle! = m_oBR.m_aRegles(R).rFiab If rFiabRegle = clsVBBBox.rCodeFiabIndefini And _ rMinFiab = clsVBBBox.rCodeFiabIndefini Then rFiab = clsVBBBox.rCodeFiabIndefini Else If rFiabRegle = clsVBBBox.rCodeFiabIndefini Then rFiabRegle = 1 If rMinFiab = clsVBBBox.rCodeFiabIndefini Then rMinFiab = 1 ' Formule de Mycin (1975) ' Si on déduit un fait par une règle à partir de plusieurs faits ' alors la fiabilité de ce nouveau fait est le produit ' de la fiabilité de la règle par le min. des fiabilités des faits rFiab = rFiabRegle * rMinFiab End If fait.rFiab = rFiab fait.rFiabOrig = clsVBBBox.rCodeFiabIndefini Dim sCle$ = sVar m_colFaits.Add(sCle, fait) End Sub Friend Function bMAJFait(ByVal sFait$, ByVal R%, ByVal C%, _ ByVal rMinFiab!, ByRef sMajFiab$, ByRef sErr$) As Boolean ' Mettre à jour un fait dans la BF Dim fait As clsDico.TPremisse = _ CType(m_colFaits.Item(sFait), clsDico.TPremisse) Dim sMemValDebut$ = fait.sValDebut Dim sMemVal$ = fait.sVal Dim sMemRegleApp$ = fait.sRegleApp Dim sVal$ = m_oBR.m_aRegles(R).aConclusions(C).sVal Dim sVar$ = m_oBR.m_aRegles(R).aConclusions(C).sVar sErr = "" If sVal <> sMemVal And sMemVal <> "" Then Dim sAvert$ = "Règle " & m_oBR.m_aRegles(R).sRegle & vbCrLf sAvert &= "Variable : " & sVar & " : " & _ sVal & " <> " & sMemVal If m_config.bLogiqueNonMonotone Then sErr = "Attention : Logique non monotone :" & vbCrLf sErr &= "La variable " & sVar & vbCrLf sErr &= "possèdent une valeur par défaut : " & _ sMemValDebut & vbCrLf sErr &= sAvert & vbCrLf Else sErr = "Erreur : En logique monotone, un fait défini" & vbCrLf sErr &= "dans la session ou par défaut ou bien déduit" & vbCrLf sErr &= "ne peut pas changer de valeur" & vbCrLf sErr &= sAvert & vbCrLf sErr &= "Solution : n'initialisez par la variable," & vbCrLf sErr &= "ou bien vérifiez les règles," & vbCrLf sErr &= "ou alors passez en logique non monotone :" & vbCrLf sErr &= "ajoutez Config_bLogiqueNonMonotone dans les variables" & vbCrLf Return False End If End If Dim rAncFiab! = fait.rFiab fait = MAJPremisse(m_oBR.m_aRegles(R).aConclusions(C), fait) Dim sRegleApp$ = m_oBR.m_aRegles(R).sRegle If fait.sReglesApp = "" Then fait.sReglesApp = sRegleApp Else fait.sReglesApp &= ", " & sRegleApp End If ' Si double changement de val du fait depuis la val de début : contrad. If sMemVal <> fait.sVal And sMemVal <> sMemValDebut Then sErr = "Il y a une contradiction entre la règle " & _ m_oBR.m_aRegles(R).sRegle & vbCrLf sErr &= "et la règle " & sMemRegleApp & vbCrLf sErr &= "Variable : " & fait.sVar & " : " & _ fait.sVal & " <> " & sMemVal If m_config.bAutoriserReglesContradictoires Then sErr = "Attention : " & sErr & vbCrLf sErr &= "Dans ce cas, le simple chaînage avant en régime irrévocable" & vbCrLf sErr &= "peut être insuffisant à trouver tous les faits déductibles" & vbCrLf Else sErr = "Erreur : " & sErr Return False End If End If sMajFiab = "" Dim rFiab! Dim rFiabRegle! = m_oBR.m_aRegles(R).rFiab If rFiabRegle = clsVBBBox.rCodeFiabIndefini And _ rMinFiab = clsVBBBox.rCodeFiabIndefini And _ rAncFiab = clsVBBBox.rCodeFiabIndefini Then rFiab = clsVBBBox.rCodeFiabIndefini Else If rFiabRegle = clsVBBBox.rCodeFiabIndefini Then rFiabRegle = 1 If rMinFiab = clsVBBBox.rCodeFiabIndefini Then rMinFiab = 1 Dim rNouvFiab! = rFiabRegle * rMinFiab Dim bFiabCompatibles As Boolean Dim bInverserFiab As Boolean ' Vérification de la valeur des faits : les règles de Mycin ' ne marchent que si les faits ne changent pas de valeur ; ' et pour les booléens, il faut intégrer le fait que Faux ' est le contraire de Vrai If (sMemVal = clsUtil.sVrai And fait.sVal = clsUtil.sFaux) Or _ (sMemVal = clsUtil.sFaux And fait.sVal = clsUtil.sVrai) Then bInverserFiab = True bFiabCompatibles = True ElseIf sMemVal = fait.sVal Then bFiabCompatibles = True 'Else ' ToDo : construire une liste de valeurs, et calculer les fiabilités ' pour chacune d'entre elles : faire une classe clsValeur End If If rAncFiab = clsVBBBox.rCodeFiabIndefini Then bFiabCompatibles = False If Not bFiabCompatibles Then rFiab = rNouvFiab Else ' Formules associatives de MYCIN (1975) ' Si un fait reçoit plusieurs fiabilités, on les combine 'http://www.computing.surrey.ac.uk/research/ai/PROFILE/mycin.html If bInverserFiab Then rAncFiab *= -1 If rAncFiab >= 0 And rNouvFiab >= 0 Then rFiab = rAncFiab + rNouvFiab - rAncFiab * rNouvFiab ElseIf rAncFiab < 0 And rNouvFiab < 0 Then ' Ce cas ne se produit pas car rFiabRegle >= 0 et ' rMinFiab >= 0 donc rNouvFiab >= 0 rFiab = rAncFiab + rNouvFiab + rAncFiab * rNouvFiab Else rFiab = (rAncFiab + rNouvFiab) / _ (1 - Math.Min(Math.Abs(rAncFiab), _ Math.Abs(rNouvFiab))) End If End If sMajFiab = "(" & Format(rFiab, clsVBBBox.sFormatFiab) & ")" If m_config.bLogiqueFloueInterpretee And rFiab < 0 And _ (fait.sVal = clsUtil.sFaux Or fait.sVal = clsUtil.sVrai) Then sErr = "Logique floue interprétée : le fait : " & vbCrLf & _ fait.sVar & " = " & fait.sVal & " (" & _ Format(rFiab, clsVBBBox.sFormatFiab) & ")" sMajFiab = "(" & Format(rFiab, clsVBBBox.sFormatFiab) & ") -> " rFiab *= -1 If fait.sVal = clsUtil.sFaux Then fait.sVal = clsUtil.sVrai Else fait.sVal = clsUtil.sFaux End If sErr &= " devient : " & vbCrLf & _ fait.sVar & " = " & fait.sVal & " (" & _ Format(rFiab, clsVBBBox.sFormatFiab) & ")" & vbCrLf sMajFiab &= fait.sVal & " (" & _ Format(rFiab, clsVBBBox.sFormatFiab) & ")" End If End If fait.rFiab = rFiab If rFiab = clsVBBBox.rCodeFiabIndefini Then sMajFiab = "" ' sRegleApp n'est plus utilisée dans le bilan, on affiche toutes les ' règles appliquées, on conserve quand même sRegleApp dans le cas ' de grosses applications où il faudra limiter les infos. If m_config.bLogiqueFloue Then ' On mémorise la règle la plus utile If rFiab >= rAncFiab Then fait.sRegleApp = m_oBR.m_aRegles(R).sRegle ' La nouvelle Else fait.sRegleApp = sMemRegleApp ' L'ancienne End If Else ' On mémorise la dernière règle appliquée fait.sRegleApp = m_oBR.m_aRegles(R).sRegle End If Dim sCle$ = sFait m_colFaits.Item(sCle) = fait bMAJFait = True End Function Private Function MAJPremisse(ByRef premNouv As clsDico.TPremisse, _ ByRef premActuelle As clsDico.TPremisse) As clsDico.TPremisse MAJPremisse = premActuelle ' Conservation des champs actuels MAJPremisse.sVar = premNouv.sVar ' Mise à jour des nouveaux champs MAJPremisse.sVal = premNouv.sVal End Function #End Region End Class End Namespace clsBR.vb ' Fichier clsBR.vb ' ---------------- Option Strict On Option Explicit On Namespace VBBrainBox ' Utile si plusieurs projets sont intégrés Friend Class clsBR ' D'après le fichier d'origine en VB6 : ' BR ' ------------------------------------------------------------ ' Module Base de Règles pour Turbo-EXPERT ' (c) Philippe LARVET Avril 96 ' Nouvelle version du 27 mai ' ------------------------------------------------------------ ' Version VB6 mai 02 ' ------------------------------------------------------------ #Region "Déclarations et initialisations" ' Structures de données de la BR : Friend Structure THypothese ' Hypothèse ou conclusion de règle Dim sRegle$, sVar$, sVal$, sOp$ Dim bConclusion As Boolean Dim rFiabRegle! End Structure Friend Structure TRegle Dim aPremisses() As clsDico.TPremisse Dim aConclusions() As clsDico.TPremisse ' Booléen pour indiquer si la règle a déjà été utiliée Dim bDeduction As Boolean Dim sRegle$ ' Nom de la règle Dim rFiab! End Structure Friend m_aRegles() As TRegle ' ToDo : Utiliser une Collection : + simple Friend m_iNbRegles As Integer ' Fin des Structures de données de la BR ' Données pour le chargement de la BR en mode fichier : Private m_iNbPremisses%, m_iNbConclusions% Private m_bErr As Boolean, m_sErr$ Private m_oDico As clsDico Private m_colCR As Specialized.StringCollection Friend Sub New(ByVal oDico As clsDico, _ ByVal colCR As Specialized.StringCollection) ' Note : en VB .NET, il n'est plus nécessaire de passer les objets par ' reférence. De plus, le ByVal est plus rapide (même pour les objets), ' ce qui n'est pas le cas en VB6. Explication : en VB .NET ' si on utilise ByVal, l'objet est copié une fois, mais il est copié ' 2 fois dans le cas du ByRef, dixit VB.NET Professionnel de Wrox Team m_oDico = oDico m_colCR = colCR End Sub Private Sub AjouterMsg(ByVal sMessage$) m_colCR.Add(sMessage) End Sub Friend Sub InitDeductions() Dim R% For R = 1 To m_iNbRegles m_aRegles(R).bDeduction = False Next R End Sub Friend Sub Initialiser() ' Init BR avant chargement d'une nouvelle BR m_iNbRegles = 0 End Sub #End Region #Region "Gestion du mode base de données" Friend Function bBDChargerBR(ByVal colRegles As Collection) As Boolean Initialiser() Dim hyp As THypothese Dim prem As clsDico.TPremisse Dim sMemRegle$ = "" m_bErr = False Dim iNbPremisses%, iNbConclusions% For Each hyp In colRegles If hyp.sRegle <> sMemRegle Then sMemRegle = hyp.sRegle m_iNbRegles += 1 ReDim Preserve m_aRegles(m_iNbRegles) m_aRegles(m_iNbRegles).sRegle = hyp.sRegle iNbConclusions = 0 iNbPremisses = 0 ReDim m_aRegles(m_iNbRegles).aConclusions(0) ReDim m_aRegles(m_iNbRegles).aPremisses(0) m_aRegles(m_iNbRegles).rFiab = hyp.rFiabRegle End If Select Case hyp.sOp Case ">=" : hyp.sOp = "G" Case "<=" : hyp.sOp = "L" Case "<>" : hyp.sOp = "D" End Select Select Case hyp.sVal Case "VRAI", "FAUX" : hyp.sVal = sGm & hyp.sVal & sGm End Select Dim sParam$ = hyp.sVar & " " & hyp.sOp & " " & hyp.sVal prem = m_oDico.DecomposerHypothese(sParam, m_bErr, m_sErr) If m_bErr Then Return False If hyp.bConclusion Then iNbConclusions += 1 ReDim Preserve m_aRegles(m_iNbRegles).aConclusions(iNbConclusions) m_aRegles(m_iNbRegles).aConclusions(iNbConclusions) = prem Else iNbPremisses += 1 ReDim Preserve m_aRegles(m_iNbRegles).aPremisses(iNbPremisses) m_aRegles(m_iNbRegles).aPremisses(iNbPremisses) = prem End If Next bBDChargerBR = True End Function #End Region #Region "Gestion du mode fichier" Friend Function bChargerBR(ByVal sCheminFichierBR$) As Boolean bChargerBR = False Initialiser() Dim sr As New IO.StreamReader(sCheminFichierBR, clsUtil.encodageVB6) Dim car$ = "" Dim iCar% = sr.Read() If iCar <> -1 Then car = Convert.ToChar(iCar) If car <> "R" Or iCar = -1 Then AjouterMsg("Ce fichier n'est pas une Base de Règles !") GoTo Fin End If ' Chargement de la BR Dim bPremisse As Boolean Dim sNumRegle$ = "." m_bErr = False Do Dim sEnreg$ = sr.ReadLine If sEnreg Is Nothing Then Exit Do sEnreg = RTrim(sEnreg) Dim iLenEnreg% = Len(sEnreg) car = Left(sEnreg, 1) Select Case car Case "R" : sNumRegle = Mid(sEnreg, 1, iLenEnreg) Case "s" If Left(sEnreg, 3) = "si " Then bPremisse = True ExtraireSi(sEnreg, sNumRegle) End If Case "e" If Left(sEnreg, 3) = "et " Then _ ExtraireEt(sEnreg, bPremisse) Case "a" If Left(sEnreg, 6) = "alors " Then bPremisse = False extraire_alors(sEnreg) End If Case "-" : sNumRegle = "." Case "=" : Exit Do End Select Loop While Not m_bErr bChargerBR = Not m_bErr If m_bErr Then AjouterMsg("Erreur Règle : " & sNumRegle) AjouterMsg(m_sErr) End If Fin: sr.Close() End Function Private Sub ExtraireSi(ByVal sEnreg$, ByVal sNumRegle$) m_iNbRegles += 1 ReDim Preserve m_aRegles(m_iNbRegles) m_aRegles(m_iNbRegles).rFiab = clsVBBBox.rCodeFiabIndefini m_iNbPremisses = 0 m_aRegles(m_iNbRegles).sRegle = sNumRegle Dim iLenEnreg% = Len(sEnreg) Dim sParam$ = Mid(sEnreg, 4, iLenEnreg - 3) StockerPremisse(sParam) End Sub Private Sub ExtraireEt(ByVal sEnreg$, ByVal bPremisse As Boolean) Dim iLenEnreg% = Len(sEnreg) Dim sParam$ = Mid(sEnreg, 4, iLenEnreg - 3) If bPremisse Then StockerPremisse(sParam) Else StockerConclusion(sParam) End If End Sub Private Sub extraire_alors(ByVal sEnreg$) m_iNbConclusions = 0 Dim iLenEnreg% = Len(sEnreg) Dim sParam$ = Mid(sEnreg, 7, iLenEnreg - 6) StockerConclusion(sParam) End Sub Private Sub StockerPremisse(ByVal sParam$) m_iNbPremisses += 1 ReDim Preserve m_aRegles(m_iNbRegles).aPremisses(m_iNbPremisses) m_aRegles(m_iNbRegles).aPremisses(m_iNbPremisses) = _ m_oDico.DecomposerHypothese(sParam, m_bErr, m_sErr) End Sub Private Sub StockerConclusion(ByVal sParam$) m_iNbConclusions += 1 ReDim Preserve m_aRegles(m_iNbRegles).aConclusions(m_iNbConclusions) m_aRegles(m_iNbRegles).aConclusions(m_iNbConclusions) = _ m_oDico.DecomposerHypothese(sParam, m_bErr, m_sErr) End Sub #End Region #Region "Traduction d'une règle appliquée en français" Friend Sub ExprimerRegleOk(ByVal iNumRegle%, ByVal bLogiqueFloue As Boolean, _ ByVal colFiab As Specialized.StringCollection, _ ByVal colFiabC As Specialized.StringCollection) Dim P%, C%, sLigne$ Dim iNbPremisses% = m_aRegles(iNumRegle).aPremisses.GetUpperBound(0) For P = 1 To iNbPremisses sLigne = m_oDico.sComposerHypothese(m_aRegles(iNumRegle).aPremisses(P)) If P = 1 Then sLigne = "si " & sLigne Else sLigne = "et " & sLigne If bLogiqueFloue Then Dim sFiab$ = colFiab(P - 1) Dim rFiab! = CSng(sFiab) If rFiab <> clsVBBBox.rCodeFiabIndefini Then _ sLigne &= " (" & sFiab & ")" End If AjouterMsg(sLigne) Next P Dim iNbConclusions% = m_aRegles(iNumRegle).aConclusions.GetUpperBound(0) For C = 1 To iNbConclusions sLigne = m_oDico.sComposerHypothese(m_aRegles(iNumRegle).aConclusions(C)) If C = 1 Then sLigne = "alors " & sLigne Else sLigne = "et " & sLigne If bLogiqueFloue Then If C <= colFiabC.Count Then Dim sFiab$ = colFiabC(C - 1) If sFiab <> "" Then sLigne &= " " & sFiab End If End If AjouterMsg(sLigne) Next C End Sub #End Region End Class End Namespace clsDico.vb ' Fichier clsDico.vb ' ------------------ Option Strict On Option Explicit On Namespace VBBrainBox ' Utile si plusieurs projets sont intégrés Friend Class clsDico ' D'après le fichier d'origine en VB6 : ' DicD ' ------------------------------------------------------------ ' Module Dictionnaire des libellés des variables des Règles ' (c) Philippe LARVET Avril 96 ' Nouvelle version du 27 mai 96 sans ptr (Pascal) ' ------------------------------------------------------------ ' Version VB6 mai 02 ' ------------------------------------------------------------ #Region "Déclarations et initialisations" Private m_asOper$() = {"=", ">", "<", ">=", "<=", "<>"} Private m_asOperCompatTE$() = {"=", ">", "<", "G", "L", "D"} Friend Enum TOper Egal ' = Sup ' > Inf ' < SupEgal ' >= InfEgal ' <= Different ' <> End Enum Friend Structure TVar Dim sVariable$, sValeurDef$, sConstante$, sDescription$ Dim bConst, bIntermediaire, bConfig As Boolean Dim rFiab! ' En mode fichier, on doit faire correspondre l'ordre des faits initiaux ' avec l'ordre de chargement du dico Dim iNumVar% End Structure Private m_iNbVariables% ' cf. TVar.iNumVar Friend m_iNbVarInitiales% Friend Enum TTypeVar Numerique ' Numérique ou date Chaine ' Chaîne de caractères Reference ' Référence à une variable ou une constante du dico End Enum Friend Structure TPremisse ' Type prémisse pour BR et BF Dim sVar$ ' Nom de la variable Dim oper As TOper 'opérateur de comparaison Dim sVal$ ' Valeur en String de la variable 1 Dim sVar2$ ' Seconde variable (référence) Dim sValDebut$ ' Valeur initiale de la variable 1, pour le bilan ' Dernière règle appliquée ayant entrainé une m.à.j. du fait Dim sRegleApp$ Dim sReglesApp$ ' Liste des règles appliquées Dim rFiab!, rFiabOrig! Dim sDateOrig$ ' Date dans le format d'origine pour l'exportation Dim type As TTypeVar Dim sRemarque$ ' Pour détailler la valeur du fait dans le rapport End Structure Friend m_colDico As Hashtable Private m_colCR As Specialized.StringCollection Friend Sub New(ByVal colCR As Specialized.StringCollection) m_colCR = colCR End Sub Private Sub AjouterMsg(ByVal sMessage$) m_colCR.Add(sMessage) End Sub #End Region #Region "Chargement du dictionnaire" Private Sub InitDico() m_colDico = New Hashtable() End Sub Friend Sub ChargerDico(ByVal colVar As Collection) InitDico() Dim var As TVar For Each var In colVar ' Valeur indéfinie If var.sValeurDef = "?" Then var.sValeurDef = "" ' C'est une chaîne ; on lui rajoute des " si elle n'en a pas var.sValeurDef = sTraiterGuillemets(var.sValeurDef) If var.sConstante <> "" Then If bVarExiste(var.sConstante) Then _ var.sValeurDef = sValDefVar(var.sConstante) End If Dim sCle$ = var.sVariable m_colDico.Add(sCle, var) Next var End Sub Friend Function sTraiterGuillemets$(ByVal sValeur$) ' Ajouter des " à la valeur si c'est une chaîne représentant ' une valeur non numérique et si ce n'est pas une date ("/") If sValeur <> "" AndAlso sValeur.Chars(0) <> sGm AndAlso _ (Not IsNumeric(sValeur)) AndAlso InStr(sValeur, "/") = 0 Then sTraiterGuillemets = sGm & sValeur & sGm Else sTraiterGuillemets = sValeur End If End Function Friend Function bChargerDico(ByVal sCheminDico$, _ ByRef colVar As Collection) As Boolean ' Charger le dictionnaire en mode fichier bChargerDico = False InitDico() Dim sr As New IO.StreamReader(sCheminDico, clsUtil.encodageVB6) Dim bVarInterm As Boolean m_iNbVariables = 0 Do Dim sLigne$ = sr.ReadLine If sLigne Is Nothing Then Exit Do Dim car$ = Left(sLigne, 1) Select Case car Case "*" : GoTo LigneSuivante ' Les var. interm. sont séparées des autres par une ligne de tirets Case "-" : sLigne = "" : bVarInterm = True Case "=" : Exit Do End Select If sLigne <> "" Then If InStr(sLigne, " ") > 0 Then AjouterMsg("Erreur : les variables doivent être sans espace :") AjouterMsg(sLigne) : GoTo Err End If If bVarExiste(sLigne) Then AjouterMsg("Erreur : variable déjà définie :") AjouterMsg(sLigne) : GoTo Err End If Dim var As TVar = Nothing m_iNbVariables += 1 var.iNumVar = m_iNbVariables var.sVariable = sLigne If Not bVarInterm Then ' En mode fichier, la valeur par défaut des ' faits initiaux est unique : "FAUX" var.sValeurDef = clsVBBBox.sValFaitInitialDefautModeFichier m_iNbVarInitiales += 1 var.bIntermediaire = False Else var.bIntermediaire = True var.sValeurDef = clsVBBBox.sValFaitIntermediaireDefautModeFichier End If var.bConfig = False If bNomVarConfig(var.sVariable) Then var.bConfig = True var.sValeurDef = clsUtil.sVrai End If Dim sCle$ = sLigne m_colDico.Add(sCle, var) colVar.Add(sLigne, sLigne) End If LigneSuivante: Loop While True Fin: bChargerDico = True Err: sr.Close() End Function Friend Function sNomVar$(ByVal iNumVar%) ' Trouver la variable iNumVar (en mode fichier seulement) Dim de As DictionaryEntry For Each de In m_colDico Dim var As clsDico.TVar = CType(de.Value, clsDico.TVar) If var.iNumVar = iNumVar Then sNomVar = var.sVariable : Exit Function Next de sNomVar = "" End Function #End Region #Region "Interrogation du dictionnaire" Friend Function ConvOper(ByVal sOper$) As TOper ' Interprétation du mode fichier ConvOper = Nothing Select Case sOper Case "=" : ConvOper = TOper.Egal Case ">" : ConvOper = TOper.Sup Case "<" : ConvOper = TOper.Inf Case "G" : ConvOper = TOper.SupEgal Case "L" : ConvOper = TOper.InfEgal Case "D" : ConvOper = TOper.Different End Select End Function Friend Function sConvOper$(ByVal Oper As TOper, _ Optional ByVal bCompatTurboExpert As Boolean = False) If bCompatTurboExpert Then sConvOper = m_asOperCompatTE(Oper) Else sConvOper = m_asOper(Oper) End If End Function Friend Function bVarExiste(ByVal sVar$) As Boolean bVarExiste = m_colDico.ContainsKey(sVar) End Function Friend Function bIntermediaire(ByVal sVar$) As Boolean bIntermediaire = CType(m_colDico.Item(sVar), TVar).bIntermediaire End Function Friend Function sValDefVar$(ByVal sVar$) sValDefVar = CType(m_colDico.Item(sVar), TVar).sValeurDef End Function Friend Function rFiabDef!(ByVal sVar$) rFiabDef = CType(m_colDico.Item(sVar), TVar).rFiab End Function Friend Function bConstante(ByVal sVar$) As Boolean bConstante = CType(m_colDico.Item(sVar), TVar).bConst End Function Friend Function bConfig(ByVal sVar$) As Boolean bConfig = CType(m_colDico.Item(sVar), TVar).bConfig End Function Friend Function bNomVarConfig(ByVal sVar$) As Boolean If sVar.Length >= 7 AndAlso _ sVar.Substring(0, 7) = "Config_" Then Return True Return False End Function #End Region #Region "Analyse d'une prémisse de règle" '-------------------------------------------------------------------------- 'EXTRACTION DES VARIABLES et VALEURS D'UNE LIGNE-PREMISSE, CONCL ou FAIT '-------------------------------------------------------------------------- Friend Function DecomposerHypothese(ByVal sParam$, _ ByRef bErr As Boolean, ByRef sErr$) As clsDico.TPremisse DecomposerHypothese = Nothing Dim type As TTypeVar Dim sVal$ ' Valeur en string de la variable 1 Dim oper As clsDico.TOper Dim sVar$ = "" Dim sVar2$ = "" Dim iLenPrm% = Len(sParam) ' Les zones à extraire sont dans sParam Dim i% = InStr(sParam, " ") If i > 0 Then ' Ici, il y a un opérateur et une valeur sVar = Mid(sParam, 1, i - 1) If Not bVarExiste(sVar) Then bErr = True sErr = "Variable inconnue : " & sVar 'Exit Function Return Nothing End If oper = ConvOper(Mid(sParam, i + 1, 1)) sVal = Mid(sParam, i + 3, iLenPrm - (i + 2)) Dim sCar$ = Left(sVal, 1) Dim j% = InStr("0123456789-", sCar) If j = 0 Then ' Ici, sVal contient une valeur-chaîne ou une seconde variable ' si c'est une valeur-chaîne, elle commence par " If sCar = sGm Then ' Ici, valeur-chaîne type = TTypeVar.Chaine Else ' Ici, seconde variable (référence) If Not bVarExiste(sVal) Then bErr = True sErr = "Variable inconnue : " & sVar 'Exit Function Return Nothing End If sVar2 = sVal If bConstante(sVar2) Then sVal = sValDefVar(sVar2) type = TTypeVar.Chaine If IsNumeric(sVal) Then type = TTypeVar.Numerique If InStr(sVal, "/") > 0 Then type = TTypeVar.Numerique ' Date End If End If Else ' Ici, valeur numérique ' cas particulier du "%": ' (on teste si ça a une importance...) 'If Right$(sVal, 1) = "%" Then _ ' sVal = Left$(sVal, Len(sVal) - 1) type = TTypeVar.Numerique End If Else ' Ici, pas d'opérateur => la var. est un booléen ' soit 'prélèvement' , soit 'non_prélèvement' If Left(sParam, 4) = "non_" Then ' En mode fichier seulement sVar = Right(sParam, Len(sParam) - 4) sVal = clsUtil.sFaux Else sVar = sParam sVal = clsUtil.sVrai End If oper = TOper.Egal type = TTypeVar.Chaine End If DecomposerHypothese.sDateOrig = "" If InStr(sVal, "/") > 0 Then DecomposerHypothese.sDateOrig = sVal clsUtil.bInverserDate(sVal) End If DecomposerHypothese.sVar = sVar DecomposerHypothese.oper = oper DecomposerHypothese.sVal = sVal DecomposerHypothese.sVar2 = sVar2 DecomposerHypothese.rFiab = clsVBBBox.rCodeFiabIndefini DecomposerHypothese.type = type End Function #End Region #Region "Traduction d'une prémisse de règle en français" Friend Function sComposerHypothese$(ByRef hyp As TPremisse) ' On reçoit ici une prémisse, et on traduit dans une string ' l'expression de la premisse ; cette fonction est l'inverse de ' de DecomposerHypothese Dim sLigne$ = hyp.sVar sLigne &= " " & m_asOper(hyp.oper) If hyp.type = TTypeVar.Reference Then sLigne &= " " & hyp.sVar2 Else Dim sVal$ = hyp.sVal If (sVal Is Nothing) Or sVal = "" Then sVal = "?" sLigne &= " " & sVal End If sComposerHypothese = sLigne End Function #End Region End Class End Namespace modUtil.vb ' Fichier modUtil.vb ' ------------------ Option Strict On Option Explicit On Module [Global] ' D'après le fichier d'origine en VB6 : ' PROTEXPERT ' ------------------------------------------------------------ ' Module des Const, Types, Var et Procedures communes ' pour Turbo-Expert ' (c) Philippe LARVET Avril 96 ' Nouvelle version simplifiée du 27 mai 96 ' ------------------------------------------------------------ ' Version VB6 mai 02, revu janvier 03 ' ------------------------------------------------------------ Public Const sGm$ = """" ' Guillemets : sGm correspond à un seul " End Module Public Class clsUtil Public Const sVrai$ = sGm & "VRAI" & sGm Public Const sFaux$ = sGm & "FAUX" & sGm ' Exportation Turbo-Expert 1.2 en VB6 ' impossible de définir une constante, donc variable globale ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 Public Shared encodageVB6 As System.Text.Encoding = _ System.Text.Encoding.GetEncoding(1252) ' Code page : windows-1252 ' Librairie de fonctions partagées : pas besoin d'instancier la classe Util #Region "Librairie de fonctions partagées" Public Shared Function sDLookUp$(ByVal sConnexion$, ByVal sSQL$) ' DLookUp sur une base de données : ' c'est une requête qui renvoie la valeur d'un champ Try Dim connexion As New OleDb.OleDbConnection(sConnexion) connexion.Open() sDLookUp = sDLookUp(connexion, sSQL) connexion.Close() Catch sDLookUp = "" End Try End Function Public Shared Function sDLookUp$(ByVal connexion As OleDb.OleDbConnection, _ ByVal sSQL$) sDLookUp = "" Try Dim adp0 As New OleDb.OleDbDataAdapter(sSQL, connexion) Dim dt As New DataTable() adp0.Fill(dt) sDLookUp = sNonVide(CType(dt.Rows(0), DataRow)(0)) Catch MsgBox("Erreur lors du LookUp :" & vbCrLf & _ sSQL & vbCrLf & Err.ToString, MsgBoxStyle.Critical) End Try End Function Public Shared Function bEstVide(ByVal oChamp As Object) As Boolean ' oChamp est un String sauf si c'est un DBNull 'If oChamp.GetType Is GetType(System.String) Then MsgBox("String") If IsDBNull(oChamp) Then Return True If CType(oChamp, String) Is Nothing Then Return True If CType(oChamp, String) = "" Then Return True Return False End Function Public Shared Function sNonVide$(ByVal oChamp As Object, _ Optional ByVal sDefaut$ = "") If bEstVide(oChamp) Then sNonVide = sDefaut : Exit Function sNonVide = CStr(oChamp) End Function Public Shared Function bNonVide(ByVal oChamp As Object, _ Optional ByVal bDefaut As Boolean = False) As Boolean If bEstVide(oChamp) Then bNonVide = bDefaut : Exit Function bNonVide = CBool(oChamp) End Function Public Shared Function rNonVide!(ByVal oChamp As Object, ByVal rDefaut!) If bEstVide(oChamp) Then rNonVide = rDefaut : Exit Function rNonVide = CSng(oChamp) End Function Public Shared Function bValeurNulleOuVrai(ByVal sValeur$) As Boolean If (sValeur Is Nothing) Or sValeur = "" Or sValeur = sVrai Then Return True Return False End Function Public Shared Function sParametrerRq$(ByVal sSQL$, ByVal iPrm%) Dim iIndexPrm% = sSQL.IndexOf("?") sParametrerRq = sSQL.Substring(0, iIndexPrm) & iPrm If iIndexPrm < sSQL.Length Then _ sParametrerRq &= sSQL.Substring(iIndexPrm + 1) End Function Public Shared Sub AjouterMsg(ByVal sMessage$, _ ByRef colMsg As Specialized.StringCollection) ' Ajouter le message à la collection passée en entrée If sMessage = "" Then colMsg.Add(sMessage) : Exit Sub Dim iMultiligne%, iMemIndex% iMemIndex = 0 Do iMultiligne = sMessage.IndexOf(vbCrLf, iMemIndex + 1) If iMultiligne = -1 And iMemIndex = 0 Then _ colMsg.Add(sMessage) : Exit Sub If iMemIndex = 0 Then iMemIndex = -2 If iMultiligne = -1 Then colMsg.Add(sMessage.Substring(iMemIndex + 2)) Exit Sub End If colMsg.Add(sMessage.Substring(iMemIndex + 2, _ iMultiligne - iMemIndex - 2)) iMemIndex = iMultiligne Loop While iMultiligne > -1 End Sub Public Shared Function bInverserDate(ByRef sDate$) As Boolean ' Inverser la date passée en entrée afin de transformer un champ date ' en un entier numérique qui peut alors être comparé dans VBBrainBox ' La date "3/12/97" devient "19971203" ' La date "1/1/92" devient "19920101" Dim sMois, sJour, sMoisAnnee, sAnnee As String Dim j% = InStr(sDate, "/") sJour = Left(sDate, j - 1) If Len(sJour) = 1 Then sJour = "0" & sJour sMoisAnnee = Right(sDate, Len(sDate) - j) j = InStr(sMoisAnnee, "/") If j = 0 Then sMois = sMoisAnnee sDate = "2000" & sMois & sJour Return True Else sMois = Left(sMoisAnnee, j - 1) End If If Len(sMois) = 1 Then sMois = "0" & sMois sAnnee = sMoisAnnee.Substring(j) Select Case sAnnee.Length Case 1 sAnnee = "200" & sAnnee Case 2 If Val(sAnnee) < 50 Then sAnnee = "20" & sAnnee Else sAnnee = "19" & sAnnee End If Case 3 sAnnee = "0" & sAnnee Case 4 Case Else Return False End Select sDate = sAnnee & sMois & sJour Return True End Function Public Shared Function sTraiterHyperlienAccess$(ByVal sLien$) ' Simplification de l'affichage des champs Access dans le rapport ' Les champs hyperliens d'Access sont stockés avec 2 représentations : ' une forme de présentation et une URL valide ' ex. : http://www.web.com#http://www.web.com# ' patrice.dargenton@free.fr#mailto:patrice.dargenton@free.fr# ' lien1#lien2# ou lien1#lien2 Dim iPosDiese% = sLien.IndexOf("#") Dim iPos2Diese% = sLien.LastIndexOf("#") If Not (iPosDiese > -1 And iPos2Diese > -1) Then GoTo Fin Dim sLien1$ = sLien.Substring(0, iPosDiese) Dim iLenLien2% = sLien.Length - iPosDiese - 1 If iPos2Diese < sLien.Length Then _ iLenLien2 = sLien.Length - iPosDiese - 1 ' Les hyperliens Access ne gère pas bien les signets dans les URL, ' d'où un petit bug : il peut manquer un # à la fin ! If Right(sLien, 1) = "#" Then iLenLien2 -= 1 Dim bMail As Boolean Const sMailto$ = "mailto:" Dim iPosMailto% = sLien.IndexOf(sMailto) Dim iPosLien2% = iPosDiese + 1 If iPosMailto > -1 Then iPosLien2 = iPosMailto + sMailto.Length iLenLien2 -= sMailto.Length bMail = True End If Dim sLien2$ = sLien.Substring(iPosLien2, iLenLien2) If sLien2 = sLien1 Then sTraiterHyperlienAccess = sLien1 : Exit Function ' Pour les URL, mieux vaux ne conserver que l'URL réelle If Not bMail Then sTraiterHyperlienAccess = sLien2 : Exit Function Fin: sTraiterHyperlienAccess = sLien : Exit Function End Function Public Shared Function bCleRegistreExiste(ByVal sCle$) As Boolean ' Vérifier si une clé existe dans la base de registre ' c'est utile pour savoir si un contrôle ActiveX est enregistré Dim sValCle$ Try ' This call goes to the Catch block if the registry key is not set. Dim myRegKey As Microsoft.Win32.RegistryKey = _ Microsoft.Win32.Registry.ClassesRoot myRegKey = myRegKey.OpenSubKey(sCle) Dim sSousCle$ = "" ' Sous-clé par défaut Dim oValue As Object = myRegKey.GetValue(sSousCle) sValCle = CStr(oValue) Return True ' On peut lire cette clé, donc elle existe Catch sValCle = "" Return False End Try 'MsgBox(sValCle) 'Exit Function End Function Public Shared Function bEnregistrerDllActiveX(ByVal sDllActiveX$, _ ByVal sRepertoireDll$, _ Optional ByVal bDesenregistrer As Boolean = False, _ Optional ByVal bConfirmer As Boolean = True) As Boolean ' Enregistrer (inscrire) la Dll ActiveX dans la base de registre : ' Une Dll ActiveX requiert la commande : ' C:\Windows\System\Regsvr32.exe MaDll.dll (system32 pour les NT/XP) ' Le désenregistrement se fait avec -u ' C:\Windows\System\Regsvr32.exe -u MaDll.dll ' (s'il y a un package d'installation, il prend alors en charge ' automatiquement l'enregistrement et le désenregistrement) Dim sCheminDll$ = sRepertoireDll & "\" & sDllActiveX If Not IO.File.Exists(sCheminDll) Then MsgBox("Impossible de trouver le fichier :" & vbCrLf & _ sCheminDll, MsgBoxStyle.Critical) Return False End If Dim iReponse% If bConfirmer Then Dim sInfo$ = "Voulez-vous inscrire le contrôle " & _ sDllActiveX & " dans la base de registre ?" If bDesenregistrer Then sInfo$ = "Voulez-vous désinscrire le contrôle " & _ sDllActiveX & " dans la base de registre ?" iReponse = MsgBox(sInfo, _ MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question) If iReponse <> MsgBoxResult.Yes Then Return False End If Dim sOption$ = "" If bDesenregistrer Then sOption = "-u" ' Autre possibilité : Environment.GetFolderPath(SpecialFolder.System) Dim sExe$ = Environment.SystemDirectory & "\regsvr32.exe" Dim startInfo As New ProcessStartInfo(sExe) startInfo.Arguments = sOption & " " & sGm & sCheminDll & sGm startInfo.WindowStyle = ProcessWindowStyle.Normal Process.Start(startInfo) iReponse = MsgBox("L'opération a-t-elle réussie ?", _ MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question) If iReponse <> MsgBoxResult.Yes Then Return False Return True End Function Public Shared Sub JolieTransitionTaDaaa(ByVal frm As Form, _ Optional ByVal bFermeture As Boolean = False) ' Faire une transition fantôme au début et à la fin de l'application Dim i! ' Attention : il y a un gros problème d'arrondi avec la boucle for : ' on est obligé d'aller jusqu'à 1.1 pour obtenir 1 !!! Dim rDebut! = 0, rFin! = 1.1, rPas! = 0.2 '1 If bFermeture Then rDebut! = 1 : rFin = -0.1 : rPas = -0.2 '1 For i = rDebut To rFin Step rPas frm.Opacity = i Application.DoEvents() Threading.Thread.Sleep(10) '100) Next i End Sub #End Region End Class