از این کد می تونید برای تبدیل تاریخ میلادی به شمسی استفاده کنید.
Function Shamsi(Optional ByVal Date1 As String = "", Optional ByVal SmallDate1 As Boolean = False, Optional ByVal Year4Char As Boolean = True) As String
Dim U, Ym, Rp, D, P, Sd, Ls, Ye, I, Mn, Yy, J, Dd As Integer
'Dim d, p As Integer()
Dim w, Mon, Days As String()
Dim T4, T5, T6 As Integer(,)
'd = New Integer() {20, 19, 20, 20, 21, 21, 22, 22, 22, 22, 21, 21}
'p = New Integer() {11, 12, 10, 12, 11, 11, 10, 10, 10, 9, 10, 10}
w = New String() {"یکشنبه", "دوشنبه", "سه شنبه", "چهارشنبه", "پنجشنبه", "جمعه", "شنبه"}
T4 = New Integer(,) {{11, 12, 11, 11}, {12, 13, 12, 12}, _
{11, 11, 10, 11}, {13, 12, 12, 12}, _
{12, 11, 11, 11}, {12, 11, 11, 11}, _
{11, 10, 10, 10}, {11, 10, 10, 10}, _
{11, 10, 10, 10}, {10, 9, 9, 9}, _
{11, 10, 10, 10}, {11, 10, 10, 10}}
T5 = New Integer(,) {{20, 19, 20, 20}, {19, 18, 19, 19}, _
{19, 20, 20, 20}, {19, 20, 20, 20}, _
{20, 21, 21, 21}, {21, 21, 21, 21}, _
{21, 22, 22, 22}, {21, 22, 22, 22}, _
{21, 22, 22, 22}, {21, 22, 22, 22}, _
{20, 21, 21, 21}, {20, 21, 21, 21}}
T6 = New Integer(,) {{10, 11, 12, 1, 2, 3, 4, 5, 6, 7, 8, 9}, _
{11, 12, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10}}
If SmallDate1 = True Then
Mon = New String() {"01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12"}
Else
Mon = New String() {"فروردین", "اردیبهشت", "خرداد", "تیر", "مرداد", "شهریور", "مهر", "آبان", "آذر", "دی", "بهمن", "اسفند"}
End If
If SmallDate1 = True Then
Days = New String() {"01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12", "13", "14", "15", _
"16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31"}
Else
Days = New String() {"یکم", "دوم", "سوم", "چهارم", "پنجم", "ششم", "هفتم", "هشتم", "نهم", "دهم", _
"یازدهم", "دوازدهم", "سیزدهم", "چهاردهم", "پانزدهم", "شانزدهم", "هفدهم", "هجدهم", "نوزدهم", "بیستم", _
"بیست و یکم", "بیست و دوم", "بیست و سوم", "بیست و چهارم", "بیست و پنجم", "بیست و ششم", "بیست و هفتم", _
"بیست و هشتم", "بیست و نهم", "سیم", "سی و یکم"}
End If
If Date1 = "" Then
Date1 = Convert.ToString(Date.Now)
End If
Yy = Convert.ToDateTime(Date1).Year
J = Convert.ToDateTime(Date1).Month
Dd = Convert.ToDateTime(Date1).Day
U = 0
Rp = 0
If KabiseM(Yy) = True Then
U = 1
End If
Ym = Yy - 622
If KabiseS(Ym) = True Then
Rp = 1
End If
If (Rp = 0 And U = 1) Then
I = 1
ElseIf (Rp = 1 And U = 0) Then
I = 2
ElseIf (Rp = 0 And U = 0) Then
I = 3
Else
I = 4
End If
D = T4(J - 1, I - 1)
P = T5(J - 1, I - 1)
If Dd <= P Then
Sd = D + Dd - 1
Mn = T6(0, J - 1)
Ls = 1
Else
Sd = Dd - P
Mn = T6(1, J - 1)
Ls = 2
End If
If (J > 3 Or (Ls = 2 And J = 3)) Then
Ye = Yy - 621
Else
Ye = Yy - 622
End If
'****************************
'****************************
If SmallDate1 = True Then
If Year4Char = True Then
Shamsi = Trim(Str(Ye)) + "/" + Trim(Mon(Mn - 1)) + "/" + Trim(Days(Sd - 1))
Else
Shamsi = Mid(Trim(Str(Ye)), 3, 2) + "/" + Trim(Mon(Mn - 1)) + "/" + Trim(Days(Sd - 1))
End If
Else
If Year4Char = True Then
Shamsi = w(Convert.ToDateTime(Date1).DayOfWeek) + " " + Days(Sd - 1) + " " + Mon(Mn - 1) + " " + Str(Ye)
Else
Shamsi = w(Convert.ToDateTime(Date1).DayOfWeek) + " " + Days(Sd - 1) + " " + Mon(Mn - 1) + " " + Mid(Trim(Str(Ye)), 3, 2)
End If
End If
End Function
Function KabiseS(ByVal Year As Integer) As Boolean
Dim s, kkb, x, w As Integer
s = (Year + 16) \ 33
kkb = s * 33 - 16
If kkb + 1 = Year Then
KabiseS = False
Else
x = (Year + 15) \ 33
w = Year - x - 17
If (w Mod 4) = 0 Then
KabiseS = True
Else
KabiseS = False
End If
End If
End Function
Function KabiseM(ByVal Year As Integer) As Boolean
If (Year Mod 100) = 0 Then
If (Year Mod 400) = 0 Then
KabiseM = True
Else
KabiseM = False
End If
Else
If (Year Mod 4) = 0 Then
KabiseM = True
Else
KabiseM = False
End If
End If
End Function
