تبلیغات
پرشین سرخ - سورس تبدیل تاریخ شمسی به میلادی
پرشین سرخ
از همه جا از همه رنگ

آرشیو موضوعی

آرشیو

لینکستان

← آمار وبلاگ

  • کل بازدید :
  • بازدید امروز :
  • بازدید دیروز :
  • بازدید این ماه :
  • بازدید ماه قبل :
  • تعداد نویسندگان :
  • تعداد کل پست ها :
  • آخرین بازدید :
  • آخرین بروز رسانی :

سورس تبدیل تاریخ شمسی به میلادی

Begin VB.Form Form1
    Caption         =   "Form1"
    ClientHeight    =   2790
    ClientLeft      =   60
    ClientTop       =   450
    ClientWidth     =   4770
    LinkTopic       =   "Form1"
    ScaleHeight     =   2790
    ScaleWidth      =   4770
    StartUpPosition =   3  'Windows Default
    Begin VB.TextBox Text6
       Height          =   495
       Left            =   3480
       TabIndex        =   9
       Top             =   1920
       Width           =   615
    End
    Begin VB.TextBox Text5
       Height          =   495
       Left            =   2640
       TabIndex        =   8
       Top             =   1920
       Width           =   615
    End
    Begin VB.TextBox Text4
       Height          =   495
       Left            =   1800
       TabIndex        =   7
       Top             =   1920
       Width           =   615
    End
    Begin VB.TextBox Text3
       Height          =   495
       Left            =   3480
       TabIndex        =   3
       Top             =   960
       Width           =   615
    End
    Begin VB.TextBox Text2
       Height          =   495
       Left            =   2640
       TabIndex        =   2
       Top             =   960
       Width           =   615
    End
    Begin VB.TextBox Text1
       Height          =   495
       Left            =   1800
       TabIndex        =   1
       Top             =   960
       Width           =   615
    End
    Begin VB.CommandButton Command1
       Caption         =   "Tabdil"
       Height          =   495
       Left            =   240
       TabIndex        =   0
       Top             =   1440
       Width           =   1215
    End
    Begin VB.Label Label3
       Alignment       =   2  'Center
       Caption         =   "Day"
       Height          =   495
       Left            =   3480
       TabIndex        =   6
       Top             =   360
       Width           =   615
    End
    Begin VB.Label Label2
       Alignment       =   2  'Center
       Caption         =   "Month"
       Height          =   495
       Left            =   2640
       TabIndex        =   5
       Top             =   360
       Width           =   615
    End
    Begin VB.Label Label1
       Alignment       =   2  'Center
       Caption         =   "Year"
       Height          =   495
       Left            =   1800
       TabIndex        =   4
       Top             =   360
       Width           =   615
    End
 End
 Attribute VB_Name = "Form1"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 Private Sub Command1_Click()
 Dim iShamsiYear As Integer
 Dim iShamsiMonth As Integer
 Dim iShamsiDay As Integer
 
 iShamsiYear = CInt(Text1.Text)
 iShamsiMonth = CInt(Text2.Text)
 iShamsiDay = CInt(Text3.Text)
 
 
 persian_civil iShamsiYear, iShamsiMonth, iShamsiDay
 
 Text4.Text = CStr(iShamsiYear)
 Text5.Text = CStr(iShamsiMonth)
 Text6.Text = CStr(iShamsiDay)
 End Sub
 
 Sub persian_civil(ByRef iYear As Integer, _
                  ByRef iMonth As Integer, _
                  ByRef iDay As Integer)
     Call jdn_civil(persian_jdn(iYear, _
                               iMonth, _
                               iDay), _
                     iYear, iMonth, iDay)
 End Sub
 
 Sub jdn_civil(jdn As Long, _
               ByRef iYear As Integer, _
               ByRef iMonth As Integer, _
               ByRef iDay As Integer)
 
     Dim l As Long
     Dim k As Long
     Dim n As Long
     Dim i As Long
     Dim j As Long
 
     If (jdn > 2299160) Then
         l = jdn + 68569
         n = ((4 * l) \ 146097)
         l = l - ((146097 * n + 3) \ 4)
         i = ((4000 * (l + 1)) \ 1461001)
         l = l - ((1461 * i) \ 4) + 31
         j = ((80 * l) \ 2447)
         iDay = l - ((2447 * j) \ 80)
         l = (j \ 11)
         iMonth = j + 2 - 12 * l
         iYear = 100 * (n - 49) + i + l
     Else
         Call jdn_julian(jdn, iYear, iMonth, iDay)
     End If
 
 End Sub
 
 Function persian_jdn(iYear As Integer, _
                      iMonth As Integer, _
                      iDay As Integer) As Long
     Const PERSIAN_EPOCH = 1948321 ' The JDN of 1 Farvardin 1
     Dim epbase As Long
     Dim epyear As Long
     Dim mdays As Long
     If iYear >= 0 Then
         epbase = iYear - 474
     Else
         epbase = iYear - 473
     End If
     epyear = 474 + (epbase Mod 2820)
     If iMonth <= 7 Then
         mdays = (CLng(iMonth) - 1) * 31
     Else
         mdays = (CLng(iMonth) - 1) * 30 + 6
     End If
     persian_jdn = CLng(iDay) _
             + mdays _
             + Fix(((epyear * 682) - 110) / 2816) _
             + (epyear - 1) * 365 _
             + Fix(epbase / 2820) * 1029983 _
             + (PERSIAN_EPOCH - 1)
 End Function
 Sub jdn_julian(jdn As Long, _
                        ByRef iYear As Integer, _
                        ByRef iMonth As Integer, _
                        ByRef iDay As Integer)
     Dim l As Long
     Dim k As Long
     Dim n As Long
     Dim i As Long
     Dim j As Long
 
     j = jdn + 1402
     k = ((j - 1) \ 1461)
     l = j - 1461 * k
     n = ((l - 1) \ 365) - (l \ 1461)
     i = l - 365 * n + 30
     j = ((80 * i) \ 2447)
     iDay = i - ((2447 * j) \ 80)
     i = (j \ 11)
     iMonth = j + 2 - 12 * i
     iYear = 4 * k + n + i - 4716
 
 End Sub

درباره وبلاگ

مدیر وبلاگ : سعید

آخرین پست ها

جستجو

نظرسنجی

  • مطالب وبلاگ را چگونه ارزیابی می کنید ؟







نویسندگان