السلام عليكم ورحمة الله تعالى
اولا كل الشكر وكل التقدير والاحترام لكل رواد المنتدى المحترمين
الافكار جميعها ولا اروع
والان حان وقت مشاركتى
فكرتى تعتمد على عمل التالى
كلاس موديول
عارف ان فى اجابات احتوت على افكار بسيطة جدا جدا جدا وفعالةوفكرتى هى كالاتى
امكانية عمل نماذج تقييم متعددة ليحتوى احد النماذج على تقييم لا يتعدى الثلاث نجوم
ونموذج اخر مثلا 5 نجوم
وممكن نموذج كمان يحتوى على 10 نجوم
فكرتى كود مركزى واحد يعمل على الجميع
امكانية اعطاء نفس النجمة او ازالتها اما من نفس النجمة او بالنجمة التى تسبقها
نبدأ شرح المنهج المتبع والفكرة والاكواد
انشاء وحدة نمطية عامة من النوع كلاسس باسم: clsStarRating
الكود سوف يكون:
Option Compare Database
Option Explicit
' ==========================================
' الثوابت الافتراضيةالخاصة
' ==========================================
Private Const DEFAULT_SOLID_STAR As Long = &H2605 ' رمز النجمة المصمتة
Private Const DEFAULT_HOLLOW_STAR As Long = &H2606 ' رمز النجمة المفرغة
Private Const DEFAULT_TOTAL_STARS As Integer = 6
Private Const MAX_STARS As Integer = 20
' ==========================================
' المتغيرات الخاصة
Private mStarCount As Integer
Private mRating As Integer
Private mSolidSymbol As Long
Private mHollowSymbol As Long
Private mLastForm As Form
Private mLastRatingField As String
Private mStarsExpression As String
' ==========================================
' التهيئة
' ==========================================
Public Sub Initialize(Optional ByVal starCount As Integer = DEFAULT_TOTAL_STARS, _
Optional ByVal SolidSymbol As Long = DEFAULT_SOLID_STAR, _
Optional ByVal HollowSymbol As Long = DEFAULT_HOLLOW_STAR)
mStarCount = IIf(starCount >= 1 And starCount <= MAX_STARS, starCount, DEFAULT_TOTAL_STARS)
mSolidSymbol = SolidSymbol
mHollowSymbol = HollowSymbol
mRating = 0
ClearCache
End Sub
' ==========================================
' تبديل حالة التقييم
' ==========================================
Public Sub StarClick(ByVal index As Integer)
If index < 1 Or index > mStarCount Then Exit Sub
mRating = IIf(index = mRating, IIf(index = 1, 0, index - 1), index)
End Sub
' ==========================================
' تحميل/حفظ >-->> فائق الكفاءة
' ==========================================
Public Sub LoadFromForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False)
On Error GoTo ErrHandler
mRating = Nz(Form.Controls(ratingControl).value, 0)
CleanExit:
Exit Sub
ErrHandler:
Debug.Print "LoadFromForm Error #" & Err.Number & ": " & Err.Description
If showMessage Then MsgBox Err.Description, vbCritical
Resume CleanExit
End Sub
Public Sub SaveToForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False)
On Error GoTo ErrHandler
If Form.NewRecord Then Exit Sub
Form.Controls(ratingControl).value = mRating
If Form.Dirty Then Form.Dirty = False
CleanExit:
Exit Sub
ErrHandler:
Debug.Print "SaveToForm Error #" & Err.Number & ": " & Err.Description
If showMessage Then MsgBox Err.Description, vbCritical
Resume CleanExit
End Sub
' ==========================================
' محرك مركزى لتحديث عرض التقييم فى النموذج
' ==========================================
Public Sub UpdateStarsForForm(FormObj As Form, ratingFieldName As String, _
Optional starPrefix As String = "txtStar", _
Optional textBoxName As String = "txtRatingText")
On Error GoTo ErrHandler
Static lastForm As Form, lastField As String
If Not lastForm Is Nothing Then
If lastForm Is FormObj And lastField = ratingFieldName Then Exit Sub
End If
Dim i As Integer, textExpr As String
For i = 1 To mStarCount
With FormObj.Controls(starPrefix & i)
.ControlSource = "=Switch([" & ratingFieldName & "]>=" & i & _
",ChrW(" & mSolidSymbol & "),True,ChrW(" & mHollowSymbol & "))"
End With
Next i
' نص التقييم (مرة واحدة)
If Len(textBoxName) > 0 Then
textExpr = "=Switch([" & ratingFieldName & "]=0,'بدون تقييم'," & _
"[" & ratingFieldName & "]=1,'نجمة'," & _
"[" & ratingFieldName & "]=2,'نجمتان'," & _
"True,[" & ratingFieldName & "] & ' نجوم')"
FormObj.Controls(textBoxName).ControlSource = textExpr
End If
' تحديث ذاكرة الكاش
Set lastForm = FormObj
lastField = ratingFieldName
CleanExit:
Exit Sub
ErrHandler:
Debug.Print "UpdateStars Error: " & Err.Description
Resume CleanExit
End Sub
' ==========================================
' تنظيف ذاكرة الكاش
' ==========================================
Private Sub ClearCache()
Set mLastForm = Nothing
mLastRatingField = ""
End Sub
----
اولا نبدأ بـــ :دليل التشغيل السريع لنظام تقييم النجوم
أعداد اى نموذج
مربعات النص المطلوبة:
txtRatingValue ← مرتبط بحقل فى الجدول نوع الحقل رقمى ليسجل قيمة التقييم مثل ← (التقييم 0-10)
txtRatingText ← (غير منضم ولا يرتبط بأى حقول فى الجدول) يعرض نص مثل ← "3 نجوم"
مربعات نص txtStarX
تبدأ من txtStar1 الى عدد النجوم التى تريد وضعها فى النموذج مثلا ← txtStar10 (غير منضمة جميعها ولا ترتبط بأى حقول فى الجدول) ← عرض نجوم التقييم ⭐
الأزرار btnStarX
خصائصها شفافة وتكون بنفس عدد مربعات النص السابقة وتكون مواضعها فوق مربعات النص فى المقدمة
كود النموذج
Option Compare Database
Option Explicit
' ==========================================
' إعدادات النموذج الثابتة (Configuration)
' ==========================================
' عدد النجوم
Private Const cintTotalStars As Integer = 10
' حقل التقييم
Private Const cstrRatingControl As String = "txtRatingValue"
' بادئة أزرار النجوم
Private Const cstrButtonPrefix As String = "btnStar"
' بادئة مربعات نص النجوم
Private Const cstrStarPrefix As String = "txtStar"
' نص التقييم
Private Const cstrTextControl As String = "txtRatingText"
Private StarEngine As clsStarRating
' ==========================================
' فتح النموذج - التهيئة الكاملة
' ==========================================
Private Sub Form_Open(Cancel As Integer)
On Error GoTo ErrHandler
Dim ctl As Control
' إنشاء محرك النجوم
Set StarEngine = New clsStarRating
StarEngine.Initialize cintTotalStars
' تحميل التقييم الحالي
If Not Me.NewRecord Then
StarEngine.LoadFromForm Me, cstrRatingControl
End If
' ربط أزرار النجوم ديناميكيا
For Each ctl In Me.Controls
If ctl.ControlType = acCommandButton And ctl.Name Like cstrButtonPrefix & "*" Then
ctl.OnClick = "=HandleStarClick(""" & ctl.Name & """)"
End If
Next ctl
' تحديث العرض
StarEngine.UpdateStarsForForm Me, cstrRatingControl, cstrStarPrefix, cstrTextControl
CleanExit:
Exit Sub
ErrHandler:
Debug.Print "Form_Open Error #" & Err.Number & ": " & Err.Description
MsgBox "خطأ في التهيئة: " & Err.Description, vbCritical, "Star Rating"
Resume CleanExit
End Sub
' ==========================================
' معالج ربط أحداث أزرار تقييم النجوم الديناميكي (مركزي)
' ==========================================
Public Function HandleStarClick(ByVal strButtonName As String) As Variant
On Error GoTo ErrHandler
Dim intStarIndex As Integer
intStarIndex = Val(Mid(strButtonName, Len(cstrButtonPrefix) + 1))
' التحقق من صحة النجمة
If intStarIndex < 1 Or intStarIndex > cintTotalStars Then
HandleStarClick = False
Exit Function
End If
' تسلسل العمليات: Load >> Click >> Save >> Refresh
StarEngine.LoadFromForm Me, cstrRatingControl
StarEngine.StarClick intStarIndex
StarEngine.SaveToForm Me, cstrRatingControl, False ' False = no message (بدون رسائل)
HandleStarClick = True
CleanExit:
Exit Function
ErrHandler:
Debug.Print "HandleStarClick Error [" & strButtonName & "] #" & Err.Number & ": " & Err.Description
HandleStarClick = False
Resume CleanExit
End Function
' ==========================================
' إغلاق آمن
' ==========================================
Private Sub Form_Unload(Cancel As Integer)
Set StarEngine = Nothing
End Sub
وطبعا يتم تعديل الاعدادت فى اعلى كود النموذج حسب المسميات ان اردت تغييرها فى النموذج بما يناسبك انت
' عدد النجوم
Private Const cintTotalStars As Integer = 10
' حقل التقييم
Private Const cstrRatingControl As String = "txtRatingValue"
' بادئة أزرار النجوم
Private Const cstrButtonPrefix As String = "btnStar"
' بادئة مربعات نص النجوم
Private Const cstrStarPrefix As String = "txtStar"
' نص التقييم
Private Const cstrTextControl As String = "txtRatingText"
وبكده يكون معانا فكرة وتنفيذ لكود مرن لا يتطلب اى تدخل منك فى المستقبل
ان اردت زيادة اعداد عناصر التقييم الا فقط باتباع نهج المواضع والمسميات
لا تعديل فى الكود ولن تحتاج الى اضافة اى اكواد فى النموذج
امكانية عمل اكثر من نموذج للتقييم فى نفس قاعدة البيانات على ان يكون لكل نموذج عدد تقييمات خاصة به وتختلف عن غيره
وأخيرا اليكم مرفقا للتجربة والتقييم للفكرة وألية العمل
الاستاذ الفاضل @ابوخليل اترك لكم حرية اختيار افضل اجابة لتكون مرجعا لرواد المنتدى ولكم خالص الشكر والتقدير
بالفعل مثل ما تفضل الاستاذ : Foksh
المشكلة دي مش من Access نفسه قد ما هي من تعريف الطابعة + إعدادات الصفحة المختلفين بين الجهازين وخصوصا مع الهوامش 0 وصورة كاملة صفحة
ليه التصميم بيخرب بين الجهازين؟
كل تقرير في Access بيتضبط على خصائص الطابعة الافتراضية وقت التصميم
لذلك أي اختلاف في تعريف الطابعة أو نوع الورق/الهوامش يخلي التقرير يعيد حساب المقاسات وتمركز الصورة والكنترولز
أغلب تعريفات الطابعات أصلا لا تسمح بهوامش 0 حقيقية فتجبر هامش أدنى (مثلا 3–5 مم من كل جانب)
وده اللي يخلي الصورة تتصغر أو تتزحزح ويظهر كأن فيه هوامش رغم إنها 0 في التقرير
على ويندوز 7 غالبا تعريف الطابعة مختلف أو إعدادات الـ Page Setup غير اللي على ويندوز 10
ماذا تفعل
على كل جهاز
افتح التقرير في معاينة قبل الطباعةثم اختر إعداد الصفحة Page Setup
تأكد أن:
حجم الورقة A4
الهوامش Manual وليست إعدادات خاصة بالطابعة (لو 0 عمل مشاكل استخدم 0.25 سم مثلا واضبط حجم الصورة بحيث تملأ المساحة داخل الهامش)
ثبت نفس تعريف الطابعة ونفس الإعداد كـ Default على الجهازين قدر الإمكان Access يعتمد على تعريف الطابعة في حساب عرض وارتفاع التقرير
لو حابب يمكن ضبط التقرير بحيث:
حجم التقرير نفسه يساوي A4 ناقص أقل هامش تدعمه الطابعة (مثلا عرض 19.7 سم بدل 21 سم)
والصورة تمتد داخل هذا المقاس كده هتاخد شكل فول بليد تقريبا على كل الأجهزة بدون ما يتلخبط التخطيط
