استفسار عن تحويل صيغة الاكسل

[جرح العراقي]

السلام عليكم ...

كيف يتم تحويل ملف اكسل الى ملف قواعد بيانات ؟

هل يمكن تحويل ملف اكسل تحت اسم (a.xls) الى ملف فوكس برو (a.dbf)

[ياسر خليل أبو البراء]

أخي الكريم جرح العراقي

يرجى فيما بعد وضع عنوان مناسب للموضوع ..يمكنك التعديل لعنوان ملائم ..مثلاً (تحويل ملف إكسيل إلى ملف فوكس برو DBF)

 

عموماً قم بعملية بحث مطورة وتحصلت على كود يؤدي الغرض إن شاء الله

كما أنه توجد برامج تقوم بهذه المهمة

إليك الكود التالي ..لاحظ أن هناك بعض المكتبات يجب إضافتها ليعمل الكود

المكتبات موجودة في بداية الكود ، وتكون الإضافة عن طريق Tools ثم References

جرب الكود ..

'References:
'***********
'Microsoft ActiveX Data Objects Library
'Microsoft ADO Ext. 6.0 for DDL and security
'Microsoft Scripting Runtime
'--------------------------------------------

Sub ExportToDBF()
    Dim FileName As Variant
    Dim Temp As Variant
    Dim CurrentFile As String
    Dim DefaultFile As String
    Dim sPath As String
    sPath = ThisWorkbook.Path

    CurrentFile = ActiveWorkbook.Name
    Temp = Split(CurrentFile, ".")
    Temp(UBound(Temp)) = "dbf"
    DefaultFile = Join(Temp, ".")

    If DefaultFile = "dbf" Then
        DefaultFile = ActiveWorkbook.Name & ".dbf"
    End If

    FileName = sPath & "\" & DefaultFile

    If FileName = False Then Exit Sub
    Call DoSaveDefault(FileName)
End Sub

Function DoSaveDefault(ByVal FileName As String)
    Dim Path As Variant
    Dim File As Variant
    Dim Tfile As Variant
    Dim Table As Variant
    Dim dbConn As ADODB.Connection

    Path = Split(FileName, "\")
    File = Path(UBound(Path))
    File = Replace(Left(File, Len(File) - 4), ".", "_") & Right(File, 4)
    Tfile = "__T_DB__.dbf"
    Path(UBound(Path)) = ""
    Path = Join(Path, "\")
    Table = Left(Tfile, 8)
    FileName = Path & File

    On Error Resume Next
    GetAttr FileName
    If Err.Number = 0 Then
        Dim mbResult As VbMsgBoxResult
        mbResult = MsgBox("The file " & File & " already exists. Do you want to replace the existing file?", _
                          VbMsgBoxStyle.vbYesNo + VbMsgBoxStyle.vbExclamation, "File Exists")
        If mbResult = vbNo Then
            DoSaveDefault = False
            Exit Function
        Else
            SetAttr FileName, vbNormal
            Kill FileName
        End If
    End If

    Err.Number = 0

    GetAttr FileName
    If Err.Number = 0 Then
        MsgBox "Unable to remove existing file " & File & ".", vbExclamation, "Error Removing File"
        DoSaveDefault = False
        Exit Function
    End If
    On Error GoTo 0
    
    Set dbConn = New ADODB.Connection
    dbConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Path & ";Extended Properties=""DBASE IV;"";"

    Dim DataRange As Range
    Set DataRange = Selection

    If DataRange.Areas.Count > 1 Then
        MsgBox "The command you chose cannot be performed with multiple selections. Select a single range and click the command again.", _
               VbMsgBoxStyle.vbCritical, "Error Saving File"
        DoSaveDefault = False
        Exit Function
    End If

    If DataRange.Cells.Count = 1 Then
        Dim Row1 As Integer
        Dim RowN As Integer
        Dim Col1 As Integer
        Dim ColN As Integer
        Dim CellFirst As Range
        Dim CellLast As Range

        Row1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
        Col1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
        RowN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        ColN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

        Set CellFirst = ActiveSheet.Cells(Row1, Col1)
        Set CellLast = ActiveSheet.Cells(RowN, ColN)
        Set DataRange = ActiveSheet.Range(CellFirst.Address, CellLast.Address)
    End If

    Dim I As Long
    Dim J As Long
    Dim NumCols As Long
    Dim NumDataCols As Long
    Dim NumRows As Long
    Dim C As Range
    Dim CreateString As String
    Dim Fieldpos(), Fieldvals(), Fieldtypes(), Fieldnames(), Fieldactive()

    NumCols = DataRange.Columns.Count
    NumDataCols = 0
    NumRows = DataRange.Rows.Count
    ReDim Fieldtypes(0 To NumCols - 1)
    ReDim Fieldnames(0 To NumCols - 1)
    ReDim Fieldactive(0 To NumCols - 1)

    I = 0
    For Each C In DataRange.Rows(1).Columns
        If WorksheetFunction.CountA(C.EntireColumn) > 0 Then
            Fieldactive(I) = True
            NumDataCols = NumDataCols + 1

            If VarType(C.Value) = vbString Then
                Fieldnames(I) = Left(Replace(C.Value, " ", "_"), 10)
            Else
                Fieldnames(I) = "N" & C.Column
            End If
        Else
            Fieldactive(I) = False
        End If

        I = I + 1
    Next

    ReDim Fieldpos(0 To NumDataCols - 1)
    ReDim Fieldvals(0 To NumDataCols - 1)
    For I = 0 To NumDataCols - 1
        Fieldpos(I) = I
    Next

    If DataRange.Rows.Count < 2 Then
        For I = 0 To NumCols - 1
            If Fieldactive(I) Then
                Fieldtypes(I) = vbString
            End If
        Next
    Else
        I = 0

        For Each C In DataRange.Rows(2).Columns
            If Fieldactive(I) Then
                Fieldtypes(I) = VarType(C.Value)
            End If

            I = I + 1
        Next
    End If

    Dim Cat As ADOX.Catalog
    Dim Tbl As ADOX.Table
    Dim Col As ADOX.Column
    Set Cat = New ADOX.Catalog
    Cat.ActiveConnection = dbConn
    Set Tbl = New ADOX.Table
    Tbl.Name = Table
    For I = 0 To NumCols - 1
        If Fieldactive(I) Then
            Set Col = New ADOX.Column
            Col.Name = Fieldnames(I)
            FillColumnType Col, Fieldtypes(I), DataRange.Columns(I + 1)
            Tbl.Columns.Append Col
            Set Col = Nothing
        End If
    Next
    On Error Resume Next
    Cat.Tables.Delete Table
    On Error GoTo 0
    Cat.Tables.Append Tbl

    Dim RS As ADODB.Recordset
    Dim R As Range
    Dim Row As Long
    Set RS = New ADODB.Recordset

    RS.Open Table, dbConn, adOpenDynamic, adLockPessimistic, adCmdTable

    If RS.LockType = LockTypeEnum.adLockReadOnly Then
        MsgBox "The recordset is read-only.", vbExclamation, "Error Inserting Record"
    End If

    For Row = 2 To NumRows
        Set R = DataRange.Rows(Row)
        If WorksheetFunction.CountA(R.EntireRow) > 0 Then
            I = 0
            J = 0
            For Each C In R.Cells
                If Fieldactive(I) Then
                    Fieldvals(J) = GetValByVbType(C.Text, Fieldtypes(I))
                    J = J + 1
                End If
                I = I + 1
            Next
            RS.AddNew Fieldpos, Fieldvals
        End If
    Next

    RS.Close
    dbConn.Close

    Dim FS As Scripting.FileSystemObject
    Set FS = New Scripting.FileSystemObject
    FS.CopyFile Path & Tfile, FileName
    Set FS = Nothing
    Kill Path & Tfile

    DoSaveDefault = True
End Function

Function FillColumnType(Col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean
    Dim GetAdoTypeFromVbType As Boolean
    Select Case vtype
    Case vbInteger, vbLong, vbByte
        Col.Type = adInteger
    Case vbSingle, vbDouble, vbDouble
        FillColNumberType Col, colrange
    Case vbCurrency
        Col.Type = adCurrency
    Case vbDate
        Col.Type = adDate
    Case vbBoolean
        Col.Type = adBoolean
    Case vbString
        FillColStringType Col, colrange
    Case Else
        Col.Type = adWChar
        Col.Precision = 32
    End Select

    GetAdoTypeFromVbType = True
End Function

Function GetValByVbType(ByVal s As String, ByVal T As Long)
    Dim Result As Variant
    Result = Null

    On Error Resume Next
    Select Case T
    Case vbInteger, vbLong, vbByte
        Result = CInt(s)
    Case vbSingle, vbDouble, vbCurrency, vbDecimal
        If CInt(s) <> CDec(s) Then
            Result = CDec(s)
        Else
            Result = CInt(s)
        End If
    Case vbDate
        Result = CDate(s)
    Case vbBoolean
        Result = CInt(s) <> 0
    Case vbString
        Result = s
    Case Else
        Result = Null
    End Select
    On Error GoTo 0

    GetValByVbType = Result
End Function

Function FillColStringType(Col As ADOX.Column, R As Range) As Boolean
    Dim Lenshort As Long
    Dim Lenlong As Long
    Dim L As Long
    Dim C As Range

    Lenshort = Len(R.Cells(2).Text)
    Lenlong = Lenshort

    For Each C In R.Cells
        If C.Row > 1 Then
            L = Len(C.Text)
            If L < Lenshort Then
                Lenshort = L
            End If

            If L > Lenlong Then
                Lenlong = L
            End If
        End If
    Next

    If Lenlong > 254 Then
        Col.Type = adLongVarWChar
    ElseIf Lenlong > 128 And Lenlong < 255 Then
        Col.Type = adWChar
        Col.Precision = 254
    ElseIf Lenshort = Lenlong And Lenlong < 17 Then
        Col.Type = adWChar
        Col.Precision = Lenlong
    Else
        Col.Type = adWChar
        Col.Precision = CeilPow2(Lenlong)
    End If

    FillColStringType = True
End Function

Function FillColNumberType(Col As ADOX.Column, R As Range) As Boolean
    Dim HasDecimal As Boolean
    Dim T As Boolean
    Dim C As Range

    HasDecimal = False

    On Error Resume Next
    For Each C In R.Cells
        If C.Row > 1 Then
            T = Val(C.Text) <> Int(Val(C.Text))
            If Err.Number = 0 And T Then
                HasDecimal = True
                Exit For
            End If
        End If
    Next
    On Error GoTo 0

    If HasDecimal Then
        Col.Type = adNumeric
        Col.Precision = 11
        Col.NumericScale = 4
    Else
        Col.Type = adInteger
    End If

    FillColNumberType = True
End Function

Function CeilPow2(x As Long)
    Dim I As Long
    I = 2
    Do While I < x
        I = I * 2
    Loop

    CeilPow2 = I
End Function

تقبل تحياتي

[جرح العراقي]

بارك الله بك لاهتمامك وجعله في ميزان اعمالك ..........

[ياسر خليل أبو البراء]

هل جربت الكود أخي الحبيب وتم التحويل بنجاح ..

هل يمكنك تحميل البرنامج الذي يقوم باستعراض هذا النوع من الملفات DBF؟ فضلاً ارفقه هنا أو ارفعه على موقع من مواقع الرفع (بس يا ريت يكون كامل مش تجريبي)