اعتبار سنجي تاريخ

[Rasool-GH]

با سلام خدمت دوستان
من خيلي جستجو كردم ولي به نتيجه نرسيدم .
در برنامه اي براي تاريخ شمسي از ماژول اقاي ازادي استفاده كردم كه از همين سايت گرفتم
براي اعتبار سنجي تاريخ وارد شده به مشكل برخوردم
دوستان اگه تجربه اي دارن در اختيار بنده قرار بدن

برای حل مشکلات تاریخ به این تاپیک مراجعه کنید

ماژول کامل تاریخ شمسی در VBA (http://barnamenevis.org/showthread.php?322266-%D9%85%D8%A7%DA%98%D9%88%D9%84-%DA%A9%D8%A7%D9%85%D9%84-%D8%AA%D8%A7%D8%B1%DB%8C%D8%AE-%D8%B4%D9%85%D8%B3%DB%8C-%D8%AF%D8%B1-%D8%A7%DA%A9%D8%B3%D8%B3-%D8%A8%D8%A7-VBA)

[morteza_lll]

دوستان اگه كامپوننتي باشه كه براي اعتبار سنجي كه مانند تقويم كار بكنه يعني كاربر زماني كه خواست تاريخ ثبت كنه براش يه تقويم بازشه كه ديفالت روز جاري باشه عاليه
اگه كسي راه حلي داره من هم به اين مورد نياز دارم

[Rasool-GH]

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

[dadsara]

سلام
این نمونه در سایت موجود بود

[Rasool-GH]

سلام
ممنون بابت نمونه ولي در اين نمونه اعتبار تاريخ برسي نميشه . به وسيله فرم تقويم از ورود تاريخ نامعتبر به فرم جلوگيري شده
من نياز دارم اعتبار تاريخي كه به صورت دستي وارد شده سنجيده بشه به طور مثال تاريخ 1390/85/66 نا معتبر هست .

[Abbas Amiri]

کار سختی نیست با چند تا دستور شرطی براحتی می توان یک تابع تشخیص معتبر بودن تاریخ ایجاد کرد. تنها مشکل 30 اسفند است که با تابع تشخیص کبیسه بودن سال حل می شود . این هم تابع کبیسه :


Public Function IsLeapYear(NumYear As Integer) As Boolean
Dim k As Integer
k = NumYear Mod 33
If k < 18 Then
If k Mod 4 = 1 Then
IsLeapYear = True
End If
ElseIf k Mod 4 = 2 Then
IsLeapYear = True
End If
End Function

[Rasool-GH]

سلام اقاي اميري
ممنون بابت راهنمايي شما
من در برنامه از ماژول تاريخ شمسي كه از همين سايت گرفتم استفاده كردم داخل ماژول تابعي با نام Valid Date تعريف شده كه ظاهرا بايد در در قسمت اعتبار ستجي فيلد مورد نظر بكار بره ولي باهر روشي استفاده كردم نشد . اگه لطف كنين برسي بفرماييد ممنون ميشم



Option Compare Database
'Çíä ãÊÛííÑ ãÞÏÇÑ ßáíß ÔÏå ÏÑ ÝÑã ÊÞæíã Ñæ ÈÕæÑÊ ÓÑÇÓÑí ÏÑ ÎæÏÔ ÐÎíÑå ãíßäå
Public STRDATE As String
'//////////////////////////////////////
'ãÇŽæá ÇÕáÇÍ ÔÏå ÌäÇÈ ÂÒÇÏí ÊæÓØ ÇÍãÏ ãíÑÒÇÒÇÏå Èå ÊÇÑíÎ 1388/7/22
' 1- ÊÚÑíÝ ßäíÏ Number(Long) ÇÓÊ ÑÇ ÈÕæÑÊ Date ÝíáÏåÇíí ßå äæÚ ÂäåÇ
' 2- Çíä ÝíáÏåÇ ÑÇ ÈÕæÑÊ 0000/00/00 ÊäÙíã ßäíÏ InputMask ÎÇÕíÊ
' ÈÏáíá 8 ÑÞãí ÏÑ äÙÑ ÑÝÊä ÝíáÏ ÊÇÑíÎ ¡ Çíä ÊæÇÈÚ ÊÇ ÓÇá 1999 ßÇÑÇíí ÏÇÑÏ
' ...
' ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå åÌÑí ÔãÓí ÊÈÏíá ãí ßäÏ Shamsi() ÊÇÈÚ
' ÈßÇÑ ÈÈÑíÏ Now() ÑÇ ãí ÊæÇäíÏ ÏÑ ÒÇÑÔÇÊ ÈÌÇí ÊÇÈÚ Dat() ÊÇÈÚ
' :ÈÑÇí ÌáæíÑí ÇÒ æÑæÏ ÊÇÑíÎ ÛáØ Èå ÏÑæä íß ÝíáÏ ÈÊÑÊíÈ ÒíÑ Úãá ãíßäíÏ
' :ÈÔßá ÒíÑ ÈßÇÑ ÈÈÑíÏ ValidationRule ÑÇ ÏÑ ÎÇÕíÊ ValidDate() ÊÇÈÚ
' ...
' ************************************************** ***********
Public Function Guon(F_Date As Long) As Byte
'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ÑæÒ íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
Guon = F_Date Mod 100
End Function
'*******************************************
Function ay(F_Date As Long) As Byte
'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ãÇå íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
ay = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function IL(F_Date As Long) As Integer
'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ÓÇá íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
IL = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlyIL As Variant) As Byte
'æÑæÏí ÊÇÈÚ ÚÏÏ ÏæÑÞãí ÇÓÊ
'Çíä ÊÇÈÚ ßÈíÓå ÈæÏä ÓÇá ÑÇ ÈÑãíÑÏÇäÏ
'ÇÑ ÓÇá ßÈíÓå ÈÇÔÏ ÚÏÏ íß æ ÏÑÛíÑ ÇíäÕæÑÊ ÕÝÑ ÑÇ ÈÑ ãíÑÏÇäÏ
Kabiseh = 0
If OnlyIL >= 1375 Then
If (OnlyIL - 1375) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlyIL <= 1370 Then
If (1370 - OnlyIL) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
End If

