PDA

View Full Version : کمک در مورد تقویم نویسی


سعید مکاری
پنج شنبه 15 تیر 1385, 14:49 عصر
سلام دوستان من تازه با Barnamenevis.org آشنا شدم و من میخواهم بدونم که چتوری میشه که یک تقویم شمسی بنویسیم سورس نمیخواهم چون سورسهای زیادی دیدم اما هیچ کدومش موثر نبود:گریه:در کل من میخواهم الگوریتم تقویم نویسی رو بدونم ممنون میشم اگه کسی بتونه کمکم کنه مرسی :تشویق:
(سعید مکاری)
aryajonbesh
پنج شنبه 15 تیر 1385, 18:32 عصر
سلام دوست من
به این انجمن خوش آمدید ، من هم چندی پیش با این انجمن آشنا شدم و از فعالیت های اون راضی هستم ، و اما در مورد جواب سوال شما.
دوست من برای اینکه ما بتونیم تاریخ میلادی رو بصورت شمسی یا بلعکس تبدیل کنیم باید اختلاف بین این دو تاریخ رو بدست آورده و از این اختلاف برای دریافت تاریخ مناسب در برناممون استفاده کنیم .
نکته جالب اینجاست که سیستم عامل شما بصورت استاندارد از تاریخ میلادی تبعیت میکنه اما شما با این اختلاف تاریخ کار چندانی صورت نمیتونید بدید چون چندین ماه از سال میلادی با ماه های شمسی تفاوت دارند و شما باید یک کد هوشمند در برنامه خود بنویسید تا در این تاریخ های متفاوت اختلاف صحیح رو بدست بیاره تا برنامه بتونه از اون اختلاف صحیح و درست استفاده کنه و تاریخ درست و بی نقصی رو به شما نشون بده . ببخشید که یک کمی طولانی شد اما در پایان یک کد میذارم امیدوارم مورد استفاده شما واقع بشه.

کد داخل فرم:
Dim a, b, c, mah
Option Base 1

()Private Sub Form_Paint
mah = Array("10", "11", "12", "1", "2", "3", "4", "5", "6", "7", "8", "9")
a = Array(10, 11, 9, 11, 10, 10, 9, 9, 9, 8, 9, 9)
b = Array(20, 19, 20, 20, 21, 21, 22, 22, 22, 22, 21, 21)

Dim D, M, Y, v, k, u
ds = Array("shnbe 1", " shanbe 2", "shanbe 3", "shanbe 4", "shanbe 5", "jome", "shanbe")
D = Day(Now)
M = Month(Now)
Y = Year(Now)
dh = Weekday(Now)
If Y Mod 4 = 0 And M > 2 Then k = 1
If Y Mod 4 = 1 And M < 4 Then k = 1
If Y Mod 4 = 1 And M = 3 Then u = 1
If D > b(M) - k + u Then D = D - b(M) + k - u: M = M + 1 Else D = D + a(M) + k
If M > 3 Then Y = Y - 621 Else Y = Y - 622
If M = 13 Then M = 1
Text1.Text = D & "/" & " " & mah(M) & "/" & " " & Y

