طلب تعديل كود دوائر حمراء على الشهادات

**يوسف عطا** · نوفمبر 25, 2012

السلام عليكم

أخوتى الأعزاء

الملف المرفق به كود لوضع الدوائر الحمراء على الشهادات

الملف بإصدارة 2010

وبه الآتى

1. الشاشة تومض 3 مرات مع طبع كل شهادة مما يؤدى إلى تهنيج البرنتر وإلا فيجب أن أطبع الشهادات شيت تلو الآخر مما يعنى أن أضغط 350 مرة على زر الطباعة لطبع 1111 شهادة

2. الأوفيس فى مكان العمل بالمدرسة 2003 والجهاز قد لا يقبل أوفيس 2010

المطلوب

تعديل الكود ليعمل على أوفيس 2003 وفى نفس الوقت محاولة تلافى عملية الوميض بالشاشة عدة مرات مع تغيير الشهادة

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

مع خالص تحياتى

كود دوائر حمراء بالشهادات 2010.rar

**يوسف عطا** · نوفمبر 26, 2012

للرفع رفع الله قدركم فى الجنة وبلغكم مناكم

**أبو حنــــين** · نوفمبر 26, 2012

أخي يوسف جربت الكود على 2003 و هو يعمل بطريقة جيدة

اما بالنسبة للاهتزاز فقد اضفت فقط سطرين و اعتقد انه توقف عن الاهتزاز


Sub Printno_From_To_()

Application.ScreenUpdating = False

Dim i As Integer

For i = Range("G6") To Range("I6") Step 3

If i <= Range("I6") Then

Range("K3") = i

Activewindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True

End If

Next i

Range("K3").Select

Application.ScreenUpdating = True

End Sub

**يوسف عطا** · نوفمبر 26, 2012

السلام عليكم أبو حنين

دام فضلك

ليس هذا هو الكود المقصود يا الغلا

الكود المراد التعديل عليه هو كود الدوائر الحمراء

الموجود فى حدث الشيت وليس فى الموديول

رجاء إعادة النظر فى الملف

تم تعديل نوفمبر 27, 2012 بواسطه يوسف عطا

**يوسف عطا** · نوفمبر 27, 2012

للرفع

رفع الله قدركم

وبلغكم آمـــــــــــــــالكم

وجعل أعمالكم فى موازين حسناتكم

**يوسف عطا** · نوفمبر 28, 2012

للرفع

رفع الله قدركم

وبلغكم آمـــــــــــــــالكم

وجعل أعمالكم فى موازين حسناتكم

**يوسف عطا** · نوفمبر 30, 2012

للرفع

رفع الله قدركم

وبلغكم آمـــــــــــــــالكم

وجعل أعمالكم فى موازين حسناتكم

إخوانى الأعزاء

لو الأمر شديد الصعوبة إخبرونى حتى أبحث فى إتجاه آخر

ولكنى أرى الأمر هين كود يعمل جيداً على إصدارة 2010 ولا يعمل على إصدارة 2003

المطلوب تعديله ليعمل على 2003 وبالتأكيد الأمر سهل لذوى الخبرة من الأساتذة الأجلاء بالمنتدى وهم كثر

كذلك موضوع الوميض عند إستخدام كود الدوائر

أعتقد أن خبراء الأكواد ببساطة سيضيفون سطر ما فى الكود لكى يتوقف الوميض بسهولة كبيرة بالنسبة لهم

وفقكم الله

ياسر خليل أبو البراء · ديسمبر 1, 2012

الأخ الكريم يوسف

حاول توضيح طلبك بتفصيل أكثر

**يوسف عطا** · ديسمبر 1, 2012

الأخ الغالى ياسر بك

المطلوب أن يتم تعديل كود إضافة الدوائر بالملف المرفق بالمشاركة الأولى كالتالى

1. أن يعمل على أوفيس 2003

2. أن يتم منع الوميض الذى يحدث 3 مرات اثناء عمل الكود

ملحوظة الكود المراد تعديله موجود فى حدث الشيت وليس فى الموديول

بس كدة

ياسر خليل أبو البراء · ديسمبر 1, 2012

جرب الكود بهذا الشكل

قمت بإضافة بسيطة...

ممكن أعرف ما هي رسالة الخطأ التي تظهر لك عندما تقوم بتشغيله على أوفيس 2003 لأني بستخدم 2007؟

Private Sub Worksheet_Calculate()

Dim c As Range

Dim MyRng As Range, V As Shape

Dim G As Integer, R As Integer, d As Integer

'================================================

G = 2	  '	ÚãæÏ ÑÞã ÇáÌáæÓ

R = 15	   '	ÕÝ ÇáÏÑÌÇÊ

Set MyRng = Range("e16:p44")  ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ

'================================================

