هل يوجد طريقة لعمل ذلك

[محمدسلام]

احبتي في الله دام فضلكم 

في الاكسس يوجد طريقه لاستيراد الفورم والموديلات والجداول من ملف آخر فهل يوجد طريقه ما يمكن من خلالها استيراد فورم او موديول ومكرو من ملف آخر مثل الاكسس بحيث يمكن نقل او نسخ فورم أو ميكرو من ملف اكسل لملف آخر دون اللجوء الي السحب والافلات في محرر الاكواد

تقبلو وافر احترامي وتقديري

[hegazee]

الحل ممكن من خلال الأكواد: و لكن لا تنسى تفعيل 

1. اذهب إلى File > Options > Trust Center > Trust Center Settings

2. ثم اذهب إلى Macro Settings

3. فعل الخيار:
    "Trust access to the VBA project object model"

أولا تضع الكود التالي في الملف الذي تريد التصدير منه

 ' officena.net
Sub ExportAllComponentsDynamically()
    ' --- هذا الكود يقوم بتصدير جميع المكونات ديناميكيًا ---
    
    Dim vbComp As Object ' VBComponent
    Dim exportPath As String
    Dim componentName As String
    Dim fileExtension As String
    
    ' 1. حدد مسار التصدير
    exportPath = "C:\ExcelComponents\"
    
    ' 2. تأكد من وجود المجلد
    If Dir(exportPath, vbDirectory) = "" Then
        MkDir exportPath
    End If
    
    ' 3. ابدأ الحلقة للمرور على كل مكون في المشروع
    For Each vbComp In ThisWorkbook.VBProject.VBComponents
        
        ' تجاهل المكونات الخاصة بالأوراق (Worksheets) و ThisWorkbook
        If vbComp.Type = 100 Then ' 100 = vbext_ct_Document
            GoTo NextComponent
        End If
        
        ' 4. حدد امتداد الملف بناءً على نوع المكون
        Select Case vbComp.Type
            Case 1 ' vbext_ct_StdModule
                fileExtension = ".bas"
            Case 2 ' vbext_ct_ClassModule
                fileExtension = ".cls"
            Case 3 ' vbext_ct_MSForm
                fileExtension = ".frm"
            Case Else
                ' تجاهل الأنواع الأخرى
                GoTo NextComponent
        End Select
        
        ' 5. احصل على اسم المكون
        componentName = vbComp.Name
        
        ' 6. قم بتصدير المكون بالاسم والامتداد الصحيحين
        Debug.Print "Exporting: " & componentName & fileExtension
        vbComp.Export exportPath & componentName & fileExtension
        
NextComponent:
    Next vbComp
    
    MsgBox "تم تصدير جميع المكونات بنجاح إلى: " & exportPath
End Sub

ثانيا تضع الكود التالي في الملف الذي تريد استيراد العناصر إليه

' officena.net
Sub ImportAllComponentsDynamically()
    ' --- هذا الكود يقوم باستيراد جميع المكونات من مجلد محدد ---
    
    Dim importPath As String
    Dim fileName As String
    
    ' 1. حدد مسار الاستيراد
    importPath = "C:\ExcelComponents\"
    
    If Dir(importPath, vbDirectory) = "" Then
        MsgBox "المجلد المحدد غير موجود!", vbCritical
        Exit Sub
    End If
    
    ' 2. ابدأ بالبحث عن الملفات
    fileName = Dir(importPath & "*.*")
    
    On Error Resume Next ' لتجاهل الأخطاء (مثل محاولة استيراد مكون موجود)
    
    ' 3. ابدأ الحلقة للمرور على كل ملف في المجلد
    Do While fileName <> ""
        ' 4. تحقق من امتداد الملف قبل الاستيراد
        If LCase(Right(fileName, 4)) = ".frm" Or _
           LCase(Right(fileName, 4)) = ".bas" Or _
           LCase(Right(fileName, 4)) = ".cls" Then
            
            Debug.Print "Importing: " & fileName
            Application.VBE.ActiveVBProject.VBComponents.Import importPath & fileName
            
        End If
        
        ' انتقل إلى الملف التالي
        fileName = Dir
    Loop
    
    On Error GoTo 0
    
    MsgBox "اكتملت عملية الاستيراد!"
