مشکلات فارسی و سورس های مربوطه

[Fazaeli]

تابع تبدیل سال میلادی به شمسی

Function Shamsi(Optional date1 As String, Optional SmallDate1 As Boolean) As String

      '=================================================  ===

      Dim d, P, w, mon, mm, ym, u, v, rp, X, i, ys, ms, dm, p1, d1, ds, DateShamsi

      d = Array(20, 19, 20, 20, 21, 21, 22, 22, 22, 22, 21, 21)

      P = Array(11, 12, 10, 12, 11, 11, 10, 10, 10, 9, 10, 10)

      w = Array("یکشنبه","دوشنبه","سه شنبه","چهارشنبه","پنج شنبه","جمعه","شنبه")

      

      If SmallDate1 = True Then

            mon = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")

      Else

            mon = Array("اسفند", "بهمن", "دی", "آذر", "آبان", "مهر", "شهریور", "مرداد", "تیر", "خرداد", "اردیبهشت", "فروردین")

      End If

      

      If date1 = "" Then date1 = DateAdd("d", 1, Date)

      

      dm = Day(date1)

      mm = Month(date1)

      ym = Year(date1)

      u = 0

      rp = 0

      If (ym Mod 4) = 0 Then u = 1

      If ((ym Mod 100) = 0 And (ym Mod 400) <> 0) Then u = 0

      ys = ym - 622

      X = ys - 22

      X = X Mod 33

      If ((X Mod 4) = 0 And X <> 32) Then rp = 1

      i = Not (rp - 2) + Not (u - 2) * 2

      X = 0

      If (i = 0 And mm = 3) Then X = 1

      If i = 0 Then i = 3

      ms = (9 + mm) Mod 13

      If ms < 10 Then ms = ms + 1

      d1 = d(mm - 1)

      If (i = 1 And mm > 2) Then d1 = d1 - 1

      If (i = 2 And mm < 3) Then d1 = d1 - 1

      p1 = P(mm - 1)

      If (i = 1 And mm > 2) Then p1 = p1 + 1

      If (i = 2 And mm < 4) Then p1 = p1 + 1

      If (dm > 0 And dm <= d1) Then

             ds = p1 + dm + X - 1

          X = 1

      Else

          ds = dm - d1

          ms = ms + 1

          If ms = 13 Then ms = 1

          X = 2

      End If

      If ((mm = 3 And X = 2) Or mm > 3) Then ys = ys + 1

      ds = Str(ds)

      If Len(Trim(ds)) = 1 Then ds = "0" + Trim(ds)

      If SmallDate1 = True Then

'     اگر سال به صورت دو کارکتری میخواهید خط زیر را از حالت کامنت در آورید

'            Shamsi = Mid(Trim(Str(Ys)), 3, 2) + "/" + Trim(mon(Ms - 1)) + "/" + Trim(Ds)

'     اگر سال به صورت چهار کارکتری میخواهید خط زیر را از حالت کامنت در آورید

            Shamsi = Trim(Str(ys)) + "/" + Trim(mon(ms - 1)) + "/" + Trim(ds)

      Else

            Shamsi = w(Weekday(Date) - 1) + " " + Str(ds) + " " + mon(ms - 1) + " " + Str(ys)

      End If

End Function