مشکل تاریخ فارسی

[مجتبی کریمی]

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

[sarami]

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

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



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

[مجتبی کریمی]

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

[maleki]

این فایل رو جایگزین فایل مشابه اون در پوشه windows/system32 بکن در windows xp تقویمت هجری شمسی میشه اما قبلش تو اکسس hijri calendar رو تیک بزن.

[sarami]

خواهش قابلی نداشت امیدوارم مشکلتون حل بشه

[mohammadgij]

این فایل زمیمه که یکی از دوستان لطف کرده و نوشته، میزارم بر دارید.
راستی تا یادم نرفته واسه استفاده از این Dll باید گزینه Hijri Calender رو غیر فعال کنید

[maleki]

حالا چه جوری از این sepandasadateconvertor.dllاستفاده کنیم.

[sarami]

دوستان عزیز دوستمون تابع می خواستن نه dll

[mohammadgij]

خب تابع براچیته؟ وقتی Dllهست؟

[sarami]

حتما فرق میکنه که تابع میخواد شاید نمیخواد برا هر کامپیوتر client این dll رو هم ببره

[mohammadgij]

ok بابا. اما بالاخره میخواد که یه Installer داشته باشه یا نه؟ .خواستم کمکی کرده باشم.

[sarami]

حالا زیاد اصرار مکنی قبول میکنیم چرا خوشو ناراحت میکنی دستت درد نکنه

[mohammad2000]

khili manon az tabe tabdil tarikh shmase be milade

[ITST-1]

دوست من این dll در سیستم 32 رجیستر نمی شود و پیام می دهد که برنامه ای در حال ااستفاده از آن است

[ITST-1]

دوست من سلام
مرسی از dll شما اما این dll تاریخ 31/06/ را نمی پذیرد دلیلش چیست

[a_r_shariati]

سلام
ببین این تابع بدردت میخوره
البته این تابع فقط تاریخ رو به شمسی تبدیل میکنه.(string برمیگردونه)
و ضمنا از 2001 به بعد رو میشناسه البته اگه بخوای بسادگی میتونی تاریخهای قبل رو هم تعریف کنی

Public Function FarsiDate(D As Date) As String
Dim YYYY1, mm, dd, Kab As String
Dim X0, X1, X2, M1, D1, D2 As Long
Dim A1, A2, A3, YYYY As Integer

X0 = D - #3/20/2001#

If X0 < 0 Then
MsgBox (".&#202;&#199;&#209;&#237;&#206; &#222;&#200;&#225; &#199;&#210; 21/3/2001 &#222;&#199;&#200;&#225; &#222;&#200;&#230;&#225; &#228;&#227;&#237;&#200;&#199;&#212;&#207;")
Cancel = 1
Exit Function
End If

A1 = Int(X0 / 365) '&#202;&#218;&#207;&#199;&#207; &#211;&#199;&#225;&#229;&#199;'
YYYY = 1380 + A1
A2 = A1 Mod 4
If A2 = 0 Then
Kab = 1
Else
Kab = 0
End If
X1 = (X0 Mod 365) - Int(A1 / 4)
If X1 < 0 Then
X1 = 365 - X1
Else
End If
X2 = X1 - 186
If X2 < 0 Then
D1 = X1 Mod 31
If D1 = 0 Then
D1 = 31
M1 = Int(X1 / 31)
Else
M1 = Int(X1 / 31) + 1
End If
Else
D1 = X2 Mod 30
If D1 = 0 Then
D1 = 30
M1 = 6 + Int(X2 / 30)
Else
M1 = 7 + Int(X2 / 30)
End If
End If

If Kab = 1 Then
FarsiDate = YYYY & "/" & M1 & "/" & D1
Else
If M1 = 12 And D1 = 30 Then
YYYY = YYYY + 1
M1 = 1
D1 = 1
Else
FarsiDate = YYYY & "/" & M1 & "/" & D1
End If
End If

End Function

[ITST-1]

دوستان مرسی از کمک شما

من این تابع را در یک ماجول کپی کردم حالا چگونه باید از آن استفاده کنم
مرسی اگر کمک کنید

[a_r_shariati]

بفرما مثلا در کجا میخواهی استفاده کنی؟

[met_ebadi]

با سلام

آیا میشه به من بگید چجوری میشه از این توی اکسل استفاده کرد من خیلی به اون نیاز دارم؟


http://www.barnamenevis.org/forum/showthread.php?p=187534#post187534

[A_KH_industrial engineer]

با سلام
من یک مشکل دارم با گزارشهای اکسس
اون هم اینه که توی گزارشهام نمیتونم ردیف ها رو به طور اتوماتیک بیارم
یعنی برای یک گزارش از یک تا هر چند ردیف که داشت اولین ستون در گزارش ردیف داشته باشم
متشکرم

[شاپرک]

اول جستجو :
http://www.barnamenevis.org/forum/showthread.php?t=37182&highlight=%D1%CF%ED%DD
http://www.barnamenevis.org/forum/showthread.php?t=927&highlight=%D1%CF%ED%DD
http://www.barnamenevis.org/forum/showthread.php?t=8432&highlight=%D1%CF%ED%DD
http://www.barnamenevis.org/forum/showthread.php?t=22899&highlight=%D1%CF%ED%DD
http://www.barnamenevis.org/forum/showthread.php?t=22926&highlight=%D1%CF%ED%DD
http://www.barnamenevis.org/forum/showthread.php?t=27872&highlight=%D1%CF%ED%DD

[شاپرک]

لینک های بالا رو دیدی
تو رو خدا دقت کنید

[alfi_rashid]

Shamsi() تابع
رو کجا باید وارد کنیم