دستور صحیح وارد کردن تاریخ در maskedbox

[hamed_vb]

سلام دوستان عزیزم
شاید برای خیلی ها اتفاق افتاده که موقع تایپ کردن تاریخ در برنامشون به فرض مثال ( 1215/04/63) دچار اشتباه شدن و تاریخ رو به صورت ذکر شده وارد کردن من میخوام کدی باشه که maskedbox رو محدود کنه یعنی کدی بنویسیم که بعد از وارد کرد کامل تاریخ در صورت اشتباه بودن تاریخ به روز سیستم رو اتوماتیک وارد کنه ممنون میشم اگر کسی این مشکل رو حل کرده باشه و در اخیتار من و سایر دوستان هم بگذاره.

[naeim_1369]

سلام دوستان عزیزم
شاید برای خیلی ها اتفاق افتاده که موقع تایپ کردن تاریخ در برنامشون به فرض مثال ( 1215/04/63) دچار اشتباه شدن و تاریخ رو به صورت ذکر شده وارد کردن من میخوام کدی باشه که maskedbox رو محدود کنه یعنی کدی بنویسیم که بعد از وارد کرد کامل تاریخ در صورت اشتباه بودن تاریخ به روز سیستم رو اتوماتیک وارد کنه ممنون میشم اگر کسی این مشکل رو حل کرده باشه و در اخیتار من و سایر دوستان هم بگذاره.

با سلام و عرض ادب،
منظورتون اینه؟
البته اینجا من مقدار سال رو بین 1300 تا 1450 محدود کردم:



Option Explicit
Dim Msg1 As Integer

Private Sub MaskEdBox1_LostFocus()
Call MSC(MaskEdBox1)
End Sub

Private Sub MSC(MASKED As MaskEdBox)
Dim Y As Integer, M As Integer, D As Integer
On Error GoTo Err
Y = Mid$(MASKED.Text, 1, 4): M = Mid$(MASKED.Text, 6, 2): D = Mid$(MASKED.Text, 9, 2)
If Y < 1300 Or Y > 1450 Then GoTo Err
If M >= 1 And M <= 6 Then
If D < 1 Or D > 31 Then GoTo Err
ElseIf M >= 7 And M <= 11 Then
If D < 1 Or D > 30 Then GoTo Err
ElseIf M = 12 Then
If D < 1 Or D > 31 Then GoTo Err
Else
GoTo Err
End If
Exit Sub
Err:
Msg1 = MsgBox("The Date is incorrect, Please Try again!", vbExclamation, "Mismatch Error")
MASKED.SetFocus
MASKED.Text = ChangeToShamsi(Date)
MASKED.SelStart = 0: MASKED.SelLength = Len(MASKED.Text)
End Sub

یه ماژولی هم باز کنید:



Function ChangeToShamsi(DateParam)
Dim Temp1 As Date
Y = CInt(Left(Date, InStr(Date, "/") - 1))
M = CInt(Mid(Date, InStr(Date, "/") + 1, InStrRev(DateParam, "/") - InStr(DateParam, "/") - 1))
D = CInt(Mid(Date, InStrRev(Date, "/") + 1))
If Y = 0 Then Y = 2000
If Y < 1000 Then Y = Y + 1900
Shamsi Y, M, D
If Trim(M) < 10 Then
ChangeToShamsi = Trim(Y) & "/0" & Trim(M)
Else
ChangeToShamsi = Trim(Y) & "/" & Trim(M)
End If
If Trim(D) < 10 Then
ChangeToShamsi = ChangeToShamsi & "/0" & Trim(D)
Else
ChangeToShamsi = ChangeToShamsi & "/" & Trim(D)
End If
End Function

Sub Shamsi(Y, M, D)
If Y = 2000 Then
If M > 2 Then
Temp = DateSerial(Y, M, D)
Temp = Temp + 1
Y = Year(Temp)
M = Month(Temp)
D = Day(Temp)
End If
End If
If M < 3 Or (M = 3 And D < 21) Then
Y = Y - 622
Else
Y = Y - 621
End If
Select Case M
Case 1
If D < 21 Then
M = 10: D = D + 10
Else
M = 11: D = D - 20
End If
Case 2
If D < 20 Then
M = 11: D = D + 11
Else
M = 12: D = D - 19
End If
Case 3
If D < 21 Then
M = 12: D = D + 9
Else
M = 1: D = D - 20
End If
Case 4
If D < 21 Then
M = 1: D = D + 11
Else
M = 2: D = D - 20
End If
Case 5, 6
If D < 22 Then
M = M - 3: D = D + 10
Else
M = M - 2: D = D - 21
End If
Case 7, 8, 9
If D < 23 Then
M = M - 3: D = D + 9
Else
M = M - 2: D = D - 22
End If
Case 10
If D < 23 Then
M = 7: D = D + 8
Else
M = 8: D = D - 22
End If
Case 11, 12
If D < 22 Then
M = M - 3: D = D + 9
Else
M = M - 2: D = D - 21
End If
End Select
End Sub

ضمناً کدنویسی ماژول رو هم یکی از دوستان عضو برنامه نویس نوشتن، ولی مشخصاتی از خودشون بین کدها نذاشتن، خواستم بگم تا حقش ضایع نشه!!

[hamed_vb]

من انجام دادم و عمل کرد

[naeim_1369]

در خصوص پیامی که دوست عزیزم hamed_vb (http://barnamenevis.org/member.php?57779-hamed_vb) گذاشتن، خطایی که ممکنه بعلت تایپ ناقص ممکنه بوجود بیاد، مثلاً __/1394/01 میتونیم با یه دستور ساده IF جلوی خطا رو بگیریم،


Option Explicit
Dim Msg1 As Integer

Private Sub MaskEdBox1_LostFocus()
Call MSC(MaskEdBox1)
End Sub

Private Sub MSC(MASKED As MaskEdBox)
If MASKED.Text Like "####/##/##" Then
Dim Y As Integer, M As Integer, D As Integer
On Error GoTo Err
Y = Mid$(MASKED.Text, 1, 4): M = Mid$(MASKED.Text, 6, 2): D = Mid$(MASKED.Text, 9, 2)
If Y < 1300 Or Y > 1450 Then GoTo Err
If M >= 1 And M <= 6 Then
If D < 1 Or D > 31 Then GoTo Err
ElseIf M >= 7 And M <= 11 Then
If D < 1 Or D > 30 Then GoTo Err
ElseIf M = 12 Then
If D < 1 Or D > 31 Then GoTo Err
Else
GoTo Err
End If
Exit Sub
Else
Err:
Msg1 = MsgBox("The Date is incorrect, Please Try again!", vbExclamation, "Type Mismatch Error")
MASKED.SetFocus
MASKED.Text = ChangeToShamsi(Date)
MASKED.SelStart = 0: MASKED.SelLength = Len(MASKED.Text)
End If
End Sub



مثال: