L'auteur
Mike Gagnon
 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é 8969 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 |
|---|
|
|
|
|
Retour à la liste
le 06/10/2010,
Merci mike pour nous avoir fait partager ce petit utilitaire
fort pratique.
Olivier