نوشته شده توسط
mazoolagh
سلام دوباره
آسوده باشین، فورس ماژور که نیست، محدودیت زمانی هم نداره
باسلام مجدد
کدها رو همون روزشنبه تغییر دادم ولی ظاهراً سایت برنامه نویس دوسه روزی با مشکل مواجه شده بود که بخاطر همین نتونستم نمونه اصلاح شده رو ضمیمه کنم
در نمونه جدید فکر میکنم هر 7 مورد اشاره شده در پست 146 انجام شده باشه (البته بنظر خودم )
در نمونه جدید کدها رو در تابع زیر قرار دادم که فراخوانی این تابع در رخداد KeyPress صورت میگیره
Public Function ShamsiDateValid(myDate As Control, KeyAscii As Integer)
On Error Resume Next
Dim d, m, Y
Dim strDate As String
Dim IntKeyAscii As Integer
Dim KeyAsc As Integer
Dim BySelStart As Byte
If (KeyAscii > 47 And KeyAscii < 58) Or (KeyAscii = 8) Or (KeyAscii = 46) Or (KeyAscii = 9) Then
KeyAscii = KeyAscii
Else:
KeyAscii = 0
End If
If myDate.InputMask <> "0000/00/00" Then myDate.InputMask = "0000/00/00"
KeyAsc = Chr(KeyAscii)
BySelStart = myDate.SelStart
strDate = myDate.Text
IntKeyAscii = KeyAsc
Y = Split(myDate.Text, "/")(0)
m = Split(myDate.Text, "/")(1)
d = Split(myDate.Text, "/")(2)
Y = Replace(Y, "_", "")
m = Replace(m, "_", "")
d = Replace(d, "_", "")
If KeyAscii = 8 Then Exit Function
If IntKeyAscii <> 1 And BySelStart = 0 Then
KeyAscii = 0
Exit Function
End If
If Len(Left(Y, 1)) > 0 And (IntKeyAscii < 2 Or IntKeyAscii > 5) And BySelStart = 1 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii >= 5 And Len(Y) = 4 And Mid(Y, 3, 1) > 0 And BySelStart = 1 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii >= 5 And Len(Y) = 4 And (Mid(Y, 3, 1) > 0 Or Mid(Y, 4, 1) > 0) And BySelStart = 1 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 0 And Mid(Y, 2, 1) = 5 And BySelStart = 2 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 0 And Mid(Y, 2, 1) = 5 And BySelStart = 3 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 1 And BySelStart = 5 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 2 And Left(m, 1) = 1 And BySelStart = 6 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 0 And Len(Mid(m, 2, 1)) > 0 And Mid(m, 2, 1) > 2 And BySelStart = 5 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii = 0 And Left(m, 1) = 0 And BySelStart = 6 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 3 And BySelStart = 8 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii > 2 And Val(Left(m, 2)) > 6 And Len(Mid(d, 2, 1)) > 0 And Mid(d, 2, 1) > 0 And BySelStart = 8 Then
KeyAscii = 0
Exit Function
End If
If Val(Left(m, 2)) < 7 Then
If IntKeyAscii > 1 And Left(d, 1) > 2 And BySelStart = 9 Then
KeyAscii = 0
Exit Function
End If
ElseIf Val(Left(m, 2)) > 6 Then
If IntKeyAscii > 0 And Left(d, 1) > 2 And BySelStart = 9 Then
KeyAscii = 0
Exit Function
End If
End If
If IntKeyAscii = 0 And Left(d, 1) = 0 And BySelStart = 9 Then
KeyAscii = 0
Exit Function
End If
If IntKeyAscii >= 0 And Int(InStr(strDate, "_")) > 0 And (BySelStart + 1) > Int(InStr(strDate, "_")) Then
KeyAscii = 0
myDate.SelStart = Int(InStr(strDate, "_")) - 1
Exit Function
End If
End Function
از تابع زیر هم برای چک کردن موارد زیر استفاده شده :
1- خالی نبودن تاریخ در صورتی که در خصوصیت tag تکست باکس تاریخ {}درج شده باشد
2- چک کردن سال بین محدوده مجاز (برای زمانی که تاریخ بصورت کپی پیست وارد میشود)
3- کنترل تعداد روزها در شش ماهه دوم سال( برای زمانی که مثلا با ماه شش ماهه اول روز 31 برای روز وارد شده باشد بعد بیائیم عدد ماه شش ماه دوم وارد کنیم)
الیته برای این مورد میتوان بدون صدور پیغام هم در زمان تغییر عدد ماه چک شود که اگر قبلا برای روز عدد 31 وارد شده دیگر نتوان عدد ماههای نیمه دوم رو وارد کرد و یا اینکه اگر عدد شش ماهه دوم وارد شد در همان موقع چک شود که اگر عدد روز 31 میباشد عدد روز پاک شود تا در ادامه با توجه به عدد ماه پر شود
4- کنترل سال کبیسه
Public Function FDateValid(myDate As Control) As Boolean
On Error Resume Next
FDateValid = True
Dim d, m, Y As String
Y = Left(myDate, 4)
m = Mid(myDate, 5, 2)
d = Mid(myDate, 7, 2)
If IsNull(myDate) And myDate.Tag = "{}" Then
FDateValid = False
MsgBoxFa "!ورود يک مقدار درست براي تاريخ الزامي ميباشد"
DoCmd.CancelEvent
Exit Function
End If
If Not (Y >= 1200 And Y <= 1500) Then
FDateValid = False
MsgBoxFa "! محدوده مجاز سال بايد از 1200 تا 1500 وارد شود", vbCritical, "خطا"
DoCmd.CancelEvent
Exit Function
End If
If (Val(m) > 6 And Val(d) > 30) Then
FDateValid = False
MsgBoxFa ". تعداد روزهاي هر ماه در شش ماهه دوم سال حداکثر 30 روز است !لطفا روز را اصلاح كنيد", vbCritical, "خطا"
DoCmd.CancelEvent
Exit Function
End If
If LeapYear(Y) = True And Val(d) = 30 And Val(m) = 12 Then
FDateValid = False
MsgBoxFa ". تعداد روزهاي اسفند ماه حداکثر 29 روز است !لطفا روز را اصلاح كنيد", vbCritical, "خطا"
DoCmd.CancelEvent
Exit Function
End If
End Function
پاسخ با نقل قول