تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
[سؤال] رسم بوصلة لمعرفة اتجاه القبلة ة
#1
السلام عليكم ورحمة اللّٰه
هل يمكن رسم بوصلة مرقمة من صفر الى 360 درجة 
 مع عقرب ساعة يشير الى اتجا القبلة .
مثال يوجد في لابل الرقم 123° انطلاقا من الشمال اذي يمثل صفر.
كيف يمكننا رسم خط احمر يمثل الاتجاه 123 .
البرنامج يعمل و يحسب اتجاه القبلة بالدرجات و المسافة بالكم بين النقطة أ و ب انطلاق ا
من خطي العرض و الطول لكل من الكعبة المشرفة و البلاد المختارة .
مع الشكر مسبقا....

سيتم رفع المشروع في قسم الامثلة حال الانتهاء منه ....
الرد
تم الشكر بواسطة:
#2
هل تريد رسم البوصلة مباشرة علي الفورم أم تريدها في كونترول منفصل؟
الرد
تم الشكر بواسطة:
#3
اولا اشكر لك اهتما مك بالموضوع...
الافضل عندي ان امكن ذلك ان تكون في كنترول منفصل
مع الشكر الجزيل ....
الرد
تم الشكر بواسطة:
#4
الكود التالي سيوضح لك فكرة رسم البوصلة
انا حصلت علي الكود من النت
و واضح ان من كتب الكود ليس محترف جرافكس لكن ممكن إعادة صياعة الكود لكي يظهر بشكل احترافي
PHP كود :
Public Class Form1
    Private Sub Form1_Load
