ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

Outil d'analyse de base de données (DORG)   



L'auteur

Mike Gagnon
Canada Canada
Membre Simple
# 0000000025
enregistré le 14/10/2004

Gagnon Mike
Pointe Cla H9R 3K8
de la société Carver Technologies Inc.
Fiche personnelle


Note des membres
18/20
1 vote


Contributions > 01 - PRG : Programmation

Outil d'analyse de base de données (DORG)
# 0000000046
ajouté le 05/11/2004 14:39:26 et modifié le 05/11/2004
consulté 8968 fois
Niveau expert


Télécharger le ZIP (4.44 Ko)
Description
Voici un outils d'analyse de base de données. Il vous permet de sélectionner un ou toutes les tables d'une base de données et d'en faire l'analyse (ie. Nom des champs, type de champs, index etc..) Très utile pour garder un archive de la structure d'un base de donnée. Vous trouverez ci-inclus le code complet (l'application originale a été écrite avec des formulaires visuels) et le rapport est inclus ici en format zip. A noter que l'accès a la base de données doit etre exclusive.
Code source :
Public odorg

odorg=Newobject("dorg")
odorg.Show
Return
Define Class dorg As Form
  Top = 0
  Left = 0
  Height = 365
  Width = 620
  DoCreate = .T.
  ShowTips = .T.
  Caption = "Outil d'analyse de base de donnés (DORG)"
  WindowType = 1
  fcdbcname = ""
  fcirtname = ""
  fcdbcdirectory = ""
  fcstartdirectory = (Sys(5) + Curdir())
  fcresetdeleted = (Set('DELETED'))
  fcresetsafety = (Set('SAFETY'))
  fccurleftidx = ('XL' + Str(100000 + Seconds(), 6))
  fccurrightidx = ('XR' + Str(100000 + Seconds(), 6))
  fcoutputdevice = "Écran"
  fcresetcentury = (Set('CENTURY'))
  Name = "DORG"
  Dimension fatablename[1]

  Add Object txtdbc As TextBox With ;
    FontSize = 10, ;
    ControlSource = "ThisForm.fcDBCName", ;
    Format = "T", ;
    Height = 25, ;
    Left = 40, ;
    TabIndex = 1, ;
    Top = 8, ;
    Width = 540, ;
    Name = "txtDBC"


  Add Object lbldbc As Label With ;
    AutoSize = .T., ;
    FontSize = 10, ;
    Caption = "DBC", ;
    Height = 18, ;
    Left = 10, ;
    Top = 12, ;
    Width = 29, ;
    TabIndex = 11, ;
    Name = "lblDBC"


  Add Object cmddbc As CommandButton With ;
    Top = 8, ;
    Left = 582, ;
    Height = 26, ;
    Width = 25, ;
    FontBold = .T., ;
    FontSize = 16, ;
    Caption = "...", ;
    TabIndex = 2, ;
    ToolTipText = "Recherche .DBC", ;
    Name = "cmdDBC"


  Add Object lstleft As ListBox With ;
    FontSize = 10, ;
    ColumnCount = 1, ;
    RowSourceType = 2, ;
    RowSource = "curLeft", ;
    FirstElement = 1, ;
    Height = 216, ;
    Left = 40, ;
    MultiSelect = .T., ;
    TabIndex = 3, ;
    Top = 60, ;
    Width = 225, ;
    Name = "lstLeft"


  Add Object lblleft As Label With ;
    AutoSize = .T., ;
    FontSize = 10, ;
    BackStyle = 0, ;
    Caption = "Tables dans la base de données:", ;
    Height = 18, ;
    Left = 40, ;
    Top = 43, ;
    Width = 139, ;
    TabIndex = 8, ;
    Name = "lblLeft"


  Add Object lblright As Label With ;
    AutoSize = .T., ;
    FontSize = 10, ;
    BackStyle = 0, ;
    Caption = "Tables sélectionnées pour analyse:", ;
    Height = 18, ;
    Left = 355, ;
    Top = 43, ;
    Width = 171, ;
    TabIndex = 9, ;
    Name = "lblRight"


  Add Object cmgallnone As CommandGroup With ;
    ButtonCount = 4, ;
    BackStyle = 0, ;
    BorderStyle = 0, ;
    Value = 1, ;
    Height = 152, ;
    Left = 282, ;
    Top = 96, ;
    Width = 55, ;
    TabIndex = 5, ;
    Name = "cmgAllNone", ;
    Command1.Top = 30, ;
    Command1.Left = 0, ;
    Command1.Height = 29, ;
    Command1.Width = 53, ;
    Command1.FontBold = .T., ;
    Command1.FontSize = 16, ;
    Command1.Caption = ">>", ;
    Command1.Enabled = .F., ;
    Command1.ToolTipText = "Selectionner toutes les tables", ;
    Command1.Name = "cmdAll", ;
    Command2.Top = 121, ;
    Command2.Left = 0, ;
    Command2.Height = 29, ;
    Command2.Width = 53, ;
    Command2.FontBold = .T., ;
    Command2.FontSize = 16, ;
    Command2.Caption = "<<", ;
    Command2.Enabled = .F., ;
    Command2.ToolTipText = "Déselectionner toutes les tables", ;
    Command2.Name = "cmdNotAll", ;
    Command3.Top = 0, ;
    Command3.Left = 0, ;
    Command3.Height = 29, ;
    Command3.Width = 53, ;
    Command3.FontBold = .T., ;
    Command3.FontSize = 16, ;
    Command3.Caption = ">", ;
    Command3.Enabled = .F., ;
    Command3.ToolTipText = "Selectionner une table", ;
    Command3.Name = "cmdOne", ;
    Command4.Top = 91, ;
    Command4.Left = 0, ;
    Command4.Height = 29, ;
    Command4.Width = 53, ;
    Command4.FontBold = .T., ;
    Command4.FontSize = 16, ;
    Command4.Caption = "<", ;
    Command4.Enabled = .F., ;
    Command4.ToolTipText = "Désélectionner une table", ;
    Command4.Name = "cmdNotOne"


  Add Object lstright As ListBox With ;
    FontSize = 10, ;
    ColumnCount = 1, ;
    RowSourceType = 2, ;
    RowSource = "curRight", ;
    FirstElement = 1, ;
    Height = 216, ;
    Left = 355, ;
    MultiSelect = .T., ;
    TabIndex = 4, ;
    Top = 60, ;
    Width = 225, ;
    Name = "lstRight"


  Add Object cmgokcancel As CommandGroup With ;
    ButtonCount = 2, ;
    BackStyle = 0, ;
    BorderStyle = 0, ;
    Value = 1, ;
    ControlSource = "m.lcOKCancel", ;
    Height = 40, ;
    Left = 189, ;
    Top = 320, ;
    Width = 241, ;
    TabIndex = 7, ;
    Name = "cmgOKCancel", ;
    Command1.Top = 5, ;
    Command1.Left = 5, ;
    Command1.Height = 29, ;
    Command1.Width = 94, ;
    Command1.FontBold = .T., ;
    Command1.FontSize = 10, ;
    Command1.Caption = "OK", ;
    Command1.Enabled = .F., ;
    Command1.TerminateRead = .T., ;
    Command1.Name = "cmdOK", ;
    Command2.Top = 5, ;
    Command2.Left = 141, ;
    Command2.Height = 29, ;
    Command2.Width = 94, ;
    Command2.FontBold = .T., ;
    Command2.FontSize = 10, ;
    Command2.Caption = "Canceler", ;
    Command2.TerminateRead = .T., ;
    Command2.Name = "cmdCancel"


  Add Object lbloutputdevice As Label With ;
    AutoSize = .T., ;
    FontSize = 10, ;
    BackStyle = 0, ;
    Caption = "Sortie", ;
    Height = 18, ;
    Left = 171, ;
    Top = 291, ;
    Width = 83, ;
    TabIndex = 10, ;
    Name = "lblOutputDevice"


  Add Object cbooutputdevice As ComboBox With ;
    FontSize = 10, ;
    RowSourceType = 1, ;
    RowSource = "Écran,Imprimante,Spreadsheet", ;
    ControlSource = "ThisForm.fcOutputDevice", ;
    Height = 24, ;
    Left = 255, ;
    NumberOfElements = 2, ;
    Style = 2, ;
    TabIndex = 6, ;
    Top = 288, ;
    Width = 109, ;
    SelectedForeColor = Rgb(0,0,0), ;
    SelectedItemForeColor = Rgb(0,0,0), ;
    SelectedBackColor = Rgb(255,255,255), ;
    SelectedItemBackColor = Rgb(192,192,192), ;
    Name = "cboOutputDevice"


  Procedure validationerror

  Lparameters m.tcMessage

  If (Parameters() < 1 ;
      OR  Empty(m.tcMessage))
    m.tcMessage = 'Erreur inconnue.'
  Endif

  Messagebox(m.tcMessage, 0+48+0, 'ERREUR')
  Return .T.
  Endproc

  Procedure makelistoftables

  Local m.lnSub1, m.lnSub2, m.lcDatabaseName

  With Thisform
    Open Database (.fcdbcname) Exclusive
    m.lnSub1      = Rat('\', .fcdbcname) + 1
    m.lnSub2      = Rat('.', .fcdbcname) - m.lnSub1
    m.lcDatabaseName  = Substr(.fcdbcname, m.lnSub1, m.lnSub2)
    Set  Database To (m.lcDatabaseName)

    Select ObjectName As TableName ;
      FROM (.fcdbcname) ;
      WHERE ObjectType = 'Table' ;
      ORDER By ObjectName ;
      INTO Array .fatablename

    Select curLeft
    Zap
    Append From Array .fatablename

    If Used(m.lcDatabaseName)
      Use In (m.lcDatabaseName)
    Endif
  Endwith
  Return .T.
  Endproc


  Procedure Release

  Local m.lcReset
  Close Database All
  On Key Label F12
  With Thisform
    m.lcReset = .fcresetcentury
    Set Century  &lcReset
    m.lcReset = .fcresetdeleted
    Set Deleted  &lcReset
    m.lcReset = .fcresetsafety
    Set Safety  &lcReset
  Endwith
  Return .T.
  Endproc


  Procedure Load
  Close Database All
  Set Century    On
  Set Collate    To 'GENERAL'
  Set Deleted    On
  Set Safety    Off

  On Key Label F12 Release Windows Dirt
  With Thisform
    Create Cursor curLeft  (TableName  C(128))
    Select curLeft
    Index On Left(TableName, 32)  To (.fccurleftidx)

    Create Cursor curRight  (TableName  C(128))
    Select curRight
    Index On Left(TableName, 32)  To (.fccurrightidx)
  Endwith
  Return .T.
  Endproc


  Procedure txtdbc.When
  With Thisform
    .cmgallnone.cmdAll.Enabled    = .F.
    .cmgallnone.cmdNotAll.Enabled  = .F.
    .cmgallnone.cmdOne.Enabled    = .F.
    .cmgallnone.cmdNotOne.Enabled  = .F.
    .cmgokcancel.cmdOK.Enabled    = .F.
  Endwith
  Endproc


  Procedure txtdbc.Valid
  Local m.lnErrorWasFound, m.lnSub1
  m.lnErrorWasFound = .F.

  With Thisform
    Do Case
    Case Empty(.fcdbcname)
      Return 1
    Case Not File(.fcdbcname)
      .validationerror('This file does not exist.')
      m.lnErrorWasFound = .T.
    Case Upper(Right(.fcdbcname, 4)) <> '.DBC'
      .validationerror('This file is not a database container (.DBC).')
      m.lnErrorWasFound = .T.
    Endcase
    If m.lnErrorWasFound
      .fcdbcname = Lower(Alltrim(Getfile('DBC''''Select', 0)))
      Return 0
    Endif
    .makelistoftables()
    .cmgallnone.cmdAll.Enabled    = .T.
    .cmgallnone.cmdNotAll.Enabled  = .T.
    .cmgallnone.cmdOne.Enabled    = .T.
    .cmgallnone.cmdNotOne.Enabled  = .T.
    .cmgokcancel.cmdOK.Enabled    = .T.
  Endwith
  Return 2
  Endproc


  Procedure cmddbc.Valid
  With Thisform
    .cmgallnone.cmdAll.Enabled    = .T.
    .cmgallnone.cmdNotAll.Enabled  = .T.
    .cmgallnone.cmdOne.Enabled    = .T.
    .cmgallnone.cmdNotOne.Enabled  = .T.
    .cmgokcancel.cmdOK.Enabled    = .T.
  Endwith
  Endproc


  Procedure cmddbc.Click
  With Thisform
    .fcdbcname = Lower(Alltrim(Getfile('DBC''''Select', 0)))
    .txtdbc.Refresh()
    .makelistoftables()
    .lstleft.SetFocus()
  Endwith
  Endproc


  Procedure lstleft.DblClick
  Thisform.cmgallnone.cmdOne.Click()
  Endproc


  Procedure cmgallnone.Click
  With Thisform
    .lstleft.Requery()
    .lstleft.Refresh()
    .lstright.Requery()
    .lstright.Refresh()
  Endwith
  Endproc


  Procedure cmgallnone.cmdAll.Click
  Set Safety Off
  Zap In curLeft
  Zap In curRight
  Set Safety On

  Select curLeft
  Append From Array Thisform.fatablename
  Delete All        && We need deleted records to RECALL if necessary.

  Select curRight
  Append From Array Thisform.fatablename
  This.Parent.Click()
  Endproc


  Procedure cmgallnone.cmdNotAll.Click
  Set Safety Off
  Zap In curLeft
  Zap In curRight
  Set Safety On
  Select curLeft
  Append From Array Thisform.fatablename
  This.Parent.Click()
  Endproc


  Procedure cmgallnone.cmdOne.Click
  With Thisform.lstleft
    If Not Empty(.Value)
      If Seek(Left(.Value, 32), 'curLeft')
        Select curRight
        Recall For TableName = curLeft.TableName
        If Not Seek(Left(.Value, 32), 'curRight')
          Append Blank
          Replace curRight.TableName  With curLeft.TableName
        Endif
        Select curLeft
        Delete
      Endif
    Endif
    .SetFocus()
  Endwith
  This.Parent.Click()
  Endproc


  Procedure cmgallnone.cmdNotOne.Click
  With Thisform.lstright
    If Not Empty(.Value)
      If Seek(Left(.Value, 32), 'curRight')
        Select curLeft
        Recall For TableName = curRight.TableName
        Select curRight
        Delete
      Endif
    Endif
    .SetFocus()
  Endwith
  This.Parent.Click()
  Endproc


  Procedure lstright.DblClick
  Thisform.cmgallnone.cmdNotOne.Click()
  Endproc
  Procedure cmgokcancel.cmdOK.Click
  Local aRelation[1]
  Local m.lnRelationRows, m.lcTableName
  Local m.lnCtr, m.lnSub, m.lnFieldNumber
  Local m.lcTagName, m.lcTagExpr, m.lcTagType, m.lcTagFor, m.lcTagAD
  Local m.lcRelParTbl, m.lcRelParTag, m.lcRelRefUDI
  Wait Window Nowait 'Créer un état ...veuiller patienter.'
  m.lnRelationRows = Adbobjects(aRelation, 'Relation')
  Dimension laFieldType[11]
  laFieldType[01] = 'C Character'
  laFieldType[02] = 'D Date '
  laFieldType[03] = 'L Logical '
  laFieldType[04] = 'M Memo '
  laFieldType[05] = 'N Numeric '
  laFieldType[06]  = 'F Float '
  laFieldType[07]  = 'I Integer '
  laFieldType[08] = 'B Double '
  laFieldType[09] = 'Y Currency '
  laFieldType[10] = 'T Date-Time'
  laFieldType[11] = 'G General '
  Dimension laStructure[1, 1]
  Create Cursor curTableStructure ( ;
    FieldName      C(128), ;
    FieldType      C(009), ;
    FieldLength      N(003), ;
    FieldDecimal    N(002), ;
    NullAllowed      L, ;
    CodePageBarred    L, ;
    FieldValidationRule  C(250), ;
    FieldValidationText  C(250), ;
    FieldDefaultValue  C(250), ;
    TableValidationRule  C(250), ;
    TableValidationText  C(250), ;
    LongTableName    C(128), ;
    InsertTrigger    C(250), ;
    UpdateTrigger    C(250), ;
    DeleteTrigger    C(250), ;
    TableComment    C(250), ;
    DBFName        C(128), ;
    FieldNumber      N(004), ;
    RecordType      C(001), ;
    TagExpression    C(250), ;
    TagType        C(009), ;
    TagFor        C(250), ;
    TagAscDesc        C(001), ;
    RelParentTbl    C(128), ;
    RelParentTag    C(010), ;
    RelRefIntegUDI    C(006) ;
    )
  Select curRight
  Scan
    m.lcTableName = Rtrim(curRight.TableName)
    Use (m.lcTableName)  In 0 Shared    Alias SourceTable
    Select SourceTable
    m.lnCtr = Afields(laStructure)

    Select curTableStructure
    m.lnSub = Reccount()
    Append From Array laStructure
    Goto m.lnSub + 1
    m.lnFieldNumber = 1
    Do While Not Eof()
      Replace LongTableName  With curRight.TableName
      Replace DBFName      With Dbf('SourceTable')
      Replace FieldNumber    With m.lnFieldNumber
      Replace RecordType    With 'F'

      m.lnSub = Ascan(laFieldType, Left(FieldType, 1))
      Replace FieldType    With Iif(m.lnSub > 0, ;
        RIGHT(laFieldType[m.lnSub], 9), '***')
      m.lnFieldNumber = m.lnFieldNumber + 1
      Skip 1
    Enddo
    If Not Empty(Cdx(1, 'SourceTable'))
      m.lcTagName  = '???'
      m.lnSub    = 1
      Select SourceTable
      Do While Not Empty(m.lcTagName)
        m.lcTagName    = Tag(m.lnSub)
        m.lcTagExpr   = Key(m.lnSub)
        m.lcTagType    = 'Regular'
        m.lcTagType    = Iif(Primary(m.lnSub),    'Primary',    m.lcTagType)
        m.lcTagType   = Iif(Candidate(m.lnSub),  'Candidate',  m.lcTagType)
        m.lcTagType    = Iif(Unique(m.lnSub),     'Unique',    m.lcTagType)
        m.lcTagFor    = For(m.lnSub)
        m.lcTagAD    = Iif(Descending(m.lnSub), 'D''A')
        m.lcRelParTbl  = ''
        m.lcRelParTag  = ''
        m.lcRelRefUDI  = ''
        If m.lcTagType = 'Regular'
          For m.lnSub2 = 1 To m.lnRelationRows
            If (Upper(aRelation[m.lnSub2, 1])  = Upper(Alltrim(m.lcTableName)) ;
                AND Upper(aRelation[m.lnSub2, 3])  = Upper(Alltrim(m.lcTagName)))
              m.lcRelParTbl  = aRelation[m.lnSub2, 2]
              m.lcRelParTag  = aRelation[m.lnSub2, 4]
              m.lcRelRefUDI  = aRelation[m.lnSub2, 5]
              m.lcTagType    = 'Foreign'
            Endif
          Endfor
        Endif
        If Not Empty(m.lcTagName)
          Select curTableStructure
          Append Blank
          Replace FieldName    With m.lcTagName
          Replace TagExpression  With m.lcTagExpr
          Replace TagType      With m.lcTagType
          Replace TagFor      With m.lcTagFor
          Replace LongTableName  With curRight.TableName
          Replace FieldNumber    With m.lnSub
          Replace RecordType    With 'I'
          Replace TagAscDesc    With m.lcTagAD
          Replace RelParentTbl  With m.lcRelParTbl
          Replace RelParentTag  With m.lcRelParTag
          Replace RelRefIntegUDI  With m.lcRelRefUDI
          Select SourceTable
        Endif
        m.lnSub  = m.lnSub + 1
      Enddo
    Endif
    Select SourceTable
    Use
    Select curRight
  Endscan
  On Error
  Wait Clear
  Select curTableStructure
  With Thisform
    Do Case
    Case .fcoutputdevice = 'Écran'
      Report Form dorg Noconsole Preview
    Case .fcoutputdevice = 'Imprimante'
      Report Form dorg Noconsole To Printer Prompt
    Case .fcoutputdevice = 'Spreadsheet'
      Public ofileinfo
      ofileinfo=Newobject("fileinfo")
      ofileinfo.Show
    Endcase
    .Release()
  Endwith
  Return .T.
  Endproc
  Procedure cmgokcancel.cmdCancel.Click
  Thisform.Release()
  Return .T.
  Endproc
Enddefine

Define Class fileinfo As Form
  Height = 107
  Width = 369
  ShowWindow = 1
  DoCreate = .T.
  AutoCenter = .T.
  Caption = "Outil d'analyse de base de donnés (DORG)"
  ControlBox = .F.
  MaxButton = .F.
  MinButton = .F.
  WindowType = 1
  fcfilename = ""
  Name = "FILEINFO"
  Add Object lblline1 As Label With ;
    AutoSize = .T., ;
    FontBold = .T., ;
    FontSize = 10, ;
    Caption = "Nom du Spreadsheet:", ;
    Height = 18, ;
    Left = 10, ;
    Top = 6, ;
    Width = 150, ;
    TabIndex = 3, ;
    Name = "lblLine1"
  Add Object txtfilename As TextBox With ;
    FontSize = 10, ;
    ControlSource = "ThisForm.fcFileName", ;
    Height = 25, ;
    Left = 10, ;
    TabIndex = 5, ;
    Top = 24, ;
    Width = 348, ;
    DisabledForeColor = Rgb(0,0,0), ;
    Name = "txtFileName"
  Add Object cmgokcancel As CommandGroup With ;
    ButtonCount = 2, ;
    BackStyle = 0, ;
    BorderStyle = 0, ;
    Value = 1, ;
    ControlSource = "m.lcOKCancel", ;
    Height = 40, ;
    Left = 64, ;
    Top = 60, ;
    Width = 241, ;
    TabIndex = 7, ;
    Name = "cmgOKCancel", ;
    Command1.Top = 5, ;
    Command1.Left = 5, ;
    Command1.Height = 29, ;
    Command1.Width = 94, ;
    Command1.FontBold = .T., ;
    Command1.FontSize = 10, ;
    Command1.Caption = "OK", ;
    Command1.TerminateRead = .T., ;
    Command1.Name = "cmdOK", ;
    Command2.Top = 5, ;
    Command2.Left = 141, ;
    Command2.Height = 29, ;
    Command2.Width = 94, ;
    Command2.FontBold = .T., ;
    Command2.FontSize = 10, ;
    Command2.Caption = "Canceler", ;
    Command2.TerminateRead = .T., ;
    Command2.Name = "cmdCancel"


  Procedure Init
  Thisform.fcfilename = Sys(05) + Curdir() + 'mafeuille.xls'
  Return .T.
  Endproc
  Procedure cmgokcancel.cmdOK.Click
  With Thisform
    .fcfilename = Alltrim(.fcfilename)
    Select curTableStructure
    Copy To (.fcfilename)  Type Xl5  Fields ;
      RecordType, ;
      DBFName, ;
      LongTableName, ;
      TableValidationRule, ;
      TableValidationText, ;
      InsertTrigger, ;
      UpdateTrigger, ;
      DeleteTrigger, ;
      CodePageBarred, ;
      TableComment, ;
      FieldNumber, ;
      FieldName, ;
      FieldType, ;
      FieldLength, ;
      FieldDecimal, ;
      NullAllowed, ;
      FieldValidationRule, ;
      FieldValidationText, ;
      FieldDefaultValue, ;
      TagExpression, ;
      TagType, ;
      TagFor, ;
      TagAscDesc, ;
      RelParentTbl, ;
      RelParentTag, ;
      RelRefIntegUDI
    .Release()
  Endwith
  Declare Integer ShellExecute In "Shell32.dll" ;
    INTEGER HWnd, ;
    STRING lpVerb, ;
    STRING lpFile, ;
    STRING lpParameters, ;
    STRING lpDirectory, ;
    LONG nShowCmd
  ShellExecute(0,"Open",Thisform.fcfilename,"","",0)
  Return .T.

  Endproc


  Procedure cmgokcancel.cmdCancel.Click
  Thisform.Release()
  Return .T.
  Endproc


Enddefine


Commentaires
le 07/11/2004, Olivier Hamou a écrit :
Merci mike pour nous avoir fait partager ce petit utilitaire
fort pratique.

Olivier

le 06/10/2010, eric leissler a écrit :
Bonjour à tous
il manque quelques virgules dans ce code,
le voici corrigé

Bonne journée à tous
Eric
Public odorg

odorg=Newobject("dorg")
odorg.Show
Return
Define Class dorg As Form
Top = 0
Left = 0
Height = 365
Width = 620
DoCreate = .T.
ShowTips = .T.
Caption = "Outil d'analyse de base de donnés (DORG)"
WindowType = 1
fcdbcname = ""
fcirtname = ""
fcdbcdirectory = ""
fcstartdirectory = (Sys(5) + Curdir())
fcresetdeleted = (Set('DELETED'))
fcresetsafety = (Set('SAFETY'))
fccurleftidx = ('XL' + Str(100000 + Seconds(), 6))
fccurrightidx = ('XR' + Str(100000 + Seconds(), 6))
fcoutputdevice = "Écran"
fcresetcentury = (Set('CENTURY'))
Name = "DORG"
Dimension fatablename[1]

Add Object txtdbc As TextBox With ;
FontSize = 10, ;
ControlSource = "ThisForm.fcDBCName", ;
Format = "T", ;
Height = 25, ;
Left = 40, ;
TabIndex = 1, ;
Top = 8, ;
Width = 540, ;
Name = "txtDBC"


Add Object lbldbc As Label With ;
AutoSize = .T. ,;
FontSize = 10, ;
Caption = "DBC", ;
Height = 18, ;
Left = 10, ;
Top = 12, ;
Width = 29, ;
TabIndex = 11, ;
Name = "lblDBC"


Add Object cmddbc As CommandButton With ;
Top = 8, ;
Left = 582, ;
Height = 26, ;
Width = 25, ;
FontBold = .T., ;
FontSize = 16, ;
Caption = "...", ;
TabIndex = 2, ;
ToolTipText = "Recherche .DBC", ;
Name = "cmdDBC"


Add Object lstleft As ListBox With ;
FontSize = 10, ;
ColumnCount = 1, ;
RowSourceType = 2, ;
RowSource = "curLeft", ;
FirstElement = 1, ;
Height = 216, ;
Left = 40, ;
MultiSelect = .T., ;
TabIndex = 3, ;
Top = 60, ;
Width = 225, ;
Name = "lstLeft"


Add Object lblleft As Label With ;
AutoSize = .T., ;
FontSize = 10, ;
BackStyle = 0, ;
Caption = "Tables dans la base de données:", ;
Height = 18, ;
Left = 40, ;
Top = 43, ;
Width = 139, ;
TabIndex = 8, ;
Name = "lblLeft"


Add Object lblright As Label With ;
AutoSize = .T., ;
FontSize = 10, ;
BackStyle = 0, ;
Caption = "Tables sélectionnées pour analyse:", ;
Height = 18, ;
Left = 355, ;
Top = 43, ;
Width = 171, ;
TabIndex = 9, ;
Name = "lblRight"


Add Object cmgallnone As CommandGroup With ;
ButtonCount = 4, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Value = 1, ;
Height = 152, ;
Left = 282, ;
Top = 96, ;
Width = 55, ;
TabIndex = 5, ;
Name = "cmgAllNone", ;
Command1.Top = 30, ;
Command1.Left = 0, ;
Command1.Height = 29, ;
Command1.Width = 53, ;
Command1.FontBold = .T., ;
Command1.FontSize = 16, ;
Command1.Caption = ">>", ;
Command1.Enabled = .F., ;
Command1.ToolTipText = "Selectionner toutes les tables", ;
Command1.Name = "cmdAll", ;
Command2.Top = 121, ;
Command2.Left = 0, ;
Command2.Height = 29, ;
Command2.Width = 53, ;
Command2.FontBold = .T., ;
Command2.FontSize = 16, ;
Command2.Caption = "<<", ;
Command2.Enabled = .F., ;
Command2.ToolTipText = "Déselectionner toutes les tables", ;
Command2.Name = "cmdNotAll", ;
Command3.Top = 0, ;
Command3.Left = 0, ;
Command3.Height = 29, ;
Command3.Width = 53, ;
Command3.FontBold = .T., ;
Command3.FontSize = 16, ;
Command3.Caption = ">", ;
Command3.Enabled = .F., ;
Command3.ToolTipText = "Selectionner une table", ;
Command3.Name = "cmdOne", ;
Command4.Top = 91, ;
Command4.Left = 0, ;
Command4.Height = 29, ;
Command4.Width = 53, ;
Command4.FontBold = .T. ,;
Command4.FontSize = 16, ;
Command4.Caption = "<", ;
Command4.Enabled = .F. ,;
Command4.ToolTipText = "Désélectionner une table", ;
Command4.Name = "cmdNotOne"


Add Object lstright As ListBox With ;
FontSize = 10, ;
ColumnCount = 1, ;
RowSourceType = 2, ;
RowSource = "curRight", ;
FirstElement = 1, ;
Height = 216, ;
Left = 355, ;
MultiSelect = .T., ;
TabIndex = 4, ;
Top = 60, ;
Width = 225, ;
Name = "lstRight"


Add Object cmgokcancel As CommandGroup With ;
ButtonCount = 2, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Value = 1, ;
ControlSource = "m.lcOKCancel", ;
Height = 40, ;
Left = 189, ;
Top = 320, ;
Width = 241, ;
TabIndex = 7, ;
Name = "cmgOKCancel", ;
Command1.Top = 5, ;
Command1.Left = 5, ;
Command1.Height = 29, ;
Command1.Width = 94, ;
Command1.FontBold = .T., ;
Command1.FontSize = 10, ;
Command1.Caption = "OK", ;
Command1.Enabled = .F. ,;
Command1.TerminateRead = .T. ,;
Command1.Name = "cmdOK", ;
Command2.Top = 5, ;
Command2.Left = 141, ;
Command2.Height = 29, ;
Command2.Width = 94, ;
Command2.FontBold = .T. ,;
Command2.FontSize = 10, ;
Command2.Caption = "Canceler", ;
Command2.TerminateRead = .T., ;
Command2.Name = "cmdCancel"


Add Object lbloutputdevice As Label With ;
AutoSize = .T., ;
FontSize = 10, ;
BackStyle = 0, ;
Caption = "Sortie", ;
Height = 18, ;
Left = 171, ;
Top = 291, ;
Width = 83, ;
TabIndex = 10, ;
Name = "lblOutputDevice"


Add Object cbooutputdevice As ComboBox With ;
FontSize = 10, ;
RowSourceType = 1, ;
RowSource = "Écran,Imprimante,Spreadsheet", ;
ControlSource = "ThisForm.fcOutputDevice", ;
Height = 24, ;
Left = 255, ;
NumberOfElements = 2, ;
Style = 2, ;
TabIndex = 6, ;
Top = 288, ;
Width = 109, ;
SelectedForeColor = Rgb(0,0,0), ;
SelectedItemForeColor = Rgb(0,0,0), ;
SelectedBackColor = Rgb(255,255,255), ;
SelectedItemBackColor = Rgb(192,192,192), ;
Name = "cboOutputDevice"


Procedure validationerror

Lparameters m.tcMessage

If (Parameters() < 1 ;
OR Empty(m.tcMessage))
m.tcMessage = 'Erreur inconnue.'
Endif

Messagebox(m.tcMessage, 0+48+0, 'ERREUR')
Return .T.
Endproc

Procedure makelistoftables

Local m.lnSub1, m.lnSub2, m.lcDatabaseName

With Thisform
Open Database (.fcdbcname) Exclusive
m.lnSub1 = Rat('\', .fcdbcname) + 1
m.lnSub2 = Rat('.', .fcdbcname) - m.lnSub1
m.lcDatabaseName = Substr(.fcdbcname, m.lnSub1, m.lnSub2)
Set Database To (m.lcDatabaseName)

Select ObjectName As TableName ;
FROM (.fcdbcname) ;
WHERE ObjectType = 'Table' ;
ORDER By ObjectName ;
INTO Array .fatablename

Select curLeft
Zap
Append From Array .fatablename

If Used(m.lcDatabaseName)
Use In (m.lcDatabaseName)
Endif
Endwith
Return .T.
Endproc


Procedure Release

Local m.lcReset
Close Database All
On Key Label F12
With Thisform
m.lcReset = .fcresetcentury
Set Century &lcReset
m.lcReset = .fcresetdeleted
Set Deleted &lcReset
m.lcReset = .fcresetsafety
Set Safety &lcReset
Endwith
Return .T.
Endproc


Procedure Load
Close Database All
Set Century On
Set Collate To 'GENERAL'
Set Deleted On
Set Safety Off

On Key Label F12 Release Windows Dirt
With Thisform
Create Cursor curLeft (TableName C(128))
Select curLeft
Index On Left(TableName, 32) To (.fccurleftidx)

Create Cursor curRight (TableName C(128))
Select curRight
Index On Left(TableName, 32) To (.fccurrightidx)
Endwith
Return .T.
Endproc


Procedure txtdbc.When
With Thisform
.cmgallnone.cmdAll.Enabled = .F.
.cmgallnone.cmdNotAll.Enabled = .F.
.cmgallnone.cmdOne.Enabled = .F.
.cmgallnone.cmdNotOne.Enabled = .F.
.cmgokcancel.cmdOK.Enabled = .F.
Endwith
Endproc


Procedure txtdbc.Valid
Local m.lnErrorWasFound, m.lnSub1
m.lnErrorWasFound = .F.

With Thisform
Do Case
Case Empty(.fcdbcname)
Return 1
Case Not File(.fcdbcname)
.validationerror('This file does not exist.')
m.lnErrorWasFound = .T.
Case Upper(Right(.fcdbcname, 4)) <> '.DBC'
.validationerror('This file is not a database container (.DBC).')
m.lnErrorWasFound = .T.
Endcase
If m.lnErrorWasFound
.fcdbcname = Lower(Alltrim(Getfile('DBC', '', 'Select', 0)))
Return 0
Endif
.makelistoftables()
.cmgallnone.cmdAll.Enabled = .T.
.cmgallnone.cmdNotAll.Enabled = .T.
.cmgallnone.cmdOne.Enabled = .T.
.cmgallnone.cmdNotOne.Enabled = .T.
.cmgokcancel.cmdOK.Enabled = .T.
Endwith
Return 2
Endproc


Procedure cmddbc.Valid
With Thisform
.cmgallnone.cmdAll.Enabled = .T.
.cmgallnone.cmdNotAll.Enabled = .T.
.cmgallnone.cmdOne.Enabled = .T.
.cmgallnone.cmdNotOne.Enabled = .T.
.cmgokcancel.cmdOK.Enabled = .T.
Endwith
Endproc


Procedure cmddbc.Click
With Thisform
.fcdbcname = Lower(Alltrim(Getfile('DBC', '', 'Select', 0)))
.txtdbc.Refresh()
.makelistoftables()
.lstleft.SetFocus()
Endwith
Endproc


Procedure lstleft.DblClick
Thisform.cmgallnone.cmdOne.Click()
Endproc


Procedure cmgallnone.Click
With Thisform
.lstleft.Requery()
.lstleft.Refresh()
.lstright.Requery()
.lstright.Refresh()
Endwith
Endproc


Procedure cmgallnone.cmdAll.Click
Set Safety Off
Zap In curLeft
Zap In curRight
Set Safety On

Select curLeft
Append From Array Thisform.fatablename
Delete All && We need deleted records to RECALL if necessary.

Select curRight
Append From Array Thisform.fatablename
This.Parent.Click()
Endproc


Procedure cmgallnone.cmdNotAll.Click
Set Safety Off
Zap In curLeft
Zap In curRight
Set Safety On
Select curLeft
Append From Array Thisform.fatablename
This.Parent.Click()
Endproc


Procedure cmgallnone.cmdOne.Click
With Thisform.lstleft
If Not Empty(.Value)
If Seek(Left(.Value, 32), 'curLeft')
Select curRight
Recall For TableName = curLeft.TableName
If Not Seek(Left(.Value, 32), 'curRight')
Append Blank
Replace curRight.TableName With curLeft.TableName
Endif
Select curLeft
Delete
Endif
Endif
.SetFocus()
Endwith
This.Parent.Click()
Endproc


Procedure cmgallnone.cmdNotOne.Click
With Thisform.lstright
If Not Empty(.Value)
If Seek(Left(.Value, 32), 'curRight')
Select curLeft
Recall For TableName = curRight.TableName
Select curRight
Delete
Endif
Endif
.SetFocus()
Endwith
This.Parent.Click()
Endproc


Procedure lstright.DblClick
Thisform.cmgallnone.cmdNotOne.Click()
Endproc
Procedure cmgokcancel.cmdOK.Click
Local aRelation[1]
Local m.lnRelationRows, m.lcTableName
Local m.lnCtr, m.lnSub, m.lnFieldNumber
Local m.lcTagName, m.lcTagExpr, m.lcTagType, m.lcTagFor, m.lcTagAD
Local m.lcRelParTbl, m.lcRelParTag, m.lcRelRefUDI
Wait Window Nowait 'Créer un état ...veuiller patienter.'
m.lnRelationRows = Adbobjects(aRelation, 'Relation')
Dimension laFieldType[11]
laFieldType[01] = 'C Character'
laFieldType[02] = 'D Date '
laFieldType[03] = 'L Logical '
laFieldType[04] = 'M Memo '
laFieldType[05] = 'N Numeric '
laFieldType[06] = 'F Float '
laFieldType[07] = 'I Integer '
laFieldType[08] = 'B Double '
laFieldType[09] = 'Y Currency '
laFieldType[10] = 'T Date-Time'
laFieldType[11] = 'G General '
Dimension laStructure[1, 1]
Create Cursor curTableStructure ( ;
FieldName C(128), ;
FieldType C(009), ;
FieldLength N(003), ;
FieldDecimal N(002), ;
NullAllowed L, ;
CodePageBarred L, ;
FieldValidationRule C(250), ;
FieldValidationText C(250), ;
FieldDefaultValue C(250), ;
TableValidationRule C(250), ;
TableValidationText C(250), ;
LongTableName C(128), ;
InsertTrigger C(250), ;
UpdateTrigger C(250), ;
DeleteTrigger C(250), ;
TableComment C(250), ;
DBFName C(128), ;
FieldNumber N(004), ;
RecordType C(001), ;
TagExpression C(250), ;
TagType C(009), ;
TagFor C(250), ;
TagAscDesc C(001), ;
RelParentTbl C(128), ;
RelParentTag C(010), ;
RelRefIntegUDI C(006) ;
)
Select curRight
Scan
m.lcTableName = Rtrim(curRight.TableName)
Use (m.lcTableName) In 0 Shared Alias 'SourceTable'
Select SourceTable
m.lnCtr = Afields(laStructure)

Select curTableStructure
m.lnSub = Reccount()
Append From Array laStructure
Goto m.lnSub + 1
m.lnFieldNumber = 1
Do While Not Eof()
Replace LongTableName With curRight.TableName
Replace DBFName With Dbf('SourceTable')
Replace FieldNumber With m.lnFieldNumber
Replace RecordType With 'F'

m.lnSub = Ascan(laFieldType, Left(FieldType, 1))
Replace FieldType With Iif(m.lnSub > 0, ;
RIGHT(laFieldType[m.lnSub], 9), '***')
m.lnFieldNumber = m.lnFieldNumber + 1
Skip 1
Enddo
If Not Empty(Cdx(1, 'SourceTable'))
m.lcTagName = '???'
m.lnSub = 1
Select SourceTable
Do While Not Empty(m.lcTagName)
m.lcTagName = Tag(m.lnSub)
m.lcTagExpr = Key(m.lnSub)
m.lcTagType = 'Regular'
m.lcTagType = Iif(Primary(m.lnSub), 'Primary', m.lcTagType)
m.lcTagType = Iif(Candidate(m.lnSub), 'Candidate', m.lcTagType)
m.lcTagType = Iif(Unique(m.lnSub), 'Unique', m.lcTagType)
m.lcTagFor = For(m.lnSub)
m.lcTagAD = Iif(Descending(m.lnSub), 'D', 'A')
m.lcRelParTbl = ''
m.lcRelParTag = ''
m.lcRelRefUDI = ''
If m.lcTagType = 'Regular'
For m.lnSub2 = 1 To m.lnRelationRows
If (Upper(aRelation[m.lnSub2, 1]) = Upper(Alltrim(m.lcTableName)) ;
AND Upper(aRelation[m.lnSub2, 3]) = Upper(Alltrim(m.lcTagName)))
m.lcRelParTbl = aRelation[m.lnSub2, 2]
m.lcRelParTag = aRelation[m.lnSub2, 4]
m.lcRelRefUDI = aRelation[m.lnSub2, 5]
m.lcTagType = 'Foreign'
Endif
Endfor
Endif
If Not Empty(m.lcTagName)
Select curTableStructure
Append Blank
Replace FieldName With m.lcTagName
Replace TagExpression With m.lcTagExpr
Replace TagType With m.lcTagType
Replace TagFor With m.lcTagFor
Replace LongTableName With curRight.TableName
Replace FieldNumber With m.lnSub
Replace RecordType With 'I'
Replace TagAscDesc With m.lcTagAD
Replace RelParentTbl With m.lcRelParTbl
Replace RelParentTag With m.lcRelParTag
Replace RelRefIntegUDI With m.lcRelRefUDI
Select SourceTable
Endif
m.lnSub = m.lnSub + 1
Enddo
Endif
Select SourceTable
Use
Select curRight
Endscan
On Error
Wait Clear
Select curTableStructure
With Thisform
Do Case
Case .fcoutputdevice = 'Écran'
Report Form dorg Noconsole Preview
Case .fcoutputdevice = 'Imprimante'
Report Form dorg Noconsole To Printer Prompt
Case .fcoutputdevice = 'Spreadsheet'
Public ofileinfo
ofileinfo=Newobject("fileinfo")
ofileinfo.Show
Endcase
.Release()
Endwith
Return .T.
Endproc
Procedure cmgokcancel.cmdCancel.Click
Thisform.Release()
Return .T.
Endproc
Enddefine

Define Class fileinfo As Form
Height = 107
Width = 369
ShowWindow = 1
DoCreate = .T.
AutoCenter = .T.
Caption = "Outil d'analyse de base de donnés (DORG)"
ControlBox = .F.
MaxButton = .F.
MinButton = .F.
WindowType = 1
fcfilename = ""
Name = "FILEINFO"
Add Object lblline1 As Label With ;
AutoSize = .T. ;
FontBold = .T. ;
FontSize = 10, ;
Caption = "Nom du Spreadsheet:", ;
Height = 18, ;
Left = 10, ;
Top = 6, ;
Width = 150, ;
TabIndex = 3, ;
Name = "lblLine1"
Add Object txtfilename As TextBox With ;
FontSize = 10, ;
ControlSource = "ThisForm.fcFileName", ;
Height = 25, ;
Left = 10, ;
TabIndex = 5, ;
Top = 24, ;
Width = 348, ;
DisabledForeColor = Rgb(0,0,0), ;
Name = "txtFileName"
Add Object cmgokcancel As CommandGroup With ;
ButtonCount = 2, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Value = 1, ;
ControlSource = "m.lcOKCancel", ;
Height = 40, ;
Left = 64, ;
Top = 60, ;
Width = 241, ;
TabIndex = 7, ;
Name = "cmgOKCancel", ;
Command1.Top = 5, ;
Command1.Left = 5, ;
Command1.Height = 29, ;
Command1.Width = 94, ;
Command1.FontBold = .T. ;
Command1.FontSize = 10, ;
Command1.Caption = "OK", ;
Command1.TerminateRead = .T. ;
Command1.Name = "cmdOK", ;
Command2.Top = 5, ;
Command2.Left = 141, ;
Command2.Height = 29, ;
Command2.Width = 94, ;
Command2.FontBold = .T. ;
Command2.FontSize = 10, ;
Command2.Caption = "Canceler", ;
Command2.TerminateRead = .T. ;
Command2.Name = "cmdCancel"


Procedure Init
Thisform.fcfilename = Sys(05) + Curdir() + 'mafeuille.xls'
Return .T.
Endproc
Procedure cmgokcancel.cmdOK.Click
With Thisform
.fcfilename = Alltrim(.fcfilename)
Select curTableStructure
Copy To (.fcfilename) Type Xl5 Fields ;
RecordType, ;
DBFName, ;
LongTableName, ;
TableValidationRule, ;
TableValidationText, ;
InsertTrigger, ;
UpdateTrigger, ;
DeleteTrigger, ;
CodePageBarred, ;
TableComment, ;
FieldNumber, ;
FieldName, ;
FieldType, ;
FieldLength, ;
FieldDecimal, ;
NullAllowed, ;
FieldValidationRule, ;
FieldValidationText, ;
FieldDefaultValue, ;
TagExpression, ;
TagType, ;
TagFor, ;
TagAscDesc, ;
RelParentTbl, ;
RelParentTag, ;
RelRefIntegUDI
.Release()
Endwith
Declare Integer ShellExecute In "Shell32.dll" ;
INTEGER HWnd, ;
STRING lpVerb, ;
STRING lpFile, ;
STRING lpParameters, ;
STRING lpDirectory, ;
LONG nShowCmd
ShellExecute(0,"Open",Thisform.fcfilename,"","",0)
Return .T.

Endproc


Procedure cmgokcancel.cmdCancel.Click
Thisform.Release()
Return .T.
Endproc


Enddefine


www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2024.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3