[vbnet]

(14-06-14, 01:19 AM)allayl كتب : ...
ضغط و إصلاح قاعدة البيانات
...

.....

منقول مع تعديل بسيط ليناسب طلبك


بنظام ADO
أضف المرجع Reference التالي: Microsoft Jet and Replication Objects 2.6 Labrary أو آخر إصدار لديك
طريقة إضافة المرجع Reference عن طريقة القائمة Project ثم ...References ثم اختيار المرجع

كود :

Private Sub Command1_Click()
    If DAOCompactDatabase("db1.mdb", "") Then
        MsgBox "تم ضغط وإصلاح قاعدة البيانات بنجاح"
    End If
End Sub

' أضف المرجع: Microsoft Jet and Replication Objects 2.6 Labrary ' أو آخر إصدار لديك
Private Function ADOCompactDatabase(filename As String, Optional password As String) As Boolean
On Error GoTo ExceptionHandle
    Const Provider = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    Const JetVersion = ";Jet OLEDB:Engine Type=5"
    Dim JRO As JetEngine
    Dim strPassword As String
    Dim strTemp As String
    strTemp = Left(filename, InStrRev(filename, "\")) & "Compact.mdb"
    If Len(Dir(strTemp)) <> 0 Then Kill strTemp
    If Len(password) <> 0 Then strPassword = ";Jet OLEDB:Database Password=" & password
    Set JRO = New JetEngine
    JRO.CompactDatabase Provider & filename & strPassword, Provider & strTemp & JetVersion & strPassword
    Set JRO = Nothing
    Kill filename
    Name strTemp As filename
    ADOCompactDatabase = True
    Exit Function
ExceptionHandle:
    MsgBox Err.Description, vbInformation
End Function

بنظام DAO
أضف المرجع Reference التالي: Microsoft DAO 3.6 Object Library أو آخر إصدار لديك
طريقة إضافة المرجع Reference عن طريقة القائمة Project ثم ...References ثم اختيار المرجع

كود :

Private Sub Command1_Click()
    If DAOCompactDatabase("db1.mdb", "") Then
        MsgBox "تم ضغط وإصلاح قاعدة البيانات بنجاح"
    End If
End Sub

' أضف المرجع: Microsoft DAO 3.6 Object Library ' أو آخر إصدار لديك
Public Function DAOCompactDatabase(filename As String, Optional password As String) As Boolean
On Error GoTo ExceptionHandle
    Dim strTemp As String
    strTemp = Left(filename, InStrRev(filename, "\")) & "Compact.mdb"
    If Len(Dir(strTemp)) <> 0 Then Kill strTemp
    If Len(password) <> 0 Then
        DBEngine.CompactDatabase filename, strTemp, ";pwd=" & password, , ";pwd=" & password
    Else
        DBEngine.CompactDatabase filename, strTemp
    End If
    Kill filename
    Name strTemp As filename
    DAOCompactDatabase = True
    Exit Function
ExceptionHandle:
    MsgBox Err.Description, vbInformation
End Function

.....