تاریخ شمسی

[M.T.P]

یک تابع جهت تبدیل تاریخ میلادی به شمسی به زبان vb6

Function MiladiToShamsi(ByVal StrDate As String) As String
    Dim IntArrDay(0 To 1, 1 To 12) As Integer
    Dim IntArrRuz(0 To 1, 1 To 12) As Integer
    Dim IntI, IntChrisToNoruz As Integer
    Dim IntKabiseh, IntLeapYear As Integer
    Dim IntYear, IntMonth, IntDay As Integer
    Dim IntSal, IntMah, IntRuz As Integer
    Dim StrFormat As String
    
    IntArrDay(0, 1) = 31: IntArrDay(0, 2) = 28: IntArrDay(0, 3) = 31: IntArrDay(0, 4) = 30
    IntArrDay(0, 5) = 31: IntArrDay(0, 6) = 30: IntArrDay(0, 7) = 31: IntArrDay(0, 8) = 31
    IntArrDay(0, 9) = 30: IntArrDay(0, 10) = 31: IntArrDay(0, 11) = 30: IntArrDay(0, 12) = 31
    IntArrDay(1, 1) = 31: IntArrDay(1, 2) = 29: IntArrDay(1, 3) = 31: IntArrDay(1, 4) = 30
    IntArrDay(1, 5) = 31: IntArrDay(1, 6) = 30: IntArrDay(1, 7) = 31: IntArrDay(1, 8) = 31
    IntArrDay(1, 9) = 30: IntArrDay(1, 10) = 31: IntArrDay(1, 11) = 30: IntArrDay(1, 12) = 31
    
    IntArrRuz(0, 1) = 31: IntArrRuz(0, 2) = 31: IntArrRuz(0, 3) = 31: IntArrRuz(0, 4) = 31
    IntArrRuz(0, 5) = 31: IntArrRuz(0, 6) = 31: IntArrRuz(0, 7) = 30: IntArrRuz(0, 8) = 30
    IntArrRuz(0, 9) = 30: IntArrRuz(0, 10) = 30: IntArrRuz(0, 11) = 30: IntArrRuz(0, 12) = 29
    IntArrRuz(1, 1) = 31: IntArrRuz(1, 2) = 31: IntArrRuz(1, 3) = 31: IntArrRuz(1, 4) = 31
    IntArrRuz(1, 5) = 31: IntArrRuz(1, 6) = 31: IntArrRuz(1, 7) = 30: IntArrRuz(1, 8) = 30
    IntArrRuz(1, 9) = 30: IntArrRuz(1, 10) = 30: IntArrRuz(1, 11) = 30: IntArrRuz(1, 12) = 30
    
    IntYear = Year(StrDate)
    IntMonth = Month(StrDate)
    IntDay = Day(StrDate)
    
    IntSal = IntYear - 622
    
    If IntYear Mod 4 = 0 Then IntLeapYear = 1 Else IntLeapYear = 0 'Barrasi sale kabisel miladi
    If IntSal Mod 4 = 3 Then IntKabiseh = 1 Else IntKabiseh = 0 'Barrasi sale kabisel Shamsi
    
    IntChrisToNoruz = 79
    
    IntRuz = 0
    IntRuz = IntRuz + IntDay
    For IntI = 1 To IntMonth - 1
      IntRuz = IntRuz + IntArrDay(IntLeapYear, IntI)
    Next IntI
    
    If (IntRuz > IntChrisToNoruz) Then
      IntSal = IntSal + 1
      IntRuz = IntRuz - IntChrisToNoruz
    Else
      For IntMah = 1 To 9
        IntRuz = IntRuz + IntArrRuz(IntKabiseh, IntMah)
      Next IntMah
      If (IntKabiseh = 1) Then
        IntRuz = IntRuz + 11
      Else
        IntRuz = IntRuz + 10
      End If
    End If
    
    IntMah = 1
    While (IntRuz > IntArrRuz(IntKabiseh, IntMah))
     IntRuz = IntRuz - IntArrRuz(IntKabiseh, IntMah)
     IntMah = IntMah + 1
    Wend
    
    StrFormat = CStr(IntSal) & "/" & Format$(IntMah, "00") & "/" & Format$(IntRuz, "00")
    MiladiToShamsi = StrFormat
End Function