End Sub

جرب و أبلغنا بالنتيجة

  اويمكنك استخدام الكود التالي لاستيراد أي عناصر تريدها مباشرة

'Officena.net
Sub ImportComponents()
    ' --- الإصدار الثالث المصحح: استخدام Or بدلاً من In ---

    Dim sourceWB As Workbook
    Dim targetWB As Workbook
    Dim sourceFilePath As Variant
    Dim tempFolderPath As String
    Dim vbComp As Object ' VBComponent
    Dim componentName As String
    Dim fileExtension As String
    Dim fileName As String
    
    ' --- 1. الإعدادات الأولية ---
    sourceFilePath = Application.GetOpenFilename( _
        FileFilter:="Excel Macro-Enabled Files (*.xlsm), *.xlsm,All Excel Files (*.xls*), *.xls*", _
        Title:="الرجاء اختيار ملف Excel المصدر الذي تريد استيراد المكونات منه", _
        MultiSelect:=False)
        
    If sourceFilePath = False Then
        MsgBox "تم إلغاء العملية.", vbInformation
        Exit Sub
    End If
    
    tempFolderPath = Environ("TEMP") & "\VBA_Import_" & Format(Now, "yyyymmdd_hhmmss") & "\"
    If Dir(tempFolderPath, vbDirectory) = "" Then MkDir tempFolderPath
    
    Set targetWB = ThisWorkbook
    Application.ScreenUpdating = False
    
    ' --- 2. فتح المصدر وتصدير المكونات ---
    On Error GoTo ErrorHandler
    
    Set sourceWB = Workbooks.Open(sourceFilePath, ReadOnly:=True, UpdateLinks:=0)
    sourceWB.Windows(1).Visible = False
    
    For Each vbComp In sourceWB.VBProject.VBComponents
        If vbComp.Type = 100 Then GoTo NextComponent
        
        Select Case vbComp.Type
            Case 1: fileExtension = ".bas"
            Case 2: fileExtension = ".cls"
            Case 3: fileExtension = ".frm"
            Case Else: GoTo NextComponent
        End Select
        
        componentName = vbComp.Name
        vbComp.Export tempFolderPath & componentName & fileExtension
NextComponent:
    Next vbComp
    
    sourceWB.Close SaveChanges:=False
    Set sourceWB = Nothing
    
    ' --- 3. استيراد المكونات إلى الملف الهدف ---
    fileName = Dir(tempFolderPath & "*.*")
    
    Do While fileName <> ""
        ' === السطر الذي تم تصحيحه ===
        If LCase(Right(fileName, 4)) = ".frm" Or _
           LCase(Right(fileName, 4)) = ".bas" Or _
           LCase(Right(fileName, 4)) = ".cls" Then
            
            On Error Resume Next
            targetWB.VBProject.VBComponents.Remove targetWB.VBProject.VBComponents(Left(fileName, InStr(fileName, ".") - 1))
            On Error GoTo ErrorHandler
            
            targetWB.VBProject.VBComponents.Import tempFolderPath & fileName
            Debug.Print "تم استيراد: " & fileName
        End If
        ' ============================
        fileName = Dir
    Loop
    
    ' --- 4. التنظيف ---
    On Error Resume Next
    Kill tempFolderPath & "*.*"
    RmDir tempFolderPath
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    MsgBox "اكتملت عملية استيراد المكونات بنجاح من الملف: " & vbCrLf & Mid(sourceFilePath, InStrRev(sourceFilePath, "\") + 1), vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ:" & vbCrLf & Err.Description, vbCritical, "خطأ"
    If Not sourceWB Is Nothing Then sourceWB.Close SaveChanges:=False
    
    If Dir(tempFolderPath, vbDirectory) <> "" Then
        On Error Resume Next
        Kill tempFolderPath & "*.*"
        RmDir tempFolderPath
        On Error GoTo 0
    End If
    
    Application.ScreenUpdating = True
End Sub

 

Test.xlsm

تم تعديل بالامس في 11:24 بواسطه hegazee