Function chk_date(ddat As String) As Variant
Dim tt1 As Integer, tt2 As Integer, tt3 As Integer
Dim dt As Variant, at As Integer, bt As Integer, ct As Integer, st As Integer
Dim msg As String
Dim chk As Integer
Dim strd As String
msg = ""
strd = "13" + Trim(ddat)
tt1 = Val(Left(Trim(strd), 4))
tt2 = Val(Mid(Trim(strd), 5, 2))
tt3 = Val(Mid(Trim(strd), 7, 2))
chk = 0
If (tt1 <= 0) Or (tt2 <= 0) Or (tt1 < 1300) Then
' Beep
chk = 1
' chk = MsgBox(msg, 48, "")
End If
'MsgBox Str(tt1) + "__" + Str(tt2) + "___" + Str(tt3)
If tt2 > 12 Then
chk = 1
' chk = MsgBox("?Aè ??éEçA?? Eé?E? AO 12 EA??", 48, msg)
End If
Select Case tt2
Case 1 To 6
If tt3 > 31 Then
' Beep
chk = 1
' chk = MsgBox("?AèèAé 1 EA 6 ??éEçA?? Eé?E? AO 31 ?çO EA??", 48, msg)
End If
Case 7 To 11
If tt3 > 30 Then
' Beep
chk = 1
' chk = MsgBox("?AèèAé 7 EA 11 ??éEçA?? Eé?E? AO 30 ?çO EA??", 48, msg)
End If
Case 12
If tt1 < 1374 Then
If (tt1 Mod 4) = 2 Then
If tt3 > 30 Then
' Beep
chk = 1
' chk = MsgBox("A?à?? ?Aè ?A? âEé?è ??éEçA?? Eé?E? AO 30 ?çO EA??", 48, msg)
End If
Else
If tt3 > 29 Then
' Beep
' chk = MsgBox("A?à?? ?Aè ?A? ?é? âEé?è ??éEçA?? Eé?E? AO 29 ?çO EA??", 48, msg)
chk = 1
End If
End If
Else
If (tt1 Mod 4) = 3 Then
If tt3 > 30 Then
' Beep
chk = 1
' chk = MsgBox("A?à?? ?Aè ?A? âEé?è ??éEçA?? Eé?E? AO 30 ?çO EA??", 48, msg)
End If
Else
If tt3 > 29 Then
' Beep
' chk = MsgBox("A?à?? ?Aè ?A? ?é? âEé?è ??éEçA?? Eé?E? AO 29 ?çO EA??", 48, msg)
chk = 1
End If
End If
End If
End Select
If (chk) = 1 Then
' DoCmd CancelEvent
Exit Function
End If
chk_date = True
End Function
Function mtosh(ddat As Variant)
Dim chkab As Integer, da As Integer, mo As Integer, ye As Integer
Dim ld As Integer
Dim tt1 As String, tt2 As String, tt3 As String
chkab = 0
ReDim buf1(12) As Integer, buf2(12) As Integer
buf1(1) = 0
buf1(2) = 31
buf1(3) = 59
buf1(4) = 90
buf1(5) = 120
buf1(6) = 151
buf1(7) = 181
buf1(8) = 212
buf1(9) = 243
buf1(10) = 273
buf1(11) = 304
buf1(12) = 334
buf2(1) = 0
buf2(2) = 31
buf2(3) = 60
buf2(4) = 91
buf2(5) = 121
buf2(6) = 152
buf2(7) = 182
buf2(8) = 213
buf2(9) = 244
buf2(10) = 274
buf2(11) = 305
buf2(12) = 335
If IsNull(ddat) Then
mtosh = " "
Exit Function
End If
If (Year(ddat) Mod 4) <> 0 Then
da = buf1(Month(ddat)) + Day(ddat)
If da > 79 Then
da = da - 79
If da <= 186 Then
Select Case da Mod 31
Case 0
mo = da / 31
da = 31
Case Else
mo = Int(da / 31) + 1
da = da Mod 31
End Select
ye = Year(ddat) - 621
Else
da = da - 186
Select Case da Mod 30
Case 0
mo = (da / 30) + 6
da = 30
Case Else
mo = Int(da / 30) + 7
da = da Mod 30
End Select
ye = Year(ddat) - 621
End If
Else
If Year(ddat) > 1996 And (Year(ddat) Mod 4) = 1 Then
ld = 11
Else
ld = 10
End If
da = da + ld
Select Case da Mod 30
Case 0
mo = (da / 30) + 9
da = 30
Case Else
mo = Int(da / 30) + 10
da = da Mod 30
End Select
ye = Year(ddat) - 622
End If
Else
da = buf2(Month(ddat)) + Day(ddat)
If Year(ddat) >= 1996 Then
ld = 79
Else
ld = 80
End If
If da > ld Then
da = da - ld
If da <= 186 Then
Select Case da Mod 31
Case 0
mo = da / 31
da = 31
Case Else
mo = Int(da / 31) + 1
da = da Mod 31
End Select
ye = Year(ddat) - 621
Else
da = da - 186
Select Case da Mod 30
Case 0
mo = (da / 30) + 6
da = 30
Case Else
mo = Int(da / 30) + 7
da = da Mod 30
End Select
ye = Year(ddat) - 621
End If
Else
da = da + 10
Select Case da Mod 30
Case 0
mo = (da / 30) + 9
da = 30
Case Else
mo = Int(da / 30) + 10
da = da Mod 30
End Select
ye = Year(ddat) - 622
End If
End If
tt1 = Trim(Str(ye))
tt2 = Trim(Str(mo))
If Len(tt2) = 1 Then
tt2 = "0" + tt2
End If
tt3 = Trim(Str(da))
If Len(tt3) = 1 Then
tt3 = "0" + tt3
End If
mtosh = tt1 + "/" + IIf(Len(tt2) > 1, tt2, "0" & tt2) + "/" + IIf(Len(tt3) > 1, tt3, "0" & tt3)
End Function
Function shtom(strd As String)
Dim dat1 As Variant, dat2 As Variant
Dim sepch As String
Dim sysdat As String, sysy As Integer, sysm As Integer, sysd As Integer
Dim fir As String, sec As String, thi As String
If Len(strd) = 6 Then
strd = "13" + strd
End If
If Len(strd) = 8 Then
strd = Left(Trim(strd), 4) + "/" + Mid(Trim(strd), 5, 2) + "/" + Mid(Trim(strd), 7, 2)
End If
Dim tt1 As String, tt2 As String, tt3 As String
Dim dt As Variant, at As Integer, bt As Integer, ct As Integer, st As Integer
If strd = " / / " Or strd = "13 / / " Then
' shtom=# / / #
' date
Exit Function
End If
tt1 = Left(Trim(strd), 4)
tt2 = Mid(Trim(strd), 6, 2)
tt3 = Mid(Trim(strd), 9, 2)
tt1 = Trim(Str(Val(tt1) + 621))
dt = IIf(Val(tt1) > 1995 And (Val(tt1) Mod 4 = 0), DateSerial(Val(tt1), 3, 20), DateSerial(Val(tt1), 3, 21))
at = Int(Val(tt1))
bt = Int(Val(tt2))
ct = Int(Val(tt3))
Select Case bt
Case 1, 2, 3, 4, 5, 6
st = ((bt - 1) * 31) + ct
Case 7, 8, 9, 10, 11, 12
st = (6 * 31) + ((bt - 7) * 30) + ct
End Select
dt = dt + st - 1
shtom = dt
End Function
Function GetCurDate() As String
'Dim rstCurDate As New ADODB.Recordset
'rstCurDate.Open "SELECT GetDate() AS CurDate", CurrentProject.Connection, adOpenForwardOnly
'GetCurDate = rstCurDate![CurDate]
'rstCurDate.Close
GetCurDate = date
End Function
'karajjavad@yahoo.com
' 1386.9
'use text box =mtosh(Now())
کد تاریخ شمسی اکسس تحت xp
پاسخ با نقل قول
این هم نمونه کامل قابل ذخیره
نقل قول: کد تاریخ شمسی اکسس تحت xp
. میشه بگی از این mdb فایل چطوری استفاده کنم.
نوشته شده توسط mohsenna30ri