همیشه سعی کن آنچه را دوست داری بدست آوری
وگرنه مجبوری آنچه بدست می آید را دوست داشته باشی
سعید مکاری
پنج شنبه 15 تیر 1385, 20:45 عصر
سلام دوستان و با تشکر از aryajonbesh (http://www.barnamenevis.org/forum/member.php?u=19436)
مرسی از کمکتون اما فکر کنم کد بالا یه چیزی تو مایه های سورس هست
ممنون میشم اگه یکی بتونه کد بالا رو به من بفهمونه (توضیح بده) مرسی از دوستان
سعید مکاری
جمعه 16 تیر 1385, 14:35 عصر
سلام
یعنی هیچ کس نمیتونه کد بالا رو معنی کنه و به من بگه ؟؟؟؟؟؟
سعید مکاری
جمعه 16 تیر 1385, 22:26 عصر
دست همگی شما درد نکنه واقعا که توی اولین پست جوابمو کامل گرفتم
yavari
شنبه 17 تیر 1385, 08:22 صبح
سلام

عزیز من ، صبر داشته باش !
الگوریتم کارو دارم ، باید بگردم ...

موفق باشید
ali_lover
شنبه 17 تیر 1385, 18:06 عصر
ببخشد دوستان من این تاپیک رو با تاپیک بالا اشتباه گرفتم شرمنده بهمین خاطر مجبور شدم پاکش کنم
سعید مکاری
شنبه 17 تیر 1385, 18:14 عصر
سلام آقای Yavari من منتظر جواب شما هستم
yavari
سه شنبه 20 تیر 1385, 21:45 عصر
سلام

ببین سعید آقا ، نمی دونم چرا اینجوری شدم و هیچیمو پیدا نمی کنم ،
تنها چیزی که ازش یادمه اینم در مورد تبدیل سال
اینه که اگه از اول فروردین تا 11 دی ماه بود
سال میلادی -621= سال شمسی
و اگه از 11 دی ماه بود تا اول فروردین
سال میلادی -622= سال شمسی
البته اگه درست یادم باشه
متاسفانه فرمول روز و ماه رو اصلا یادم نمی یاد ، البته میشه با استفاده از کدا یه تخمینائی زد اما ضریب خطا خیلیه !
یه کدم داشتم که توضیحاتم داشت اما نمی دونم چرا اینجوری شده !!!

با این حال امیدوارم اگه دوستان فرمول رو دارن ، بذارن !


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/2001#
Dif = DateDiff("d", Miladi_mabna, Format$(Now, "yyyy/mm/dd"))
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 = "&Ocirc;&auml;&Egrave;&aring;"
Case 1
a = "&iacute;&szlig;&Ocirc;&auml;&Egrave;&aring;"
Case 2
a = "&Iuml;&aelig;&Ocirc;&auml;&Egrave;&aring;"
Case 3
a = "&Oacute;&aring; &Ocirc;&auml;&Egrave;&aring;"
Case 4
a = "&aring;&Ccedil;&Ntilde; &Ocirc;&auml;&Egrave;&aring;"
Case 5
a = "&auml;&Igrave; &Ocirc;&auml;&Egrave;&aring;"
Case 6
a = "&Igrave;&atilde;&Uacute;&aring;"
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 MyDay()
Dim D As Long
D = Shamsi
MyDay = DayWeek(D)
End Function
Public Function MyDat()
Dim D As Long
D = Shamsi
MyDat = " 13" & sal(D) & "/" & Format(mah(D), "0#") & "/" & Format(rooz(D), "0#")
End Function
Public Function DateNumber()
Dim D As Long
DateNumber = Shamsi

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 = "&Yacute;&Ntilde;&aelig;&Ntilde;&Iuml;&iacute;&auml;"
Case 2
MahName = "&Ccedil;&Ntilde;&Iuml;&iacute;&Egrave;&aring;&Ocirc;&Ecirc;"
Case 3
MahName = "&Icirc;&Ntilde;&Iuml;&Ccedil;&Iuml;"
Case 4
MahName = "&Ecirc;&iacute;&Ntilde;"
Case 5
MahName = "&atilde;&Ntilde;&Iuml;&Ccedil;&Iuml;"
Case 6
MahName = "&Ocirc;&aring;&Ntilde;&iacute;&aelig;&Ntilde;"
Case 7
MahName = "&atilde;&aring;&Ntilde;"
Case 8
MahName = "&Acirc;&Egrave;&Ccedil;&auml;"
Case 9
MahName = "&Acirc;&ETH;&Ntilde;"
Case 10
MahName = "&Iuml;&iacute;"
Case 11
MahName = "&Egrave;&aring;&atilde;&auml;"
Case 12
MahName = "&Ccedil;&Oacute;&Yacute;&auml;&Iuml;"
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
سعید مکاری
چهارشنبه 21 تیر 1385, 00:54 صبح
مرسی دوست عزیز