کسی جواب نداد خودم به چیزی نوشتم شاید به درد بقیه بخوره البته حرفه ای نیست ولی کار می کنه
روز و ماه و سال رو جداگانه از سیستم می گیره و جداگانه به شمسی تبدیل می کنه خروجی هاشم 4 تاس:
sy سال رو به شمسی میده بیرون
sd روز رو به شمسی میده
sm ماه رو به عدد شمسی میده
monthname نام ماه شمسی رو میده
Dim dt As Date
dt = DateString()
Dim mm, my, md, w, r, sy, q, l, sm, d, sd, s As String
Dim monthname As String
mm = Month(dt)
my = Year(dt)
md = Day(dt)
mm = Month(dt)
my = Year(dt)
md = Day(dt)
Select Case mm
Case 1
r = md
Case 2
r = md + 31
Case 3
r = md + 28 + 31
Case 4
r = md + 28 + (31 * 2)
Case 5
r = md + 28 + (31 * 2) + 30
Case 6
r = md + 28 + (31 * 3) + 30
Case 7
r = md + 28 + (31 * 3) + (30 * 2)
Case 8
r = md + 28 + (31 * 4) + (30 * 2)
Case 9
r = md + 28 + (31 * 5) + (30 * 2)
Case 10
r = md + 28 + (31 * 5) + (30 * 3)
Case 11
r = md + 28 + (31 * 6) + (30 * 3)
Case 12
r = md + 28 + (31 * 6) + (30 * 4)
End Select
If r > 79 Then
sy = my - 621
r = r - 79
If r < 186 Then
q = r Mod 31
l = Fix(r / 31)
sm = 0
d = 31
Else
r = r - 186
q = r Mod 30
l = Fix(r / 30)
sm = 6
d = 30
End If
If q = 0 Then
sm = sm + l
sd = d
Else
sm = sm + 1 + l
sd = q
End If
Else
sy = my - 622
s = sy - 1
If s Mod 4 = 0 And s Mod 100 = 0 Then
w = 11
ElseIf s Mod 400 = 0 Then
w = 11
Else
w = 10
End If
r = r + w
q = r Mod 30
l = Fix(r / 30)
If q = 0 Then
sm = l + 9
sd = 30
Else
sm = l + 10
sd = q
End If
End If
Select Case sm
Case 1
monthname = "فروردین"
Case 2
monthname = "اردیبهشت"
Case 3
monthname = "خرداد"
Case 4
monthname = "تیر"
Case 5
monthname = "مرداد"
Case 6
monthname = "شهریور"
Case 7
monthname = "مهر"
Case 8
monthname = "آبان"
Case 9
monthname = "آذر"
Case 10
monthname = "دی"
Case 11
monthname = "بهمن"
Case 12
monthname = "اسفند"
End Select
