hanan_ms

=============================================( صور + مرفق + فيديو ) Update: 🌹 استاذ @Foksh ❤️🌹 لما انتهي منه اقدم شرح بيسط لطريقة الاستخدام بعض التعديلات مثل دالة موحده لكافة التقارير والنماذج بتحدد الصلاحيات للمستخدمين وتنسيق النافذه والادوات ممكن (تعديل على الدالة فقط) افضل من تعديل على كل النماذج والتقارير 😇 تم اضافة دالة للاخطاء وتبسيط الكود 😂 بالاخير دمج الداول بدالة Name_Function : User_Mod_Admin ----------------------------------------------- @Foksh ❤️🌹اسألك هل عندك اقتراحات او كود او دالة لو التعديل لاي جزء استكمال ☕ 1- استكمال بتعديل على ادوات انشاء القوائم للواجهة الرئيسية 2- تعديل عند الخطأ كود حيث يمكن زيادة عدد الحقول بجلب IP And .... ToEnd تعديل داخل دالة واحده لاي حدث للنماذج او التقارير كود كود: '-----------------------------------------------------------------------( Error_Finction) exit_Ops: Exit Sub ops: Dim Error_Finction As String Error_Finction = err.Number & ":" & err.Description _ & ":" & Me.ActiveControl.name & ":" & Me.Form.name Error_Now (Error_Finction) DoEvents Resume exit_Ops Exit Sub 3- نسيت عرض بتحديث امس اضافة تخصيص للتقارير عند قائمة 😇 Admin And Devloper \ InFo_Company ...+ بعض من التصحيحات واستكمال ========================================= الاستكمال قريبا تحميل المرفق https://www.mediafire.com/file/yx87dhkb8gderak/Update_16-2-2025_Add_v3_Into_4_User_Control_Open_App.rar/file

=============================================( صور + مرفق + فيديو ) Update: 🌹 استكمال ☕ 1- تعديل الدالة بجعل الاعدادة وتنسيق بدالة واحد للمستخدم لكافة التقارير ( حجم التقرير كامل الشاشة وليس متغير كحجم النماذج ) الدالة : Public Function ReportAllowed(ByVal strname As String) As String '(FrmName As String) As Boolean ' ===========! '===================================( Only Copy this Dim name as sours type Dim strMsg_Give_Nmae As Response Dim GiveMeError As Recordset Dim Run_Cod1 As Integer Dim s2 As Integer Dim iprgrs As Long Dim MsG1 As String Dim MsG2 As String Dim MsG3 As String Dim strMsg_X As String Dim Title_X As String Dim SubTitle_X As String On Error GoTo ops Dim User_Name As String Dim ID_Name As String User_Name = DLookup("[name_user]", "[Control_User]") ID_Name = DLookup("[IDDX]", "[Control_User]") 'IDDX '===========( Name_Report For Reprt Control User '==========================================(1)No use True Dim Name_X As String Name_X = ReportAllowed '==============================================(Chack frist) If IsNull(DLookup("[name_rep]", "[User_Report]", "[name_rep] ='" & strname & "' And [IDDX] =" & ID_Name & " ")) Then MsG2 = "Sand Massage !" MsG1 = "لم تهئة الادارة بصلاحيات " MsG3 = " الرجاء الاتصال على مركز المعلومات لتهيئة والصلاحيات خطأ 101" MyMsgBox (MsG3), (MsG2), (MsG1), msg_Exclamation, Btn_OK_Only, Arabic_Center ', True, 2.5 DoCmd.Close acReport, strname Exit Function End If '============================================================================( Open REport If DLookup("[Open_Rep]", "[User_Report]", "[name_rep] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then 'DoCmd.OpenReport strname End If If DLookup("[Open_Rep]", "[User_Report]", "[name_rep] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = False Then MsG2 = "Sand Massage !" MsG1 = "تنبيه للمستخدم! رسالة ادارية راجع المسؤل المختص " MsG3 = "الا تملك صلاحية الدخول او ليس لك حق الدخول او تم حظرك من الدخول او تم منعك من الدخول " MyMsgBox (MsG3), (MsG2), (MsG1), msg_Exclamation, Btn_OK_Only, Arabic_Center ', True, 2.5 DoCmd.Close acReport, strname DoCmd.Close acForm, "background_set_M" DoCmd.Close acForm, "Menu5" DoCmd.Close acForm, "Menu18" Exit Function End If '============================================================================( Print into Button Or If Keybord If DLookup("[Print_rip]", "[User_Report]", "[name_rep] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then 'DoCmd.OpenReport strname 'DoCmd.RunCommand acCmdPrint End If If DLookup("[Print_rip]", "[User_Report]", "[name_rep] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = False Then MsG2 = "Sand Massage !" MsG1 = "تنبيه للمستخدم! رسالة ادارية راجع المسؤل المختص " MsG3 = " تملك صلاحية طباعة التقرير او ليس لك حق بالطباعة او تم حظرك من الطباعة او تم منعك من الطباعة" MyMsgBox (MsG3), (MsG2), (MsG1), msg_Exclamation, Btn_OK_Only, Arabic_Center ', True, 2.5 Exit Function End If '**********************************************************( Editor Report Admin with Devloper 'If Form_Menu18.n = 1 Then 'change_font_M (Me.name) 'End If On Error Resume Next '=====================================( Imge Report! ) If DLookup("[Slected_Img_Or_Txt]", "[Pssword_admin]") = True Then Reports(strname).B.Visible = True Reports(strname).B.Picture = DLookup("[Rep_IMG_dawon]", "[Pssword_admin]") Reports(strname).C.Visible = False End If If DLookup("[Slected_Img_Or_Txt]", "[Pssword_admin]") = False Then Reports(strname).C.Visible = True Reports(strname).B.Visible = False End If If IsNull(DLookup("[Rep_IMG_2]", "[Pssword_admin]")) Then Reports(strname).A.Visible = False Else Reports(strname).A.Visible = True Reports(strname).A.Picture = DLookup("[Rep_IMG_2]", "[Pssword_admin]") End If '**********************************************************( Keybord ) ********************************************* '====================================================( Frist Chack Keybord If IsNull(DLookup("[Name_Form_Report]", "[Set_KeyBord_Report]", "[Name_Form_Report] ='" & strname & "'")) Then MsG2 = "Sand Massage !" MsG1 = "لم تهئة الادارة بصلاحيات " MsG3 = " الرجاء الاتصال على مركز المعلومات لتهيئة والصلاحيات خطأ 102" MyMsgBox (MsG3), (MsG2), (MsG1), msg_Exclamation, Btn_OK_Only, Arabic_Center ', True, 2.5 DoCmd.Close acReport, strname Exit Function End If '=====================================================( Set OFF Or On Set Keybord If DLookup("[Set_On_Keybord]", "[Set_KeyBord_Report]", "[Name_Form_Report] ='" & strname & "'") = True Then Reports(strname).KeyPreview = True Else Reports(strname).KeyPreview = False End If '******************************************( Set _ Icon Window _ Text ) ************************************ Dim dbs As DAO.Database Dim obj As Object Dim strTitle As String Dim s As String Dim intX As Integer Dim strDBIcon As String Dim strFormIcon As String Const DB_Text As Long = 10 Const conPropNotFoundError = 3270 '=========================( عنوان وايقون لقاعدة البيانات For db Name And Icon ) Set dbs = CurrentDb '=============================( Name ) strTitle = DLookup("[name_text]", "[DB_Icon_At_OPen]") dbs.Properties!AppTitle = strTitle '=====================( Icon ) strDBIcon = DLookup("[Icon_path]", "[DB_Icon_At_OPen]") s = DLookup("[Icon_path]", "[DB_Icon_At_OPen]") intX = AddAppProperty("AppIcon", DB_Text, s) Application.RefreshTitleBar '=========================( عنوان وايقونة للنموذج For Me.report.Name Name And Icon ) '===================(Icon ) strFormIcon = DLookup("[Icon_path]", "[Icon_bar_Repor]", "[name_Form]='" & strname & "'") SetFormIcon Reports(strname).hwnd, DLookup("[Icon_path]", "[Icon_bar_Repor]", "[name_Form]='" & strname & "'") '==========================( Name ) Reports(strname).Caption = DLookup("[name_text]", "[Icon_bar_Repor]", "[name_Form]='" & strname & "'") & " " & Date & " " 'DoCmd.Maximize '========================================( No Control cahng Size window Form and report And Click bar windows for chacng ) If DLookup("[No_Click_Chang_Size]", "[Icon_bar_Form]", "[name_Form]='" & strname & "'") = -1 Then Dim hMenu As Long Dim lStyle As Long 'disable MAXIMIZE button If DLookup("[Style_Nobar_For_disktop]", "[Icon_bar_Form]", "[name_Form]='" & strname & "'") = -1 Then Else lStyle = GetWindowLong(Reports(strname).hwnd, GWL_STYLE) End If lStyle = lStyle And Not WS_MAXIMIZEBOX Call SetWindowLong(Reports(strname).hwnd, GWL_STYLE, lStyle) End If '************************************( Set_Top_Left Chacng Size window ) ********************************* If DLookup("[Only_Full_Desktop]", "[Icon_bar_Repor]", "[name_Form]='" & strname & "'") = -1 Then Dim lngWH As Long, lngWL As Long, lngWT As Long, lngWW As Long ' With Reports(strname) DoCmd.Maximize ' lngWT = .WindowTop ' lngWL = .WindowLeft ' lngWH = .WindowHeight ' lngWW = .WindowWidth ' DoCmd.Restore ' DoCmd.OpenForm "xzx" ' Forms![xzx]![x1] = lngWL 'Forms![xzx]![x2] = lngWT 'Forms![xzx]![x3] = lngWW 'Forms![xzx]![x4] = lngWH 'Call .move(lngWL, lngWT, lngWW, lngWH) 'End With For j = 1 To DLookup("[Line_window]", "[DB_Icon_At_OPen]") '200 'round corners 'UISetRoundRect code in modCreateRoundCorners Reports(strname).UISetRoundRect_rpt_desktop Reports(strname), j, False DoEvents Next DoCmd.Maximize Else For j = 1 To DLookup("[Line_window]", "[DB_Icon_At_OPen]") '200 'round corners 'UISetRoundRect code in modCreateRoundCorners Reports(strname).UISetRoundRectx Reports(strname), j, False DoEvents Next DoCmd.Maximize End If '==================================( Set Image wallpaper back Report ) ****************************** If IsNull(Form_background_set_M.S_N) Or Form_background_set_M.S_N = "" Then Else Reports(strname).Picture = Form_background_set_M.S_N End If '-----------------------------------------------------------------------( For Error Code Only Copy And No Can use Function = Here Error :) X exit_Ops: Exit Function ops: If err.Number = 2465 Then DoCmd.Maximize Exit Function End If If err.Number = 2585 Then DoCmd.Maximize Exit Function End If If err.Number = conPropNotFoundError Then Set obj = dbs.CreateProperty("AppTitle", dbText, strTitle) dbs.Properties.Append obj End If Dim strMsg As String Dim Title As String Dim SubTitle As String ' MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description : strMsg = "Error Description : " & vbCrLf & err.Description : Title = "Error Massage !" : SubTitle = "Error Number: " & err.Number Dim Number_MX_Error As String '============( XLong '========================( Sand Error To Tablet Set GiveMeError = CurrentDb.OpenRecordset("Error_All_MSGBOX") GiveMeError.AddNew GiveMeError![Err_Number] = err.Number GiveMeError![Error_Description] = err.Description GiveMeError![User] = "Not Now _CommingSoon " GiveMeError![Pc] = Environ("username") GiveMeError![Today] = Date GiveMeError![ToTime] = Time() ' GiveMeError![name_Form] = Me.Form.name ' GiveMeError![Click_Button] = Me.ActiveControl.name & " -Name_Button: " & "تفعيل رسالة الخطأ عند الخطأ OnError" 'Me.Error.Caption GiveMeError.Update DoEvents 'Number_MX_Error = DMax("[ID]", "[Error_All_MSGBOX]") MyMsgBox strMsg, Title, SubTitle, msg_Critical, Btn_OK_Only, English_Left, False Resume exit_Ops Exit Function End Function كود الاستدعاء داخل التقرير حدث عند الفتح كود: Private Sub Report_Open(Cancel As Integer) '===========================( chack User '=============================( Only 2 Code Function For Chack User '=====================================( IF Form (1) 'Call FormsAllowed(Me.Form.name) '=====================================( IF Report (1) Call ReportAllowed(Me.Report.name) End Sub 2- استكمال وتصحيح عرض التقارير بزر الفتح 3- اضافة عرض التقارير بالواجهة الرئيسية بعد تسجيل الدخول ...+ بعض من التصحيحات واستكمال ========================================= الاستكمال قريبا تحميل المرفق https://www.mediafire.com/file/9rur7b2grpokxdu/Update_15-2-2025_Add_v3_Into_4_User_Control_Open_App.rar/file

=============================================( صور + مرفق + فيديو ) Update: 🌹 استكمال ☕ 1- تصحيح الدالة الصلاحيات للنماذج والتقارير On Error GoTo ops Dim User_Name As String Dim ID_Name As String User_Name = DLookup("[name_user]", "[Control_User]") ID_Name = DLookup("[IDDX]", "[Control_User]") 'IDDX '===========( Name_Report For Reprt Control User '==========================================(1)No use True Dim Name_X As String Name_X = FormsAllowed '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( Open Form If DLookup("[open_frm]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then DoCmd.OpenForm strname End If If DLookup("[open_frm]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = False Then MsG2 = "Sand Massage !" MsG1 = "تنبيه للمستخدم! رسالة ادارية راجع المسؤل المختص " MsG3 = "الا تملك صلاحية الدخول او ليس لك حق الدخول او تم حظرك من الدخول او تم منعك من الدخول " MyMsgBox (MsG3), (MsG2), (MsG1), msg_Exclamation, Btn_OK_Only, Arabic_Center ', True, 2.5 DoCmd.Close acForm, strname 'Exit Function End If '============================================================================( AllowAddition If DLookup("[add_new]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then Forms(strname).AllowAdditions = True End If If DLookup("[add_new]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = False Then Forms(strname).AllowAdditions = False End If '============================================================================( AllowDeletion If DLookup("[delet]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then Forms(strname).AllowDeletions = True End If If DLookup("[delet]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = False Then Forms(strname).AllowDeletions = False End If '============================================================================( AllowEdits If DLookup("[editor]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then Forms(strname).AllowEdits = True End If If DLookup("[editor]", "[Usre_frm]", "[name_frm] ='" & strname & "' And [IDDX] =" & ID_Name & " ") = True Then Forms(strname).AllowEdits = False End If 2- اضافة عرض التقارير + بتخصيص قائمة للمستخدمين 3- اضافة اختيار ايكون للتقارير مع العنوان بقائمة الادوات Admin 4- اضافة قائمة لتهيئة التقارير وعلامة المائية لحساب المطور ...+ بعض من التصحيحات واستكمال ========================================= الاستكمال قريبا تحميل المرفق https://www.mediafire.com/file/0nrnjkxipry23y6/Update_Fix_Add_v3_Into_4_User_Control_Open_App.rar/file

ان توفر الوقت اصحح واستكمل بتعديل الاكواد بنطاق جغرافي 2

=============================================( صور + مرفق + فيديو ) Update: 🌹 استكمال ☕ (( :اضافة بقائمة الاعدادة (( قوائمة الادخال 1- اخال الرقم المدني القومي 2- ادخال المبالغ المالية 3- ادخال ارقام الهوات 4- ادخال التواريخ الاجازات الرسمة للترصيد - ملاحظة تم اضافة تجربة الاخال لكل القوائم المذكوره ************************ 5- تطبيق على قائمة اضافة مستخدم جديد للصلاحيات بعض من التصحيحات واستكمال ========================================= الاستكمال قريبا تحميل المرفق https://www.mediafire.com/file/vzncllvgs933v79/Update_v3_Into_4_User_Control_Open_App.rar/file

=============================================( صور + مرفق + فيديو ) Update: 🌹 دايم طلباتي صعبة على العموم سكرة التهيئة بقائمة ادارة المستخدمين والصلاحيات @استبرق الموسوي ❤️🌹 استكمال ☕ 1- اضافة ادراج مستخدمين جدد 💯 - مع الفحص ولكل مستوى من مدير الى الموظف بالادارة بالقسم المحدد واذا كان مدير بادارته المحدد 2- اضافة تسجيل الكمبيوتر للمستخدم الجديد مع امكانية جعل المستخدم يتخدم اجهزة زملاءة التابعين للقسم فقط 3- خيارات التحكم تفعيل من قراءة فقط او القراء والكتابة او الاطلاع فقط على التقارير ... مع امكانية التعديل بقائمة الصلاحيات ========================================== 4 .. 5 QR- Barcod ( User ) : لتمكين تسجيل الدخول لتأمين اكثر عبر بطاقة يتم طباعتها للمستخدم قبل ادخال كلمة المرور واسم المستخدم -حسب رغبة العميل لتأمين دخول المستخدم ========================================== تصحيح استخدم كود عند الخطأ بالازرار بقائمة ادارة المستخدمين والصلاحيات بدل الدالة 😇 تحديث التالي فيديو للتوضيح في الاسفل تحميل المرفق https://www.mediafire.com/file/18o5da9o4mhtd6k/v3_Update_User_Control_Open_App.rar/file

=============================================( صور + مرفق + فيديو ) Update: 🌹 استكمال مع طلب المساعده طلب المساعده:- كيف الحق لكل حساب مستخدم عند الادار الى عند القسم فقط يلحق القسم المستخدم اما المراقب والمدير يلحق الادارة الحاق كافة النماذج والتقارير التي تم تحديدها بقائمة الصلاحيات 1 (يحدث الكل) 1- حذف الكل 2- الحاق كما ذكر اعلاه 2(عند اضافة حساب جديد بعد تحديد القسم) الحاق القسم بنماذجة وتقاريره بقائمة الصلاحيات فقط ====================================☕ او من عنده حل ثاني بتوضيح 1-الصلاحيات تتبع الادادرة والقسم لهم تقارير معينة ونماذج مخصصة 2- المدير والوكيل والمراقب ( ادارة = الكل ) جميع الاقسام التابعة 3-من اصلاحيات المفترض ذكرها لكل مستخدم عرض ملفات التي تم انشائها في حسابة فقط يعني ما يشوف شغل زملائة فقط الملفات التي تم انشائها من حسابة (... ملفات المحاسبة - ملفات العقود - ملفات تابع المندوب للوكيل للمحامات ) ولم اقصد الرقم المدني القومي نختص بطبيعة عمل ثانية 4- تسجيل الكمبيوتر بالحساب صلاحية ويسجل الكمبيوتر فريد مع امكانية اختيار هذا المستخدم بستخدام اجهزة زملاءة فقط بقسمه 5- بدل ظهور اسماء المستخدمين استخدم صلاحية تذكر عند المستخدم يمكن الغاء المستخدم التذكير هي الحاق اسم المستخدم بقائمة اختيار اسم المستخدم فقط ثم كتابة كلمة المرور في جدول التذكير =========================================================== -:تحديث 1- اعتماد تسجيل جهاز المستخدم فقط لتسجيل دخول وبالامكان اختيار اجهزة القسم التابع للمستخدم فقط لتسجيل دخول 2- اختيار نمط النص عنوان بعد اذن استاذي @ابو جودي ❤️🌹☕ 3D Text 3- اضافة تفعيل الكل لصلاحية استخدام اختصارات الكيبورد 4- قائمة الفورية المنشأه فقط تهيئة النماذج والتقارير بختيارهم بالاعدادة 5- تغير نمط رسائل اكسس بتعديل دالة استاذ @Moosak❤️🌹☕ 6-اضافة قائمة تحديد دقة الشاشة التي ستعمل مع مشروعك مع بعض خيارات اخفاء الاكسس والمعلومات .... 7 8.. فيديو للتوضيح في الاسفل تحميل المرفق https://www.mediafire.com/file/lqcqko691c7920b/v3_User_Control_Open_App.rar/file

نفترض مشروع اكسس متشعب :محاسبة قسم الميزانية والرواتب :ادارة قسم الحضور والغياب جعل النماذج والتقارير مجموعات قبل الصلاحيات لا يمكن اظهار صلاحيات المجموعات الاخرى فقط مجموعة قسم المستخدم فقط ( بيطبيعة العمل ================================================ اضافة تحكم بالصلاحيات للمسئول المباشر وتخصيص للمراقب والمدير عرض الكل

=============================================( صور + مرفق + فيديو ) Update: 🌹 < السابق > 1- شرح مبسط عن التثبيت + فك الضغط 2- شرح مبسط عن اضافة مستخدمين وتحكم بالصلاحية بداله << الجديد >> بعد انشاء نموذج او تقرير مباشر حدد تفعيل اختصارات الكيبورد فقط لكل نموذج او تقرير اللصق كود الحدث عند المفتاح للاسفل مع التأكد في نهائة الخصائص (مفتاح المعاينة ) = نعم الكود: Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Dim f As String '============================================('طباعة الفورم او التقارير X If DLookup("[print_form]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyP Then MsgBox " Not Allow Print Form And Sand Order Manger Cinter غير مسموح لك طباعة الشاشة ", vbExclamation, " Close Ctrl + P " & Date KeyCode = 0 End If End If '===========================================(بحث واستبدال X If DLookup("[Sarch_Fend_Change]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyF Then KeyCode = 0 End If If KeyCode = vbKeyShift And vbKeyF4 Then KeyCode = 0 End If End If '===========================================(تراجع وتوسيط X If DLookup("[back and center]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyF8 Then KeyCode = 0 End If End If If DLookup("[Escape]", "[Set_KeyBord]") = True Then If KeyCode = vbKeyEscape Then KeyCode = 0 End If End If '===========================================(تحديد الكل وحذف X If DLookup("[Selected All]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyA Then KeyCode = 0 End If End If If KeyCode = vbKeyF2 Then KeyCode = 0 End If If DLookup("[Selected_Delete]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If KeyCode = vbKeyDelete Then KeyCode = 0 End If End If '===========================================(ادوات التحرير X If DLookup("[Cut]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyX Then KeyCode = 0 End If End If If DLookup("[Copy]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyC Then KeyCode = 0 End If End If If DLookup("[Past]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyV Then KeyCode = 0 End If End If '===========================================(تحديد عامود وتحكم في الجدول المعروض X If DLookup("[Selected_dawon_tablet]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyDown Then KeyCode = 0 End If End If '===========================================(اضافة بيانات وتحكم بتنقل الى جديد X If DLookup("[add_New_record]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If Shift = acCtrlMask And KeyCode = vbKeyTab Then KeyCode = 0 End If End If If DLookup("[tab]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If KeyCode = vbKeyShift And vbKeyTab Then KeyCode = 0 End If End If '==============================================( Enter ) If DLookup("[Enter]", "[Set_KeyBord]", "[Name_Form_Report] ='" & Me.Form.name & "'") = True Then If KeyCode = vbKeyReturn Then MsgBox "hello" End If End If Select Case KeyCode End Select End Sub تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) v2_1_Control_User_With_Keybord_Auto(LognIN)_Ms_Access.rar

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن الاستاذ @Moosak ❤️🌹☕ تغير الدالة مع الكود بمرفقك بالكامل يعمل مع اي تقرير او نموذج من غير كتابة اسمة بداله واحده فقط 😇 تلقائي Auto اسهل صلاحيات لكافة النماذج والتقارير والطباعة بدالة وحده اشر بالجدول بس يعني سو جدول وتقرير جديد اختر من الجدول صلاحيات مباشره شباب ؟! 😂 (حدث عند التحميل) كود الاستدعاء: '=============================( Only 2 Code Function For Chack User '=====================================( IF Form (1) Call FormsAllowed(Me.Form.name) '=====================================( IF Report (1) 'Call FormsAllowed(Me.Report.name) الدالة : Option Compare Database Option Explicit Public Function FormsAllowed(ByVal strname As String) As String '(FrmName As String) As Boolean ' ===========! Dim name_x As String name_x = FormsAllowed '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Control_User]", "[name_frm] ='" & strname & "'")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( Open Form If DLookup("[open_frm]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then DoCmd.OpenForm strname Else MsgBox "لا تملك صلاحية الدخول او ليس لك حق الدخول او تم حظرك من الدخول او تم منعك من الدخول ", vbExclamation, "رسالة ادارية راجع المسؤل المختص " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( AllowAddition If DLookup("[add_new]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowAdditions = True Else Forms(strname).AllowAdditions = False End If '============================================================================( AllowDeletion If DLookup("[delet]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowDeletions = True Else Forms(strname).AllowDeletions = False End If '============================================================================( AllowEdits If DLookup("[editor]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowEdits = True Else Forms(strname).AllowEdits = False End If End Function Public Function Print_Allowed(ByVal strname As String) As String '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Control_User]", "[name_frm] ='" & strname & "'")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( Print into Button Or If Keybord If DLookup("[print]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then DoCmd.OpenReport strname DoCmd.RunCommand acCmdPrint Else MsgBox "لا تملك صلاحية طباعة التقرير او ليس لك حق بالطباعة او تم حظرك من الطباعة او تم منعك من الطباعة ", vbExclamation, "رسالة ادارية راجع المسؤل المختص " & Date Exit Function End If End Function @dd13901390🌹☕ 2- تعديل واستكمال بعض تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) V2_One_FunctionLoginIN_Whit_Exprot_FileAuto_Ms_Access.rar

=============================================( صور + مرفق + فيديو ) Update: 🌹 @dd13901390🌹☕ قدمت لك طلبك وانا لم انتهي منه للتحكم بالحساب والصلاحيات 1- قائمة في نموذج تسجيل الدخول اذا كنت مطور او آدمن او مستخدم 2-تسجيل شركة او مؤسستك او قطاع عملك على البرنامج او نظامك مع اضافة اشعار والخلفية لنموذج تسجيل الدخول (مرونة بالتعديل على البيانات) 3- استايل بقائمة سفلية يمكن الاستفاده منها 4- انشاء حسابات وانشاء قائمة النماذج والتقارير للصلاحيات 5- تحكم بالصلاحيات والتحديث عند اختيار المستخدم 7- تحديث المسار الصور تلقائي عند الفتح + مرفق 6- طلبك عند فتح النموذج كود بسيط @dd13901390 ☕ '=====================( Err (1) And Exit (2) For On Error GoTo Look daown On Error GoTo Err_Ops '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Control_User]", "[name_frm] ='" & "QR" & "'")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date Exit Sub End If '========================================( Now Look Open Or No = Back User (Out) If DLookup("[open_frm]", "[Control_User]", "[name_frm] ='" & "QR" & "'") = True Then DoCmd.OpenForm "QR" Else MsgBox "لا تملك صلاحية الدخول او ليس لك حق الدخول او تم حظرك من الدخول او تم منعك من الدخول ", vbExclamation, "رسالة ادارية راجع المسؤل المختص " & Date Exit Sub End If '================================( name Err Exit (1) Exit_Ops: Exit Sub '================================( name At On Err 2 Err_Ops: MsgBox err.Description & err.number '========================================================( IF No Error Go Back Exit To (1) Resume Exit_Ops تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) هذا هو طلب V1_LoginIN_Whit_Exprot_FileAuto_Ms_Access.rar

تعديل مرفق استاذ @kkhalifa1960☕ 1 - اصلاح تحجيم النموذج بعد عرض التقرير 2- فقط انسخ الكود وغير اسم التقرير 3- تعديل حجم النموذج بالعرض والارتفاع بنسخ رقم الحقلين ولصقهم باسفل الكود '=========================( الطابعة غير متوفره '=============================================( Only Copy Code And Chang Name Report Only Dim rptName As String Dim Name_Tablt As String Dim Fix_Size As Integer Name_Tablt = DLookup("[Size_paper]", "[Control_Print]") '====================================================( Frist Chack If IsNull(Name_Tablt) Or Name_Tablt = "" Then MsgBox " Slected itme Size paper (Isnull) ", vbCritical, "Close Done " Exit Sub End If If DCount("[Size_paper]", "[Control_Print]") = 0 Then MsgBox " لم تعين اعدادة للطباعة ", vbCritical, " Close Don " & Date Exit Sub End If On Error GoTo Awch: For Fix_Size = 1 To 1 rptName = "rapt" DoCmd.OpenReport rptName, acViewPreview With Reports(rptName).Printer On Error Resume Next '========================( No Size desin for print .PaperSize = acPRPS & Name_Tablt ' If p1 = -1 Then .Orientation = acPRORLandscape If p2 = -1 Then .Orientation = acPRORPortrait End With ' DoCmd.PrintOut ' DoCmd.Close acReport, rptName Next '===================================( Fix Size Form after Change Size report Me.Form.InsideHeight = 2190 Me.Form.InsideWidth = 5835 Exit Sub Awch: MsgBox Err.Description & Err.Number Exit Sub base_RP-1.rar

تفضل مرفق سابق لتغير الى A4 Code '========================= ( قديم لم يستكمل جرب المرفق Full Control Of Print Report التحكم في الطابعة وخصائصها طباعة التقارير.rar

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذي @ابو جودي ❤️🌹☕🌹 بعد اذن الاستاذ @Moosak ❤️🌹☕ بعد اذن الاستاذ @Amr Ashraf ❤️🌹 بعد اذن الاستاذ @Foksh 🌹❤️☕ هل من توصية او اقتراح بالتعديل والاضافة 1- تكامل الادخال البيانات بالجديد والحفظ الرجوع يمكن كده تلسمه للعميل 2- عند تحريك المؤشر تغير الحقول مع ليبل تغيره الى زر مع الضغط 3-4-5 .... (الكل من غير [ دوال ] الا الغاء زر الاغلاق وتمكينة (لا يتمكن المستخدم من ترك الاضافة الجديده او التعديل (الا بالحفظ او الرجوع ) ☕ على فكرة كود استاذ @Foksh جرب وغير تلاحظ الازرار لا تغير التمكين لا يعمل عند التنقل ما سويت سحر 😂 فرجعة على الكود سابق فشغال مع استكمال اذا كان جديد كود: On Error GoTo Ops Dim recordCount As String '========================== ( IF No Count Sum Or Change Only Number String 255 k recordCount = Nz(DCount("[Id]", "[Add_Custorm_QR]"), 0) '=========================( Not Number No Long Smoll and Long Long , Look for read db Link Acountes 1 To 20 Full Size , This Text If txtRec = recordCount Then Me.cmdLast.Enabled = False Me.cmdNext.Enabled = False Else Me.cmdLast.Enabled = True Me.cmdNext.Enabled = True End If If recordCount > txtRec Then Me.cmdPrevious.Enabled = True Me.cmdFirst.Enabled = True Me.cmdLast.Enabled = True Me.cmdNext.Enabled = True End If If recordCount = 0 Then Me.cmdPrevious.Enabled = False Me.cmdFirst.Enabled = False Me.cmdLast.Enabled = False Me.cmdNext.Enabled = False Me.cmDelete.Enabled = False Me.Save.Enabled = False Me.UndoR.Enabled = False Me.n.Enabled = False Me.x.Enabled = False Else Me.cmDelete.Enabled = True Me.n.Enabled = True Me.x.Enabled = True End If If txtRec = 1 Then Me.cmdPrevious.Enabled = False Me.cmdFirst.Enabled = False Else Me.cmdPrevious.Enabled = True Me.cmdFirst.Enabled = True End If If Me.Editor_date = -1 Then Me.PID.Enabled = True Me.PID.Locked = False Me.PName.Enabled = True Me.PName.Locked = False Me.PPhone.Enabled = True Me.PPhone.Locked = False Else Me.PID.Enabled = False Me.PID.Locked = True Me.PName.Enabled = False Me.PName.Locked = True Me.PPhone.Enabled = False Me.PPhone.Locked = True End If Exit Sub Ops: '=====================================( For New Record If IsNull(Me.txtRec) Or Me.txtRec = "" Then Exit Sub Else MsgBox "Error: " & Err.Description & " (" & Err.Number & ")", vbExclamation, " :: Error Chack Devloper :: " Exit Sub End If Contrl_Record_With_Qr__AppRunAuto_V-1-8 Add Folder_with _File_ SyS_ Ms_Access.rar

👍 بتأكيد افضل ومختصر ☕🌹❤️ شكرا + + + بخلص ورفع التحديث ومنتظره رايك

الملفات عندك بالتيرات مو داخل القاعده يستخدم للقراءة المستندات و المنتاجات والكرنيهات وهو صحيح الحذف تقريبا عند قرائة بالجهاز يستخرج رقم فقط ما تحتاج تحفظ صور الباركود ؟! لو كانت مستندات او فواتير ما تحذف صح يستخرج الرقم والاسم فقط كمرجع نحذف الصور الباركود عشان 98 ما يثقل ويفلش 😂 امزح جرب المرفق بعد اذن استاذ @Foksh☕❤️🌹

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذي @ابو جودي ❤️🌹☕🌹 بعد اذن الاستاذ @Moosak ❤️🌹☕ بعد اذن الاستاذ @Amr Ashraf ❤️🌹 بعد اذن الاستاذ @Foksh 🌹❤️☕ هل من توصية او اقتراح بالتعديل والاضافة اداة بسيطة لحفظ مرفقات مشروعك او نظامك ويعمل فوري عند بداية التشغيل وعند فقط اي من الملفات اكثر من 16 نوع منها : - خطوط -ادوات تنفيذية -صور -فيديو -صوت -نصوص وورد -اكسل -بور بوينت -وتفصيلات اخرى - ملفات الضغط يعمل الكل من انشاء ملفات واستخراج من المرفقات الى الملفات والتثبيت وفك الضغط تلقائي ملاحظة الخطوط تثبت ولكن تغيرها فقط بوضع التصميم ثم الفتح الكود Dim s As Integer For s = 1 To 1 DoCmd.OpenForm "xf", acDesign, , , , acHidden Form_xf.xx.FontName = Me.x Form_xf.x.FontName = Me.x Next DoCmd.Close acForm, "xf", acSaveYes DoCmd.OpenForm "xf" ما ينفع تغير نوع الخط بالكود Me.Text.FontName = "Font_X" الا اذا تم نقلهم وتثبيتهم في ملف الخطوط بالويندوز الحديث: 1- اضافة انشاء الباركود ويثبت تلقائي بصيغة تنفيذية من غير تثبيته exe 2- اضافة بسيطة لادراجة وتجربة كيو باركود - تحكم بالتنقل و الاضافة بكود بسيط On Error GoTo Ops If txtRec = DCount("[Id]", "[Add_Custorm_QR]") Then Me.cmdLast.Enabled = False Me.cmdNext.Enabled = False Else Me.cmdLast.Enabled = True Me.cmdNext.Enabled = True End If If DCount("[Id]", "[Add_Custorm_QR]") > txtRec Then Me.cmdPrevious.Enabled = True Me.cmdFirst.Enabled = True Me.cmdLast.Enabled = True Me.cmdNext.Enabled = True End If If DCount("[Id]", "[Add_Custorm_QR]") = 0 Then Me.cmdPrevious.Enabled = False Me.cmdFirst.Enabled = False Me.cmdLast.Enabled = False Me.cmdNext.Enabled = False Me.cmDelete.Enabled = False Else Me.cmDelete.Enabled = True End If If txtRec = 1 Then Me.cmdPrevious.Enabled = False Me.cmdFirst.Enabled = False Else Me.cmdPrevious.Enabled = True Me.cmdFirst.Enabled = True End If Exit Sub Ops: MsgBox Err.Description & Err.Number Exit Sub -اعادة الترقيم التلقائي ببساط بكود DOA On Error GoTo Ops Dim RS As DAO.Recordset Dim dbs As DAO.Database Dim strsq2 As String Dim sof As LongLong Dim iprgrs As Integer '=======================================================( Set Number 0 strsq2 = "Update Add_Custorm_QR Set nx = '" & 0 & "'" CurrentDb.Execute strsq2 DoEvents '=====================================================( set prograse Me.ProgressBar3.max = DCount("[Id]", "[Add_Custorm_QR]") Me.xc.Caption = "Counting... " & Me.ProgressBar3 & "/" & "100%" Me.ProgressBar3 = 1 '======================================================( 1 To End Count Record Set dbs = CurrentDb sof = 0 Set RS = CurrentDb.OpenRecordset("Add_Custorm_QR") Do While Not RS.EOF sof = sof + 1 RS.Edit RS![Nx] = RS![Nx] + sof On Error Resume Next RS.Update RS.MoveNext 'Exit Do 'This will exit loop after first record Loop Me.ProgressBar3 = 1 RS.Close Set RS = Nothing dbs.Close For iprgrs = 1 To DCount("[Id]", "[Add_Custorm_QR]") Me.xc.Caption = "Counting... " & iprgrs & "/" & "100%" On Error Resume Next Me.ProgressBar3 = iprgrs DoEvents Next Me.lblCount.Caption = DCount("[Id]", "[Add_Custorm_QR]") If IsNull(Me.idx) Or Me.idx Then DoCmd.GoToRecord , , acFirst Else DoCmd.SearchForRecord acDataForm, "Qr", acFirst, "[ID] = " & Me!idx Me.idx = "" End If Exit Sub Ops: MsgBox Err.Description & Err.Number Exit Sub 3- تعديل على الدالة ======================================( تحديث سابق 1- اضافة 16 نوع من ملفات تثبت وتضاف عند الفتح وعند الفقد + ملفات التشغيلية + ملفات المضغوطة ملاحظة: -اذا كان .exe غير الى .ex بعد التنفيذ يغير الى exe. - اذا ملف فك الضغط Zip يبدأ في حذف الملف ثم الفك التلقائي للملفات تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) Qr_With_AppRunAuto_V-1-7 Add Folder_with _File_ SyS_ Ms_Access.rar

هالسنة منوره

قصدك بتغيرها الى شكر وامتنان فهي لا ثالث لهما تهدف اذا كان في محلها وتذنب بغير محلها ☕ حل آخر فصحيح اختصر اضافة لردود الاعضاء مع زر التوصية لا يعمل الزر الى بعد اضافة مرفق او كود ويحق للعضو ازالة التوصية اذا كتشف الخطأ في الكود او مرفق (( 1 )) لكل عضو له في كل الموضوع توصية واحده فقط اذا حدث المرفق او صحح كود يزيل ثم يضيف التوصية بالرد المناسب للموضوع وتوصية لها شروط: -الا يكون متكرر في الموضوع -يستبعد اذا حول الاستعلام من غير كود وهو نفس الحل الا DOA وجمل SQL -اذا غير من VBA الى الادنى ماكرو ؟! ..... من يخالف عمد يحظر من التوصية بالرد الى سنة ان لم تكن في محلها انذار او حجب زر التوصية بالرد في هذا الموضوع او المواضيع ان كان العضو يفسد الموضوع عمد بتوصية كاذبة

كود: Dim FSO As Scripting.FileSystemObject Set FSO = New Scripting.FileSystemObject On Error Resume Next '=================================( Delete Folder #Qr_IMGES ! What ! Opss No Delet Folder ) FSO.DeleteFolder CurrentProject.Path & "\Qr_IMGES" الملف ما ينحذف انت اضفة من المكتبة اداة Zint خذها من اي عملية تثبيت غير قواعد الاكسس تسبب مشكلة لدى العميل لبعض العملاء يغفلون الحواسيب من يوزر الويندوز من سهولة فكه وارجاعة CMD يعتبر مخالفة غير مشروعه تأكد في كاميرات 😂 العميل محتاج قواعدة بمشروع ونظام آمن ما تقدر تثبته باجهزة العملاء الا اذا كان اجهزتهم غير مغفلة بيوز الويندوز كصلاحيات فستبدل بالخط فقط يكون جنب القاعدة يوجد مرفق ☕ بالاشاره الى الملف ( كوي آر بار كود ) فريد ما ينحذف خصص له مكان واحد بالسنوات وتعدد رقمي

مختصر يقول شاب راسي تغير من افضل اجابة ب( الاجابات الموصى بها ) = متعدده معيار اجابة الموصى بها هي تجرب 1- شغال 2- طريقة مختلفة او جديده 3- اذا تم تصحيحها 4- احتمال الازالة فلا تقول ذاك خبير ولا مو خبير الفاصل التجربة ونظر الى بناء الاكواد وتصميم الكود بالمساهمة بالتوجيه والملاحظات =================================( احتمال تجاهل الحل بقصره او يوجد خطأ فطلب اضافة الرد بأجابة الموصى بها يكون بتراسل اذا تجاهل او لم يكن احد موجود

اتفق مع استاذ @أبو إبراهيم الغامدي❤️🌹 بعد اذن استاذ @محمد طاهر عرفه ❤️🌹 تأشير على الرد الموصى به من جهة الاخبر منه لا انصح بتنوع التأشير يكون تأشير واحد فريد ويعدد من 1 الى 5 او 10 في الموضوع فحدد اما ان يكون التوجية او مرفق والكود يفضل مرفق والكود فقط يرفق التأشير بالتعميم والاعلان من تاريخ اليوم الى سبعة ايام ويزيد بتحديث التأشير *************************************************************************** '======================================= ( راس الموضوع ) اضافة تحديث الموضوع بارقام كأرقام تصفح الموقع السابق والتالي في رأس الموضوع استاذي @ابو جودي❤️🌹☕ يحدث الرأس الموضوع + تاريخ اضافة + تعميم براس المواضيع بسطر واحط فقط باجمالي التعميميات الجديد في التحديثات موضيع مختلفة على السبيل المثال 6 تثبيتهم حتى لو شهر بما تراه مناسب '========================================( نوع الطلب ) كان سؤال او اهداء هنا يحدد اضافة تفريع براس الموضوع '=========================================( ازالة صورة الكأس واجراء ) اذا حدد صاحب السؤال عشوائية الرد كأفضل اجابة يمنع في هذا الموضع والمشاركة المحدد تأشير في هذا الموضوع فقط احتمال اختيار العشوائي بسبب الوقت او اثبات امر آخر بنسبة لصاحب السؤال '==========================================( سمات التأشير ) خيار انتقال الى التأشير او قرائة عامة عند دخول المستخدم الى الموضوع او قبل الدخول اختيار الاجابة الموصى بها يحق اضافة رد داخل الرد الموصى به من قبل الاداري بالتوجية وملاحظات قبل الاخذ بالرد الموصى به ويحق للاداري اضافة هذا الاهداء الى مكتبة الموقع مع تأشير على الموضوع '===========================================( اضافة اساسية ) نوع السؤال 1- كان واحد او اكثر ويأخذ ببناء الطلب -نموذج -تقرير -تصميم جداول -دوال -ميكرو -كود - شجرة 2- جهة الموضوع باحث فيها السؤال - عام ويخصص للاهداء - مصانع - خدمات - مدارس -طبي -قانوني .... 3- استخدام القيم - تواريخ - جمع ومعادلات في الجدول او الفورم - ترحيل وتنفيذ اجراءات - حساب وقت او حسابات اخرى -تصحيح اخطاء '==================================( يطبق بالاهداء مع التعديل ) '=========================================================( النتائج ) لا يوجد فوضى بالتأشير وتكسيد الردود بالتحديث فوق بعض وممكن ضم الردود تطوير طريقة البحث من ومن ومن مع الجمع ************************************************************************************************************** اضافة جديد خلها تحت الدراسة - المستخدمين احتمال يكرر السؤال فنخلق جهتين 1- مواضيع المستخدمين مع التكرار 2- مواضيع ثابتة وتحدث فقط بالموصى به في نفس الموضوع بالحلول المختلفة والمصححة يعني راس الموضوع واحد فريد ===============( احتمال بعد سنوات حذف المكرر للسؤال بما احتفظنا بافضل اجابات موصى بها بالتحديث)

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذي @ابو جودي ❤️🌹☕🌹 بعد اذن الاستاذ @Moosak ❤️🌹☕ بعد اذن الاستاذ @Amr Ashraf ❤️🌹 1- اضافة 16 نوع من ملفات تثبت وتضاف عند الفتح وعند الفقد + ملفات التشغيلية + ملفات المضغوطة ملاحظة: -اذا كان .exe غير الى .ex بعد التنفيذ يغير الى exe. - اذا ملف فك الضغط Zip يبدأ في حذف الملف ثم الفك التلقائي للملفات تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) الدالة : Public Function AddFonts() '======================================================( File Add Dim ExtractPath As String Dim FontPath As String Dim ExtractPath2 As String Dim FontPath2 As String Dim ExtractPath3 As String Dim FontPath3 As String Dim ExtractPath4 As String Dim FontPath4 As String Dim ExtractPath5 As String Dim FontPath5 As String Dim ExtractPath6 As String Dim FontPath6 As String Dim ExtractPath7 As String Dim FontPath7 As String Dim ExtractPath8 As String Dim FontPath8 As String Dim ExtractPath9 As String Dim FontPath9 As String Dim ExtractPath10 As String Dim FontPath10 As String Dim ExtractPath11 As String Dim FontPath11 As String Dim ExtractPath12 As String Dim FontPath12 As String Dim ExtractPath13 As String Dim FontPath13 As String Dim ExtractPath14 As String Dim FontPath14 As String Dim ExtractPath15 As String Dim FontPath15 As String Dim ExtractPath16 As String Dim FontPath16 As String Dim FSO As Scripting.FileSystemObject '======================================================( Exprt Fil In File Add Dim File As File Dim FontFolder As Folder Dim File2 As File Dim FontFolder2 As Folder Dim File3 As File Dim FontFolder3 As Folder Dim File4 As File Dim FontFolder4 As Folder Dim File5 As File Dim FontFolder5 As Folder Dim File6 As File Dim FontFolder6 As Folder Dim File7 As File Dim FontFolder7 As Folder Dim File8 As File Dim FontFolder8 As Folder Dim File9 As File Dim FontFolder9 As Folder Dim File10 As File Dim FontFolder10 As Folder Dim File11 As File Dim FontFolder11 As Folder Dim File12 As File Dim FontFolder12 As Folder Dim File13 As File Dim FontFolder13 As Folder Dim File14 As File Dim FontFolder14 As Folder Dim File15 As File Dim FontFolder15 As Folder Dim File16 As File Dim FontFolder16 As Folder '========================================================( Expoert Any File rar zip 7z tgz ... Dim sFolder, sFile, strDest, _ zipPath, zipPwd, strFileName, _ Operation, MyApp, strSource As String Dim Rar_X_Zip As Integer Dim RarXZip As Object Set FSO = New Scripting.FileSystemObject On Error Resume Next '=================================( Delete Folder #File 16 for Export Zip or rar ) FSO.DeleteFolder CurrentProject.Path & "\All_InFile_One_Zip_Rar" ' ÅäÔÇÁ ãÌáÏ ááÎØæØ ÈÌÇäÈ ÞÇÚÏÉ ÇáÈíÇäÇÊ '=========================================================( File 1 ExtractPath = CurrentProject.Path & "\fonts" If Not FSO.FolderExists(ExtractPath) Then FSO.CreateFolder (ExtractPath) '=========================================================( File 2 ExtractPath2 = CurrentProject.Path & "\Icon_Button" If Not FSO.FolderExists(ExtractPath2) Then FSO.CreateFolder (ExtractPath2) '=========================================================( File 3 ExtractPath3 = CurrentProject.Path & "\Icon_Msgbox" If Not FSO.FolderExists(ExtractPath3) Then FSO.CreateFolder (ExtractPath3) '=========================================================( File 4 ExtractPath4 = CurrentProject.Path & "\Sound" If Not FSO.FolderExists(ExtractPath4) Then FSO.CreateFolder (ExtractPath4) '=========================================================( File 5 ExtractPath5 = CurrentProject.Path & "\Wallpaper" If Not FSO.FolderExists(ExtractPath5) Then FSO.CreateFolder (ExtractPath5) '=========================================================( File 6 ExtractPath6 = CurrentProject.Path & "\Video" If Not FSO.FolderExists(ExtractPath6) Then FSO.CreateFolder (ExtractPath6) '=========================================================( File 7 ExtractPath7 = CurrentProject.Path & "\db_BE" If Not FSO.FolderExists(ExtractPath7) Then FSO.CreateFolder (ExtractPath7) '=========================================================( File 8 ExtractPath8 = CurrentProject.Path & "\ExE" If Not FSO.FolderExists(ExtractPath8) Then FSO.CreateFolder (ExtractPath8) '=========================================================( File 9 ExtractPath9 = CurrentProject.Path & "\IMG_Report" If Not FSO.FolderExists(ExtractPath9) Then FSO.CreateFolder (ExtractPath9) '=========================================================( File 10 ExtractPath10 = CurrentProject.Path & "\File_word" If Not FSO.FolderExists(ExtractPath10) Then FSO.CreateFolder (ExtractPath10) '=========================================================( File 11 ExtractPath11 = CurrentProject.Path & "\File_Excel" If Not FSO.FolderExists(ExtractPath11) Then FSO.CreateFolder (ExtractPath11) '=========================================================( File 12 ExtractPath12 = CurrentProject.Path & "\Book" If Not FSO.FolderExists(ExtractPath12) Then FSO.CreateFolder (ExtractPath12) '=========================================================( File 13 ExtractPath13 = CurrentProject.Path & "\File_PowerPoint" If Not FSO.FolderExists(ExtractPath13) Then FSO.CreateFolder (ExtractPath13) '=========================================================( File 14 ExtractPath14 = CurrentProject.Path & "\File_Text" If Not FSO.FolderExists(ExtractPath14) Then FSO.CreateFolder (ExtractPath14) '=========================================================( File 15 ExtractPath15 = CurrentProject.Path & "\File_Code" If Not FSO.FolderExists(ExtractPath15) Then FSO.CreateFolder (ExtractPath15) '=========================================================( File 16 ExtractPath16 = CurrentProject.Path & "\All_InFile_One_Zip_Rar" If Not FSO.FolderExists(ExtractPath16) Then FSO.CreateFolder (ExtractPath16) ' ÇÓÊÎÑÇÌ ÌãíÚ ÇáÎØæØ ãä ÇáÌÏæá Åáì ãÌáÏ ÇáÎØæØ '==========================================================( Form Name_tablet,File ,past File '==========================================================( 1 ExtractAllAttachments "FontsT", "Fonts", ExtractPath '==========================================================( 2 ExtractAllAttachments "FontsT", "Icon_Button", ExtractPath2 '==========================================================( 3 ExtractAllAttachments "FontsT", "Icon_Msgbox", ExtractPath3 '==========================================================( 4 ExtractAllAttachments "FontsT", "Sound", ExtractPath4 '==========================================================( 5 ExtractAllAttachments "FontsT", "Wallpaper", ExtractPath5 '==========================================================( 6 ExtractAllAttachments "FontsT", "Video", ExtractPath6 '==========================================================( 7 ExtractAllAttachments "FontsT", "db_BE", ExtractPath7 '==========================================================( 8 ExtractAllAttachments "FontsT", "File_Executable_ExE", ExtractPath8 '==========================================================( 9 ExtractAllAttachments "FontsT", "IMG_Report", ExtractPath9 '==========================================================( 10 ExtractAllAttachments "FontsT", "File_Word", ExtractPath10 '==========================================================( 11 ExtractAllAttachments "FontsT", "File_Excel", ExtractPath11 '==========================================================( 12 ExtractAllAttachments "FontsT", "Book", ExtractPath12 '==========================================================( 13 ExtractAllAttachments "FontsT", "File_PowerPoint", ExtractPath13 '==========================================================( 14 ExtractAllAttachments "FontsT", "File_Text", ExtractPath14 '==========================================================( 15 ExtractAllAttachments "FontsT", "File_Code", ExtractPath15 '==========================================================( 16 ExtractAllAttachments "FontsT", "All_InFile_One_Zip_Rar", ExtractPath16 '==========================================================( Chack File with Type For Past File '==========================================================( 1 Font Set FontFolder = FSO.GetFolder(ExtractPath) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder.Files If Right(File.Name, 3) = "TTF" Or Right(File.Name, 3) = "OTF" Then FontPath = ExtractPath & "\" & File.Name Debug.Print vbCr & FontPath AddOneFont FontPath Debug.Print File.Name, "Added" End If Next '==========================================================( 2 Img Icon_Button Set FontFolder2 = FSO.GetFolder(ExtractPath2) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File2 In FontFolder2.Files If Right(File2.Name, 3) = "jpg" Or Right(File2.Name, 3) = "jpeg" _ Or Right(File2.Name, 3) = "png" Or Right(File2.Name, 3) = "gif" _ Or Right(File2.Name, 3) = "bmp" Or Right(File2.Name, 3) = "tiff" _ Or Right(File2.Name, 3) = "tif" Or Right(File2.Name, 3) = "ico" _ Or Right(File2.Name, 3) = "webp" Or Right(File2.Name, 3) = "heif" _ Or Right(File2.Name, 3) = "heic" Then FontPath2 = ExtractPath2 & "\" & File2.Name Debug.Print vbCr & FontPath2 AddOneFont FontPath2 Debug.Print File2.Name, "Added" End If Next '==========================================================( 3 IMG Icon_ Msgbox Set FontFolder3 = FSO.GetFolder(ExtractPath3) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File3 In FontFolder3.Files If Right(File3.Name, 3) = "jpg" Or Right(File3.Name, 3) = "jpeg" _ Or Right(File3.Name, 3) = "png" Or Right(File3.Name, 3) = "gif" _ Or Right(File3.Name, 3) = "bmp" Or Right(File3.Name, 3) = "tiff" _ Or Right(File3.Name, 3) = "tif" Or Right(File3.Name, 3) = "ico" _ Or Right(File3.Name, 3) = "webp" Or Right(File3.Name, 3) = "heif" _ Or Right(File3.Name, 3) = "heic" Then FontPath = ExtractPath3 & "\" & File3.Name Debug.Print vbCr & FontPath3 AddOneFont FontPath3 Debug.Print File3.Name, "Added" End If Next '==========================================================( 4 Sound Set FontFolder4 = FSO.GetFolder(ExtractPath4) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File4 In FontFolder4.Files If Right(File4.Name, 3) = "mp3" Or Right(File4.Name, 3) = "wav" _ Or Right(File4.Name, 3) = "ogg" Or Right(File4.Name, 4) = "flac" _ Or Right(File4.Name, 3) = "aac" Or Right(File4.Name, 3) = "m4a" _ Or Right(File4.Name, 3) = "wma" Or Right(File4.Name, 4) = "alac" _ Or Right(File4.Name, 4) = "opus" Or Right(File4.Name, 4) = "aiff" Then FontPath = ExtractPath4 & "\" & File4.Name Debug.Print vbCr & FontPath4 AddOneFont FontPath4 Debug.Print File4.Name, "Added" End If Next '==========================================================( 5 IMGE Wallpaper Set FontFolder5 = FSO.GetFolder(ExtractPath5) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder5.Files If Right(File5.Name, 3) = "jpg" Or Right(File5.Name, 3) = "jpeg" _ Or Right(File5.Name, 3) = "png" Or Right(File5.Name, 3) = "gif" _ Or Right(File5.Name, 3) = "bmp" Or Right(File5.Name, 3) = "tiff" _ Or Right(File5.Name, 3) = "tif" Or Right(File5.Name, 3) = "ico" _ Or Right(File5.Name, 3) = "webp" Or Right(File5.Name, 3) = "heif" _ Or Right(File5.Name, 3) = "heic" Then FontPath = ExtractPath5 & "\" & File5.Name Debug.Print vbCr & FontPath5 AddOneFont FontPath5 Debug.Print File5.Name, "Added" End If Next '==========================================================( 6 video Set FontFolder6 = FSO.GetFolder(ExtractPath6) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File6 In FontFolder6.Files If Right(File6.Name, 3) = "mp4" Or Right(File6.Name, 3) = "avi" _ Or Right(File6.Name, 3) = "mov" Or Right(File6.Name, 3) = "mkv" _ Or Right(File6.Name, 3) = "flv" Or Right(File6.Name, 3) = "wmv" _ Or Right(File6.Name, 3) = "webm" Or Right(File6.Name, 3) = "mpeg" _ Or Right(File6.Name, 3) = "mpg" Or Right(File6.Name, 3) = "3gp" _ Or Right(File6.Name, 3) = "ts" Then FontPath6 = ExtractPath6 & "\" & File6.Name Debug.Print vbCr & FontPath6 AddOneFont FontPath6 Debug.Print File6.Name, "Added" End If Next '==========================================================( 7 DB Ms Access Set FontFolder7 = FSO.GetFolder(ExtractPath7) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File7 In FontFolder7.Files If Right(File7.Name, 3) = "accda" Or Right(File7.Name, 3) = "accdb" _ Or Right(File7.Name, 3) = "accde" Or Right(File7.Name, 3) = "accdr" _ Or Right(File7.Name, 3) = "accdt" Or Right(File7.Name, 3) = "accdw" _ Or Right(File7.Name, 3) = "mda" Or Right(File7.Name, 3) = "mdb" _ Or Right(File7.Name, 3) = "mde" Or Right(File7.Name, 3) = "mdf" _ Or Right(File7.Name, 3) = "mdw" Then FontPath = ExtractPath7 & "\" & File7.Name Debug.Print vbCr & FontPath7 AddOneFont FontPath7 Debug.Print File7.Name, "Added" End If Next '==========================================================( 8 Run Applciation Set FontFolder8 = FSO.GetFolder(ExtractPath8) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder8.Files If Right(File8.Name, 3) = "exe" Or Right(File8.Name, 3) = "bat" _ Or Right(File8.Name, 3) = "cmd" Or Right(File8.Name, 3) = "msi" _ Or Right(File8.Name, 3) = "apk" Or Right(File8.Name, 3) = "app" _ Or Right(File8.Name, 3) = "dmg" Or Right(File8.Name, 3) = "jar" Then FontPath8 = ExtractPath8 & "\" & File8.Name Debug.Print vbCr & FontPath8 AddOneFont FontPath8 Debug.Print File8.Name, "Added" End If If FontPath8 = ExtractPath8 & "\" & File8.Name = ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex" Then '=========================================================() Set RarXZip = CreateObject("scripting.filesystemobject") '==========================================(Chang Name ) RarXZip.CopyFile (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex"), (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.exe") End If Next Kill (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex") '==========================================================( 9 IMg_Report Set FontFolder9 = FSO.GetFolder(ExtractPath9) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder9.Files If Right(File9.Name, 3) = "jpg" Or Right(File9.Name, 3) = "jpeg" _ Or Right(File9.Name, 3) = "png" Or Right(File9.Name, 3) = "gif" _ Or Right(File9.Name, 3) = "bmp" Or Right(File9.Name, 3) = "tiff" _ Or Right(File9.Name, 3) = "tif" Or Right(File9.Name, 3) = "ico" _ Or Right(File9.Name, 3) = "webp" Or Right(File9.Name, 3) = "heif" _ Or Right(File9.Name, 3) = "heic" Then FontPath9 = ExtractPath9 & "\" & File9.Name Debug.Print vbCr & FontPath9 AddOneFont FontPath9 Debug.Print File9.Name, "Added" End If Next '==========================================================( 10 File_word Set FontFolder10 = FSO.GetFolder(ExtractPath10) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder10.Files If Right(File10.Name, 4) = "docx" Or Right(File10.Name, 3) = "doc" _ Or Right(File10.Name, 4) = "docm" Or Right(File10.Name, 4) = "dotx" _ Or Right(File10.Name, 4) = "dotm" Or Right(File10.Name, 3) = "rtf" _ Or Right(File10.Name, 3) = "odt" Then FontPath10 = ExtractPath10 & "\" & File10.Name Debug.Print vbCr & FontPath10 AddOneFont FontPath10 Debug.Print File10.Name, "Added" End If Next '==========================================================( 11 File_Excel Set FontFolder11 = FSO.GetFolder(ExtractPath11) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder11.Files If Right(File11.Name, 4) = "xlsx" Or Right(File11.Name, 3) = "xls" _ Or Right(File11.Name, 4) = "xlsm" Or Right(File11.Name, 4) = "xlsb" _ Or Right(File11.Name, 4) = "xltx" Or Right(File11.Name, 4) = "xltm" Then FontPath11 = ExtractPath11 & "\" & File11.Name Debug.Print vbCr & FontPath11 AddOneFont FontPath11 Debug.Print File11.Name, "Added" End If Next '==========================================================( 12 Book Set FontFolder12 = FSO.GetFolder(ExtractPath12) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder12.Files If Right(File12.Name, 3) = "pdf" Or Right(File12.Name, 3) = "Html" _ Or Right(File12.Name, 3) = "Cs3" Or Right(File12.Name, 3) = "Cs6" _ Or Right(File12.Name, 3) = "jpg" Or Right(File12.Name, 3) = "png" _ Or Right(File12.Name, 3) = "C4D" Then FontPath12 = ExtractPath12 & "\" & File12.Name Debug.Print vbCr & FontPath12 AddOneFont FontPath12 Debug.Print File12.Name, "Added" End If Next '==========================================================( 13 File_PowerPoint Set FontFolder13 = FSO.GetFolder(ExtractPath13) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder13.Files If Right(File13.Name, 3) = "pptx" Or Right(File13.Name, 3) = "ppt" _ Or Right(File13.Name, 3) = "ppsx" Or Right(File13.Name, 3) = "pps" _ Or Right(File13.Name, 3) = "pptm" Or Right(File13.Name, 3) = "potx" _ Or Right(File13.Name, 3) = "potm" Then FontPath13 = ExtractPath13 & "\" & File13.Name Debug.Print vbCr & FontPath13 AddOneFont FontPath13 Debug.Print File13.Name, "Added" End If Next '==========================================================( 14 File_Text Set FontFolder14 = FSO.GetFolder(ExtractPath14) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder14.Files If Right(File14.Name, 3) = "txt" Or Right(File14.Name, 3) = "csv" _ Or Right(File14.Name, 3) = "log" Or Right(File14.Name, 3) = "md" _ Or Right(File14.Name, 3) = "rtf" Then FontPath14 = ExtractPath14 & "\" & File14.Name Debug.Print vbCr & FontPath14 AddOneFont FontPath14 Debug.Print File14.Name, "Added" End If Next '==========================================================( 15 File_Code Set FontFolder15 = FSO.GetFolder(ExtractPath15) On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder15.Files If Right(File15.Name, 3) = "html" Or Right(File15.Name, 3) = "css" _ Or Right(File15.Name, 3) = "js" Or Right(File15.Name, 3) = "php" _ Or Right(File15.Name, 3) = "py" Or Right(File15.Name, 3) = "java" _ Or Right(File15.Name, 3) = "cpp" Or Right(File15.Name, 3) = "c" _ Or Right(File15.Name, 3) = "rb" Or Right(File15.Name, 3) = "swift" _ Or Right(File15.Name, 3) = "go" Or Right(File15.Name, 3) = "ts" Then FontPath15 = ExtractPath15 & "\" & File15.Name Debug.Print vbCr & FontPath15 AddOneFont FontPath15 Debug.Print File15.Name, "Added" End If Next '==========================================================( 16 All_InFile_One_Zip_Rar Set FontFolder16 = FSO.GetFolder(ExtractPath16) MyApp = Application.CurrentProject.Path & "\ExE\Zip-UnZip By Amr Ashraf.exe" On Error Resume Next '==================== ( IsNull_And_Next Raed For Each File In FontFolder16.Files On Error Resume Next ' If Right(File16.Name, 3) = "zip" Then Or Right(File16.Name, 3) = "rar" _ ' Or Right(File16.Name, 3) = "7z" Or Right(File16.Name, 3) = "tar" _ ' Or Right(File16.Name, 3) = "gz" Or Right(File16.Name, 3) = "tar.gz" _ ' Or Right(File16.Name, 3) = "tgz" Or Right(File16.Name, 3) = "xz" _ ' Or Right(File16.Name, 3) = "bz2" Then FontPath16 = ExtractPath16 & "\" & File16.Name Debug.Print vbCr & FontPath16 AddOneFont FontPath16 Debug.Print File16.Name, "Added" ' End If Next '=================================================================() '=================================================( 16 Open Export Any File Rar Zip 7z tgz ... For Rar_X_Zip = 1 To 1 ' who match rar file or zip Operation = "UnZipFile" strSource = ExtractPath16 & "\" & "Help_Or_Action_Concted_File_FTP.zip" zipPwd = "" strDest = ExtractPath16 & "\\" Debug.Print strSource Debug.Print strDest Call Shell("""" & MyApp & """ """ & Operation & """ """ & strSource & """ """ & strDest & """ """ & zipPwd & """", 1) Next Pause (1) Kill (strSource) Set FSO = Nothing End Function V-1-6 Add Folder_with _File_ SyS_ Ms_Access.rar

=============================================( صور + مرفق + فيديو ) Update: 🌹 اهلا اهلا بالاستاذه @Lamyaa❤️🌹🌹☕ الاداة الي رفعتها مضمنها فيجوال 6 ما تشتغل لبعض الاجهزة لاختلاف 64 وفقر في تعريفات Dell ! ============================================= اهلا بالاستاذ @Moosak 🌹❤️ تقديم نوعين والاثنين من غير اضافة مكتبات خارجية 1- استخدام اداة اكتفتي (TabStrip) من غير اضافة اداة 2- تعديل بالوقت = اسرع بحفظ التغيرات للنص العامودي ================================== وفي الثالثه من تنزيل Ms Word Use IMGE on Ms Aceess من اكواد ودوال الورد تعمل داخل الاكسس تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) No Add For Active_X-TabspChange_Text_Up_To_Dawon_V1.rar

استاذ @gavan ❤️🌹 منتظره خبرتك يمكن يحتاج الى تعديل