End Function
'*******************************************
Function ValidDate(F_Date As Long) As Boolean
Dim M, S, R As Byte
' Çíä ÊÇÈÚ ÇÚÊÈÇÑ íß ÚÏÏ æÑæÏí ÑÇ ÇÒ äÙÑ ÊÇÑíÎ åÌÑí ÔãÓí ÈÑÑÓí ãí ßäÏ
' ÑÇ ÈÑãí ÑÏÇäÏ False æÇÑ äÇãÚÊÈÑ ÈÇÔÏ True ÇÑ ÊÇÑíÎ ãÚÊÈÑ ÈÇÔÏ
ValidDate = True

S = IL(F_Date)
M = ay(F_Date)
R = Guon(F_Date)
'********
If F_Date < 10000101 Then
ValidDate = False
Exit Function
End If

If M > 12 Or M = 0 Or R = 0 Then
ValidDate = False
Exit Function
End If

If R > ayDays(S, M) Then
ValidDate = False
Exit Function
End If
End Function
'*******************************************
Public Function AddDay(ByVal F_Date As Long, ByVal Add As Integer) As Long
Dim k, M, R, Days As Byte
Dim S As Integer
R = Guon(F_Date)
M = ay(F_Date)
S = IL(F_Date)
k = Kabiseh(S)

'ÊÈÏíá ÑæÒ Èå ÚÏÏ 1 ÌåÊ ÇÏÇãå ãÍÇÓÈÇÊ æ íÇ ÇÊãÇã ãÍÇÓÈå
Days = ayDays(S, M)
If Add > Days - R Then
Add = Add - (Days - R + 1)
R = 1
If M < 12 Then
M = M + 1
Else
M = 1
S = S + 1
End If
Else
R = R + Add
Add = 0
End If

While Add > 0
k = Kabiseh(S) 'ßÈíÓå: 1 æ ÛíÑ ßÈíÓå: 0
Days = ayDays(S, M) 'ÊÚÏÇÏ ÑæÒåÇí ãÇå ÝÚáí
Select Case Add
Case Is < Days
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ÇÝÒæÏäí ßãÊÑ ÇÒ íß ãÇå ÈÇÔÏ
R = R + Add
Add = 0
Case Days To IIf(k = 0, 365, 366) - 1
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ÇÝÒæÏäí ÈíÔÊÑ ÇÒ íß ãÇå æ ßãÊÑ ÇÒ íß ÓÇá ÈÇÔÏ
Add = Add - Days
If M < 12 Then
M = M + 1
Else
S = S + 1
M = 1
End If
Case Else
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ÇÝÒæÏäí ÈíÔÊÑ ÇÒ íß ÓÇá ÈÇÔÏ
S = S + 1
Add = Add - IIf(k = 0, 365, 366)
End Select
Wend
'AddDay = (s * 10000) + (M * 100) + (R)
AddDay = CLng(S & Format(M, "00") & Format(R, "00"))
End Function

'***********************************************
Public Static Function Shamsi() As Long
'ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå ÊÇÑíÎ åÌÑí ÔãÓí ÊÈÏíá ãí ßäÏ
Dim Shamsi_Mabna As Long
Dim Miladi_mabna As Date
Dim Dif As Long
'ÏÑ ÇíäÌÇ 78/10/11 ÈÇ 2000/01/01 ãÚÇÏá ÞÑÇÑÏÇÏå ÔÏå
Shamsi_Mabna = 13781011
Miladi_mabna = #1/1/2000#
Dif = DateDiff("d", Miladi_mabna, Date)
If Dif < 0 Then
MsgBox "ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÔãÇ äÇÏÑÓÊ ÇÓÊ , ÂäÑÇ ÇÕáÇÍ ßäíÏ."
Else
Shamsi = AddDay(Shamsi_Mabna, Dif)
End If
End Function
'***********************************************
Public Function DayWeek(F_Date As Long) As String
Dim a As String
Dim N As Byte
N = DayWeekNo(F_Date)
Select Case N
Case 0
a = "ÔäÈå"
Case 1
a = "íßÔäÈå"
Case 2
a = "ÏæÔäÈå"
Case 3
a = "ÓåÔäÈå"
Case 4
a = "åÇÑÔäÈå"
Case 5
a = "ä̝ÔäÈå"
Case 6
a = "ÌãÚå"
End Select
DayWeek = a
End Function

'***********************************************
Public Function Dat()
Dim d As Long
d = Shamsi
'Dat = DayWeek(d) & IL(d) & "/" & ay(d) & "/" & Guon(d)
Dat = IL(d) & "/" & ay(d) & "/" & Guon(d)
End Function

'***********************************************
Public Function Diff(ByVal FromDate As Long, ByVal To_Date As Long) As Long
'Çíä ÊÇÈÚ ÊÚÏÇÏ ÑæÒåÇí Èíä Ïæ ÊÇÑíÎ ÑÇ ÇÑÇÆå ãí ßäÏ
Dim Tmp As Long
Dim S1, M1, R1, S2, M2, R2 As Integer
Dim Sumation As Single
Dim Flag As Boolean
Flag = False
If FromDate = 0 Or IsNull(FromDate) = True Or To_Date = 0 Or IsNull(To_Date) = True Then
Diff = 0
Exit Function
End If

If FromDate > To_Date Then
'ÇÑ ÊÇÑíÎ ÔÑæÚ ÇÒ ÊÇÑíÎ ÇíÇä ÈÒѐÊÑ ÈÇÔÏ ÂäåÇ ãæÞÊÇ ÌÇÈÌÇ ãí ÔæäÏ
Flag = True
Tmp = FromDate
FromDate = To_Date
To_Date = Tmp
End If
R1 = Guon(FromDate)
M1 = ay(FromDate)
S1 = IL(FromDate)
R2 = Guon(To_Date)
M2 = ay(To_Date)
S2 = IL(To_Date)
Sumation = 0

Do While S1 < S2 - 1 Or (S1 = S2 - 1 And (M1 < M2 Or (M1 = M2 And R1 <= R2)))
'ÇÑ íß ÓÇá íÇ ÈíÔÊÑ ÇÎÊáÇÝ ÈæÏ
If Kabiseh((S1)) = 1 Then
If M1 = 12 And R1 = 30 Then
Sumation = Sumation + 365
R1 = 29
Else
Sumation = Sumation + 366
End If
Else
Sumation = Sumation + 365
End If
S1 = S1 + 1
Loop

Do While S1 < S2 Or M1 < M2 - 1 Or (M1 = M2 - 1 And R1 < R2)
'ÇÑ íß ãÇå íÇ ÈíÔÊÑ ÇÎÊáÇÝ ÈæÏ
Select Case M1
Case 1 To 6
If M1 = 6 And R1 = 31 Then
Sumation = Sumation + 30
R1 = 30
Else
Sumation = Sumation + 31
End If
M1 = M1 + 1
Case 7 To 11
If M1 = 11 And R1 = 30 And Kabiseh(S1) = 0 Then
Sumation = Sumation + 29
R1 = 29
Else
Sumation = Sumation + 30
End If
M1 = M1 + 1
Case 12
If Kabiseh(S1) = 1 Then
Sumation = Sumation + 30
Else
Sumation = Sumation + 29
End If
S1 = S1 + 1
M1 = 1
End Select
Loop

If M1 = M2 Then
Sumation = Sumation + (R2 - R1)
Else
Select Case M1
Case 1 To 6
Sumation = Sumation + (31 - R1) + R2
Case 7 To 11
Sumation = Sumation + (30 - R1) + R2
Case 12
If Kabiseh(S1) = 1 Then
Sumation = Sumation + (30 - R1) + R2
Else
Sumation = Sumation + (29 - R1) + R2
End If
End Select
End If

If Flag = True Then
Sumation = -Sumation
End If
Diff = Sumation
End Function

Public Function DayWeekNo(F_Date As Long) As String
'Çíä ÊÇÈÚ íß ÊÇÑíÎ ÑÇ ÏÑíÇÝÊ ßÑÏå æ ãÔÎÕ ãí ßäÏ å ÑæÒí ÇÒ åÝÊå ÇÓÊ
'ÇÑ ÔäÈå ÈÇÔÏ ÚÏÏ 0
'ÇÑ 1ÔäÈå ÈÇÔÏ ÚÏÏ 1
'......
'ÇÑ ÌãÚå ÈÇÔÏ ÚÏÏ 6
Dim day As String
Dim Shmsi_Mabna As Long
Dim Dif As Long
'ãÈäÇ 80/10/11
Shmsi_Mabna = 13801011
Dif = Diff(Shmsi_Mabna, F_Date)
If Shmsi_Mabna > F_Date Then
Dif = -Dif
End If
'ÈÇ ÊæÌå Èå Çíäßå 80/10/11 3ÔäÈå ÇÓÊ ãÍÇÓÈå ãíÔæÏ day ãÊÛíÑ
day = (Dif + 3) Mod 7
If day < 0 Then
DayWeekNo = day + 7
Else
DayWeekNo = day
End If
End Function


Function ayName(ByVal ay_no As Byte) As String
Select Case ay_no
Case 1
ayName = "ÝÑæÑÏíä"
Case 2
ayName = "ÇÑÏíÈåÔÊ"
Case 3
ayName = "ÎÑÏÇÏ"
Case 4
ayName = "撄"
Case 5
ayName = "ãÑÏÇÏ"
Case 6
ayName = "ÔåÑíæÑ"
Case 7
ayName = "ãåÑ"
Case 8
ayName = "ÂÈÇä"
Case 9
ayName = "ÂÐÑ"
Case 10
ayName = "Ïí"
Case 11
ayName = "Èåãä"
Case 12
ayName = "ÇÓÝäÏ"
End Select
End Function

Function ILay(ByVal F_Date As Long) As Long
'ÔÔ ÑÞã Çæá ÊÇÑíÎ ßå ãÚÑÝ ÓÇá æ ãÇå ÇÓÊ ÑÇ ÈÑãí ÑÏÇäÏ
ILay = Val(Left$(F_Date, 6))
End Function

Function ayDays(ByVal IL As Integer, ByVal ay As Byte) As Byte
'Çíä ÊÇÈÚ ÊÚÏÇÏ ÑæÒåÇí íß ãÇå ÑÇ ÈÑãí ÑÏÇäÏ
Select Case ay
Case 1 To 6
ayDays = 31
Case 7 To 11
ayDays = 30
Case 12
If Kabiseh(IL) = 1 Then
ayDays = 30
Else
ayDays = 29
End If
End Select

End Function

Function Make_Date(ByVal F_Date As Long) As String
'íß ÊÇÑíÎ ÑÇ ÈÕæÑÊ íß ÑÔÊå 10 ÑÞãí ÈÇ ÐßÑ åÇÑ ÑÞã ÈÑÇí ÓÇá ÇÑÇÆå ãí ßäÏ
Dim d As String
d = Trim(Str(F_Date))
If IsNull(F_Date) = True Or F_Date = 0 Then
Make_Date = ""
Else
Make_Date = Mid(d, 1, 4) & "/" & Mid(d, 5, 2) & "/" & Mid(d, 7, 2)
End If
End Function

Function Nextay(ByVal IL_ay As Long) As Long
If (IL_ay Mod 100) = 12 Then
Nextay = (Int(IL_ay / 100) + 1) * 100 + 1
Else
Nextay = IL_ay + 1
End If
End Function

Function Previousay(ByVal IL_ay As Long) As Long
If (IL_ay Mod 100) = 1 Then
Previousay = (Int(IL_ay / 100) - 1) * 100 + 12
Else
Previousay = IL_ay - 1
End If
End Function


Function SubtractDay(ByVal F_Date As Long, ByVal Subtract As Long) As Long
'Èå ÊÚÏÇÏ ÑæÒ ãÚíäí ÇÒ íß ÊÇÑíÎ ßã ßÑÏå æ ÊÇÑíÎ ÍÇÕáå ÑÇ ÇÑÇÆå ãíßäÏ
Dim k, M, S, R, Days As Byte

R = Guon(F_Date)
M = ay(F_Date)
S = IL(F_Date)
k = Kabiseh(S)

'ÊÈÏíá ÑæÒ Èå ÚÏÏ 1 ÌåÊ ÇÏÇãå ãÍÇÓÈÇÊ æ íÇ ÇÊãÇã ãÍÇÓÈå
If Subtract >= R - 1 Then
Subtract = Subtract - (R - 1)
R = 1
Else
R = R - Subtract
Subtract = 0
End If

While Subtract > 0
k = Kabiseh(S - 1) 'ßÈíÓå: 1 æ ÛíÑ ßÈíÓå: 0
Days = ayDays(IIf(M >= 2, S, S - 1), IIf(M >= 2, M - 1, 12)) 'ÊÚÏÇÏ ÑæÒåÇí ãÇå ÞÈáí
Select Case Subtract
Case Is < Days
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ßÇåÔ ßãÊÑ ÇÒ íß ãÇå ÈÇÔÏ
R = Days - Subtract + 1
Subtract = 0
If M >= 2 Then
M = M - 1
Else
S = S - 1
M = 12
End If
Case Days To IIf(k = 0, 365, 366) - 1
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ßÇåÔ ÈíÔÊÑ ÇÒ íß ãÇå æ ßãÊÑ ÇÒ íß ÓÇá ÈÇÔÏ
Subtract = Subtract - Days
If M >= 2 Then
M = M - 1
Else
S = S - 1
M = 12
End If
Case Else
'ÇÑ ÊÚÏÇÏ ÑæÒåÇí ßÇåÔ ÈíÔÊÑ ÇÒ íß ÓÇá ÈÇÔÏ
S = S - 1
Subtract = Subtract - IIf(k = 0, 365, 366)
End Select
Wend
SubtractDay = (S * 10000) + (M * 100) + (R)

