شفرة برنامج لاستخراج الكودمن ملفات الاكسس mdb
ولكن للاسف لا اعرف كيف يعمل الرجاء من الاخوه المساعده وشكرا
Option Compare Database
Option Explicit
Dim cnn As ADODB.Connection
Dim pth As String 'Database Path
Dim ErrGen As Boolean
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Sub GetPath()
On Error GoTo ErrGetPath
' Set CancelError is True
CommonDialog1.CancelError = True
' Set flags
CommonDialog1.Flags = cdlOFNHideReadOnly
' Set filters
CommonDialog1.Filter = "All Files(*.*)|*.*|Access 2000 DB (*.mdb)|*.mdb"
' Specify default filter
CommonDialog1.FilterIndex = 2
' Display the Open dialog box
CommonDialog1.ShowOpen
' Display name of selected file
pth = CommonDialog1.FileName
Exit Sub
ErrGetPath:
'User pressed the Cancel button
pth = vbNullString
Exit Sub
End Sub
Private Sub Connect()
On Error GoTo CnnError
Dim strCnn As String
strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;"
strCnn = strCnn & "Data Source=" & pth & ";"
strCnn = strCnn & "Jet OLEDB:Engine Type=5;"
Set cnn = New ADODB.Connection
cnn.Open strCnn
Exit Sub
CnnError:
Dim psw As String
Select Case Err
Case Is = -2147217843 'Database password incorrect
psw = ObtainPassword
strCnn = vbNullString
strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;"
strCnn = strCnn & "Data Source=" & pth & ";"
strCnn = strCnn & "Jet OLEDB:Engine Type=5;"
strCnn = strCnn & psw
If LenB(psw) = 0 Then
Resume Next
Else
Resume
End If
Case Else
MsgBox "Error Number : " & Err & vbCrLf & Error, vbCritical, Err.Source
End
End Select
End Sub
Private Sub CodeGen()
On Error GoTo ErrorGen
Dim Ctl As ADOX.Catalog
Dim CtlTbl As ADOX.Table
Dim CtlIdx1 As ADOX.Index
Dim Col As ADOX.Column
Dim sGen As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Screen.MousePointer = vbHourglass
txtCodeGen.Text = vbNullString
'Open the Database Catalog from Actual Connection
Set Ctl = New ADOX.Catalog
Ctl.ActiveConnection = cnn
GenerateCode "Private Sub CreateDatabase()"
GenerateCode "On Error Goto ErrorCreateDB" & vbCrLf & vbCrLf & _
"Dim Cat As New ADOX.Catalog" & vbCrLf & _
"Dim Tbl(" & Ctl.Tables.Count - 1 & ") As ADOX.Table" & vbCrLf & _
"Dim Idx() As ADOX.Index" & vbCrLf & _
"Dim msgErrR As integer" & vbCrLf & _
"Dim sCnn As String " & vbCrLf & vbCrLf & _
"sCnn = ""Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Jet OLEDB:Engine Type=5;Data Source=" & App.Path & "\NuevaDB.mdb""" & vbCrLf & vbCrLf & _
"Cat.Create sCnn" & vbCrLf
ProgressBar1.Max = Ctl.Tables.Count
ProgressBar1.Visible = True
lblMessage.Visible = True
cmdExit.Visible = False
'Get table names
i = 0
'Table Definitions
For Each CtlTbl In Ctl.Tables
If CtlTbl.Type = "TABLE" Then
GenerateCode " '----------* Table Definition of " & CtlTbl.Name & " *----------"
GenerateCode " Set Tbl(" & Trim$(Str$(i)) & ")= New ADOX.Table"
GenerateCode " Tbl(" & Trim$(Str$(i)) & ").ParentCatalog = Cat"
GenerateCode " With Tbl(" & Trim$(Str$(i)) & ")" & vbTab
GenerateCode " .Name = """ & CtlTbl.Name & """"
'Field Definitions
For Each Col In CtlTbl.Columns
lblMessage.Caption = "Generating code... Table " & CtlTbl.Name
sGen = sGen & " .Columns.Append """ & Col.Name & """, " & Trim$(LoadResString(Col.Type)) & IIf(Col.DefinedSize <> 0 And Col.Type <> adBoolean, ", " & Col.DefinedSize, "") & vbCrLf
'Some Properties
If Col.Properties("AutoIncrement").Value Then
sGen = sGen & " .Columns(""" & Col.Name & """).Properties(""AutoIncrement"").Value = True" & vbCrLf
End If
If Len(Col.Properties("Description").Value) > 0 Then
sGen = sGen & " .Columns(""" & Col.Name & """).Properties(""Description"").Value = """ & Col.Properties("Description").Value & """" & vbCrLf
End If
If Not Col.Properties("Nullable").Value = False Then
sGen = sGen & " .Columns(""" & Col.Name & """).Properties(""Nullable"").Value = False" & vbCrLf
End If
If Len(Col.Properties("Default").Value) > 0 Then
sGen = sGen & " .Columns(""" & Col.Name & """).Properties(""Default"").Value = """ & Col.Properties("Default").Value & """" & vbCrLf
End If
Next Col
sGen = sGen & " End With"
'Indexes
If CtlTbl.Indexes.Count > 0 Then
lblMessage.Caption = "Generating code... Indexes in Table " & CtlTbl.Name
sGen = sGen & vbCrLf & " '----------* Index Definitions of " & CtlTbl.Name & " *----------" & vbCrLf
sGen = sGen & " ReDim Idx(" & Trim$(Str$(CtlTbl.Indexes.Count - 1)) & ")" & vbCrLf
End If
j = 0
For Each CtlIdx1 In CtlTbl.Indexes
lblMessage.Caption = "Generating code... Index " & CtlIdx1.Name & " in Table " & CtlTbl.Name
sGen = sGen & " Set Idx(" & Trim$(Str$(j)) & ")= New ADOX.Index" & vbCrLf
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Name = """ & CtlIdx1.Name & """" & vbCrLf
If CtlIdx1.PrimaryKey Then
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").PrimaryKey = True" & vbCrLf
End If
If CtlIdx1.IndexNulls <> adIndexNullsDisallow Then
Select Case CtlIdx1.IndexNulls
Case Is = 0
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").IndexNulls = adIndexNullsAllow" & vbCrLf
Case Is = 2
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").IndexNulls = adIndexNullsIgnore" & vbCrLf
Case Is = 4
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").IndexNulls = adIndexNullsIgnoreAny" & vbCrLf
End Select
End If
If CtlIdx1.Unique = True Then
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Unique = True" & vbCrLf
End If
If CtlIdx1.Columns.Count = 1 Then
'Single Column Index
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Columns.Append """ & CtlIdx1.Columns(0).Name & """" & vbCrLf
If CtlIdx1.Columns.Item(0).SortOrder = adSortDescending Then
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Columns(""" & CtlIdx1.Columns(0).Name & """).SortOrder = adSortDescending" & vbCrLf
End If
ElseIf CtlIdx1.Columns.Count > 1 Then
'MultiColumn Index
For k = 0 To CtlIdx1.Columns.Count - 1
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Columns.Append """ & CtlIdx1.Columns(k).Name & """" & vbCrLf
If CtlIdx1.Columns.Item(k).SortOrder = adSortDescending Then
sGen = sGen & " Idx(" & Trim$(Str$(j)) & ").Columns(""" & CtlIdx1.Columns(k).Name & """).SortOrder = adSortDescending" & vbCrLf
End If
Next k
End If
j = j + 1
Next CtlIdx1
If j > 1 Then
sGen = sGen & " For i = 0 to UBound(Idx)" & vbCrLf
sGen = sGen & " Tbl(" & Trim$(Str$(i)) & ").Indexes.Append Idx(i)" & vbCrLf
sGen = sGen & " Next i" & vbCrLf
ElseIf j = 1 Then
sGen = sGen & " Tbl(" & Trim$(Str$(i)) & ").Indexes.Append Idx(0)" & vbCrLf
End If
GenerateCode sGen
GenerateCode " Cat.Tables.Append Tbl(" & Trim$(Str$(i)) & ")" & vbCrLf
sGen = vbNullString
End If
i = i + 1
ProgressBar1.Value = i
Next CtlTbl
'Error code
sGen = " Set Cat = Nothing" & vbCrLf
sGen = sGen & " Exit Sub" & vbCrLf & vbCrLf
sGen = sGen & " ErrorCreateDB:" & vbCrLf
sGen = sGen & " msgErrR = MsgBox("""
sGen = sGen & " Error No. "" & Err & "" "" & vbCrLf & Error, vbCritical+vbAbortRetryIgnore, ""Code Gen Error"")" & vbCrLf
sGen = sGen & " Select Case msgErrR" & vbCrLf
sGen = sGen & " Case Is = vbAbort" & vbCrLf
sGen = sGen & " If Not (Cat is Nothing) Then" & vbCrLf
sGen = sGen & " Set Cat = Nothing" & vbCrLf
sGen = sGen & " Endif" & vbCrLf
sGen = sGen & " Exit Sub" & vbCrLf
sGen = sGen & " Case Is = vbRetry" & vbCrLf
sGen = sGen & " Resume Next" & vbCrLf
sGen = sGen & " Case Is = vbIgnore" & vbCrLf
sGen = sGen & " Resume" & vbCrLf
sGen = sGen & " End Select" & vbCrLf & vbCrLf
sGen = sGen & "End Sub"
GenerateCode sGen
ProgressBar1.Visible = False
lblMessage.Visible = False
cmdExit.Visible = True
Screen.MousePointer = vbDefault
Exit Sub
ErrorGen:
MsgBox "Error No. " & Err & vbCrLf & Error, vbCritical, "Error"
ErrGen = True
cmdExit.Visible = True
ProgressBar1.Visible = False
lblMessage.Visible = False
Screen.MousePointer = vbDefault
Exit Sub
End Sub
Private Sub GenerateCode(ByRef CodeLine As String)
LockWindowUpdate txtCodeGen.Hwnd
txtCodeGen.SelText = CodeLine & vbCrLf
LockWindowUpdate False
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not (cnn Is Nothing) Then
cnn.Close
Set cnn = Nothing
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case Is = 1 'Open and Genera
'Obtain the database path
GetPath
'Check if we have correct path!
If LenB(pth) > 0 And LenB(Dir(pth)) > 0 Then
'Connect to Database
Connect
'Check if we have a connection now
If Not (cnn Is Nothing) Then
'Start code generation
CodeGen
If Not ErrGen Then
MsgBox "Generation finished without errors.", vbInformation
Else
MsgBox "This program found errors during the generation.", vbExclamation
End If
End If
End If
Case Is = 3 'Cut
Clipboard.SetText txtCodeGen.SelText, vbCFText
txtCodeGen.SelText = vbNullString
Case Is = 4 'Copy
Clipboard.SetText txtCodeGen.SelText, vbCFText
Case Is = 5 'Paste
txtCodeGen.SelText = Clipboard.GetText(vbCFText)
End Select
End Sub
Private Function ObtainPassword() As String
Dim psw As String
psw = vbNullString
Do While Len(psw) = 0
frmLogin.Show vbModal
psw = frmLogin.Password
If frmLogin.NoMore Then
ObtainPassword = vbNullString
Exit Do
End If
Loop
If Len(psw) > 0 And (Not frmLogin.NoMore) Then
ObtainPassword = ";Jet OLEDB:Database Password=" & psw & ";"
Unload frmLogin
Else
MsgBox "The correct password is needed to" & vbCrLf & "start the code generation.", vbExclamation
ObtainPassword = vbNullString
Set cnn = Nothing
Unload frmLogin
End If
End Function