سلام
دنباله یه تابع تو اکسس می گردم که بتونه تاریخ میلادی رو به شمسی تبدیل کنه
خودم نتونستم بنویسمش
ممنون
Printable View
سلام
دنباله یه تابع تو اکسس می گردم که بتونه تاریخ میلادی رو به شمسی تبدیل کنه
خودم نتونستم بنویسمش
ممنون
در بانک اطلاعاتی 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/
دوست عزیز از راهنماییتان کمال تشکر را دارم
موفق باشید
این فایل رو جایگزین فایل مشابه اون در پوشه windows/system32 بکن در windows xp تقویمت هجری شمسی میشه اما قبلش تو اکسس hijri calendar رو تیک بزن.
خواهش قابلی نداشت امیدوارم مشکلتون حل بشه
این فایل زمیمه که یکی از دوستان لطف کرده و نوشته، میزارم بر دارید.
راستی تا یادم نرفته واسه استفاده از این Dll باید گزینه Hijri Calender رو غیر فعال کنید
حالا چه جوری از این sepandasadateconvertor.dllاستفاده کنیم.
دوستان عزیز دوستمون تابع می خواستن نه dll
خب تابع براچیته؟ وقتی Dllهست؟
حتما فرق میکنه که تابع میخواد شاید نمیخواد برا هر کامپیوتر client این dll رو هم ببره
ok بابا. اما بالاخره میخواد که یه Installer داشته باشه یا نه؟ .خواستم کمکی کرده باشم.
حالا زیاد اصرار مکنی قبول میکنیم چرا خوشو ناراحت میکنی دستت درد نکنه
khili manon az tabe tabdil tarikh shmase be milade
دوست من این dll در سیستم 32 رجیستر نمی شود و پیام می دهد که برنامه ای در حال ااستفاده از آن است
دوست من سلام
مرسی از dll شما اما این dll تاریخ 31/06/ را نمی پذیرد دلیلش چیست
سلام
ببین این تابع بدردت میخوره
البته این تابع فقط تاریخ رو به شمسی تبدیل میکنه.(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 (".ÊÇÑíÎ ÞÈá ÇÒ 21/3/2001 ÞÇÈá ÞÈæá äãíÈÇÔÏ")
Cancel = 1
Exit Function
End If
A1 = Int(X0 / 365) 'ÊÚÏÇÏ ÓÇáåÇ'
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
دوستان مرسی از کمک شما
من این تابع را در یک ماجول کپی کردم حالا چگونه باید از آن استفاده کنم
مرسی اگر کمک کنید
بفرما مثلا در کجا میخواهی استفاده کنی؟
با سلام
آیا میشه به من بگید چجوری میشه از این توی اکسل استفاده کرد من خیلی به اون نیاز دارم؟
http://www.barnamenevis.org/sh...534#post187534
با سلام
من یک مشکل دارم با گزارشهای اکسس
اون هم اینه که توی گزارشهام نمیتونم ردیف ها رو به طور اتوماتیک بیارم
یعنی برای یک گزارش از یک تا هر چند ردیف که داشت اولین ستون در گزارش ردیف داشته باشم
متشکرم
لینک های بالا رو دیدی
تو رو خدا دقت کنید
Shamsi() تابع
رو کجا باید وارد کنیم