Application.ScreenUpdating = False

Application.EnableEvents = False

'==============ÍÐÝ ÇáÏæÇÆÑ ÇáÓÇÈÞÉ====================

For Each V In ActiveSheet.Shapes

If V.Top = Rows(16).Top + 1 Or V.Top = Rows(30).Top + 1 Or V.Top = Rows(44).Top + 1 Then V.Delete

Next

'================================================

For Each c In MyRng

	If Cells(c.Row, G) = 0 Or Cells(c.Row, G) = "" Then GoTo 1

	If IsNumeric(Cells(R, c.Column)) And Not IsEmpty(Cells(R, c.Column)) And (c.Value < Cells(R, c.Column) Or c.Value = "Û") And c.Value <> "" Then

	Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left + 1, c.Top + 1, c.Width - 2, c.Height - 2)

		V.Fill.Visible = msoFalse

		V.Line.ForeColor.SchemeColor = 10

		V.Line.Weight = 2

		d = d + 1

	End If

1 Next

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

**يوسف عطا** · ديسمبر 2, 2012

للأسف أخى الغالى ياسر بك

لم يظبط معى الملف على أوفيس 2003 رغم أنه شغال على أوفيس 2010

طيب هل ظبط معك على أوفيس 2007 ؟؟

مرفق الملف 2003

دوائر 2003.rar

ياسر خليل أبو البراء · ديسمبر 2, 2012

الملف المرفق لم يتم تحميله جيداً

أرجو إعادة رفعه

تم تعديل ديسمبر 2, 2012 بواسطه YasserKhalil

**يوسف عطا** · ديسمبر 2, 2012

الملف المرفق لم يتم تحميله جيداً

أرجو إعادة رفعه

تفضل أخى الغالى

دوائر 2003.rar

تم تعديل ديسمبر 2, 2012 بواسطه يوسف عطا

حسن الحاوى · ديسمبر 2, 2012

أستاذ / يوسف عطا

التعديل الجديد الذى قمت به على شهادتكم والذى يتميز بسرعة التنفيذ ( رسم الدوائر )باستخدام الكود الخاص بى بعد إختصاره

وأيضاً سرعة الحذف باستخدام كود أستاذ خبور خير بعد تعديله ليتناسب مع كود رسم الدوائر الخاص بى

أنظر المرفقات

يا ريت تقولى رأيك

شهادات1.rar

حسن الحاوى · ديسمبر 2, 2012

هناك تعديل بسيط فى أول الكود ممكن حضرتك تلاحظه فى أول 3 أسطر

Sub إضافة_الدوائروالمربعات_شهادات2_نقر()

Application.ScreenUpdating = False

Application.EnableEvents = False

حذف_الدوائر_والمربعات_شهادات2_نقر

إضافة_الدوائر_شهادات2_نقر

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

Sub إضافة_الدوائر_شهادات2_نقر()

'

' إضافة_الدوائر_شهادات2_نقر ماكرو

' الماكرو مسجل ‎17/05/2012 بواسطة ‎مجدى الحاوى

'

Activewindow.Zoom = 100

ActiveSheet.Unprotect

'=====================================================

' رسم شكل بيضاوى

ActiveSheet.Shapes.AddShape(msoShapeOval, 0.75, 0.75, 36, 17).Select

'تنسيق الشكل البيضاوى

Selection.ShapeRange.Fill.Solid

Selection.ShapeRange.Fill.Transparency = 0#

Selection.ShapeRange.Line.Weight = 1.5

Selection.ShapeRange.Line.DashStyle = msoLineSolid

Selection.ShapeRange.Line.Style = msoLineSingle

Selection.ShapeRange.Line.Transparency = 0#

Selection.ShapeRange.Line.Visible = msoTrue

Selection.ShapeRange.Line.ForeColor.SchemeColor = 64

Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

Selection.ShapeRange.Fill.Visible = msoFalse

Selection.Name = "oval 1"

'=====================================================

'تحديد لشكل البيضاوى وقصه المسمى oval 1

ActiveSheet.Shapes.Range(Array("oval 1")).Select

Selection.Cut

'=====================================================

' الشهادة الأولى

Dim R As Integer

'تحديد أول خلية فى مادة اللغة العربية

R = 15

Range("E16").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

' الشهادةالثانية

'تحديد أول خلية فى مادة اللغة العربية

R = 29

Range("E30").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

'الشهادة الثالثة

'تحديد أول خلية فى مادة اللغة العربية

R = 43

Range("E44").Select

For i = 1 To 9

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'تحديد أول خلية فى مادة التربية الدينية

ActiveCell.Offset(0, 2).Select

If ActiveCell.Value < Cells(R, ActiveCell.Column) Or ActiveCell.Value = "غ" Then

ActiveSheet.Paste

End If

ActiveCell.Offset(0, 1).Select

'=====================================================

'اللغة الفرنسية ليست مادة نجاح ورسوب وبالتالى لا يتم رسم دوائر لها

'=====================================================

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowSorting:=True, AllowFiltering:=True

'

End Sub

Sub حذف_الدوائر_والمربعات_شهادات2_نقر()

'

' كود الحذف

ActiveSheet.Unprotect

'=====================================================

' حذف الدوائر

Dim V As Shape

For Each V In ActiveSheet.Shapes

If V.Name = "oval 1" Then V.Delete

, AllowSorting:=True, AllowFiltering:=True

End Sub

**يوسف عطا** · ديسمبر 2, 2012

بالفعل التعديل إختصر الكود وجعله أكثر سلاسة

ولكنه لا زال لا يقوم بالعمل أوتوماتيكياً

من حيث إضافة وإزالة الدوائر تلقائياً أثناء إستعراض الشهادات

خاصة مع إستخدام أسهم التقديم والتأخير للشهادات صفحة صفحة

وجارى عمل كود لوضع الدوائر بالشهادة بمساعدة خاصية التحقق من الصحة فى أوفيس 2003

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

حسن الحاوى · ديسمبر 2, 2012

أنظر إلى هذا التعديل ستجد ما تريد

شهادات2.rar

**يوسف عطا** · ديسمبر 3, 2012

أخى حسن

أنظر إلى هذا الملف

التنقل بين الشهادات بالكتابة فى الخلية الزرقاء وليس بالأسهم والقوائم المنسدلة

ولكن عند الطبع تظهر الدوائر تلقائياً بطريقة مظبوطة سواء طبع كل الشهادات أو طبع شهادات معينة أو صفحات محددة

والمشكلة التى تواجهنى حالياً هى

1. الكود لا يعمل عند نقله لملفى الاصلى ولا أعرف السبب

2. الكود متعارض مع كود أخر فى نفس الشيت عند تفعيل الكودين

3. لازلت لم أتوصل لطريقة لوضع المربع حول درجة الطالب الراسب حكماً فى مادة ما علماً بأننى أفكر فى وضع معادلة لجلب الدرجة الأقل من 15 فى تحريرى 2 بترتيب المواد فى جدول مجاور لجدول الدرجات

فكرة الكود وضع دائرة عند عدم التحقق من صحة الرقم الموجود فى خلية الدرجة

دوائرشهادات.rar

تم تعديل ديسمبر 3, 2012 بواسطه يوسف عطا

**الـعيدروس** · ديسمبر 19, 2012

السلام عليكم

جرب المرفق وهو ورقة 13 فقط

Ali_Sh_2007.rar

Ali_Sh_2003.rar

تم تعديل ديسمبر 19, 2012 بواسطه عباد

**يوسف عطا** · ديسمبر 19, 2012

الف شكر يا أخى الغالى جارى تحميل الملف

**يوسف عطا** · ديسمبر 19, 2012

للأسف يا أخى الغالى لم يعمل الملفان كلاهما لم يعملان معى

**الـعيدروس** · ديسمبر 19, 2012

الملف المرسل من قبلك على الرابط

لم يعمل معي فعدلت على الأكواد عدة محاولات

حتى عمل معي على الملف الأساسي

مالأوفيس المستخدم لديك ؟

**يوسف عطا** · ديسمبر 19, 2012

أوفيس 2003

الملفان مرة أخرى مرفقان هنا

الملف الكبير مضغوط مرتين ليمكن رفعه بالمنتدى

كنترول 2 2013.rar

دوائر الشهادات نهائى.rar

**الـعيدروس** · ديسمبر 20, 2012

انا مسحت اوفيس 2007

ونصبت اوفيس 2003

وجربت الكود يعمل 100%

جرب المرفقات

كنترول 2_A - 2013.part01.rar

**يوسف عطا** · ديسمبر 21, 2012

بعد تنزيل الملف وفك الضغط عنه تظهرلى رسالة أن الجزء الثانى من الملف مفقود

رجاء إعادة الرفع أو إرساله على الإيميل

الف شكر

تسجيل الدخول

طلب تعديل كود دوائر حمراء على الشهادات

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

يوسف عطا

يوسف عطا

أبو حنــــين

يوسف عطا

يوسف عطا

يوسف عطا

يوسف عطا

ياسر خليل أبو البراء

يوسف عطا

ياسر خليل أبو البراء

يوسف عطا

ياسر خليل أبو البراء

يوسف عطا

حسن الحاوى

حسن الحاوى

يوسف عطا

حسن الحاوى

يوسف عطا

الـعيدروس

يوسف عطا

يوسف عطا

الـعيدروس

يوسف عطا

الـعيدروس

يوسف عطا

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information