(sender As ObjectAs EventArgsHandles MyBase.Load

    End Sub


    Protected Overrides Sub OnPaint
(As PaintEventArgs)
 
       MyBase.OnPaint(e)

 
       e.Graphics.DrawImage(DrawCompass(175280180, New Size(200200)), New Point(00))
 
   End Sub

    Public 
Function DrawCompass(degree As Doublepitch As Doublemaxpitch As Doubletilt As Doublemaxtilt As DoubleAs Size) As Bitmap


        Dim maxRadius 
As Double = If(s.Width s.Heights.Height 2s.Width 2)

 
       Dim sizeMultiplier As Double maxRadius 200
        Dim relativepitch 
As Double pitch maxpitch
        Dim relativetilt 
As Double tilt maxtilt

        Dim result 
As Bitmap Nothing
        Dim drawBrushWhite 
As New SolidBrush(Color.FromArgb(255244255))
 
       Dim drawBrushRed As New SolidBrush(Color.FromArgb(24025500))
 
       Dim drawBrushOrange As New SolidBrush(Color.FromArgb(2402551500))
 
       Dim drawBrushBlue As New SolidBrush(Color.FromArgb(1000250255))
 
       Dim drawBrushWhiteGrey As New SolidBrush(Color.FromArgb(20255255255))

 
       Dim outerradius As Double = (((maxRadius sizeMultiplier 60) / maxRadius) * maxRadius)
 
       Dim innerradius As Double = (((maxRadius sizeMultiplier 90) / maxRadius) * maxRadius)
 
       Dim degreeRadius As Double outerradius 37 sizeMultiplier
        Dim dirRadius 
As Double innerradius 30 sizeMultiplier
        Dim TriRadius 
As Double outerradius 20 sizeMultiplier
        Dim PitchTiltRadius 
As Double innerradius 0.55
        If s
.Width s.Height 0 Then
            result 
= New Bitmap(s.Widths.Height)
 
           Using font2 As New Font("Arial"CSng(16 sizeMultiplier))
 
               Using font1 As New Font("Arial"CSng(14 sizeMultiplier))
 
                   Using penblue As New Pen(Color.FromArgb(1000250255), (If(CInt(Math.Truncate(sizeMultiplier)) < 44CInt(Math.Truncate(sizeMultiplier)))))
 
                       Using penorange As New Pen(Color.FromArgb(2551500), (If(CInt(Math.Truncate(sizeMultiplier)) < 11CInt(Math.Truncate(sizeMultiplier)))))
 
                           Using penred As New Pen(Color.FromArgb(25500), (If(CInt(Math.Truncate(sizeMultiplier)) < 11CInt(Math.Truncate(sizeMultiplier)))))

 
                               Using pen1 As New Pen(Color.FromArgb(255255255), CInt(Math.Truncate(sizeMultiplier 4)))

 
                                   Using pen2 As New Pen(Color.FromArgb(255255255), (If(CInt(Math.Truncate(sizeMultiplier)) < 11CInt(Math.Truncate(sizeMultiplier)))))
 
                                       Using pen3 As New Pen(Color.FromArgb(0255255255), (If(CInt(Math.Truncate(sizeMultiplier)) < 11CInt(Math.Truncate(sizeMultiplier)))))
 
                                           Using g As Graphics Graphics.FromImage(result)


 
                                               ' Calculate some image information.
                                                Dim sourcewidth As Double = s.Width
                                                Dim sourceheight As Double = s.Height

                                                Dim xcenterpoint As Integer = CInt(s.Width / 2)
                                                Dim ycenterpoint As Integer = CInt((s.Height / 2))
                                                ' 
maxRadius;
 
                                               Dim pA1 As New Point(xcenterpointycenterpoint CInt(Math.Truncate(sizeMultiplier 45)))
 
                                               Dim pB1 As New Point(xcenterpoint CInt(Math.Truncate(sizeMultiplier 7)), ycenterpoint CInt(Math.Truncate(sizeMultiplier 45)))
 
                                               Dim pC1 As New Point(xcenterpointycenterpoint CInt(Math.Truncate(sizeMultiplier 90)))
 
                                               Dim pB2 As New Point(xcenterpoint CInt(Math.Truncate(sizeMultiplier 7)), ycenterpoint CInt(Math.Truncate(sizeMultiplier 45)))

 
                                               Dim a2 As Point() = New Point() {pA1pB1pC1}
 
                                               Dim a3 As Point() = New Point() {pA1pB2pC1}

 
                                               g.DrawPolygon(penreda2)
 
                                               g.FillPolygon(drawBrushReda2)
 
                                               g.DrawPolygon(penreda3)
 
                                               g.FillPolygon(drawBrushWhitea3)

 
                                               Dim Cos As Double() = New Double(359) {}
 
                                               Dim Sin As Double() = New Double(359) {}

 
                                               'draw centercross
                                                g.DrawLine(pen2, New Point(CInt(Math.Truncate(xcenterpoint - (PitchTiltRadius - sizeMultiplier * 50))), ycenterpoint), New Point(CInt(Math.Truncate(xcenterpoint + (PitchTiltRadius - sizeMultiplier * 50))), ycenterpoint))
                                                g.DrawLine(pen2, New Point(xcenterpoint, CInt(Math.Truncate(ycenterpoint - (PitchTiltRadius - sizeMultiplier * 50)))), New Point(xcenterpoint, CInt(Math.Truncate(ycenterpoint + (PitchTiltRadius - sizeMultiplier * 50)))))

                                                '
draw pitchtiltcross
                                                Dim PitchTiltCenter 
As New Point(CInt(Math.Truncate(xcenterpoint PitchTiltRadius relativetilt)), CInt(Math.Truncate(ycenterpoint PitchTiltRadius relativepitch)))
 
                                               Dim rad As Integer CInt(Math.Truncate(sizeMultiplier 8))
 
                                               Dim rad2 As Integer CInt(Math.Truncate(sizeMultiplier 25))

 
                                               Dim r As New Rectangle(CInt(PitchTiltCenter.rad2), CInt(PitchTiltCenter.rad2), CInt(rad2 2), CInt(rad2 2))
 
                                               g.DrawEllipse(pen3r)
 
                                               g.FillEllipse(drawBrushWhiteGreyr)
 
                                               g.DrawLine(penorangePitchTiltCenter.radPitchTiltCenter.YPitchTiltCenter.radPitchTiltCenter.Y)
 
                                               g.DrawLine(penorangePitchTiltCenter.XPitchTiltCenter.radPitchTiltCenter.XPitchTiltCenter.rad)

 
                                               'prep here because need before and after for red triangle.
                                                For d As Integer = 0 To 359
                                                    ' 
  map[y] = new long[src.Width];
 
                                                   Dim angleInRadians As Double = ((CDbl(d) + 270.0) - degree) / 180.0F Math.PI
                                                    Cos
(d) = Math.Cos(angleInRadians)
 
                                                   Sin(d) = Math.Sin(angleInRadians)
 
                                               Next

                                                For d 
As Integer 0 To 359


                                                    Dim p1 
As New Point(CInt(Math.Truncate(outerradius Cos(d))) + xcenterpointCInt(Math.Truncate(outerradius Sin(d))) + ycenterpoint)
 
                                                   Dim p2 As New Point(CInt(Math.Truncate(innerradius Cos(d))) + xcenterpointCInt(Math.Truncate(innerradius Sin(d))) + ycenterpoint)

 
                                                   'Draw Degree labels
                                                    If d Mod 30 = 0 Then
                                                        g.DrawLine(penblue, p1, p2)

                                                        Dim p3 As New Point(CInt(Math.Truncate(degreeRadius * Cos(d))) + xcenterpoint, CInt(Math.Truncate(degreeRadius * Sin(d))) + ycenterpoint)
                                                        Dim s1 As SizeF = g.MeasureString(d.ToString(), font1)
                                                        p3.X = p3.X - CInt(s1.Width / 2)
                                                        p3.Y = p3.Y - CInt(s1.Height / 2)

                                                        g.DrawString(d.ToString(), font1, drawBrushWhite, p3)
                                                        Dim pA As New Point(CInt(Math.Truncate(TriRadius * Cos(d))) + xcenterpoint, CInt(Math.Truncate(TriRadius * Sin(d))) + ycenterpoint)

                                                        Dim width As Integer = CInt(Math.Truncate(sizeMultiplier * 3))
                                                        Dim dp As Integer = If(d + width > 359, d + width - 360, d + width)
                                                        Dim dm As Integer = If(d - width < 0, d - width + 360, d - width)

                                                        Dim pB As New Point(CInt(Math.Truncate((TriRadius - (15 * sizeMultiplier)) * Cos(dm))) + xcenterpoint, CInt(Math.Truncate((TriRadius - (15 * sizeMultiplier)) * Sin(dm))) + ycenterpoint)
                                                        Dim pC As New Point(CInt(Math.Truncate((TriRadius - (15 * sizeMultiplier)) * Cos(dp))) + xcenterpoint, CInt(Math.Truncate((TriRadius - (15 * sizeMultiplier)) * Sin(dp))) + ycenterpoint)

                                                        Dim p As Pen = penblue
                                                        Dim b As Brush = drawBrushBlue
                                                        If d = 0 Then
                                                            p = penred
                                                            b = drawBrushRed
                                                        End If
                                                        Dim a As Point() = New Point() {pA, pB, pC}

                                                        g.DrawPolygon(p, a)
                                                        g.FillPolygon(b, a)
                                                    ElseIf d Mod 2 = 0 Then
                                                        g.DrawLine(pen2, p1, p2)
                                                    End If

                                                    '
draw N,E,S,W
                                                    If d Mod 90 
0 Then
                                                        Dim dir 
As String = (If(0"N", (If(90"E", (If(180"S""W"))))))
 
                                                       Dim p4 As New Point(CInt(Math.Truncate(dirRadius Cos(d))) + xcenterpointCInt(Math.Truncate(dirRadius Sin(d))) + ycenterpoint)
 
                                                       Dim s2 As SizeF g.MeasureString(dirfont1)
 
                                                       p4.p4.CInt(s2.Width 2)
 
                                                       p4.p4.CInt(s2.Height 2)



 
                                                       g.DrawString(dirfont1, If(0drawBrushReddrawBrushBlue), p4)

 
                                                   End If
 
                                               Next



                                                Dim deg 
As [String] = Math.Round(degree2).ToString("0.00") & "°"
 
                                               Dim s3 As SizeF g.MeasureString(degfont1)


 
                                               g.DrawString(degfont2drawBrushOrange, New Point(xcenterpoint CInt(s3.Width 2), ycenterpoint CInt(Math.Truncate(sizeMultiplier 40))))
 
                                           End Using
                                        End Using
                                    End Using
                                End Using
                            End Using
                        End Using
                    End Using
                End Using
            End Using
        End 
If
 
       Return result
    End 
Function

End Class 
الرد
تم الشكر بواسطة:
#5
شكراا لك اأخي.....
انظر في الموضوع....
الرد
تم الشكر بواسطة:
#6
السلام عليكم

تفضل هذا الكود  بعد وضع الصورتين التي في المرفقات ضعها في الريسورس Resources
كود :
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
   PictureBox1.Image = GetQiblahCompass(123)
   PictureBox1.SizeMode = PictureBoxSizeMode.Zoom
End Sub

Function GetQiblahCompass(angle As Integer) As Image
   Using b As New Bitmap(My.Resources.Compass.Width, My.Resources.Compass.Height)
       Using g As Graphics = Graphics.FromImage(b)
           g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality
           Dim c As New Point((b.Width / 2), (b.Height / 2))
           g.DrawImage(My.Resources.Compass, New Rectangle(0, 0, b.Width, b.Height))
           Dim x As Double = (c.X - 110) * Math.Cos(Math.PI * (angle - 90) / 180.0) + c.X
           Dim y As Double = (c.Y - 110) * Math.Sin(Math.PI * (angle - 90) / 180.0) + c.Y
           Dim p As New Pen(Color.FromArgb(180, Color.Brown), 48)
           p.EndCap = Drawing2D.LineCap.ArrowAnchor
           g.DrawLine(p, New Point(c.X, c.Y), New Point(x, y))
           g.DrawImage(My.Resources.kaba, New Rectangle(c.X - 64, c.Y - 64, 128, 128))
           Return b.Clone
       End Using
   End Using
End Function

هذه النتيجة


الملفات المرفقة
.rar   Resources.rar (الحجم : 851.73 ك ب / التحميلات : 17)
الرد
تم الشكر بواسطة: الشاكي لله
#7
صراحة أروع من الروعة ....... يعجز لساني عن الشكر .....
جعلها الله في ميزان حسناتك......
الرد
تم الشكر بواسطة:


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  اريد كود لمعرفة نوع النظام المثبت علي الجهاز اذا كان XP or 7 or 8 ؟ DanyGhost2010 7 185 28-12-17, 08:41 PM
آخر رد: عبد العزيز البسكري
  أريد كود لمعرفة عدد برتشنات الجهاز ؟ DanyGhost2010 4 132 28-12-17, 08:16 PM
آخر رد: عبد العزيز البسكري
  [VB.NET] مساعدة مع داتاجريد لمعرفة الكمية المتوفرة 0theghost0 4 228 29-08-17, 01:21 AM
آخر رد: حريف برمجة
  [سؤال] اريد كود لمعرفة الانترنت متصل ام لا Mina Botros 9 385 16-07-17, 02:55 PM
آخر رد: Mina Botros
  مشكلة في اتجاه label تناسيم 0 195 12-07-17, 10:30 AM
آخر رد: تناسيم
  اتجاه ال label تناسيم 2 233 15-06-17, 12:55 PM
آخر رد: تناسيم
  كود لمعرفة أسماء المجلدات المعمول عليها share على الشبكة maayahsoft 1 171 04-06-17, 08:04 PM
آخر رد: maayahsoft
  [سؤال] كيف يتم فحص جهاز العميل لمعرفة هل مشغل الفلاش منصب عليه أم لا ؟ السندبااد 2 510 22-08-16, 04:25 PM
آخر رد: السندبااد
  كود لمعرفة الرقم الفريد الخاص بالهارديسك Hard disk mohamed salah bashir 5 987 10-08-16, 01:21 AM
آخر رد: أسامة السالمي
  [سؤال] هل أستطيع تغيير اتجاه أعمدة الداتا قريد فيو؟! أسامة السالمي 5 474 27-07-16, 01:05 PM
آخر رد: طالب 22

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم