25
برای ایرانیان پرتالی است متمرکز به جغرافیای گردشگری که این جغرافیا بستر مناسبی برای توسعه سایر بانکهای اطلاعاتی از قبیل مشاهیر و بزرگان هر شهر و بررسی آثار آنها و بانکهای اطلاعاتی مثل، خدمات و گردشگری که شامل غذاهای محلی،سوغات،صنایع دستی،بازار،صنعت،اکوتوریسم می باشد.با فرستادن عکس،سفرنامه،فیلم کوتاه،گذاشتن کامنت در آخر هر مطلب و معرفی شغل یا کار خود در آن منطقه، و با به اشتراک گذاشتن این مطالب به توسعه صنعت توریسم کشور کمک کرده باشیم
چهارشنبه ٠١ شهريور ١٣٩٦
منو اصلی
ورود
نام کاربری :   
کلمه عبور :   
عضویت
[فراموشی کلمه عبور]
ترفندهاي اكسس
13 دی 1388

توابع تبديل تاريخ هجري شمسي به ميلادي در اكسس و اكسل(ترفندهای اکسس )

توضيحات:

در بانك اطلاعاتي Access فيلدهاي نوع Date/Time پاسخگوي نياز كاربران فارسي كه با تاريخ هجري شمسي كار مي كنند نيست . البته برنامه هاي تجاری در بازار جهت تبدیل تقویم ویندوز و آفیس به تقویم شمسی وجود دارد که بعد از خرید و نصب آن كاربران فارسي مي توانند از فيلدهاي نوع Date/Time اكسس استفاده كنند .بدين ترتيب مشكل تاريخ هجري شمسي را حل ميكند ولي بعضا تاريخ شمسي سيستم بنا به دلايلي از بين ميرود . به جهت عدم وابستگي برنامه هاي شما به این فارسی سازها و همچنین هزینه نکردن جهت خرید این فارسی سازها، توابع زير مي تواند مشكل شما را بطور كامل حل كند .
اين ماجول در چندين برنامه تست شده و جواب گرفته است شما هم مي توانيد از آن استفاده كنيد.

نکات زیر جهت استفاده از این توابع مدنظر قرار گیرد:

1- برای فیلدهای حاوی تاریخ نظیر «تاریخ تولد» به جای تعریف فيلدهاي از نوع DateTime بايد از نوع Number استفاده شود.

2- خاصیت InputMask آن فيلد را بصورت 00/00/00 تنظيم كنيد (این کار باعث می شود کاربر برای ورود تاریخ در Table و یا Form نیازی به دوبار تایپ کردن کاراکتر / نداشته باشد و در Report ها هم بصورت خودکار دو کاراکتر / بین ارقام وارده نمایش یابد)

3- بدليل 6 رقمي در نظر گرفتن فيلد تاريخ ، اين توابع فعلا تا سال 1399 كارايي دارد (در نسخه های بعدی اصلاحات انجام خواهد شد)

4- در گزارشات به جای تایپ عبارت=Now()  درون TextBox عبارت =Dat() تایپ شود. (این کار باعث می شود عبارتی مشابه "یک شنبه 13/10/1388" دورن گزارش چاپ شود)

5- جهت ورود تاریخ جاری سیستم درون یک فیلد مثلا فیلد «تاریخ ثبت نامه» می توان در خاصیت DafaultValue مربوط به TextBox عبارت =Shamsi() تایپ شود.(تابع Shamsi بدون پارامتر ورودی تاریخ جاری سیستم را به شمسی تبدیل می کند.)
6- براي جلوگيري از ورود تاريخ غلط به درون يك فيلد بترتيب زير عمل ميكنيد
:بشكل زير بكار ببريد ValidationRule را در خاصيت ValidDate() تابع
ValidDate([نام فيلد])=True

براي استفاده از اين برنامه، از خط زیر تا انتهاي متن را در حافظه كپي كرده (Copy) و سپس در يك Module جديد در اكسس يا VB قرار دهيد (Paste):

*************************************************************
برنامه نويس : حميد آزادي
Email: azadi1355@yahoo.com
Web Address:
http://www.4iranian.com
ويرايش چهارم : زمستان 1388
*************************************************************
...
*************************************************************

*******************************************
برنامه نويس : حميد آزادي
Email: azadi1355@yahoo.com
Web Address: http://try.persianblog.ir
ويرايش سوم : زمستان 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

 

استفاده از مظالب با ذکر نویسنده و سایت بلامانع است.

20:23

نظر خود را ثبت كنيد(4)


اوقات شرعی
نظرسنجی
نظرسنجي غير فعال مي باشد

بازديدکنندگان اين صفحه: 33606 بازديدکنندگان امروز :  77 کل بازديدکنندگان :  52383395 بازديدکنندگان آنلاين :  6 زمان بارگزاري صفحه:  0.9287