RE: تبديل تاريخ
سلام
اين تابع ها را ببين حال كن همه چي هست:
اين كد رو تو يه Module بريز:
Public Function dm(ns As String)
Dim nd As Long, y As Long
Dim m As Integer, mms As Variant
Dim i As Long, nk As Long, yl As Long, sy As Long
Dim k As Integer, d As Integer
nd = Val(ns)
If nd > 0 Then
Do
If i Mod 4 = 0 Then
yl = 366
nk = nk + 1
Else
yl = 365
End If
i = i + 1
sy = sy + yl
If nd <= sy Then Exit Do
Loop
y = i - 1
If y Mod 4 = 0 Then
mms = Array(31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366)
nk = nk - 1
Else
mms = Array(31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365)
End If
nd = nd - (y * 365 + nk)
For m = 1 To 12
If nd <= mms(m - 1) Then Exit For
Next
If m > 1 Then k = mms(m - 2)
d = nd - k
dm = y & "/" & m & "/" & d
Else
dm = "Invalid number"
End If
End Function
Function ds(ns As String)
Dim nd As Long, y As Long
Dim m As Integer, mms As Variant
Dim i As Long, nk As Long, yl As Long, sy As Long
Dim k As Integer, d As Integer
nd = Val(ns)
If nd > 0 Then
Do
If (i + 1) Mod 4 = 0 Then
yl = 366
nk = nk + 1
Else
yl = 365
End If
i = i + 1
sy = sy + yl
If nd <= sy Then Exit Do
Loop
y = i - 1
If (y + 1) Mod 4 = 0 Then
mms = Array(31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336, 366)
nk = nk - 1
Else
mms = Array(31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336, 365)
End If
nd = nd - (y * 365 + nk)
For m = 1 To 12
If nd <= mms(m - 1) Then Exit For
Next
If m > 1 Then k = mms(m - 2)
d = nd - k
ds = y & "/" & m & "/" & d
Else
ds = "Invalid Number"
End If
End Function
Public Function ndm(a As String)
Dim ch As Integer, y As Variant, m As Variant, d As Variant
Dim mm As Variant, i As Integer
For i = 1 To Len(a)
If Mid(a, i, 1) = "/" Then
ch = ch + 1
Else
If ch = 0 Then y = y & Mid(a, i, 1)
If ch = 1 Then m = m & Mid(a, i, 1)
If ch = 2 Then d = d & Mid(a, i, 1)
End If
Next
mm = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
If Val(m) < 13 And Val(m) > 0 Then
If y Mod 4 = 0 Then mm(1) = 29
If y < 0 Or d < 1 Or d > Val(mm(m - 1)) Then
ndm = "Invalid date"
Else
If y Mod 4 <> 0 Then mm(1) = 28
If y <> 0 Then ndm = y * 365 + Int((y - 1) / 4) + 1
For i = 1 To m - 1
ndm = ndm + mm(i - 1)
Next
ndm = ndm + d
End If
Else
ndm = "Invalid Date"
End If
End Function
Public Function nds(a As String)
Dim ch As Integer, y As Variant, m As Variant, d As Variant
Dim ms As Variant, i As Integer
For i = 1 To Len(a)
If Mid(a, i, 1) = "/" Then
ch = ch + 1
Else
If ch = 0 Then y = y & Mid(a, i, 1)
If ch = 1 Then m = m & Mid(a, i, 1)
If ch = 2 Then d = d & Mid(a, i, 1)
End If
Next
ms = Array(31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 30)
If Val(m) < 13 And Val(m) > 0 Then
If (y + 1) Mod 4 = 0 Then ms(11) = 30
If y < 0 Or d < 1 Or d > Val(ms(m - 1)) Then
nds = "Invalid date"
Else
If (y + 1) Mod 4 <> 0 Then ms(11) = 29
nds = y * 365 + Int(y / 4)
For i = 1 To m - 1
nds = nds + ms(i - 1)
Next
nds = nds + d
End If
Else
nds = "Invalid date"
End If
End Function
Public Function mtos(a As String)
mtos = ds(Val(ndm(a)) - 226900)
If ndm(a) = "Invalid date" Or mtos = "Invalid date" Then mtos = "Invalid date"
End Function
Public Function stom(a As String)
stom = dm(Val(nds(a)) + 226900)
If nds(a) = "Invalid date" Then stom = "Invalid date"
End Function
Public Function wm(a As String)
Dim nd As Variant, w As Integer
nd = ndm(a)
w = Val(nd) Mod 7
Select Case w
Case 0
wm = "Thursday"
Case 1
wm = "Friday"
Case 2
wm = "Saturday"
Case 3
wm = "Sunday"
Case 4
wm = "Monday"
Case 5
wm = "Tuesday"
Case 6
wm = "wednesday"
End Select
If nd = "Invalid date" Then wm = "Invalid date"
End Function
Public Function ws(a As String)
Dim nd As Variant, w As Integer
nd = nds(a)
w = Val(nd) Mod 7
Select Case w
Case 0
ws = "ÔäÈå"
Case 1
ws = "íß ÔäÈå"
Case 2
ws = "ÏæÔäÈå"
Case 3
ws = "Óå ÔäÈå"
Case 4
ws = "åÇÑ ÔäÈå"
Case 5
ws = "äÌ ÔäÈå"
Case 6
ws = "ÌãÚå"
End Select
If nd = "Invalid date" Then ws "Invalid date"
End Function
End Function
Public Function ndm1()
Dim ch As Integer, y As Variant, m As Variant, d As Variant
Dim mm As Variant, i As Integer
y = Year(Date)
m = Month(Date)
d = Day(Date)
mm = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
If Val(m) < 13 And Val(m) > 0 Then
If y Mod 4 = 0 Then mm(1) = 29
If y < 0 Or d < 1 Or d > Val(mm(m - 1)) Then
ndm1 = "Invalid date"
Else
If y Mod 4 <> 0 Then mm(1) = 28
If y <> 0 Then ndm1 = y * 365 + Int((y - 1) / 4) + 1
For i = 1 To m - 1
ndm1 = ndm1 + mm(i - 1)
Next
ndm1 = ndm1 + d
End If
Else
ndm1 = "Invalid Date"
End If
End Function
Public Function mtos1()
mtos1 = ds1(Val(ndm1) - 226900)
End Function
Private Sub Command1_Click()
Print mtos1
End Sub
Function ds1(ns As String)
Dim nd As Long, y As Long
Dim m As Integer, mms As Variant
Dim i As Long, nk As Long, yl As Long, sy As Long
Dim k As Integer, d As Integer
nd = Val(ns)
If nd > 0 Then
Do
If (i + 1) Mod 4 = 0 Then
yl = 366
nk = nk + 1
Else
yl = 365
End If
i = i + 1
sy = sy + yl
If nd <= sy Then Exit Do
Loop
y = i - 1
If (y + 1) Mod 4 = 0 Then
mms = Array(31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336, 366)
nk = nk - 1
Else
mms = Array(31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336, 365)
End If
nd = nd - (y * 365 + nk)
For m = 1 To 12
If nd <= mms(m - 1) Then Exit For
Next
If m > 1 Then k = mms(m - 2)
d = nd - k
ds1 = y & "." & m & "." & d
Else
ds1 = "Invalid Number"
End If
End Function
حالا تابع ها را معرفي كنم:
dm : اين تابع تعداد روزهاي سپري شده از ابتداي شروع تاريخ ميلادي را مي گيرد و تاريخ ميلادي به صورت y/m/d بر مي گرداند.
ds:اين تابع تعداد روزهاي سپري شده از ابتداي شروع تاريخ شمسي را مي گيرد و تاريخ ميلادي به صورت y/m/d بر مي گرداند.
ndm : اين تابع يك تاريخ به صورت y/m/d مي گيرد و تعداد روزهاي سپري شده از ابتداي شروع تاريخ ميلادي تا تاريخ مورد نظر را بر مي گرداند.
nds : اين تابع يك تاريخ به صورت y/m/d مي گيرد و تعداد روزهاي سپري شده از ابتداي شروع تاريخ شمسي تا تاريخ مورد نظر را بر مي گرداند.
mtos : تاريخ ميلادي را به صورت y/m/d مي گيرد و تاريخ شمسي به شكل y/m/d بر مي گرداند.
stom : تاريخ شمسي را به صورت y/m/d مي گيرد و تاريخ ميلادي به شكل y/m/d بر مي گرداند.
wm : تاريخ ميلادي به صورت y/m/d مي گيرد و روز هفته را بر مي گرداند
ws : تاريخ شمسي به صورت y/m/d مي گيرد و روز هفته را بر مي گرداند
موفق باشي
باي
|
صفحه اصلی
انجمن
جستجو
فهرست اعضا
افزونه های فایرفاکس
» 
تشکر شده توسط :
