اذهب الي المحتوي
أوفيسنا

كود لتحكم فى لون وحجم ونوع الخط من خلال المستخدم من فورم فى البرنامج

User user

بواسطه User user
في قسم الأكسيس Access

 مشاركة

الردود الموصى بها

User user

User user

قام بنشر
قام بنشر (معدل)

محتاج كود لتحكم فى لون وحجم ونوع الخط من خلال المستخدم من خلال نموذج 
بحيث اتحكم فى كل عنصر بشكل منفصل عن الاخر مثلا لو لدى 
Test 1  ده مثلا لونه احمر ونوع الخط تيم نيو  وبولد 
Test 2 ده مثلا لونه ازرق ونوع الخط كايرو  وبولد 
Test 3 ده مثلا لونه اخضر ونوع الخط تهوما  وبولد 
Test 4  ده مثلا لونه اصفر ونوع الخط اريل  وبولد  وهكذا 
ارجوا انت تكون وصل المطلوب 
وهذا كود لاستاذنا الفاضل @jjafferr 
من فضلك لو تتكرم وتبلغنا ننفذ المطلوب كيف ؟
  

Function Convert_img_Embed_to_Link()
 
 Dim frm As AccessObject
    Dim rpt As AccessObject
    Dim dbs As Object
    Dim frm1 As Access.Form
    Dim rpt1 As Access.Report
    Dim ctl As Access.Control
    
    Set dbs = Application.CurrentProject
    
    For Each frm In dbs.AllForms

        DoCmd.OpenForm frm.Name, acDesign
        Set frm1 = Forms(frm.Name)

        For Each ctl In frm1.Controls
            If ctl.ControlType = acComboBox Or _
               ctl.ControlType = acCommandButton Or _
               ctl.ControlType = acLabel Or _
               ctl.ControlType = acListBox Or _
               ctl.ControlType = acOptionButton Or _
               ctl.ControlType = acTextBox Then
                
               Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name
               ctl.FontName = "Cairo"
               
               If frm1.DefaultView = 2 Then
                frm1.DatasheetFontName = "Cairo"  'DataSheetForms
               End If
               
            End If
        Next ctl

       DoCmd.Close acForm, frm.Name, acSaveYes
    Next frm
    
 Exit Function

    For Each rpt In dbs.AllReports

        DoCmd.OpenReport rpt.Name, acDesign
        Set rpt1 = Reports(rpt.Name)
        
        For Each ctl In rpt1.Controls
            If ctl.ControlType = acComboBox Or _
               ctl.ControlType = acCommandButton Or _
               ctl.ControlType = acLabel Or _
               ctl.ControlType = acListBox Or _
               ctl.ControlType = acOptionButton Or _
               ctl.ControlType = acTextBox Then
               
               Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name
               ctl.FontName = "Cairo"
               
               If rpt1.DefaultView = 2 Then
                frm1.DatasheetFontName = "Cairo"
               End If
            
            End If
        Next ctl

        DoCmd.Close acReport, rpt.Name, acSaveYes
    Next rpt
    
    
End Function

 


 

تم تعديل بواسطه jjafferr
إظهار الكود بالطريقة الصحيحة بإستعمال زر <> من القائمة
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر

طيب مبدئيا انا قمت بعمل بعض التعديلات الطفيفة جدا على الكود

  • لأنه كان يتوقف بعد تغيير خطوط النماذج بسبب  Exit Function  قمت بإزالتها
  • قمت بتغيير اسم الروتين العام حتى يتناسب مع الوظيفة ليسهل مستقبلا لأى احد معرفتها
  • إضافة كود تصيد الأخطاء لمعرفة التوصيف والرقم المناسب لأى خطأ حتى يسهل تفاديه 
  • إضاقة متغير ثابت في اول الكود ليتم وضع اسم الخط فقط مرة واحدة

ملاحظة هامة جدا جدا  لابد من تغير اسم الخط الذى قمت انا باستخدامه في الوحدة النمطية وهو  Calibri (Detail) باسم الخط الذى تريد أنت التغيير إليه 
وقمت بوضع هذا التلميح للتذكير في الوحدة النمطية عند المتغير الثابت الذى يحمل اسم الخط  <<---------<  Font name must be changed here between the quotation marks

يتم استدعاء الكود من خلال 

  Call ApplyDefaultFont

ويتم وضع الكود الاتي في موديول 

Function ApplyDefaultFont()

On Error GoTo ErrorHandler

Const strFontName = "Calibri (Detail)"    ' <<---------<  Font name must be changed here between the quotation marks

Dim frm           As AccessObject
Dim rpt           As AccessObject
Dim dbs           As Object
Dim frm1          As Access.Form
Dim rpt1          As Access.Report
Dim ctl           As Access.Control
        
Set dbs = Application.CurrentProject
  ' Apply Default Font for All Forms
  For Each frm In dbs.AllForms
    DoCmd.OpenForm frm.Name, acDesign
    Set frm1 = Forms(frm.Name)
      For Each ctl In frm1.Controls
        If ctl.ControlType = acComboBox Or _
           ctl.ControlType = acCommandButton Or _
           ctl.ControlType = acLabel Or _
           ctl.ControlType = acListBox Or _
           ctl.ControlType = acOptionButton Or _
           ctl.ControlType = acTextBox Then
           ctl.FontName = strFontName
           'Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name
              If frm1.DefaultView = 2 Then
                frm1.DatasheetFontName = strFontName
              End If
         End If
      Next ctl
      DoCmd.Close acForm, frm.Name, acSaveYes
  Next frm
  ' Apply Default Font for All Reports
    For Each rpt In dbs.AllReports
        DoCmd.OpenReport rpt.Name, acDesign
        Set rpt1 = Reports(rpt.Name)
          For Each ctl In rpt1.Controls
            If ctl.ControlType = acComboBox Or _
               ctl.ControlType = acCommandButton Or _
               ctl.ControlType = acLabel Or _
               ctl.ControlType = acListBox Or _
               ctl.ControlType = acOptionButton Or _
               ctl.ControlType = acTextBox Then
               ctl.FontName = strFontName
               'Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name
                  If rpt1.DefaultView = 2 Then
                    frm1.DatasheetFontName = strFontName
                  End If
            End If
        Next ctl
        DoCmd.Close acReport, rpt.Name, acSaveYes
    Next rpt

    Set frm = Nothing
    Set rpt = Nothing
    Set dbs = Nothing
    Set frm1 = Nothing
    Set rpt1 = Nothing
    Set ctl = Nothing
    Exit Function

ExitHandler:
   Exit Function
ErrorHandler:
   MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description
   
End Function

 

وهذا التطبيق العملي
 

Change Font.mdb

  • Like 1
رابط هذا التعليق
شارك
User user

User user

قام بنشر
  • الكاتب
قام بنشر
14 ساعات مضت, ابا جودى said:

طيب مبدئيا انا قمت بعمل بعض التعديلات الطفيفة جدا على الكود

  • لأنه كان يتوقف بعد تغيير خطوط النماذج بسبب  Exit Function  قمت بإزالتها
  • قمت بتغيير اسم الروتين العام حتى يتناسب مع الوظيفة ليسهل مستقبلا لأى احد معرفتها
  • إضافة كود تصيد الأخطاء لمعرفة التوصيف والرقم المناسب لأى خطأ حتى يسهل تفاديه 
  • إضاقة متغير ثابت في اول الكود ليتم وضع اسم الخط فقط مرة واحدة

ملاحظة هامة جدا جدا  لابد من تغير اسم الخط الذى قمت انا باستخدامه في الوحدة النمطية وهو  Calibri (Detail) باسم الخط الذى تريد أنت التغيير إليه 
وقمت بوضع هذا التلميح للتذكير في الوحدة النمطية عند المتغير الثابت الذى يحمل اسم الخط  <<---------<  Font name must be changed here between the quotation marks

يتم استدعاء الكود من خلال 

  Call ApplyDefaultFont

ويتم وضع الكود الاتي في موديول 

Function ApplyDefaultFont()

On Error GoTo ErrorHandler

Const strFontName = "Calibri (Detail)"    ' <<---------<  Font name must be changed here between the quotation marks

Dim frm           As AccessObject
Dim rpt           As AccessObject
Dim dbs           As Object
Dim frm1          As Access.Form
Dim rpt1          As Access.Report
Dim ctl           As Access.Control
        
Set dbs = Application.CurrentProject
  ' Apply Default Font for All Forms
  For Each frm In dbs.AllForms
    DoCmd.OpenForm frm.Name, acDesign
    Set frm1 = Forms(frm.Name)
      For Each ctl In frm1.Controls
        If ctl.ControlType = acComboBox Or _
           ctl.ControlType = acCommandButton Or _
           ctl.ControlType = acLabel Or _
           ctl.ControlType = acListBox Or _
           ctl.ControlType = acOptionButton Or _
           ctl.ControlType = acTextBox Then
           ctl.FontName = strFontName
           'Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name
              If frm1.DefaultView = 2 Then
                frm1.DatasheetFontName = strFontName
              End If
         End If
      Next ctl
      DoCmd.Close acForm, frm.Name, acSaveYes
  Next frm
  ' Apply Default Font for All Reports
    For Each rpt In dbs.AllReports
        DoCmd.OpenReport rpt.Name, acDesign
        Set rpt1 = Reports(rpt.Name)
          For Each ctl In rpt1.Controls
            If ctl.ControlType = acComboBox Or _
               ctl.ControlType = acCommandButton Or _
               ctl.ControlType = acLabel Or _
               ctl.ControlType = acListBox Or _
               ctl.ControlType = acOptionButton Or _
               ctl.ControlType = acTextBox Then
               ctl.FontName = strFontName
               'Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name
                  If rpt1.DefaultView = 2 Then
                    frm1.DatasheetFontName = strFontName
                  End If
            End If
        Next ctl
        DoCmd.Close acReport, rpt.Name, acSaveYes
    Next rpt

    Set frm = Nothing
    Set rpt = Nothing
    Set dbs = Nothing
    Set frm1 = Nothing
    Set rpt1 = Nothing
    Set ctl = Nothing
    Exit Function

ExitHandler:
   Exit Function
ErrorHandler:
   MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description
   
End Function

 

وهذا التطبيق العملي
 

Change Font.mdb 348 kB · 8 downloads

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

  • Haha 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
5 ساعات مضت, User user said:

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

انا اسف يبدو أنى لم انتبه جيدا لطلبكم واختلط على الامر وظننت انكم تريدون تشغيل الكود الذى أشرتم اليه في طلبكم

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept