كل الانشطه

سأوافيك بها غدا بحول الله

أين التقرير في مرفقك للتطبيق والتجربة ؟؟

شكرا استاذ على التعديل الصحيح والان كيف يستدعى الكود في التقرير علما ان name1 هو المعني Me.Da5.Caption = Format(rs!Date_Marj, "yyyy/mm/dd") & " بـ" & name1 & " تحت رقم : " & rs!N_Act_Marj

وعليكم السلام ورحمة الله وبركاته .. تم تعديل المديول ليصبح :- Option Compare Database Option Explicit Function PartOfName(InName As String, NumberOfPart As Byte) As String Dim parts() As String Dim tempName As String Dim i As Integer Dim currentIndex As Integer Dim normalizedParts() As String Dim j As Integer tempName = Trim(InName) PartOfName = "" If tempName = "" Then Exit Function tempName = Replace(tempName, " -", " - ") tempName = Replace(tempName, "- ", " - ") tempName = Replace(tempName, " ", " ") parts = Split(tempName, " - ") currentIndex = 0 ReDim normalizedParts(0 To 0) For i = 0 To UBound(parts) If Trim(parts(i)) <> "" Then normalizedParts(currentIndex) = Trim(parts(i)) If i < UBound(parts) Then ReDim Preserve normalizedParts(0 To currentIndex + 1) currentIndex = currentIndex + 1 End If End If Next i If UBound(normalizedParts) > 0 Then If NumberOfPart - 1 <= UBound(normalizedParts) Then PartOfName = Trim(normalizedParts(NumberOfPart - 1)) End If Else Dim words() As String words = Split(tempName, " ") If NumberOfPart - 1 <= UBound(words) Then PartOfName = Trim(words(NumberOfPart - 1)) End If End If End Function Function NoSpaces(InName As String) As String Dim NewName As String Dim i As Integer Dim TheStr As String Dim ThePrevStr As String InName = Trim(InName) For i = 1 To Len(InName) TheStr = Mid(InName, i, 1) If TheStr = " " And ThePrevStr = " " Then TheStr = "" If TheStr <> "" Then ThePrevStr = TheStr NewName = NewName & TheStr Next NoSpaces = NewName End Function وتم تعديل الإستعلام ليصبح :- SELECT Table1.Name, PartOfName([Name],1) AS Firstname, PartOfName([Name],2) AS Secondname, PartOfName([Name],3) AS Thirdname, PartOfName([Name],4) AS Forthname, PartOfName([Name],5) AS SubFamily, PartOfName([Name],6) AS Family, [SubFamily] & " " & [Family] AS Familyname FROM Table1 WITH OWNERACCESS OPTION; ملفك بعد التعديل :- فصل ماقبل المطة.zip

وعليكم السلام ورحمة الله وبركاته .. استخدم في حدث في الحالي الكود التالي :- If Me.NewRecord Then Me.AllowAdditions = True Me.AllowEdits = True Me.AllowDeletions = True Else Me.AllowEdits = False Me.AllowDeletions = False End If وفي حدث بعد الإضافة للنموذج الحدث التالي :- Private Sub Form_AfterInsert() Me.AllowEdits = False Me.AllowDeletions = False End Sub ملفك بعد التطبيق :- 123452025.zip

السلام عليكم أساتذي الكرام 1- ياريت مساعدة بالتعديل على الاستعلام والمتمثل في : التعديل على كود الفصل في الاسم المركب سوى احادي او ثنائي او ثلاثي او رباعي المهم يكون الفصل في الاسم المركب قبل " - " لوحده الحالي: الماء الأبيض - تبسة / الكود يفصلها " الماء " و " الأبيض " المطلوب : الماء الأبيض - تبسة / الكود يفصلها " الماء الأبيض " 2- كيف يستدعى كود الفصل في تقرير مثلا وشكرا فصل ماقبل المطة.rar

بارك الله فيكم وينكم من زمان هذا الموضوع طرحته اليوم بعد وصولي لنتيجة صحيحة مرضية بل محكمة هذا الوصول سبقه موضوع تجاوزت المشاركات فيه الــــ 100 لن اتنازل عن اكوادي التي صنعتها .. مادام العمل سليم .. لاني تعبت من التجربة والتكرار والبحث عن الطريقة السليمة ..... ولكن ستبقى هذه الأكواد التي تفضلتم بها مرجعا مهما لي ولغيري لمن اراد بناء برنامج حضور كي يستنير بها حفظكم الله من كل سوء وزادكم علما ورفعة

ممتاز جدا جدا وانا قمت بتجربة كود جلب الخطوط العربية فقط من النظام وسوف ادمج بينه وبين طريقتى لتمكين المطور او المستخدم من تحديد خطوط معينه ان اراد ذلك فى المستقبل وهذا الكود المنقح Option Compare Database Option Explicit '=== تعريف LOGFONT === Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(0 To 31) As Byte End Type Private Const ARABIC_CHARSET As Byte = 178 Private Const DEFAULT_CHARSET As Byte = 1 '=== الـ API Declarations === #If VBA7 Then Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" _ (ByVal hdc As LongPtr, lpLogFont As LOGFONT, ByVal lpEnumFontProc As LongPtr, _ ByVal lParam As LongPtr, ByVal dwFlags As Long) As Long #Else Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" _ (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, _ ByVal lParam As Long, ByVal dwFlags As Long) As Long #End If Private m_FontList As Collection '=== الدالة الرئيسية === Public Sub LoadArabicFonts(cbo As Control, Optional IncludeNonArabic As Boolean = False) On Error GoTo ErrorHandler ' التحقق من صحة الـ Control If cbo Is Nothing Then Err.Raise 91, , "Control غير صالح" ' تهيئة القائمة بأمان SafeClearCombo cbo cbo.RowSourceType = "Value List" ' تحميل الخطوط Set m_FontList = New Collection If LoadSystemArabicFonts(IncludeNonArabic) Then PopulateComboBox cbo Else SafeAddItem cbo, "خطوط غير متوفرة" End If Exit Sub ErrorHandler: SafeClearCombo cbo SafeAddItem cbo, "خطأ في تحميل الخطوط" Debug.Print "LoadArabicFonts Error: " & Err.Number & " - " & Err.Description End Sub '=== وظائف مساعدة آمنة === Private Sub SafeClearCombo(cbo As Control) On Error Resume Next cbo.Clear On Error GoTo 0 End Sub Private Sub SafeAddItem(cbo As Control, itemText As String) On Error Resume Next cbo.AddItem itemText On Error GoTo 0 End Sub '=== تحميل الخطوط من النظام === Private Function LoadSystemArabicFonts(IncludeNonArabic As Boolean) As Boolean Dim hdc As LongPtr Dim lf As LOGFONT ' إعداد LOGFONT للخطوط العربية lf.lfCharSet = IIf(IncludeNonArabic, DEFAULT_CHARSET, ARABIC_CHARSET) ' الحصول على Device Context #If VBA7 Then hdc = GetDC(0) #Else hdc = GetDC(0&) #End If If hdc = 0 Then Exit Function On Error GoTo Cleanup EnumFontFamiliesEx hdc, lf, AddressOf EnumFontProc, 0, 0 Cleanup: LoadSystemArabicFonts = (m_FontList.Count > 0) #If VBA7 Then ReleaseDC 0, hdc #Else ReleaseDC 0&, hdc #End If On Error GoTo 0 End Function '=== Callback للخطوط === #If VBA7 Then Private Function EnumFontProc(lpelf As LOGFONT, ByVal lpntm As LongPtr, _ ByVal FontType As Long, ByVal lParam As LongPtr) As Long #Else Private Function EnumFontProc(lpelf As LOGFONT, ByVal lpntm As Long, _ ByVal FontType As Long, ByVal lParam As Long) As Long #End If On Error Resume Next Dim fName As String fName = StrConv(lpelf.lfFaceName, vbUnicode) fName = Left$(fName, InStr(fName, ChrW(0)) - 1) fName = Trim$(fName) ' فلتر TrueType فقط + تجنب التكرار If Len(fName) > 2 And (FontType And 4) = 4 And Not FontExists(fName) Then m_FontList.Add fName, fName ' Debug.Print "Font added: " & fName ' للاختبار End If EnumFontProc = 1 End Function '=== فحص وجود الخط === Private Function FontExists(fontName As String) As Boolean Dim f As Variant On Error Resume Next Set f = m_FontList(fontName) FontExists = (Err.Number = 0) On Error GoTo 0 End Function '=== ملء القائمة مع الترتيب === Private Sub PopulateComboBox(cbo As Control) Dim arr() As String Dim i As Long If m_FontList.Count = 0 Then Exit Sub ' تحويل Collection إلى Array ReDim arr(1 To m_FontList.Count) For i = 1 To m_FontList.Count arr(i) = m_FontList(i) Next i ' ترتيب سريع QuickSort arr, LBound(arr), UBound(arr) ' إضافة للـ ComboBox For i = LBound(arr) To UBound(arr) cbo.AddItem arr(i) Next i End Sub '=== Sort === Private Sub QuickSort(arr() As String, ByVal low As Long, ByVal high As Long) Dim pivot As String, i As Long, j As Long, temp As String If low < high Then pivot = arr((low + high) \ 2) i = low: j = high Do While StrComp(arr(i), pivot, vbTextCompare) < 0: i = i + 1: Wend While StrComp(arr(j), pivot, vbTextCompare) > 0: j = j - 1: Wend If i <= j Then temp = arr(i): arr(i) = arr(j): arr(j) = temp i = i + 1: j = j - 1 End If Loop While i <= j If low < j Then QuickSort arr, low, j If i < high Then QuickSort arr, i, high End If End Sub '=== وظيفة اختبار === Public Function GetArabicFontsCount() As Long Set m_FontList = New Collection LoadSystemArabicFonts False GetArabicFontsCount = m_FontList.Count End Function

اجدت وأفدت مع ان ما قدمه اخونا Debug Ace رائع لا يقاوم .. لوجود ميزات متقدمة الا انني يبدو سأعتمد نسختك هذه لعدة اسباب : - تحقق عرض الخطوط العربية فقط من وندوز - التعامل مع التقرير مباشرة وحفظ آخر نسخة لتصبح دائمة - جلب الخلفية مفتوح وغير مقيد كل هذه قريبة من عملي تقريبا .. مع بعض التعديلات اللازمة جزاكم الله خيرا .. جميعا واجزل لكم الثواب

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

وبذلك التعديل يصبح الكود فى النهاية بهذا الشكل '=== ÇáËæÇÈÊ ááæÑÏíÉ ÇáãÓÇÆíÉ === Private Const SHIFT_START_HOUR As Integer = 17 ' 5 ãÓÇÁ Private Const SHIFT_END_HOUR As Integer = 1 ' 1 ÕÈÇÍÇ Private Const DEFAULT_WORK_HOURS As Long = 8 Private Const DEFAULT_FREE_IN_MINS As Long = 30 Private Const DEFAULT_FREE_OUT_MINS As Long = 30 '=== 1. ÝÍÕ ãÇ ÅÐÇ ßÇä ÇáæÞÊ ÇáãÍÏÏ Öãä æÑÏíÉ ãÓÇÆíÉ === Public Function IsEveningShiftNow(Optional ByVal checkTime As Date = 0) As Boolean If checkTime = 0 Then checkTime = Time() IsEveningShiftNow = (checkTime >= TimeSerial(SHIFT_START_HOUR, 0, 0)) Or (checkTime < TimeSerial(SHIFT_END_HOUR, 0, 0)) End Function '=== 2. ÊÇÑíÎ ÇáæÑÏíÉ ÇáÍÇáíÉ === Public Function CurrentShiftDate(Optional ByVal currentTime As Date = 0) As Date If currentTime = 0 Then currentTime = Time() If IsEveningShiftNow(currentTime) Then If currentTime >= TimeSerial(SHIFT_START_HOUR, 0, 0) Then CurrentShiftDate = Date Else CurrentShiftDate = Date - 1 End If Else CurrentShiftDate = Date End If End Function '=== 3. ÞÑÇÁÉ ÅÚÏÇÏÇÊ ÇáæÑÏíÉ ãÑÉ æÇÍÏÉ === Private Function GetShiftSettings() As Variant Static cachedSettings As Variant Static lastCacheTime As Date If DateDiff("n", lastCacheTime, Now()) > 5 Then Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("SELECT fatrah2_In, hours_Work2, free2_in, free2_out FROM tblTimeCtrl WHERE 1=1") If Not rst.EOF Then cachedSettings = Array( _ Nz(rst!fatrah2_In, "17:00:00"), _ Nz(rst!hours_Work2, DEFAULT_WORK_HOURS), _ Nz(rst!free2_in, DEFAULT_FREE_IN_MINS), _ Nz(rst!free2_out, DEFAULT_FREE_OUT_MINS) _ ) Else cachedSettings = Array("17:00:00", DEFAULT_WORK_HOURS, DEFAULT_FREE_IN_MINS, DEFAULT_FREE_OUT_MINS) End If rst.Close: Set rst = Nothing lastCacheTime = Now() End If GetShiftSettings = cachedSettings End Function '=== 4. æÞÊ ÈÏÇíÉ ÇáÊÓÌíá ÇáãÓãæÍ (ÞÈá ÇáÏÎæá ÇáÑÓãí) === Public Function funFirstTimeB_In(Optional ByVal refTime As Date = 0) As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim freeMins As Long: freeMins = CLng(settings(2)) If refTime = 0 Then refTime = Time() Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) funFirstTimeB_In = DateAdd("n", -freeMins, shiftDate + officialIn) End Function '=== 5. æÞÊ äåÇíÉ ÇáÊÓÌíá ÇáãÓãæÍ (ÈÚÏ ÇáÇäÕÑÇÝ ÇáÑÓãí) === Public Function funLastTimeB_Out(Optional ByVal refTime As Date = 0) As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim workHours As Long: workHours = CLng(settings(1)) Dim extraMins As Long: extraMins = CLng(settings(3)) If refTime = 0 Then refTime = Time() Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) funLastTimeB_Out = DateAdd("n", (workHours * 60) + extraMins, shiftDate + officialIn) End Function '=== 6. æÙÇÆÝ ÅÖÇÝíÉ ááÊÍÞÞ æÇáÇÎÊÈÇÑ ãÚ ãÚÇãá æÞÊ === Public Function GetCurrentShiftInfo(Optional ByVal refTime As Date = 0) As String Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) GetCurrentShiftInfo = "ÇáæÑÏíÉ: " & Format(shiftDate, "yyyy-mm-dd") & " | " & _ "ÇáÏÎæá ÇáãÓãæÍ: " & Format(funFirstTimeB_In(refTime), "hh:nn") & " | " & _ "ÇáÎÑæÌ ÇáãÓãæÍ: " & Format(funLastTimeB_Out(refTime), "hh:nn") End Function '=== 7. ÇÎÊÈÇÑ ÇáãäØÞ === Public Function TestShiftLogic(Optional ByVal testTime As Date = 0) As String If testTime = 0 Then testTime = Now() TestShiftLogic = "ÇáæÞÊ: " & Format(testTime, "hh:nn:ss") & " ? " & GetCurrentShiftInfo(testTime) End Function Sub TestDebugPrint() Debug.Print TestShiftLogic() Debug.Print TestShiftLogic(#11:30:00 PM#) Debug.Print TestShiftLogic(#12:30:00 AM#) End Sub

وجهة نظرك منطقية وتحترم ينفع معاك الحل ده ؟ Public Function IsEveningShiftNow(Optional ByVal checkTime As Date = 0) As Boolean If checkTime = 0 Then checkTime = Time() IsEveningShiftNow = (checkTime >= TimeSerial(17, 0, 0)) Or (checkTime < TimeSerial(1, 0, 0)) End Function Public Function CurrentShiftDate(Optional ByVal currentTime As Date = 0) As Date If currentTime = 0 Then currentTime = Time() If IsEveningShiftNow(currentTime) Then If currentTime >= TimeSerial(17, 0, 0) Then CurrentShiftDate = Date Else CurrentShiftDate = Date - 1 End If Else CurrentShiftDate = Date End If End Function

الفا مليون شكر الاساتذة الكرام

تمام ، وبما أنك تحاكي اختبار لمنطق الورديات .. فإن اسناد قيمة إلى دالة مدمجة في اكسيس مثل Time بحد ذاته غير منطقي ( وجهة نظري طبعاً ) . وبالتالي فإن الحل الأفضل هو جعل الدوال تستقبل الوقت كـ باراميتر ، أو إنشاء دالة وسيطة تعيد الوقت الحالي . واعتذر إن جررت الحديث خارج محتوى الموضوع

الدالة لا تغير وقت النظام الحقيقي في الكمبيوتر الدالة محاكاة اختبار لمنطق الورديات بتغيير الوقت الحالي بشكل مؤقت لاختبار سلوك النظام في أوقات مختلفة دون انتظار مرور الوقت الحقيقي Public Function TestShiftLogic(Optional testTime As Date = 0) As String If testTime = 0 Then testTime = Now() ' 1. استخدم الوقت الحالي لو مفيش وقت محدد Dim originalTime As Date: originalTime = Time() ' 2. احفظ الوقت الأصلي Time = testTime ' 3. غير الوقت الحالي بشكل مؤقت ← **السر هنا** TestShiftLogic = "الوقت: " & Format(testTime, "hh:nn:ss") & " → " & GetCurrentShiftInfo() ' 4. نفذ الاختبار واحصل على النتيجة Time = originalTime ' 5. ارجع الوقت الأصلي ← **الأمان** End Function صارت الامور اوضح معك بهذا الشرح

وهذه الإجابة التي انتظرها لتأكيد رواية "اني لأشم ريح يوسف" وأعلم أنها ليست من فراغ وارجو ان يتسع صدرك لحديثنا هذا بأن توضح لي المقصود من الدالة Public Function TestShiftLogic(Optional testTime As Date = 0) As String If testTime = 0 Then testTime = Now() Dim originalTime As Date: originalTime = Time() Time = testTime ' اختبار مؤقت TestShiftLogic = "الوقت: " & Format(testTime, "hh:nn:ss") & " → " & GetCurrentShiftInfo() Time = originalTime ' إعادة الوقت الأصلي End Function هل تحاول تغيير وقت النظام ( في الكمبيوتر ) فعلياً بهذه الدالة ؟؟؟؟

اجابتى كانت من واقع خبرتى المتواضعه وفوق كل ذى علم عليم . شكرا ليك على هذه المعلومة سوف اقوم بالتجربة

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

طيب وانا كتبت الفكرة الثانية ليه تفتكر من فراغ يعنى ؟؟؟

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

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

افتح موضوع جديد ، وارفق ملفك وإن شاء الله تجد حل لمشكلتك .

🤨

ما شاء الله تبارك الرحمن 🙂 جميل جدا تنوع الأفكار في نفس المجال 😊👌 وأنا أيضا لدي برنامج خاص بتصميم الشهادات وتنسيقها وتوليد الشهادات لمجموعة كبيرة من الطلاب أو المتدربين أو المستلمين بشكل عام ، وكذلك يقوم بإرسال الشهادات بالبريد الإلكتروني لكل المستهدفين ( كل متدرب أو طالب يستلم شهادته) ، وأيضا يقوم بحفظ جميع الشهادات على شكل Pdf دفعة واحدة .. 🙂 مع إمكانيات تنسيق النص ( الخطوط والألوان ) بشكل حر ، وإضافة التواقيع ، وتغيير إطارات البرنامج .. إلخ تصميم وتنسيق النصوص بكل أريحية إضافة المتدربين دفعة واحدة بعدد لا محدود معاينة بشكل مباشر اواجهة البرنامج مع خيارات البحث وعرض تقارير وإحصائيات لتحميل البرنامج : تنصيب برنامج صانع الشهادات الإصدار الثالث 3.0.zip

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