شخابيط وافكار شخابيط وحلول : الاستيراد من الاكسل

[ابو جودي]

السلام عليكم ورحمة الله تعالى وبركاته
 
بعد مواجهتى لمشكلة فى هذه النقطة عند التعامل مع ملفات الاكسل
بسبب اختلاف النسخ والتنسيق لملفات الاكسل تبعا لاختلاف الاصدارات كانت هذه نتيجة وخلاصة افكاارى لحل مشاكلى

اليكم الخطوات 
1- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basFileUtilityKit بها هذه الكود

' Enumeration for the types of file dialogs
Enum EnumFileDialogType
    msoFileDialogFilePicker = 1
    msoFileDialogFolderPicker = 4
End Enum

' Enumeration for different file extensions
Enum EnumFileExtensions
    AllFiles
    TextFiles
    ExcelFiles
    ImageFiles
    VideoFiles
    AudioFiles
    PDFFiles
    WordFiles
    ' You can add additional file extensions as needed here
End Enum

' Enumeration for different options related to file paths
Enum EnumOptionFile
    DirectoryWithoutFileName
    DirectoryWithFileName
    FileNameWithExtension
    FileNameWithoutExtension
    ExtensionOnly
End Enum

' Function to open the folder dialog and return the selected folder path
Function GetFolderDialog() As String
    On Error Resume Next
    Dim folderDialogObject As Object
    Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker)
    
    With folderDialogObject
        .Title = "Select Folder"
        .AllowMultiSelect = False
        .Show
    End With
    
    If folderDialogObject.SelectedItems.Count > 0 Then
        GetFolderDialog = folderDialogObject.SelectedItems(1)
    Else
        ' Handle the case where no folder is selected
        MsgBox "No folder selected.", vbExclamation
        GetFolderDialog = ""
    End If
    
    Set folderDialogObject = Nothing
    On Error GoTo 0
End Function

' Function to open the file dialog and return the selected file path
Function GetFileDialog(ByVal EnumFileExtension As EnumFileExtensions) As String
    On Error Resume Next
    
    
    ' Check if the Microsoft Office Object Library is referenced
    ' Make sure to go to Tools > References and select the appropriate version
    ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016

Dim fileDialogObject As Object
    Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker)
    
    With fileDialogObject
        .Title = "Select File"
        .AllowMultiSelect = False
        .Filters.Clear
        ' Adding filters based on the selected file extension
        Select Case EnumFileExtension
            Case EnumFileExtensions.AllFiles
                .Filters.Add "All Files", "*.*"
            Case EnumFileExtensions.TextFiles
                .Filters.Add "Text Files", "*.txt"
            Case EnumFileExtensions.ExcelFiles
                .Filters.Add "Excel Files", "*.xlsx; *.xls"
            Case EnumFileExtensions.ImageFiles
                .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif"
            Case EnumFileExtensions.VideoFiles
                .Filters.Add "Video Files", "*.mp4; *.avi; *.mov"
            Case EnumFileExtensions.AudioFiles
                .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg"
            Case EnumFileExtensions.PDFFiles
                .Filters.Add "PDF Files", "*.pdf"
            Case EnumFileExtensions.WordFiles
                .Filters.Add "Word Files", "*.docx; *.doc"
            ' You can add additional file extensions as needed here
        End Select
        
        .Show
    End With
    
    If fileDialogObject.SelectedItems.Count > 0 Then
        GetFileDialog = fileDialogObject.SelectedItems(1)
    Else
        ' Handle the case where no file is selected
        MsgBox "No file selected.", vbExclamation
        GetFileDialog = ""
    End If
    
    Set fileDialogObject = Nothing
    
    Exit Function
    
    If Err.Number <> 0 Then
    
    Select Case Err.Number
        Case 3078: Resume Next  ' Ignore error if user cancels the file dialog
        Case 0: Resume Next
        Case Else
'             Call ErrorLog(Err.Number, Error$, strProcessName)
    End Select
        ' Clear the error
        Err.Clear
    End If

End Function

' Function to get the desired option for a file path
Function GetFileOption(ByRef strFilePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = DirectoryWithFileName) As String
    On Error Resume Next
    Select Case EnumOptionFile
        Case DirectoryWithoutFileName
            GetFileOption = Left(strFilePath, InStrRev(strFilePath, "\"))
        
        Case DirectoryWithFileName
            GetFileOption = strFilePath
        
        Case FileNameWithExtension
            GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1)
        
        Case ExtensionOnly
            GetFileOption = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, "."))
        
        Case FileNameWithoutExtension
            GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1, InStrRev(strFilePath, ".") - InStrRev(strFilePath, "\") - 1)
    End Select
    On Error GoTo 0
End Function

' Function to get additional information about a file
Function GetFileInfo(filePath As String) As String
    On Error Resume Next
    Dim fileInfo As String
    fileInfo = "File Information:" & vbCrLf
    fileInfo = fileInfo & "Path: " & filePath & vbCrLf
    fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf
    fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf
    GetFileInfo = fileInfo
    On Error GoTo 0
End Function

شرح الوظائف فى هذه الوحدة النمطية 

Enumerations توفر طريقة لتعريف مجموعة من الثوابت التي يمكن استخدامها لتحديد أنواع معينة من القيم.

EnumFileDialogType
هذه الـ Enumeration تستخدم لتحديد نوع مربع الحوار الخاص بالملفات:

msoFileDialogFilePicker: لفتح مربع حوار لاختيار الملفات.

msoFileDialogFolderPicker: لفتح مربع حوار لاختيار المجلدات.

EnumFileExtensions
هذه الـ Enumeration تستخدم لتحديد نوع الامتدادات التي يمكن اختيارها من مربع حوار الملفات:

AllFiles: جميع الملفات.

TextFiles: ملفات النصوص.

ExcelFiles: ملفات إكسل.

ImageFiles: ملفات الصور.

VideoFiles: ملفات الفيديو.

AudioFiles: ملفات الصوت.

PDFFiles: ملفات PDF.

WordFiles: ملفات وورد.

EnumOptionFile
هذه الـ Enumeration تستخدم لتحديد الخيارات المختلفة المتعلقة بالمسارات:

DirectoryWithoutFileName: المسار بدون اسم الملف.

DirectoryWithFileName: المسار مع اسم الملف.

FileNameWithExtension: اسم الملف مع الامتداد.

FileNameWithoutExtension: اسم الملف بدون الامتداد.

ExtensionOnly: الامتداد فقط.

Functions
GetFolderDialog
هذه الدالة تفتح مربع حوار لاختيار المجلدات وتعيد المسار الكامل للمجلد الذي تم اختياره. إذا لم يتم اختيار أي مجلد، تعرض رسالة تنبيه وتعيد قيمة فارغة.
 

GetFileDialog
هذه الدالة تفتح مربع حوار لاختيار الملفات وتعيد المسار الكامل للملف الذي تم اختياره.
يمكنك تحديد نوع الملفات المسموح باختيارها عبر الـ EnumFileExtensions.
إذا لم يتم اختيار أي ملف، تعرض رسالة تنبيه وتعيد قيمة فارغة.

GetFileOption
هذه الدالة تستخدم لتحديد أجزاء معينة من مسار الملف بناءً على القيمة المحددة في الـ EnumOptionFile:

DirectoryWithoutFileName: يعيد المسار بدون اسم الملف.

DirectoryWithFileName: يعيد المسار مع اسم الملف.

FileNameWithExtension: يعيد اسم الملف مع الامتداد.

FileNameWithoutExtension: يعيد اسم الملف بدون الامتداد.

ExtensionOnly: يعيد الامتداد فقط

GetFileInfo
هذه الدالة تعيد معلومات حول ملف محدد، بما في ذلك المسار، الحجم، وتاريخ الإنشاء. تعرض هذه المعلومات كجزء من نص مرتجع.

------------------------
2- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basExcelDataImport بها هذه الكود

Public Const strTableExcel As String = "tblImportExcel"

Function ExcelDataImport(ByRef excelFilePath As String)
    On Error Resume Next ' Disable error handling temporarily
    
    Const xlOpenXMLWorkbook As Long = 51

    ' Variables for Excel and Access
    Dim excelApp As Object
    Dim excelWorkbook As Object
    Dim excelOpened As Boolean
    Dim sourceFileName As String
    Dim mainDirectory As String
    Dim convertedExcelFilePath As String

    ' Check if the Excel file path is provided
    If Nz(excelFilePath, "") = "" Then Exit Function


    ' Check if the Excel file exists
    If Dir(excelFilePath) = "" Then Exit Function

    ' Extract file information
    sourceFileName = GetFileOption(excelFilePath, FileNameWithExtension)
    mainDirectory = GetFileOption(excelFilePath, DirectoryWithoutFileName)
    convertedExcelFilePath = excelFilePath

    ' Create Excel application object
    Set excelApp = CreateObject("Excel.Application")

    ' Check if Excel application is successfully created
    If Err.Number <> 0 Then
        Err.Clear
        Set excelApp = CreateObject("Excel.Application")
        excelOpened = False
    Else
        excelOpened = True
    End If

    ' Reset error handling
    On Error GoTo 0

    ' Set Excel application visibility
    excelApp.Visible = False

    ' Open Excel workbook
    Set excelWorkbook = excelApp.Workbooks.Open(mainDirectory & sourceFileName)

    ' Save the workbook in xlsx format without displaying alerts
    excelApp.DisplayAlerts = False
    excelWorkbook.SaveAs Replace(mainDirectory & sourceFileName, ".xls", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    excelApp.DisplayAlerts = True

    ' Close the workbook without saving changes
    excelWorkbook.Close False

    ' Quit Excel application if it was opened by the function
    If excelOpened = True Then excelApp.Quit

    ' Update the source file name with the new extension
    sourceFileName = sourceFileName & "x"

    ' Reset file attributes
    SetAttr mainDirectory & sourceFileName, vbNormal

    ' Import Excel data into Access table
    DoCmd.SetWarnings False
       
    'acSpreadsheetTypeExcel8
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTableExcel, mainDirectory & sourceFileName, True
    

ExitFunction:
    ' Enable system alerts before exiting the function
    DoCmd.SetWarnings True
    Exit Function

ErrorHandler:
    ' Handle errors
    Select Case Err.Number
        Case 3078: Resume Next  ' Ignore error if user cancels the file dialog
        Case 0: Resume Next
        Case Else
'             Call ErrorLog(Err.Number, Error$, strProcessName)
    End Select
End Function


' Function to delete all records from the specified table
Sub DeleteAllRecords(Optional ByRef strTable As String = "")
    On Error Resume Next
    
    If Nz(strTable, "") = "" Then strTable = strTableExcel
       
    CurrentDb.Execute "DELETE FROM " & strTable

    
     ' Handle errors
    Select Case Err.Number
        Case 3078
            If strTable = strTableExcel Then Resume Next Else
                     
        Case Else
'             HandleAndLogError strProcessName
    End Select
End Sub

شرح الوظائف فى هذه الوحدة النمطية 
الدالة ExcelDataImport
تستورد بيانات من ملف Excel إلى جدول في قاعدة بيانات Access.
strTableExcel: ثابت يحدد اسم الجدول في قاعدة بيانات Access الذي سيتم استيراد بيانات Excel إليه.
excelFilePath: مسار ملف Excel الذي سيتم استيراد البيانات منه.


------------------------
3- انشاء نموذج وفى الحدث عند النقر على زر الامر استخدم الكود التالى 

Private Sub cmdSubmit_Click()
    ' Get the path of the Excel file
    Dim strFilePath As String
    strFilePath = GetFileDialog(EnumFileExtensions.ExcelFiles)

    ' Check if a file was selected
    If strFilePath <> "Cancelled" Then
        ' Show status label
        Me!lblStatus.Visible = True
        Me!lblStatus.Caption = "Please wait ... "

        ' Clear TableData
        DeleteAllRecords

        ' Import data from Excel
        ExcelDataImport strFilePath
        
        
        ' Add Or Update Yor Table
        
        ' Hide the status label or reset any visual indicator
        Me!lblStatus.Visible = False
    Else
         
        ' User canceled the file selection
        MsgBox "File selection canceled", vbExclamation

    End If
End Sub

الان يتبقى عمل الاستعلام اللازم لاضاقة او تحديث وتعديل بياناتك طبقا لجدول الاكسس حسب رغباتك وتطلعاتك

واخيرا مرفق قاعدة البيانات


 

ImportFromExel.accdb

[abouelhassan]

شكر من القلب وتقدير واحترام من اخيك 

[abouelhassan]

نحتاج من ابداعك اخى برنامج شامل لتصدير اى جدول إلى اكسيل مع تحديد مسار الحفظ واستيراد البيانات من الاكسيل إلى الجدول 

موضوع مهم للحفاظ ولنقل البيانات نحتاجه بلمسة احترافية من إبداعاتك

مشكووور