هل يمكن عمل مربع بدل الدائرة فى كود الدوائر الحمراء

[الحديثة]

هل يمكن عمل مربع بدل الدائرة فى كود الدوائر الحمراء اى عمل مربع على ربع الدرجة ودائرة على على الدرجة للمجموع

[عبدالله المجرب]

ممكن ذلك

فاذا كنت تستخدم كود الاستاذ خبور فالتعديل سيكون في هذا السطر

Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)

[الحديثة]

انا استخدم هذا الكود

Sub sDrawOval()

If TypeName(Selection) <> "Range" Then Exit Sub

Dim ssRange As Range

Set ssRange = Selection

DrawOvals ssRange, 60, 0.1

End Sub

Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String

Application.Volatile

DrawOvals fRange, MinDegree, MarginRatio

fDrawOval = ""

End Function

Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single)

Dim cCell As Range

Dim shShape As Shape

Dim OvName As String, OvSheet As String

On Error GoTo DR_OVAL_Err

For Each cCell In sRange

OvName = "oval" + cCell.AddressLocal

OvSheet = cCell.Worksheet.Name

If IsExistShape(OvName, OvSheet) Then

'If cCell.Value >= MinDegree Or cCell.Formula = "" Then

If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value <> "Û" And cCell.Value <> "ÛÜ") Then

cCell.Worksheet.Shapes(OvName).Delete

End If

Else

'If cCell.Value < MinDegree And cCell.Formula <> "" Then

If cCell.Value < MinDegree And cCell.Formula <> "" Or (cCell.Value = "Û" Or cCell.Value = "ÛÜ") Then

MrH = OvMargRatio * cCell.Height

MrW = OvMargRatio * cCell.Width

OvalW = cCell.Width - MrW

OvalH = cCell.Height - MrH

Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH)

With shShape

.Name = OvName

.Fill.Transparency = 1#

.Fill.Visible = msoFalse

.Line.ForeColor.RGB = RGB(255, 0, 0)

.Line.Weight = 1#

End With

End If

End If

Next

Set cCell = Nothing

Exit Function

DR_OVAL_Err:

MsgBox Err & " : " & Error

Err.Clear

Resume Next

End Function

Function IsExistShape(ShapeName As String, SheetName As String) As Boolean

Dim shShape As Shape

IsExistShape = False

For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes

If shShape.Name = ShapeName Then

IsExistShape = True

Exit Function

End If

Next shShape

End Function

[عبدالله المجرب]

سيصبح كودك هكذا

====================

Sub sDrawOval()

If TypeName(Selection) "Range" Then Exit Sub

Dim ssRange As Range

Set ssRange = Selection

DrawOvals ssRange, 60, 0.1

End Sub

Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String

Application.Volatile

DrawOvals fRange, MinDegree, MarginRatio

fDrawOval = ""

End Function

Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single)

Dim cCell As Range

Dim shShape As Shape

Dim OvName As String, OvSheet As String

On Error GoTo DR_OVAL_Err

For Each cCell In sRange

OvName = "oval" + cCell.AddressLocal

OvSheet = cCell.Worksheet.Name

If IsExistShape(OvName, OvSheet) Then

'If cCell.Value >= MinDegree Or cCell.Formula = "" Then

If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value "غ" And cCell.Value "غـ") Then

cCell.Worksheet.Shapes(OvName).Delete

End If

Else

'If cCell.Value < MinDegree And cCell.Formula "" Then

If cCell.Value < MinDegree And cCell.Formula "" Or (cCell.Value = "غ" Or cCell.Value = "غـ") Then

MrH = OvMargRatio * cCell.Height

MrW = OvMargRatio * cCell.Width

OvalW = cCell.Width - MrW

OvalH = cCell.Height - MrH

Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeRectangle, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH)

With shShape

.Name = OvName

.Fill.Transparency = 1#

.Fill.Visible = msoFalse

.Line.ForeColor.RGB = RGB(255, 0, 0)

.Line.Weight = 1#

End With

End If

End If

Next

Set cCell = Nothing

Exit Function

DR_OVAL_Err:

MsgBox Err & " : " & Error

Err.Clear

Resume Next

End Function

Function IsExistShape(ShapeName As String, SheetName As String) As Boolean

Dim shShape As Shape

IsExistShape = False

For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes

If shShape.Name = ShapeName Then

IsExistShape = True

Exit Function

End If

Next shShape

End Function

[الحديثة]

بيطلع خطاء فى السطر

If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value "Û" And cCell.Value "ÛÜ") Then

[عبدالله المجرب]

استبدل هذا "Û" ب "غ"

وهذا "ÜÛ" ب "غـ"

[الحديثة]

استاذى عبد الله المجرب

بعد التحية والاحترام

ام اتوصل الى الحل

ولكن اليك المرفك اريد مربع على درجة الترم الثانى اذا كان اقل من 15 درجة ومجموع العربى لو اقل من 40 دائرة

الثالث.rar

[عبدالله المجرب]

السلام عليكم

اليك ملفك وقد اضفت اليه كود الاستاذ خبور للدوائر

وهو الافضل من وجهة نظري

جرب المرفق واعلمني بالنتيجة

الثالث.rar

[الحديثة]

استاذى العزيز

لك منى كل تقدير واحترام

واشكرك على سعة صدرك وعلمك الذى افادنى كثيرا

ولى طلب لو طبقنا هذا على الورقة 1 بحيث يضع على درجة الترم 2 مربع اذا كانت اقل من 15 درجة اما فى مجموع الدرجة للمادة يكون عليها دائرة بمعنى استعمل كود لدرجة ربع الدرجة فى الترم 2 يكون مربع وكود للدرجة المادة اقل من 40 درجة فى العربى يضع دائرة هل هذا ممكن باى طريقة

تم تعديل يونيو 14, 2012 بواسطه الحديثة

[الحديثة]

او ممكن شرح كود الاستاذ خبور اوشرح كود زرع الدالة ولكم جزيل الشكر

[عبدالله المجرب]

السلام عليكم

هل تقصد هكذا

الثالث.rar

[الحديثة]

استاذى العزيز المحترم

اشكرك كثيرا على سعة صدرك واعطاك الله من علمو الكثير

نعم هذا ما اقصدة ولكن لا اريد ان يضع دائرة على الترم 1 ويكون هو المطلوب تماما

وادعو المولى عز وجل ان يعطيك من بحر علمة الفياض

ولك كل شكر وتفدير والاحترام

[دغيدى]

غير هذا السطر من الكود

 Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)

بهذا السطر من الكود

Set V = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)

بعد إذن أخى الفاضل .. أبو احمد

غير السطر الأول بالسطر الثانى لتحصل على مستطيل مستدير الأركان بدلا من قائم الزاوية

[ياسر الحافظ]

ما شاء الله

ماذا نقول " دينمو الموقع + العميـــــــــــــــد " ما شاء الله ماشاء الله

ادامكم الله ... ويسر امركم

وفقكم الله

ابو الحارث

[عبدالله المجرب]

السلام عليكم

تم التعديل

كما تم اضافة المريع الدائري بدل القائم

الثالث.rar

[دغيدى]

أخى وحبيبى / يــــــاسر

عود حميد .. بارك الله فى سورية والسوريين

[الحديثة]

كل الشكر والتقدير والاحترام

الى كل من ساهم فى هذه المشاركة واخص بالذكر الاستاذ عبد الله والاستاذ دغيدى و كل اعضاء ومشرفى هذا المنتدى الكرام الذين تعلمنا منهم الكثير

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

ولكم كل الشكر و التقدير

[دغيدى]

اخى الفاضل / الحديثة

الشكر لك ولكل أعضاء المنتدى الذين يثروا المنتدى بكل ماهو نافع .

[hafez81]

مشكور اخي