نجوم المشاركات

السلام عليكم أرجو أن يكون مناسباً Sub Sort_Sum() Application.ScreenUpdating = False Sheets("البيانات").Range("Data").Copy Sheets("فرز وجمع").Range("Sort_Sum[اسم الموظف]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Clear ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[الشعبة]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[المبلغ]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort.SortFields.Add Key:=Range("Sort_Sum[اسم الموظف]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("فرز وجمع").ListObjects("Sort_Sum").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("K2").FormulaR1C1 = _ "=SUMIF(Sort_Sum[[الشعبة]:[المبلغ]],[@الشعبة],Sort_Sum[المبلغ])" Range("K2").AutoFill Destination:=Range("شعب[المبلغ]") Range("a1").Select Calculate Application.ScreenUpdating = True End Sub فرز وجمع.xlsm

Sub Test() Const sOutput As String = "Output" Dim shp As Shape, m As Long, r As Long, n As Long Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0 Application.DisplayAlerts = True Sheets(1).Copy , Sheets(Sheets.Count) Sheets(Sheets.Count).Name = sOutput With Sheets(sOutput) For Each shp In .Shapes shp.Delete Next shp .AutoFilterMode = False If .FilterMode = True Then .ShowAllData m = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1:H" & m).Sort Key1:=.Range("G1:G" & m), Order1:=xlAscending, Header:=xlYes r = 2 Do Until .Cells(r, 7).Value = Empty If r = 2 Then n = r If .Cells(r, 7).Value <> .Cells(r + 1, 7).Value Then .Rows(r + 1).Insert Shift:=xlDown .Cells(r + 1, 7).Value = "Total" .Cells(r + 1, 8).Formula = "=SUM(H" & n & ":H" & r & ")" With .Cells(r + 1, 7).Resize(, 2) .Font.Color = vbWhite .Interior.Color = RGB(55, 86, 36) End With r = r + 1 n = r + 1 End If r = r + 1 Loop End With Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

السلام عليكم اتفضل استاذ احمد @Ahmed_J تم التعديل فقد كنت مستعجل عند المشاركه الاولى للنزول للعمل واستخدمت الموديول فحدث آخر لذلك لم يعمل وجزاه الله خيرا معلمنا العزيز جعفر 💐🌹 تم تعديل التقرير الثالث rpt_Ev3 بالتوفيق 1468.1.Lines in Report2.accdb

السلام عليكم ورحمة الله تعالى وبركاته وردنى السؤال الآتى عند فتح نموذج او تصفح بيانات من استعراض السجلات من خلال نموذج فى حالة التركيز على عنصر تحكم ما قد يتم اضاقة شئ بالخطأ الى البيانات او حذف شئ من البيانات هل ممكن تأمين جميع الحقول بحيث لا يمكن التعديل او حذف او اضافة بيانات بالخطأ الاجابة نعم ممكن ذلك بكل سهولة من خلال الفكرة الاتية بترتيب الخطوات إنشاء زر امر ونسمى زر الامر cmdEdit نقوم بتسمية زر الامر بـ Edit نضع الكود الاتى فى حدث الحالى للنموذج If Me.NewRecord Then With Me .cmdEdit.Caption = "Edit" .cmdEdit.ForeColor = 0 .cmdEdit.FontBold = False .AllowEdits = True .cmdEdit.Enabled = False End With Else With Me .AllowEdits = False .cmdEdit.Caption = "Edit" .cmdEdit.ForeColor = 0 .cmdEdit.FontBold = False .cmdEdit.Enabled = True End With End If نضع الكود الاتى فى حدث عند النقر لزر الامر Select Case Me.cmdEdit.Caption Case "Edit" With Me .AllowEdits = True .cmdEdit.Caption = "Lock" .cmdEdit.ForeColor = 255 .cmdEdit.FontBold = True .Refresh End With Case "Lock" With Me .AllowEdits = False .cmdEdit.Caption = "Edit" .cmdEdit.ForeColor = 0 .cmdEdit.FontBold = False .Refresh End With End Select المرفق Securing records.accdb

ياريت يا ابوجودى وخلى الدفع عليا المرادى استاذ @Amr Ashraf 😀 وجزاك الله خيرا

السلام عليكم معلمى العزيز @jjafferr جزاك الله خيرا على ما تقدمه لنا مساعدات ومعلومات 💐 استطعت جعلها كما يريد استاذ @Ahmed_J ولكن عالتقرير rpt_Ev2 ولم استطع تظبيطها مع التقرير الذى به الخطوط فلعلك تقدر ع ضبطها 1468.1.Lines in Report1.accdb

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

بس فعلا انا فى العمل قاعدة البيانات تم حذفها بالخطا ذات مرة وبقليل من البحث توصلت لتعديل اعدادت امان المجلد ليصبح قابل للقراءة والتعديل فقط دون الحذف وبذلك لا يتم حذف القاعدة الا ان قمت بتعديل اعدادات الامان مرة اخرة وبعدين يا سيدى هزر براحتك على قلبى زى العسل ولو عاوز تعمل مجلد لا يتم حذف ما بداخلة ابدا بكل سهولة اذهب لموجه اوامر الدوس اكتب لامر الاتى cacls D:\Moh3ssam /P everyone:n مع تعديل D:\Moh3ssam بمسار المجلد وان كان اسم المجلد يتكون من اكثر من مقطع تعامل معه مثل ما تتعامل مع الاسماؤ فى محرر الاكواد يعمى لو عندنا مجلد على القطاع D باسم Amr Ashraf يكتب الامر فى موجه اوامر الدوس بهذا الشكل cacls D:\ Amr_Ashraf /P everyone:n ثم اضغط من لوحة المقاتيح على زر الـ Enter تأتى لك رسالة تخبرك ان اردت الاستمرار اضغط على حرف الـ y من لوحة المفاتيح وان اردت عدم الاستمرار اظغط على حرف الـ N وبمجرد الضغط على حرف الـ Y يتم تعديل اعداد الامان للمجلد لن تستطيع حذف او اضافة اى شئ اليه ولفتح الاعدادت مرة اخرى للمجلد ليقبل الكتابة او الحذف cacls D:\ Amr_Ashraf /P everyone:f انا مجلد البرامج بأقوم بعمل تلك الخطوة للحفاظ عليها من الحذف او التعديل عليها من قبل الفيروسات

السلام عليكم ورحمة الله وبركاته أخي الكريم @lionheart جزاكم الله خيراً ..أحسنتم كود رائع لاستخلاص النتائج بواسطة كود Pivot Table تقبل تحياتي العطرة لشخصكم الكريم والسلام عليكم.

عند كلمة function اكتب قبلها PtrSafe function وعند كلمة long اكتب بعدها longPtr وراح يعمل معك إن شاء الله

أخي الكريم بما أنه لا توجد لديك بيانات فعلية، أرسل لك ما تريد و انا نقلت من الورقة 1 للورقة2 VLookUp_Jinane.xls

جزيت خيرا تسلم هو المطلوب

اخواني الاعزاء 🙂 رجاء قراءة ما كتبته في الرابط الذي ذكرته ، فهو خاص للمبرمجين مثلي ومثلكم : ولكن وللأسف الشديد ، فأنا ارى ان 99.99% من البرامج ، يتم حذف هذه القائمة وعدم تفعيلها ، والسبب ان المستخدم يستطيع ان يدخل في تصميم النموذج من خلال هذه الاوامر(في الدائرة الحمراء) : . لا تخفي القائمة كاملة ، واجعل المستخدم يستفيد منها ، واستخدم على الاقل هذه القوائم المختصرة : . او . وللتقرير . فهذه القوائم لا تسمح للمستخدم في الدخول في تصميم البرنامج ، ولكنه يعطيه قوة جبارة في الاكسس والتي لا توجد في بعض اقوى برامج الويب ، ان تعمل الفرز والتصفية وبدون برمجة 🙂 في برامجي اثقف واخبر المستخدم عن هذه الميزة ، ولا احتاج الى برمجتها ، ويأتيني احد المستخدمين لاحقا وبإفتخار بأنه استطاع الوصول الى سجل معين طلبه منه رئيسه (يحتاج الى تصفية عدة حقول وفرز) ، باستخدام القوائم بعد ان فشل بقية اصدقائة المستخدمين في الوصول لهذا السجل بالطرق العادية. وفي الرابط اعلاه ، فيه قاعدة بيانات مرفقة بإسم myRight_Click.mdb ، وفيها هذه القوائم جاهزة ، ولا يحتاج لك برمجة ، فقط اتبع الخطوات (بالصور من الرابط) لإستيرادها لبرنامجك من البرنامج المرفق. رجاء اجعلوا برنامجكم يبرز ، واعطوا الاكسس حقه ، ولا تحذفوا القوائم المختصرة 🙂 جعفر

بسم الله الرحمن الرحيم.. السلام عليكم ورحمة الله وبركاته.. بعد طول غياب عن الساحة بسبب ضروف الحياة والعمل.. اقدم لكم اداة صغيرة من برمجتي بلغة Visual Studio .NET تقوم بالتقاط الصور كاميرا الويب او اي كاميرا متصلة بالكومبيوتر ومن ثم خزنها في الجهاز الاداة قمت بربطها مع الاكسس، بحيث تقوم بتمرير براميتر من الاكسس الى الاداة وهذا البراميتر متمثل بـ مسار حفظ الصورة + واسم الصورة + صيغتها مثال: Dim SavedPath As String SavedPath = """" & CurrentProject.Path & "\Capture.png" & """" الاداة تستخدم مكتبات AForge للتحكم بالكاميرات. صورة الاداة: بمجرد ان تضغط زر Open Camera من الاكسس ستعمل الاداة مباشرة قم بترتيب الكاميرا الخاصة بك لاخذ لقطة مناسبة واضغط على الزر Snapshot ثم اضغط على الز save لحفظ الصورة. الاداة اخذت مني وقت 8 ساعات في البرمجة لذلك لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. SEMO_webCam.rar كلمات مفتاحية: التقاط صورة من الكاميرا، حفظ الصورة من الكاميرا، جلب الصورة من كاميرا الويب، جلب الصورة من الكاميرا وحفظها في قاعدة البيانات، حفظ الصور بقاعدة البيانات، خزن الصورة من الكاميرا كاميرا ويب قاعدة بيانات اكسس، اكسس كاميرا الويب، اكسس كاميرا، جلب الصورة من الكاميرا

من عيونى الشرح هنا فى موضوع مستقل

Sub Test() Dim ws As Worksheet, sh As Worksheet, r As Range, d As Object, i As Long Application.ScreenUpdating = False Set ws = Sheets(1): Set sh = Sheets(2) Set d = CreateObject("Scripting.Dictionary") With ws Set r = .Range("B4:BF" & .Cells(Rows.Count, 3).End(xlUp).Row) For Each r In Intersect(r, r.Offset(1, 2)) If r.Value <> "" Then i = r.Row d(.Cells(i, 2) & .Cells(i, 3) & r) = Array(.Cells(i, 2), .Cells(i, 3), r) End If Next r End With With sh .Range("C3:BE15").ClearContents .Range("BK1").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items)) .Range("BN1:BN" & d.Count).Formula = "=BL1&BM1" With .Range("C3:BE15") .Formula = "=IFERROR(INDEX($BK:$BK,MATCH($B3&C$2,$BN:$BN,0)),"""")" .Value = .Value End With .Columns("BK:BN").ClearContents End With Application.ScreenUpdating = True End Sub

بس فكرة جيدة فعلا مطبقتهاش قبل كده بس سؤال لولبى لو المجلد ده اصبح Read Only لو بداخله قاعدة الجداول BE والواجهة مربوطة بيه مش هيشتغل على ما اتذكر لازم المجلد اللى فيه الجداول يبقى RW

السلام عليكم. اخي ابو خليل، يمكنك ذلك بلغة غير الاكسس لانها قديمة نوعا ما ولا تدعم مكتبات Google V3 الحديثة يمكنك عمل ذلك بواسطة Visual Studio .NET وتمرير براميتر مسار الملف الذي تريد حفظة من الاكسس للاداة التي قمت بعملها بالفيجوال والاداة ستقوم بعملها.

بهزر معاك يابو جودى

على الرغم انك لم تقم برفع ملف مدعوم بشرح كافى عن المطلوب ... وكما تعلم والجميع يعلم ان هذا بدوره يؤدى الى اهدار وقت كل من يطلع على مشاركتك دون جدوى ,, فسأجيبك أيضا بدون ملف .. هذا هو الكود المطلوب Function NumberToText(Number As Double, MainCurrency As String, SubCurrency As String) Dim Array1(0 To 9) As String Dim Array2(0 To 9) As String Dim Array3(0 To 9) As String Dim MyNumber As String Dim GetNumber As String Dim ReadNumber As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetText As String Dim Billion As String Dim Million As String Dim Thousand As String Dim Hundred As String Dim Fraction As String Dim MyAnd As String Dim I As Integer Dim ReMark As String If Number > 999999999999.99 Then Exit Function If Number < 0 Then Number = Number * -1 ReMark = "سالب " End If If Number = 0 Then NumberToText = "صفر" Exit Function End If MyAnd = " و" Array1(0) = "" Array1(1) = "مائة" Array1(2) = "مائتان" Array1(3) = "ثلاثمائة" Array1(4) = "أربعمائة" Array1(5) = "خمسمائة" Array1(6) = "ستمائة" Array1(7) = "سبعمائة" Array1(8) = "ثمانمائة" Array1(9) = "تسعمائة" Array2(0) = "" Array2(1) = " عشر" Array2(2) = "عشرون" Array2(3) = "ثلاثون" Array2(4) = "أربعون" Array2(5) = "خمسون" Array2(6) = "ستون" Array2(7) = "سبعون" Array2(8) = "ثمانون" Array2(9) = "تسعون" Array3(0) = "" Array3(1) = "واحد" Array3(2) = "اثنان" Array3(3) = "ثلاثة" Array3(4) = "أربعة" Array3(5) = "خمسة" Array3(6) = "ستة" Array3(7) = "سبعة" Array3(8) = "ثمانية" Array3(9) = "تسعة" GetNumber = Format(Number, "000000000000.00") I = 0 Do While I < 15 If I < 12 Then MyNumber = Mid$(GetNumber, I + 1, 3) Else MyNumber = "0" + Mid$(GetNumber, I + 2, 2) End If If (Mid$(MyNumber, 1, 3)) > 0 Then ReadNumber = Mid$(MyNumber, 1, 1) My100 = Array1(ReadNumber) ReadNumber = Mid$(MyNumber, 3, 1) My1 = Array3(ReadNumber) ReadNumber = Mid$(MyNumber, 2, 1) My10 = Array2(ReadNumber) If Mid$(MyNumber, 2, 2) = 11 Then My11 = "إحدى عشرة" If Mid$(MyNumber, 2, 2) = 12 Then My12 = "إثنى عشرة" If Mid$(MyNumber, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNumber, 1, 1)) > 0) And ((Mid$(MyNumber, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNumber, 3, 1)) > 0) And ((Mid$(MyNumber, 2, 1)) > 1) Then My1 = My1 + MyAnd GetText = My100 + My1 + My10 If ((Mid$(MyNumber, 3, 1)) = 1) And ((Mid$(MyNumber, 2, 1)) = 1) Then GetText = My100 + My11 If ((Mid$(MyNumber, 1, 1)) = 0) Then GetText = My11 End If If ((Mid$(MyNumber, 3, 1)) = 2) And ((Mid$(MyNumber, 2, 1)) = 1) Then GetText = My100 + My12 If ((Mid$(MyNumber, 1, 1)) = 0) Then GetText = My12 End If If (I = 0) And (GetText <> "") Then If ((Mid$(MyNumber, 1, 3)) > 10) Then Billion = GetText + " مليار" Else Billion = GetText + " مليارات" If ((Mid$(MyNumber, 1, 3)) = 2) Then Billion = " مليار" If ((Mid$(MyNumber, 1, 3)) = 2) Then Billion = " مليارن" End If End If If (I = 3) And (GetText <> "") Then If ((Mid$(MyNumber, 1, 3)) > 10) Then Million = GetText + " مليون" Else Million = GetText + " ملايين" If ((Mid$(MyNumber, 1, 3)) = 1) Then Million = " مليون" If ((Mid$(MyNumber, 1, 3)) = 2) Then Million = " مليونان" End If End If If (I = 6) And (GetText <> "") Then If ((Mid$(MyNumber, 1, 3)) > 10) Then Thousand = GetText + " ألف" Else Thousand = GetText + " ألاف" If ((Mid$(MyNumber, 3, 1)) = 1) Then Thousand = " ألف" If ((Mid$(MyNumber, 3, 1)) = 2) Then Thousand = " ألفان" End If End If If (I = 9) And (GetText <> "") Then Hundred = GetText If (I = 12) And (GetText <> "") Then Fraction = GetText End If I = I + 3 Loop If (Billion <> "") Then If (Million <> "") Or (Thousand <> "") Or (Hundred <> "") Then Billion = Billion + MyAnd End If If (Million <> "") Then If (Thousand <> "") Or (Hundred <> "") Then Million = Million + MyAnd End If If (Thousand <> "") Then If (Hundred <> "") Then Thousand = Thousand + MyAnd End If If Fraction <> "" Then If (Billion <> "") Or (Million <> "") Or (Thousand <> "") Or (Hundred <> "") Then NumberToText = ReMark + Billion + Million + Thousand + Hundred + " " + MainCurrency + MyAnd + Fraction + " " + SubCurrency Else NumberToText = ReMark + Fraction + " " + SubCurrency End If Else NumberToText = ReMark + Billion + Million + Thousand + Hundred + " " + MainCurrency End If End Function

السلام عليكم .. اول خطوة تحول مصدر بيانات القائمة الى Value List الخطوة الثانية اضافة الكود التالى الى حدث AfterUpdate للكومبوبوكس الاول Private Sub cbo1_AfterUpdate() StrItem = Me.cbo1.Column(1) Me.Notce.AddItem (StrItem) ' اضافة الى آخر القائمة 'Me.Notce.AddItem (StrItem), 0 ' يتم تفعيلها والغاء السطر السابق اذا اردت الحاق القيمة فى اول القائمة وليس فى آخرها End Sub واضافة هذا الى الكومبوبوكس الثانى Private Sub cbo2_AfterUpdate() StrItem = Me.cbo2.Column(1) Me.Notce.AddItem (StrItem) ' اضافة الى آخر القائمة 'Me.Notce.AddItem (StrItem), 0 ' يتم تفعيلها والغاء السطر السابق اذا اردت الحاق القيمة فى اول القائمة وليس فى آخرها End Sub يتم اعلان متغير نصى StrItem فى بداية النموذج النتيجة هل هذا هو المطلوب ؟ مرفق القاعدة بعد التعديل ComboToListbox-Amr.accdb

You can simply use the Copy method if you just want to copy data for once. I think you have to explain your question well

بسيطة وذلك لأن نظام الكمبيوتر لديك 64بت وهذا الكود لا يعمل الا على 32 بت .... وشكراً

تم بحمد لله الوصول الي حل المشكلة وما زال استاذنا صاحب الفكرة والكود مبدع كالعادة 1- تسجيل اسم الحقل كما هو بالجدول وليس الاسم البرمجي في النموذج 2- الغاء تسجيل مصدر النموذج تتبع جميع حركات المستخدم 1.01.rar

طيب هو الكلام كان واضح من العنوان تأمين السجلات من تعديل او حذف البيانات بالخطأ لم اقصد حذف السجل نفسه ولكن البيانات داخل احد العناصر فى النموذج للسجل الحالى ولكن على كل حال زيادة فى الخير ومن اجل عيون صاحب السؤال الحل كالاتى .AllowDeletions = عند التأمين = False فلا يتم حذف السجل وعند الغاء التامين وفى وضع التعديل تكون = True Securing records(2).accdb

السلام عليكم استاذ الحبيب ابو الحسن السبب هو التغييرات التي حدثت للجداول مما يؤثر على الاكواد والتي تحتاج الى مزيد من المتابعة مع التعديلات اللازمة التعديل الجديد تم على قاعدة البيانات القديمة والتعديل شمل جدول الحسابات فقط مع بعض التعديلات الضرورية في النماذج ارجو ان تكون هذه المحاولة موفقة وعذرا للتقصير الدائن و المدين-2.rar

بالخدمة استاذ محمد ورخم الله والديك

فكرة رائعة باش مهندس .. بارك الله فيك 🌹😊 فقط لاحظت أن زر الحذف يعمل في حال الحماية .. ربما من الأفضل منع الحذف أيضا 🙂

اهلا استاذ نبيل .... لاحظ التعديلات الموجودة في الصورة وشرحها بالترتيب ::::::: - جدول الارشيف المؤقت - جدول الرشيف النهائي - جدول بيانات الموظفين - نموذج الارشيف المرقت - نموذج الارشيف النهائي - نموذج رئيسي - نموذج اختيار نوع الترحيل - استعلام توحيد للترقيم حتى لا يتم تكرار الترقيم ملاحظة : لم يتم ادراج زر في النموذج الرئيسي لنموذج الارشيف النهائي ( اختر لها زر حسب برنامجك ) ..... Database26.accdb

حسب ما فهمته من ملفك وارفق لك صور بالكود من ورقة تصفية .... وعملت فلترة من ورقة التصاريح نفس النتيجة

Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim x, r As Long, cnt As Long Application.ScreenUpdating = False With ActiveSheet For r = sRow To eRow cnt = cnt + 1 x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0) If Not IsError(x) Then .Cells(x, 14).Resize(, 11).Cut If r <> x Then .Cells(r, 14).Insert Shift:=xlDown Else .Cells(r, 2).Resize(, 11).Cut .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Insert Shift:=xlDown If cnt = eRow Then Exit For r = r - 1 End If Next r End With Application.ScreenUpdating = True End Sub

عملت تغيير على الكود ليصبح: Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) Dim i As Integer, UB As Integer Dim x() As String Dim L As Single, T As Single, W As Single, H As Single x = Split(Me.Ev, Chr(13)) UB = UBound(x) If UB = 0 Then Exit Sub L = Me.Ev.Left T = Me.Ev.Top W = Me.Ev.Width H = (Me.Ev.FontSize + 4) * 20 'convert Font size Points to Twips, but the number 4 can be adjusted For i = 1 To UB T = T + H Me.Line (L, T)-(W, T), vbRed 'vbBlack Next i End Sub . والسطر المهم فيه هو ، نأخذ الارتفاع على حسب حجم الخط * 20 (لتحويل حجم الخط الى twips) ، فلا يجب تغيير هذه المتغيرات ، بينما يمكنك تغيير الرقم 4 حسب الحاجة (مع ان تجاربي يتضح منها انه لا يتغير كذلك) : H = (Me.Ev.FontSize + 4) * 20 'convert Font size Points to Twips, but the number 4 can be adjusted . والنتيجة : . او . وحتى اذا جعلنا الخط يساوي 18 نقطة . النتيجة . ونعم ، لتغيير اللون الى اللون الاسود ، بدل vbRed استعمل vbBlack 🙂 جعفر 1468.1.Lines in Report.accdb.zip

جزاك الله انت وكل اساتذتنا عنا كل خير فمنكم تعلمنا ونتعلم كل يوم بارك الله لنا فيكم 💐 ان شاء الله ربنا هييسرلك الامور وسوف احاول التواصل مع بعض الاخوه عبر الفيس ممن لديهم خبره فى مجال الويب والعمل مع قواعد البيانات mysql وان شاء الله يقدروا يفيدونا وعليكم السلام استاذ عمر ان شاء الله ربنا ييسرها على شيخنا الجليل وفيك بارك الله اخى ونفعنا الله واياكم بما نتعلم

______ __ __ ___ .__ __. _______ _______ __ ______ ______ .__ __. / || | | | / \ | \ | | / _____|| ____| | | / | / __ \ | \ | | | ,----'| |__| | / ^ \ | \| | | | __ | |__ | | | ,----'| | | | | \| | | | | __ | / /_\ \ | . ` | | | |_ | | __| | | | | | | | | | . ` | | `----.| | | | / _____ \ | |\ | | |__| | | |____ | | | `----.| `--' | | |\ | \______||__| |__| /__/ \__\ |__| \__| \______| |_______| |__| \______| \______/ |__| \__| تغيير شعار ميكروسوفت أكسس في TASK Manager في النموذج المرفق واستبداله بأيقونة أخرى يتم استدعاء الروتين من خلال وضع الكود الاتى فى حدث عند تحميل نموذج Call Xicon مع مراعاة تغيير البيانات الاتية فى رأس الموديول اسم التطبيق AppName اسم الايقونة بدون الامتداد icoName وتم عمل الكود على ان الايقونة فى نفس مسار القاعدة فى حالة تغيير مكان الايقونة لابد من تغير المسار فى الروتين AppIcon() Const AppName = "www.officena.net" Const icoName = "officenaIco" Public Function AppIcon() AppIcon = CurrentProject.Path & "\" & icoName & ".ico" End Function Public Function AccessIcon() AccessIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Debug.Print AccessIcon End Function Function AddAppProperty(strName As String, _ varType As Variant, varValue As Variant) As Integer Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270 Set dbs = CurrentDb On Error GoTo AddProp_Err dbs.Properties(strName) = varValue AddAppProperty = True AddProp_Bye: Exit Function AddProp_Err: If Err = conPropNotFoundError Then Set prp = dbs.CreateProperty(strName, varType, varValue) dbs.Properties.Append prp Resume Else AddAppProperty = False Resume AddProp_Bye End If End Function Function Xicon() On Error GoTo ErrHandler Dim dbs As Object Set dbs = CurrentDb() Dim intX As Integer Const DB_Text As Long = 10 ' AppTitle intX = AddAppProperty("AppTitle", DB_Text, AppName) ' AppIcon Dim Chk Dim MyIcon As String Set Chk = CreateObject("Scripting.FileSystemObject") If Chk.FileExists(AppIcon()) = False Then MyIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Else MyIcon = AppIcon() End If intX = AddAppProperty("AppIcon", DB_Text, MyIcon) dbs.Properties("UseAppIconForFrmRpt") = 1 Application.RefreshTitleBar exitProc: Exit Function ErrHandler: If Err = 3270 Then Resume Next Else MsgBox Err & Err.Description Resume exitProc End If End Function ---------------------------------------------------------------------