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

[850725115]

:لبخند:با سلام

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

لطفا اگه کسی سورس داره یا فرمولشو بلده برام بزاره ممنون میشم.:لبخند:

[xxxxx_xxxxx]

سلام
از Shamsi.dll استفاده كنيد. كافيه جستجو كنيد خيلي زياد پيدا ميشه. فايل helpش هم يادمه قبلا ها گذاشتم تو سايت.
موفق باشيد/

[850725115]

ممنون ولی من برنامش رو میخوام dll دارم

[Morteza_Nooh]

یک ماژول به فرم خود بیفزایید و کد های زیر را در آن Paste کنید . این کد تاریخ میلادی را به شمسی تبدیل می کند.

Function TarikhShamsi(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("1 shanbe", "2 shanbe", "3 shanbe", "4 shanbe", "5 shanbe", "jome", "shanbe")

If SmallDate1 = True Then
mon = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
Else
mon = Array("farvardin", "ordibehesht", "khordad", "tir", "mordad", "shahrivar", "mehr", "aban", "azar", "dey", "bahman", "esfand")
End If

If date1 = "" Then date1 = 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
If SmallDate1 = True Then
' ??? ??? ?? ???? ???? ???????? ???????? ?? ??? ?? ?? ???? ????? ?? ?????
' TarikhShamsi = Trim(Str(Ys)) + "/" + Trim(mon(Ms - 1)) + "/" + Trim(Str(Ds))
TarikhShamsi = Mid(Trim(Str(Ys)), 3, 2) + "/" + Trim(mon(Ms - 1)) + "/" + Trim(Str(Ds))
Else
TarikhShamsi = w(Weekday(Date) - 1) + " " + Str(Ds) + " " + mon(Ms - 1) + " " + Str(Ys)
End If
End Function
Function MthGetdateMilady(YY_MM_DD As String) As String
'<---------????? ????? ???? ?? ??????----------
'--- ??? ??????? ? ?? ???? (??/? ?/? ?)--- ?????--------
'--- ?? ??????? ?? ???? (??/? ?/? ? ? ?)---- ????? ----
Dim i, sh_yy As Integer, sh_mm As Integer, sh_dd As Integer
Dim md_yy As Integer, md_dd As Integer, md_mm As Integer, t_date As Single
Dim md_yy1 As String, md_dd1 As String, md_mm1 As String
Dim md_mon(12) As Integer, sh_mon(12) As Integer, md_date As String, t_mm As Integer, t_day As Single
If Len(YY_MM_DD) <> 8 Then
MsgBox "??? - - - ????? ?? ????? ???/???/??? ???? ??????"
Exit Function
End If
YY_MM_DD = "13" + Mid(YY_MM_DD, 1, 8)
sh_yy = Val(Mid(YY_MM_DD, 1, 4))
sh_mm = Val(Mid(YY_MM_DD, 6, 2))
sh_dd = Val(Mid(YY_MM_DD, 9, 2))
If sh_yy < 1300 Then
MsgBox ("??? - - - ??? ?? ???? ???? ??????")
End If
If sh_mm < 1 Or sh_mm > 12 Then
MsgBox ("mah - - - bayad beyne 1 ta 12 bashe")
End If
md_mon(1) = 31
md_mon(2) = 28
md_mon(3) = 31
md_mon(4) = 30
md_mon(5) = 31
md_mon(6) = 30
md_mon(7) = 31
md_mon(8) = 31
md_mon(9) = 30
md_mon(10) = 31
md_mon(11) = 30
md_mon(12) = 31
sh_mon(1) = 31
sh_mon(2) = 31
sh_mon(3) = 31
sh_mon(4) = 31
sh_mon(5) = 31
sh_mon(6) = 31
sh_mon(7) = 30
sh_mon(8) = 30
sh_mon(9) = 30
sh_mon(10) = 30
sh_mon(11) = 30
sh_mon(12) = 29
t_mm = 0
md_mm = 1
t_date = (226898 - 154) / 365
md_yy = Int(t_date) + sh_yy
If (sh_yy Mod 4) = 3 Then
sh_mon(12) = sh_mon(12) + 1
md_mon(2) = md_mon(2) + 1
End If
If sh_dd > sh_mon(sh_mm) Or sh_dd < 1 Then
MsgBox ("xxxxxxxxx1")
End If
For i = 1 To sh_mm - 1
t_mm = t_mm + sh_mon(i)
Next
t_day = ((t_date - Int(t_date)) * 365) + t_mm + sh_dd
i = 1
Do While t_day > md_mon(i)
t_day = t_day - md_mon(i)
md_mm = md_mm + 1
i = i + 1
If i = 13 Then
If Int(t_day) <> 0 Then
i = 1
md_mm = 1
md_yy = md_yy + 1
If md_mon(2) = 29 Then
md_mon(2) = 28
End If
If (md_yy Mod 4) = 0 Then
md_mon(2) = 29
End If
Else
md_mm = 12
t_day = md_mon(12)
Exit Do
End If
End If
Loop
If Int(t_day) = 0 Then
md_mm = md_mm - 1
t_day = md_mon(md_mm)
End If
md_dd = t_day
md_dd1 = Str(md_dd)
md_mm1 = Str(md_mm)
md_yy1 = Str(md_yy)
If Val(md_dd1) < 10 Then
md_dd1 = "0" + Trim(md_dd1)
End If
If Val(md_mm1) < 10 Then
md_mm1 = "0" + Trim(md_mm1)
End If

MthGetdateMilady = Trim(md_yy1) + "/" + Trim(md_mm1) + "/" + Trim(md_dd1)
End Function

[online_mansoor2007]

سلام

کامپوننت های زیادی برای این کار وجود داره . تو گوگل یه سرچ بزنید چیزای خیلی زیادی بدست میارید

[barname_majid]

Public mydate As Date
mydate = Year(Date) & "/" & Month(Date) & "/" & Day(Date)
ints = Val(Mid$((Form1.mydate), 1, 4))
intm = Val(Mid$((Form1.mydate), 6, 2))
intd = Val(Mid$((Form1.mydate), 9, 2))
bytkabise = 0
If (ints - 1992) Mod 4 = 0 Then bytkabise = 1
intyyyy = ints - 621
Select Case intm
Case 1: rooz = 0
Case 2: rooz = 31
Case 3: rooz = 59 + bytkabise
Case 4: rooz = 90 + bytkabise
Case 5: rooz = 120 + bytkabise
Case 6: rooz = 151 + bytkabise
Case 7: rooz = 181 + bytkabise
Case 8: rooz = 212 + bytkabise
Case 9: rooz = 243 + bytkabise
Case 10: rooz = 273 + bytkabise
Case 11: rooz = 304 + bytkabise
Case 12: rooz = 334 + bytkabise
End Select
intd = intd + rooz
If intd < 80 Then intyyyy = intyyyy - 1
a = 0
If ((ints - 1) Mod 4) = 0 Then a = 1
If intd < (21 - a) Then
intm = 10
intd = intd + 10 + a
ElseIf intd < (51 - a) Then
intm = 11
intd = intd - 20 + a
ElseIf intd < 80 Then
intm = 12
intd = intd - 50 + a
ElseIf intd < 111 Then
intm = 1
intd = intd - 79
ElseIf intd < 142 Then
intm = 2
intd = intd - 110
ElseIf intd < 173 Then
intm = 3
intd = intd - 141
ElseIf intd < 204 Then
intm = 4
intd = intd - 172
ElseIf intd < 235 Then
intm = 5
intd = intd - 203
ElseIf intd < 266 Then
intm = 6
intd = intd - 234
ElseIf intd < 296 Then
intm = 7
intd = intd - 265
ElseIf intd < 326 Then
intm = 8
intd = intd - 295 - bytkabise
ElseIf intd < 356 Then
intm = 9
intd = intd - 325
ElseIf intd < 370 Then
intm = 10
intd = intd - 355
End If
s = Trim$(Str$(intyyyy))
If intm > 9 Then
m = Trim$(Str$(intm))
Else
m = "0" + Trim$(Str$(intm))
End If
If intd > 9 Then
d = Trim$(Str$(intd))
Else
d = "0" + Trim$(Str$(intd))
End If
Label2.Caption = Trim$(s + "/" + Trim$(m) + "/" + Trim$(d))سلام دوست عزيز اين بهترين و ساده ترين كد_اگه مشكلي داشتي تماس بگير 09155228482

[ƒxmahdi]

نمونه برنامه کامل
اگر در هنگام اجراء خطا داد dll را به برنامه باید اضافه کنی
موفق باش