End Function


'ÔãÇÑå Çæáíä ÑæÒ ãÇå
Public Function Firstday(IL As Integer, ay As Integer) As Long
Dim strfd As Long
strfd = IL & Format(ay, "00") & Format(1, "00")
Firstday = DayWeekNo(strfd)
End Function


Public Function Report_Zoom(strReportName As String, intZoomCoeff As Integer)
On Error GoTo Err_PreviewAndZoomReport
If Not (intZoomCoeff >= 0 And intZoomCoeff <= 2500) Then
intZoomCoeff = 0
End If
With DoCmd
.OpenReport strReportName, acViewPreview
.Maximize
End With
Reports(strReportName).ZoomControl = intZoomCoeff
Exit_PreviewAndZoomReport:
Exit Function
Err_PreviewAndZoomReport:
MsgBox Err.Description
Resume Exit_PreviewAndZoomReport
End Function


ممنون بابت كمكهاي مفيدتون

[morteza_lll]

ميگم آيا خود اكسس كامپوننت تقويم نداره كه بشه ازش استفاده كرد ؟؟؟؟؟؟؟

[Rasool-GH]

متاسفانه تاريخ شمسي رو پشتيباني نميكنه

[ARData]

دوست عزیز شما آخرین ورژن از فایل Dll تقویم شمسی رو از www.CPSD.ir (http://www.cpsd.ir/) دریافت کنید سپس ماژول زیرا که خودم نوشتم به نام MdlShamsiDate ذخیره نمایید ....
Option Compare Database
Public MyVar As New CPSD_PDC.CPSD_PersianDateConverter
Public MyVarTime As New CPSD_PDC.CPSD_PersianTimeConverter
Public Function Mydate(ByVal MyMiladiDate As String) As String
Mydate = MyVar.ConvertDate(MyMiladiDate, MiladiBeShamsi)
End Function
Public Function MyTime(ByVal MyThisTime As Integer) As String
MyTime = MyVarTime.MinuteToHour(MyThisTime)
End Function
Public Function MyHourToMin(ByVal MyAllMin As String) As Integer
If Len(MyAllMin) = 5 Then
MyHourToMin = (Left(MyAllMin, 2) * 60) + Right(MyAllMin, 2)
End If
If Len(MyAllMin) = 4 Then
MyHourToMin = (Left(MyAllMin, 1) * 60) + Right(MyAllMin, 2)
End If
End Function
Public Function MyHourToMin2(ByVal MyStrClock As String) As Integer
If Len(MyStrClock) = 3 Then
MyHourToMin2 = (Left(MyStrClock, 2) * 60) + Right(MyStrClock, 1)
End If
If Len(MyStrClock) = 4 Then
MyHourToMin2 = (Left(MyStrClock, 2) * 60) + Right(MyStrClock, 2)
End If
End Function
Public Function MYAllMinTime(ByVal TimeAllAz As String, ByVal TimeAllTa As String) As String
MYAllMinTime = ((Int(Left([TimeAllTa], 2)) - Int(Left([TimeAllAz], 2))) * 60) + (Int(Right([TimeAllTa], 2)) - Int(Right([TimeAllAz], 2)))
End Function
Public Function MYStrTimeToIntMin(ByVal StrTime As String) As Integer
MYStrTimeToIntMin = Int(Left(StrTime, 2) * 60) + Int(Right(StrTime, 2))
End Function
Public Function CurYear() As String
CurYear = Left(MyVar.CurrentDate, 4)
End Function
Public Function ShamsiINT() As Long
ShamsiINT = Left(MyVar.CurrentDate, 4) & Mid(MyVar.CurrentDate, 6, 2) & Right(MyVar.CurrentDate, 2)
End Function
Public Function ShamsiSTR() As String
ShamsiIntToStr = Left(MyVar.CurrentDate, 4) & "/" & Mid(MyVar.CurrentDate, 5, 2) & "/" & CurrentDate
End Function
Public Function ShamsiIntToStr(ByVal StrShmasi As Long) As String
ShamsiIntToStr = Left(StrShmasi, 4) & "/" & Mid(StrShmasi, 5, 2) & "/" & Right(StrShmasi, 2)
End Function
Public Function INTShamsiDiff(ByVal StrShmasiBegin As Long, ByVal StrShmasiEnd As Long) As String
INTShamsiDiff = MyVar.DDiff(ShamsiIntToStr(StrShmasiBegin), ShamsiIntToStr(StrShmasiEnd), Diff_By_Day) + 1
End Function
Public Function ShamsiStrToInt(ByVal StrShmasi As String) As Long
ShamsiStrToInt = Left(MyVar.CurrentDate, 4) & Mid(MyVar.CurrentDate, 6, 2) & Right(MyVar.CurrentDate, 2)
End Function
Public Function IntShamsiMounthName(ByVal IntDateSH As Long) As Long
IntShamsiMounthName = MyVar.ShamsiMonthName(ShamsiIntToStr(IntDateSH), ShomarehMah)
End Function
Public Function StrShamsiMounthName(ByVal StrDateSH As Long) As String
StrShamsiMounthName = MyVar.ShamsiMonthName(ShamsiIntToStr(StrDateSH), NameMah)
End Function

[Rasool-GH]

ممنون که جواب دادین
به دلیل اینکه نرم افزار رو روی سیستم های اداری استفاده میکنم و اجازه نصب برنامه رو نمیدن باید با ماژولهای توکار کار کنم امکان استفاده از DLL نیست

[emami.sie]

سلام
ببینید نمونه زیر کمکتون می کنه
یک تاریخ اشتباه (مثل 1390/05/35) رو وارد کنید و نتیجه رو ببینید
یا علی

[Rasool-GH]

ممنون بابت راهنمايي خيلي خوبتون . من كاملا به مقصود رسيدم
يك توضيح هم خدمت Zero Defect عزيز بدم كه استفاده از DLL هاي خارجي بسيار مفيده و من هم واقف هستم ولي همونطور كه گفتم به دليل اينكه اجازه نصب نرمافزار در همه سيستمها وجود نداره نميتونم از برنامه هاي نصب استفاده كنم
باز هم ممنون از همه دوستاني كه كمك كردن
ضمنا تابع شما رو اعمال كردم متاسفانه در هر حالت تاريخ رو نا معتبر تشخيص ميده . با كد زير در قسمت اعتبار سنجي جواب داد
ValidDate ([TextBox Name])=True
برنامه دوست خوبم emami.sie فقط در حالت بدون / جواب ميده .
سوال :
براي اشاره كردن به Object مربوطه به جاي نام Object نميشه عبارتي نوشت كه معنيش همون Object باشه كه شرط در اون برسي ميشه . (مثلا چيزي مثل me.value)

[Rasool-GH]

اين ماژول خيلي كار امد هست ولي متاسفانه نواقصي داره كه بايد بازنگري بشه . اگر نمونه كاملتري رو دارين ممنون ميشم ارائه كنين
ضمنا در همين ماژول اقاي ازادي چطور ميشه تعداد روز مشخصي رو از تاريخ روز كم كرد (در كدوم تابع انجام ميشه)

[Rasool-GH]

بنده عرض كردم كه با كد ValidDate ([TextBox Name])=True
جواب داد و مشكل كاملا حل شد . خيلي ممنون بابت اصلاح تابع

[expert2219]

بنده عرض كردم كه با كد ValidDate ([TextBox Name])=True
جواب داد و مشكل كاملا حل شد . خيلي ممنون بابت اصلاح تابع

دوست عزيز اين كدرو دقيقا كجاي تابع اضافه كردي

[Rasool-GH]

شما باید کل برنامه رو در یک ماژول قرار بدین بعد در روال Validation Rule یک تکست باکس که قراره توش تاریخ درج بشه این کد رو قرار بدین
در صورتی که تاریخ اشتباه باشه پیغامی که در Validation Text درج کردین نمایش داده میشه

[Rasool-GH]

سلام خدمت دوستان يك مشكل كوچيك ديگه ايجاد شده
در اين تابع وقتي اقدام به پاك كردن تاريخ درج شده داخل باكس ميكني موقع خارج شدن از باكس ايراد ميگيره و ميگه داده معتبر نيست . داخل تابع چه تغييري بايد داد تا مقدار Null هم معتبر باشه
ممنون بابت راهنمايي ها ي خوبتون


سوال :
براي اشاره كردن به Object مربوطه به جاي نام Object نميشه عبارتي نوشت كه معنيش همون Object باشه كه شرط در اون برسي ميشه . (مثلا چيزي مثل (me.value)

براي اين مورد راهي نيست ؟؟؟؟؟

[emami.sie]

سلام
نمونه رو براتون اصلاح کردم
به رویداد Before update فیلد تاریخ توجه کنید... (validation Rule رو پاک کردم...)
تاریخ اشتباه رو وارد کنید و نتیجه رو ببینید و همچنین یک تاریخ رو Delete کنید...
موفق باشید
یا علی

[mj_bayati]

با سلام
من خودم با ماژول آقای آزادی کار میکنم و ازین راه استفاده میکنم :متفکر:
(البته فک کنم مشابه راهی است که emami.sie پیشنهاد دادند)

فقط توی رویداد After Update فیلدی که میخواهیم اعتبارش رو بررسی کنیم این کدها رو وارد میکنیم:
(ADate فیلدی است که میخواهیم اعتبار اون رو بررسی کنیم :افسرده:)

On Error Resume Next

If IsNull(ADate.Value) Or IsEmpty(ADate.Value) Then
Exit Sub

ElseIf ValidDate(ADate.Value) = False Then
MsgBox "تاريخ وارد شده معتبر نمي باشد", vbCritical, "تاريخ نامعتبر"
Undo

End If

ایشالله مفید باشه

[emami.sie]

با سلام
من خودم با ماژول آقای آزادی کار میکنم و ازین راه استفاده میکنم :متفکر:
(البته فک کنم مشابه راهی است که emami.sie پیشنهاد دادند)

فقط توی رویداد After Update فیلدی که میخواهیم اعتبارش رو بررسی کنیم این کدها رو وارد میکنیم:
(ADate فیلدی است که میخواهیم اعتبار اون رو بررسی کنیم :افسرده:)


On Error Resume Next

If IsNull(ADate.Value) Or IsEmpty(ADate.Value) Then
Exit Sub

ElseIf ValidDate(ADate.Value) = False Then
MsgBox "تاريخ وارد شده معتبر نمي باشد", vbCritical, "تاريخ نامعتبر"
Undo

End If

ایشالله مفید باشه

راه حلی که جناب بیاتی ارائه فرمودند فقط یه مشکل کوچیک داره و اون هم اینه که بعد از پیغام خطا، فوکوس به فیلد یا شی بعدی منتقل میشه و این کاربر برنامه رو اذیت میکنه...
در عین حال منطق هر دو یکیه...
موفق باشید
یا علی

[Rasool-GH]

اقایون ممنون لطف کردین . این هم کار منو راه میندازه ولی برای اینکه کار رو اساسی درست کنیم لطفا همکاری کنید
داخل ماژول اقای ازادی چند مورد تغییرات دادم که اگر بشه این مورد رو هم به اون اضافه کرد خیلی خوب میشه و ضمنا میشه برای استفاده عموم اینجا قرار داد
من متوجه نشدم که در صورت خالی بودن فیلد چرا اشکال میگیره . من میگم بهتره داخل تابع یک شرط دیگه اضافه بشه که در صورت خالی بودن فیلد True برگرده
داخل تابع شرط رو نوشتم ولی اصلا متغیری به تابع نمیره که برسی بشه کلا میگه مقدار مچ نیست .
چه راهی به نظرتون میرسه ؟

[mj_bayati]

با سلام و خسته نباشید
برادر emami.sie از بررسی دقیق شما متشکرم :متفکر:
من ازین کد همیشه استفاده میکردم و به این نکته توجه نکرده بودم
اما فک میکنم علت اینکه توجه نکرده بودم این بوده که برنامه قبل از رفتن به رکورد بعد یکبار Undo هم انجام میده
ولی انصافاً توصیه خوبی بود :تشویق:
اگه کد رو به Before Update منتقل کنیم مشکل حله دیگه

[mj_bayati]

داخل ماژول اقای ازادی چند مورد تغییرات دادم که اگر بشه این مورد رو هم به اون اضافه کرد خیلی خوب میشه ...
من متوجه نشدم که در صورت خالی بودن فیلد چرا اشکال میگیره . من میگم بهتره داخل تابع یک شرط دیگه اضافه بشه که در صورت خالی بودن فیلد True برگرده

وقتی یک کد داخل تابع Validation Rule باشه دیگه نمیشه اون فیلد رو خالی نگه داشت چون اکسس مقدار "" رو هم مخالف با Validation Rule میدونه و بنابراین False رو برمیگردونه
البته من نتونستم (نمیشه گفت نمیشه!!) و پیام خطای اکسس هم همین رو میگه
پس با همون کدی که بیان شد (+توصیه استاد) عمل کن :چشمک:

البته اگه کسی بتونه راه بهتری بگه نوکرشم هستیم

[emami.sie]

وقتی یک کد داخل تابع Validation Rule باشه دیگه نمیشه اون فیلد رو خالی نگه داشت چون اکسس مقدار "" رو هم مخالف با Validation Rule میدونه و بنابراین False رو برمیگردونه

ابتدا عرض کنم که من شاگردی میکنم خدمت اساتید...

در جواب دوستمون من هم با جناب بیاتی موافقم و فکر نمیکنم در فیلدی که validation Rule براش تعریف شده، بشه مقدار وارد شده رو پاک کرد و به فیلد بعد رفت...
در پیشنهاد جناب پیروز مهر هم فقط پیغام اکسس حذف میشه و مقصود نهایی حاصل نمیشه... (اینکه فیلد تاریخ پس از حذف، خالی بمونه) البته طبق خواسته آقای Rasool-GH

سلام خدمت دوستان يك مشكل كوچيك ديگه ايجاد شده
در اين تابع وقتي اقدام به پاك كردن تاريخ درج شده داخل باكس ميكني موقع خارج شدن از باكس ايراد ميگيره و ميگه داده معتبر نيست . داخل تابع چه تغييري بايد داد تا مقدار Null هم معتبر باشه موفق باشید
یا علی

[Rasool-GH]

دوستان در همين قسمت از كد كه تغيير کرده نميشه به طور خاص يه IF نوشت كه اگر كد Error فلان كد بود مقدار تابع True بشه ؟؟؟
اين كه من اصرار دارم اين مورد درست بشه واسه اينه كه هم حجم كد نويسي كم ميشه و هم در اينده براي اديت كردن با مشكل كمتري روبرو ميشم

سوال :
براي اشاره كردن به Object مربوطه به جاي نام Object نميشه عبارتي نوشت كه معنيش همون Object باشه كه شرط در اون برسي ميشه . (مثلا چيزي مثل (me.value)
اينم يكي جواب بده اگه نميشه زياد پيگيرش نشم خيلي گشتم ولي چيزي پيدا نكردم

[mj_bayati]

...تغيير مرده نميشه ....
اين كه من اسرار دارم ... كد نويسي كمم ميشه ....

برادر Rasool-GH غلط املایی ها زیاد شده؟! :لبخند:
شوخی کردما به دل نگیرید!!! :چشمک:

اما سؤال اول:

نميشه به طور خاص يه IF نوشت كه اگر كد Error فلان كد بود مقدار تابع True بشه ؟من فک نمیکنم عملی باشه چون اون True یا False رو خوده اکسس میده، نمیشه کاریش کرد
البته بازم میگم کار نشد نداره، من نمیتونم... :افسرده:

اینکه فرمودید:

براي اشاره كردن به Object مربوطه به جاي نام Object نميشه عبارتي نوشت كه معنيش همون Object باشه كه شرط در اون برسي ميشه .

چرا میشه....
فقط به جای اسم Object باید بنویسی Screen.ActiveControl
اینو میخوای که کدهات همگانی بشه؟ آره! :متفکر:
کار خوبی است.. :تشویق:

موفق باشید

[Rasool-GH]

ممنون بابت تذکر . اصلاح شد .
بله میخوام که بدون نیاز به اینکه به نام شی توجه بشه شرط داخل Validation Rule هر شی مقدار داخل همون رو کنترل کنه . خوبیش اینه که اگه بخوای اسم اون شی رو عوض کنی دیگه نیاز نیست این قسمت رو ادیت کنی

اقای Zero Defect ممنون بابت توجه شما ولی باز هم مشکل قبلی وجود داره و با خروج از فیلد مجددا فیلد پر میشه
یه توضیح بدم . در موردی که فیلد باند باشه با خروج از فیلد اشکال مچ نبودن دیتا رو میده و در حالت باند نبودن فیلد مجدد فیلد پر میشه

[Rasool-GH]

من شرمنده ام شما واقعا وقت صرف کردین . مشکل ظاهرا مربوط میشه به input mask من . ("13"00/00/00;0;-) در حالی که شما 0000/00/00 استفاده کردین .
من هم با شما موافقم که سوال شفاف جواب شفاف رو در پی داره
من برنامه خودم رو مطابق نمونه بالا تغییر دادم و درست کار میکنه ولی برای Input Mask خودم جواب نمیده
من نمونه رو میزارم اگه لطف کنید و مورد برسی قرار بدید منت میزارین .

[Rasool-GH]

ممنون از لطفت . من همین قدر همراهی شما رو هم روی سر خودم منت میدونم .
شما بزرگتر بنده هستید اگر هم حرفی بزنید به هیچ وجه ناراحت نیمشم .
من تو برنامه نویسی تازه کارم و حدود 2 ماهه دارم کار میکنم . با خیلی از مسائل اشنا نیستم . امیدوارم شما به بزرگی خدتون ببخشید .

ضمنا هر دو تابع اصلاحی شمارو اعمال کردم . تابع دوم مشکل رو کاملا حل کرد اشکال از من بود که تصور کردم فقط قسمت اخر تابع تغییر کرده و من هم همون تغییر رو اعمال کردم . شرمنده:اشتباه:
ضمنا دلیل پر شدن مجدد فیلد Unbound این بود که براش مقدار Default Value قرار داده بودم
بازهم ممنون داداش:خجالت:

[Rasool-GH]

نتیجه این تاپیک رو در ماژول کامل تاریخ شمسی در اکسس با VBA (http://barnamenevis.org/showthread.php?322266-%D9%85%D8%A7%DA%98%D9%88%D9%84-%DA%A9%D8%A7%D9%85%D9%84-%D8%AA%D8%A7%D8%B1%DB%8C%D8%AE-%D8%B4%D9%85%D8%B3%DB%8C-%D8%AF%D8%B1-%D8%A7%DA%A9%D8%B3%D8%B3-%D8%A8%D8%A7-VBA)
دنبال کنید

[mosafer1375]

نقل قول: اعتبار سنجي تاريخ

با سلام
یه نمونه می خوام یه فیلد باشه که با کلیک روش تقویم بازبشه و بشه تاریخ امروز رو انتخاب کرد همچنین من می خوام که که با این نمونه بین دو بازه زمانی مثلا از این تاریخ تا این تاریخ گزارش گرفت