در بانک اطلاعاتی Access فیلدهای نوع Date پاسخگوی نیاز کاربران فارسی که با تاریخ هجری شمسی کار می کنند نیست . البته برنامه هایی مثل پارسا ۹۹ تقویم سیستم را به تقویم هجری شمسی تبدیل می کند و بعد از آن کاربران فارسی می توانند از فیلدهای نوع Date اکسس استفاده کنند .بدین ترتیب پارسا مشکل تاریخ هجری شمسی را حل میکند ولی بعضا تاریخ شمسی سیستم بنا به دلایلی از بین میرود . مثلا اگربعد از نصب پارسا، Officeنصب شود تاریخ هجری شمسی سیستم به هم می خورد. برای رهایی از وابستگی برنامه های شما به پارسا و ... ، توابع زیر می تواند مشکل شما را بطور کامل حل کند .
این ماجول در چندین برنامه تست شده و جواب گرفته است شما هم می توانید از آن استفاده کنید.
(توجه داشته باشید که کدهای نوشته شده ، در اینجا از چپ به راست نمایش داده شده اند ولی با کپی آن در اکسس ، نمایش آن از چپ به راست خواهد شد)
در صورت استفاده از این ماجول ، فیلدهای از نوع تاریخ را باید از نوع Number تعریف کنید. توضیحات بیشتر جهت استفاده از ماجول ، درون خود ماجول نوشته شده است.
برای استفاده از این ماجول ، از دو خط پایین تر تا انتهای متن را در حافظه کپی کرده (Copy) و سپس در یک ماجول جدید در اکسس یا VB قرار دهید (Paste):
' ************************************************** ***********
' برنامه نویس : حمید آزادی
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ویرایش سوم : زمستان 1381
' ************************************************** ***********
' 1- تعریف کنید Number(Long) است را بصورت Date فیلدهایی که نوع آنها
' 2- این فیلدها را بصورت 00/00/00 تنظیم کنید InputMask خاصیت
' بدلیل 6 رقمی در نظر گرفتن فیلد تاریخ ، این توابع تا سال 1399 کارایی دارد
' ...
' تاریخ جاری سیستم را به هجری شمسی تبدیل می کند Shamsi() تابع
' بکار ببرید Now() را می توانید در گزارشات بجای تابع Dat() تابع
' :برای جلوگیری از ورود تاریخ غلط به درون یک فیلد بترتیب زیر عمل میکنید
' :بشکل زیر بکار ببرید ValidationRule را در خاصیت ValidDate() تابع
' ValidDate([نام فیلد])=True
' ...
' ************************************************** ***********
'*******************************************
' برنامه نویس : حمید آزادی
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ویرایش سوم : زمستان 1381
'*******************************************
Public Function Rooz(F_Date As Long) As Byte
'این تابع عدد مربوط به روز یک تاریخ را برمگرداند
Rooz = F_Date Mod 100
End Function
'*******************************************
Function Mah(F_Date As Long) As Byte
'این تابع عدد مربوط به ماه یک تاریخ را برمگرداند
Mah = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function Sal(F_Date As Long) As Byte
'این تابع عدد مربوط به سال یک تاریخ را برمگرداند
Sal = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlySal As Variant) As Byte
'ورودی تابع عدد دورقمی است
'این تابع کبیسه بودن سال را برمیگرداند
'اگر سال کبیسه باشد عدد یک و درغیر اینصورت صفر را بر میگرداند
Kabiseh = 0
If OnlySal >= 75 Then
If (OnlySal - 75) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 70 Then
If (70 - OnlySal) 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 = Sal(F_Date)
M = Mah(F_Date)
R = Rooz(F_Date)
'********
If F_Date < 100101 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 > MahDays(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, S, R, Days As Byte
R = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(F_Date)
K = Kabiseh(S)
'تبدیل روز به عدد 1 جهت ادامه محاسبات و یا اتمام محاسبه
Days = MahDays(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 = MahDays(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)
End Function
'***********************************************
Public Function Shamsi() As Long
'تاریخ جاری سیستم را به تاریخ هجری شمسی تبدیل می کند
Dim Shamsi_Mabna As Long
Dim Miladi_mabna As Date
Dim Dif As Long
'در اینجا 80/10/11 با 2002/01/01 معادل قرارداده شده
Shamsi_Mabna = 791012
Miladi_mabna = #1/1/01#
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) & " 13" & Sal(D) & "/" & Mah(D) & "/" & Rooz(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 = Rooz(FromDate)
M1 = Mah(FromDate)
S1 = Sal(FromDate)
r2 = Rooz(To_Date)
m2 = Mah(To_Date)
S2 = Sal(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 = 801011
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 MahName(ByVal Mah_no As Byte) As String
Select Case Mah_no
Case 1
MahName = "فروردین"
Case 2
MahName = "اردیبهشت"
Case 3
MahName = "خرداد"
Case 4
MahName = "تیر"
Case 5
MahName = "مرداد"
Case 6
MahName = "شهریور"
Case 7
MahName = "مهر"
Case 8
MahName = "آبان"
Case 9
MahName = "آذر"
Case 10
MahName = "دی"
Case 11
MahName = "بهمن"
Case 12
MahName = "اسفند"
End Select
End Function
Function SalMah(ByVal F_Date As Long) As Integer
'چهار رقم اول تاریخ که معرف سال و ماه است را برمی گرداند
SalMah = Val(Left$(F_Date, 4))
End Function
Function MahDays(ByVal Sal As Byte, ByVal Mah As Byte) As Byte
'این تابع تعداد روزهای یک ماه را برمی گرداند
Select Case Mah
Case 1 To 6
MahDays = 31
Case 7 To 11
MahDays = 30
Case 12
If Kabiseh(Sal) = 1 Then
MahDays = 30
Else
MahDays = 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 = "13" & Mid(D, 1, 2) & "/" & Mid(D, 3, 2) & "/" & Mid(D, 5, 2)
End If
End Function
Function NextMah(ByVal Sal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 12 Then
NextMah = (Int(Sal_Mah / 100) + 1) * 100 + 1
Else
NextMah = Sal_Mah + 1
End If
End Function
Function PreviousMah(ByVal Sal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 1 Then
PreviousMah = (Int(Sal_Mah / 100) - 1) * 100 + 12
Else
PreviousMah = Sal_Mah - 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 = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(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 = MahDays(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
به نقل از وبلاگ:
http://try.persianblog.com/
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول