آموزشMicrosoft Office Access

آموزش اکسس بخش نهم

توسط amin8505 | گروه مقاله های آموزشی | 1394/07/28

نظرات 0

  ماجول تاريخ هجري شمسي با توابع جانبي آن 

در بانك اطلاعاتي Access فيلدهاي نوع Date پاسخگوي نياز كاربران فارسي كه با تاريخ هجري شمسي كار مي كنند نيست . البته برنامه هايي مثل پارسا ۹۹ تقويم سيستم را به تقويم هجري شمسي تبديل مي كند و بعد از آن كاربران فارسي مي توانند از فيلدهاي نوع Date اكسس استفاده كنند .بدين ترتيب پارسا مشكل تاريخ هجري شمسي را حل ميكند ولي بعضا تاريخ شمسي سيستم بنا به دلايلي از بين ميرود . مثلا اگربعد از نصب پارسا، Officeنصب شود تاريخ هجري شمسي سيستم به هم مي خورد. براي رهايي از وابستگي برنامه هاي شما به پارسا و ... ، توابع زير مي تواند مشكل شما را بطور كامل حل كند . 
اين ماجول در چندين برنامه تست شده و جواب گرفته است شما هم مي توانيد از آن استفاده كنيد. 
(توجه داشته باشيد كه كدهاي نوشته شده ، در اينجا از چپ به راست نمايش داده شده اند ولي با كپي آن در اكسس ، نمايش آن از چپ به راست خواهد شد) 

در صورت استفاده از اين ماجول ، فيلدهاي از نوع تاريخ را بايد از نوع Number تعريف كنيد. توضيحات بيشتر جهت استفاده از ماجول ، درون خود ماجول نوشته شده است. 
براي استفاده از اين ماجول ، از دو خط پايين تر تا انتهاي متن را در حافظه كپي كرده (Copy) و سپس در يك ماجول جديد در اكسس يا VB قرار دهيد (Paste): 

 

' 1- تعريف كنيد Number(Long) است را بصورت Date فيلدهايي كه نوع آنها 
' 2- اين فيلدها را بصورت 00/00/00 تنظيم كنيد InputMask خاصيت 
' بدليل 6 رقمي در نظر گرفتن فيلد تاريخ ، اين توابع تا سال 1399 كارايي دارد 
' ... 
' تاريخ جاري سيستم را به هجري شمسي تبديل مي كند Shamsi() تابع 
' بكار ببريد Now() را مي توانيد در گزارشات بجاي تابع Dat() تابع 
' :براي جلوگيري از ورود تاريخ غلط به درون يك فيلد بترتيب زير عمل ميكنيد 
' :بشكل زير بكار ببريد ValidationRule را در خاصيت ValidDate() تابع 
' ValidDate([نام فيلد])=True 
' ... 


'******************************************* 
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 
 

 

0 نظر

نظر محترم شما در مورد مقاله های وب سایت برنامه نویسی و پایگاه داده

نظرات محترم شما در خدمات رسانی بهتر ما را یاری می نمایند. لطفا اگر مایل بودید یک نظر ما را مهمان فرمائید. آدرس ایمیل و وب سایت شما نمایش داده نخواهد شد.

حرف 500 حداکثر