منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب

السلام عليكم

كيف ننشئ مخطط دائري

كما في الصورة

http://im33.gulfup.com/OgnRL.jpg

هذا مثال منقول يحتوي على دالة رسم المقطع الدائري

ضع Command وPictureBox ثم ضع هذا الكود

كود :

Option Explicit

 Private Sub Command1_Click()

   Call DrawPiePiece(Picture1, 100, 100, 60, 0.001, 36, QBColor(9), QBColor(9))

   Call DrawPiePiece(Picture1, 100, 100, 60, 36, 55, QBColor(10), QBColor(10))

   Call DrawPiePiece(Picture1, 100, 100, 60, 55, 75, QBColor(11), QBColor(11))

   Call DrawPiePiece(Picture1, 100, 100, 60, 75, 99.999, QBColor(12), QBColor(12))

   Call DrawPiePiece(Picture1, 250, 100, 60, 0.001, 36, vbBlack, QBColor(9))

   Call DrawPiePiece(Picture1, 250, 100, 60, 36, 55, vbBlack, QBColor(10))

   Call DrawPiePiece(Picture1, 250, 100, 60, 55, 75, vbBlack, QBColor(11))

   Call DrawPiePiece(Picture1, 250, 100, 60, 75, 99.999, vbBlack, QBColor(12))

 End Sub

 Public Sub DrawPiePiece(pic As PictureBox, x As Integer, y As Integer, radius As Integer, fStart As Double, fEnd As Double, lineColor As Long, fillColor As Long)

   Const PI As Double = 3.14159265359

   pic.ScaleMode = vbPixels

   Dim CircleEnd As Double

   CircleEnd = -2 * PI

   pic.fillColor = fillColor

   pic.FillStyle = 0

   Dim dStart As Double

   Dim dEnd As Double

   dStart = fStart * (CircleEnd / 100)

   dEnd = fEnd * (CircleEnd / 100)

   pic.Circle (x, y), radius, lineColor, dStart, dEnd

 End Sub

وهذه النتيجة

و كيف نحدد زاوية او مقدار كل قطاع دائري

النسبة المئوية هي اللي باللون الأحمر (وعدلت الدالة عشان تتلافى مشكلة تطابق الصفر وال100 على الدائرة)

[COLOR="#FF0000"]تلاحظ ان الجزء التالي يبدأ من نهاية اللي قبله
[/COLOR]

كود :

Option Explicit

 Private Sub Command1_Click()

   Call DrawPiePiece(Picture1, 100, 100, 60, [color=#ff0000]0[/color], [color=#ff0000]36[/color], QBColor(9), QBColor(9))

   Call DrawPiePiece(Picture1, 100, 100, 60, [color=#ff0000]36[/color], [color=#ff0000]55[/color], QBColor(10), QBColor(10))

   Call DrawPiePiece(Picture1, 100, 100, 60, [color=#ff0000]55[/color], [color=#ff0000]75[/color], QBColor(11), QBColor(11))

   Call DrawPiePiece(Picture1, 100, 100, 60, [color=#ff0000]75[/color], [color=#ff0000]100[/color], QBColor(12), QBColor(12))

   Call DrawPiePiece(Picture1, 250, 100, 60, [color=#ff0000]0[/color], [color=#ff0000]36[/color], vbBlack, QBColor(9))

   Call DrawPiePiece(Picture1, 250, 100, 60, [color=#ff0000]36[/color], [color=#ff0000]55[/color], vbBlack, QBColor(10))

   Call DrawPiePiece(Picture1, 250, 100, 60, [color=#ff0000]55[/color], [color=#ff0000]75[/color], vbBlack, QBColor(11))

   Call DrawPiePiece(Picture1, 250, 100, 60, [color=#ff0000]75[/color], [color=#ff0000]100[/color], vbBlack, QBColor(12))

 End Sub

 Public Sub DrawPiePiece(pic As PictureBox, x As Integer, y As Integer, radius As Integer, [color=#ff0000]fStart [/color]As Double, [color=#ff0000]fEnd [/color]As Double, lineColor As Long, fillColor As Long)

   If fStart=0 Then fStart= 0.001

   If fStart=100 Then fStart= 99.999

   If fEnd=0 Then fEnd= 0.001

   If fEnd=100 Then fEnd= 99.999

   Const PI As Double = 3.14159265359

   pic.ScaleMode = vbPixels

   Dim CircleEnd As Double

   CircleEnd = -2 * PI

   pic.fillColor = fillColor

   pic.FillStyle = 0

   Dim dStart As Double

   Dim dEnd As Double

   dStart = fStart * (CircleEnd / 100)

   dEnd = fEnd * (CircleEnd / 100)

   pic.Circle (x, y), radius, lineColor, dStart, dEnd

 End Sub

شكرا جزيلا بس سؤال أخير اللون الشفاف او بلا لون شو رقمه في QBColor(9)

asto كتب :شكرا جزيلا بس سؤال أخير اللون الشفاف او بلا لون شو رقمه في QBColor(9)

عشان اللون الشفاف قمت بتعديل الدالة (خلي لون التعبئة fillColor يساوي (-1) يعني ناقص واحد)

كود :

Option Explicit

Private Sub Command1_Click()

    Call DrawPiePiece(Picture1, 100, 100, 60, 0, 36, QBColor(9), QBColor(9))

    Call DrawPiePiece(Picture1, 100, 100, 60, 36, 55, QBColor(10), QBColor(10))

    Call DrawPiePiece(Picture1, 100, 100, 60, 55, 75, QBColor(11), [color=#FF0000][b]-1[/b][/color])

    Call DrawPiePiece(Picture1, 100, 100, 60, 75, 100, QBColor(12), QBColor(12))

    Call DrawPiePiece(Picture1, 250, 100, 60, 0, 36, vbBlack, QBColor(9))

    Call DrawPiePiece(Picture1, 250, 100, 60, 36, 55, vbBlack, QBColor(10))

    Call DrawPiePiece(Picture1, 250, 100, 60, 55, 75, vbBlack, [b][color=#FF0000]-1[/color][/b])

    Call DrawPiePiece(Picture1, 250, 100, 60, 75, 100, vbBlack, QBColor(12))

End Sub

Public Sub DrawPiePiece(pic As PictureBox, x As Integer, y As Integer, radius As Integer, fStart As Double, fEnd As Double, lineColor As Long, fillColor As Long)

    If fStart = 0 Then fStart = 0.001

    If fStart = 100 Then fStart = 99.999

    If fEnd = 0 Then fEnd = 0.001

    If fEnd = 100 Then fEnd = 99.999

    Const PI As Double = 3.14159265359

    pic.ScaleMode = vbPixels

    Dim CircleEnd As Double

    CircleEnd = -2 * PI

    If fillColor = -1 Then

        pic.FillStyle = 1

    Else

        pic.FillStyle = 0

        pic.fillColor = fillColor

    End If

    Dim dStart As Double

    Dim dEnd As Double

    dStart = fStart * (CircleEnd / 100)

    dEnd = fEnd * (CircleEnd / 100)

    pic.Circle (x, y), radius, lineColor, dStart, dEnd

End Sub

هل يمكن رسم الشكل على الفورم مباشرة او طريقة اذا ما نقلت عنصرا ما و ليكن تكست بوكس و ضعته فوقها يظهر فوق الصورة

منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب

asto

MSDOS

asto

MSDOS

asto

MSDOS

asto