1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277
| VERSION 5.00
Object = "{00028C01-0000-0000-0000-000000000046}#1.0#0"; "DBGRID32.OCX"
Begin VB.Form ZING
BackColor = &H00E0E0E0&
BorderStyle = 0 'None
Caption = " Sélection d'une Table dans une Base de Données Access97 et Access2000."
ClientHeight = 4095
ClientLeft = 30
ClientTop = 615
ClientWidth = 9510
KeyPreview = -1 'True
LinkTopic = "Zing"
MaxButton = 0 'False
MinButton = 0 'False
Moveable = 0 'False
ScaleHeight = 4393.104
ScaleMode = 0 'User
ScaleWidth = 9504
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin MSDBGrid.DBGrid DBGrid1
Bindings = "zing.frx":0000
Height = 1695
Left = 2880
OleObjectBlob = "zing.frx":0014
TabIndex = 9
Top = 2040
Width = 6255
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access 2000;"
DatabaseName = ""
DefaultCursorType= 0 'DefaultCursor
DefaultType = 2 'UseODBC
Exclusive = 0 'False
Height = 375
Left = 840
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 2760
Width = 1140
End
Begin VB.Frame Frame2
BackColor = &H000080FF&
Caption = " Tables."
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 1572
Left = 5280
TabIndex = 7
Top = 120
Width = 2172
Begin VB.ListBox List1
Appearance = 0 'Flat
BackColor = &H00FFFFC0&
Height = 810
Left = 120
TabIndex = 8
Top = 360
Width = 1812
End
End
Begin VB.Frame Frame1
BackColor = &H000080FF&
Caption = " Fichiers MDB. "
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 1572
Left = 3000
TabIndex = 0
Top = 120
Width = 1932
Begin VB.FileListBox File1
Appearance = 0 'Flat
BackColor = &H0080C0FF&
Height = 810
Left = 120
Pattern = "*.mdb*"
TabIndex = 3
Top = 360
Width = 1692
End
End
Begin VB.CommandButton CmdOuvrir
BackColor = &H00C0C0C0&
Caption = "&Ouvrir la Table"
Enabled = 0 'False
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 492
Left = 7680
TabIndex = 5
Top = 600
Width = 1575
End
Begin VB.DirListBox Dir1
Appearance = 0 'Flat
BackColor = &H00C0E0FF&
Height = 2115
Left = 720
TabIndex = 2
Top = 600
Width = 2052
End
Begin VB.DriveListBox Drive1
BackColor = &H00C0FFFF&
Height = 288
Left = 840
TabIndex = 1
Top = 120
Width = 1692
End
Begin VB.Line Line2
BorderColor = &H00FF0000&
BorderWidth = 4
X1 = 2880.182
X2 = 9480.015
Y1 = 2058.698
Y2 = 2058.698
End
Begin VB.Line Line1
BorderColor = &H00FF0000&
BorderWidth = 10
X1 = 479.697
X2 = 479.697
Y1 = 643.678
Y2 = 3089.656
End
Begin VB.Label Label1
BackColor = &H000000FF&
Height = 132
Left = 1
TabIndex = 6
Top = 6528
Width = 10000
End
Begin VB.Label LabAide
BackColor = &H00C0E0FF&
Caption = "LabAide"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 0
TabIndex = 4
Top = 3840
Width = 9990
End
Begin VB.Menu MnQuitter
Caption = " &Quitter"
End
End
Attribute VB_Name = "ZING"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Ce programme installe un modèle objet DAO pour trouver la collection des
' Tables
'
Dim Table As String, Chemin As String
Dim OPF As String, Fichier As String
Private Sub Form_Load()
Drive1.Drive = App.Path
Chemin = App.Path
Dir1.Path = Chemin
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
LabAide = " Sélectionnez le Répertoire puis cliquez sur un Fichier MDB puis sur une Table."
File1.Pattern = "*.MDB"
End Sub
'
Private Sub File1_Click()
On Error GoTo Erreur
Dim I As Long
Dim TD As TableDefs
List1.Clear
File1.Path = Dir1.Path
LabAide = " " & Dir1.Path & "\" & File1.FileName
OPF = File1.Path
OPF = OPF & "\" & File1.FileName
Data1.DatabaseName = OPF
Data1.Refresh
Set TD = Data1.Database.TableDefs
For I = 0 To TD.Count - 1
If TD(I).Attributes = 0 Then
List1.AddItem UCase(TD(I).Name)
' List1.AddItem TD(I).Attributes
End If
Next I
CmdOuvrir.Enabled = True
Exit Sub
Erreur:
If Err = 3078 Then Resume Next
MsgBox Err & " - " & Err.Description
End Sub
'
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then Beep: Unload Me
End Sub
'
Private Sub CmdOuvrir_Click()
Table = List1.Text
Call Ouverture
End Sub
'
Private Sub Dir1_Change()
File1.Path = Dir1.Path
LabAide = " " & Dir1.Path
List1.Clear
End Sub
'
Private Sub Drive1_Change()
On Error GoTo Erreur
Dir1.Path = Drive1.Drive
Exit Sub
Erreur:
If Err = 68 Or Err = 70 Or Err = 71 Or Err = 72 Then
Beep
MsgBox "Unité non prête ou lecteur sans disquette.", vbOKOnly + vbCritical, " Lecteur non prêt."
Drive1.ListIndex = 2
End If
Exit Sub
End Sub
'
Sub Ouverture()
On Error GoTo Erreur
Fichier = ""
Fichier = File1.FileName
If Table = "" Then
MsgBox "Aucune Table n'a été sélectionnée dans le Fichier " & Fichier, vbOKOnly + vbCritical, " Aucune Table sélectionnée."
Else
DBGrid1.Caption = "Base Access2000 - Fichier : " & Fichier & " - Table: " & Table
Data1.RecordSource = "SELECT * From " & Table
Data1.Refresh
CmdOuvrir.Enabled = True
End If
Exit Sub
Erreur:
MsgBox Err & " - " & Err.Description
End Sub
'
Private Sub MnQuitter_Click()
Unload Me
End Sub |
Partager