تاریخ میلادی به شمسی

[PERSONAL.ATA]

با اهدا سلام و خسته نباشید . بنده کد مربوط به تبديل تاريخ ميلادی به شمسی را از اينترنت ديده ام که خيلی طولانی است استدعا دارد اگر کدی کوتاهتر مد نظرتون هست برايم ارسال کنيد و در موردکد زير هم نحوه کد نویسی تاریخ شمسی در رابطه با متغیر هاو تابع استفاده شده در ان توضيحاتی ارسال فرماييد





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

با تشکر از جنابعالی

[AmirAmiri]

سلام دوست عزیز شما باید از همون کد طولانی استفاده کنی چون این کد ریزره ها درست کار نمیکنن. شاید فقط برای بعضی روزها درست کار کنن ولی در کل مشکل دارن. من برات یه کد میزارم که اونم طولانیه:




Option Explicit

Private Const mcDayOff = 226894
Private mvarGDayTab
Private mvarJDayTab
Private mcSolar As Double

Public Sub GetJalaliDate(ByVal vGYear As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer, pJYear As Integer, pJMonth As Integer, pJDay As Integer, pDayName As String)

Dim mGTotalDay As Long

SetConstants

mGTotalDay = GetDayFromFirstGregorianDay(vGYear, vGMonth, vGDay)
pDayName = GetWeekDayName(mGTotalDay)
GetJalaliYearMonthDay mGTotalDay, vGYear, vGMonth, vGDay
pJDay = vGDay
pJMonth = vGMonth
pJYear = vGYear
End Sub

Private Sub SetConstants()

mvarGDayTab = Array(Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), Array(0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31))
mvarJDayTab = Array(Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29), Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 30))
mcSolar = 365.25 - 0.25 / 33

End Sub

Private Function GetDayFromFirstGregorianDay(ByVal vGYaer As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer) As Long

Dim mGYearDiv4 As Integer, mGYearDiv100 As Integer, mGYearDiv400 As Integer
Dim mGTotalDays As Long

mGYearDiv4 = vGYaer \ 4
mGYearDiv100 = vGYaer \ 100
mGYearDiv400 = vGYaer \ 400

mGTotalDays = GetGDayFromBeginOfYear(vGYaer, vGMonth, vGDay)
mGTotalDays = CLng(vGYaer - 1) * 365 + mGTotalDays + mGYearDiv4 - mGYearDiv100 + mGYearDiv400

GetDayFromFirstGregorianDay = mGTotalDays
End Function

Private Function GetGDayFromBeginOfYear(ByVal vGYear As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer) As Long
Dim mGLeap As Integer
Dim mCount As Integer

GetGDayFromBeginOfYear = vGDay
mGLeap = IsLeapGregorian(vGYear)
For mCount = 1 To vGMonth – 1
GetGDayFromBeginOfYear = GetGDayFromBeginOfYear + mvarGDayTab(mGLeap)(mCount)
Next mCount

End Function

Private Function IsLeapGregorian(ByVal vGYear As Integer) As Integer

If (vGYear Mod 4 = 0 And vGYear Mod 100 <> 0) Or (vGYear Mod 400 = 0) Then
IsLeapGregorian = 1
Else
IsLeapGregorian = 0
End If
End Function

Private Function GetJalaliYearMonthDay(vGTotalDay As Long, pJYear As Integer, pJMonth As Integer, pJDay As Integer)

Dim mJTotalDay As Long
Dim mJYear As Integer
Dim mJDay As Integer
Dim mJLeaps As Integer

mJTotalDay = vGTotalDay – mcDayOff
mJYear = mJTotalDay \ mcSolar

mJLeaps = GetAllJalaliLeapFromBegin(mJYear)

mJDay = mJTotalDay - (365 * CLng(mJYear) + mJLeaps)
mJYear = mJYear + 1

Do While mJDay <= 0
mJYear = mJYear – 1
If IsLeapJalali(mJYear) = 1 Then
mJDay = mJDay + 366
Else
mJDay = mJDay + 365
End If
Loop

If (mJDay = 366 And IsLeapJalali(mJYear) = 0) Then
mJDay = 1
mJYear = mJYear + 1
End If
pJYear = mJYear
GetJalaliMonthDay mJYear, mJDay, pJMonth, pJDay

End Function

Private Function IsLeapJalali(ByVal vJYear As Integer) As Integer

Dim mTemp As Integer

mTemp = vJYear Mod 33
If mTemp = 1 Or mTemp = 5 Or mTemp = 9 Or mTemp = 13 Or mTemp = 17 Or mTemp = 22 Or mTemp = 26 Or mTemp = 30 Then
IsLeapJalali = 1
Else
IsLeapJalali = 0
End If

End Function

Private Function GetAllJalaliLeapFromBegin(ByVal vJYear As Integer) As Integer

Dim mJLeap As Integer
Dim mCurrentCycle As Integer
Dim mJDiv33 As Integer
Dim mCount As Integer
Dim mTemp As Integer

mJDiv33 = vJYear \ 33
mCurrentCycle = vJYear - (mJDiv33 * 33)
mJLeap = mJDiv33 * 8
If mCurrentCycle > 0 Then
mTemp = IIf(mCurrentCycle <= 18, mCurrentCycle, 18)
For mCount = 1 To mTemp Step 4
mJLeap = mJLeap + 1
Next
End If

If mCurrentCycle > 21 Then
mTemp = IIf(mCurrentCycle <= 30, mCurrentCycle, 30)
For mCount = 22 To mTemp Step 4
mJLeap = mJLeap + 1
Next
End If
GetAllJalaliLeapFromBegin = mJLeap

End Function

Private Sub GetJalaliMonthDay(ByVal vJYear As Integer, ByVal vJDayOfYear As Integer, pJMonth As Integer, pJDay As Integer)
Dim mCount As Integer
Dim mJLeap As Integer

mJLeap = IsLeapJalali(vJYear)
mCount = 1
Do While vJDayOfYear > mvarJDayTab(mJLeap)(mCount)
vJDayOfYear = vJDayOfYear - mvarJDayTab(mJLeap)(mCount)
mCount = mCount + 1
Loop
pJMonth = mCount
pJDay = vJDayOfYear
End Sub

Private Function GetWeekDayName(DayFromBegin As Long) As String
Dim Temp As Integer

Temp = DayFromBegin Mod 7
Select Case Temp

Case 0
GetWeekDayName = "يك شنبه"
Case 1
GetWeekDayName = "دو شنبه"
Case 2
GetWeekDayName = "سه شنبه"
Case 3
GetWeekDayName = "چهار شنبه"
Case 4
GetWeekDayName = "پنج شنبه"
Case 5
GetWeekDayName = "جمعه"
Case 6
GetWeekDayName = "شنبه"

End Select

End Function

Public Sub GetGregorianDate(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer, ByRef pGYear As Integer, ByRef pGMonth As Integer, ByRef pGDay As Integer, pDayName As String)

Dim mJTotalDays As Long
Dim mGYear As Integer
Dim mGMonth As Integer
Dim mGDay As Integer

SetConstants

mJTotalDays = GetDayFromFirstJalaliDay(vJYear, vJMonth, vJDay)
GetWeekDayName (mJTotalDays + mcDayOff)
GetGregorianYearMonthDay mJTotalDays, mGYear, mGMonth, mGDay
pGYear = mGYear
pGMonth = mGMonth
pGDay = mGDay
End Sub

Private Function GetDayFromFirstJalaliDay(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer) As Long

Dim mJLeap As Integer
Dim mTemp As Integer

mJLeap = GetAllJalaliLeapFromBegin(vJYear - 1)
mTemp = GetJDayFromBeginOfYear(vJYear, vJMonth, vJDay)
GetDayFromFirstJalaliDay = CLng((vJYear - 1)) * 365 + mJLeap + mTemp

End Function

Private Function GetJDayFromBeginOfYear(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer) As Integer

Dim mCount As Integer
Dim mJLeap As Integer

GetJDayFromBeginOfYear = vJDay
mJLeap = IsLeapJalali(vJYear)
For mCount = 1 To vJMonth – 1
GetJDayFromBeginOfYear = GetJDayFromBeginOfYear + mvarJDayTab(mJLeap)(mCount)
Next mCount

End Function

Private Sub GetGregorianYearMonthDay(vJTotalDays As Long, pGYear As Integer, pGMonth As Integer, pGDay As Integer)

Dim mGTotalDays As Long
Dim mGDiv4 As Integer
Dim mGDiv100 As Integer
Dim mGDiv400 As Integer
Dim mGDays As Integer

mGTotalDays = vJTotalDays + mcDayOff
pGYear = mGTotalDays \ mcSolar
mGDiv4 = pGYear \ 4
mGDiv100 = pGYear \ 100
mGDiv400 = pGYear \ 400

' Find Gregorian day of year
mGDays = mGTotalDays - (365 * CLng(pGYear)) - (mGDiv4 - mGDiv100 + mGDiv400)
pGYear = pGYear + 1

Do While mGDays <= 0
pGYear = pGYear – 1
If IsLeapGregorian(pGYear) = 1 Then
mGDays = mGDays + 366
Else
mGDays = mGDays + 365
End If
Loop

If (mGDays = 366 And IsLeapGregorian(pGYear) = 0) Then
mGDays = 1
pGYear = pGYear + 1
End If
GetGregorianMonthDay pGYear, mGDays, pGMonth, pGDay
End Sub

Private Sub GetGregorianMonthDay(ByVal vGYear As Integer, ByVal vGDayOfYear As Integer, pGMonth As Integer, pGDay As Integer)
Dim mCount As Integer
Dim mGLeap

mGLeap = IsLeapGregorian(vGYear)
mCount = 1
Do While vGDayOfYear > mvarGDayTab(mGLeap)(mCount)
vGDayOfYear = vGDayOfYear - mvarGDayTab(mGLeap)(mCount)
mCount = mCount + 1
Loop
pGMonth = mCount
pGDay = vGDayOfYear
End Sub


کد بالا رو تو ماژول بنویس و کد زیر رو هم تو فرمت بنویس:



Private Sub Form_Load()
Dim intYear As Integer, intMonth As Integer, intDay As Integer
Dim strDayName As String, strShamsi As String
GetJalaliDate Year(Date), Month(Date), Day(Date), intYear, intMonth, intDay, strDayName
strShamsi = intYear & "/" & intMonth & "/" & intDay & " " & strDayName
Me.Caption = strShamsi
End Sub


موفق باشید.

[AmirAmiri]

سورس کد بالا رو میتونی از اینجا دانلود کنی.
http://v-basic.persiangig.com/VB6/Source/Shamsi_Date.zip

[.:KeihanCPU:.]

دوست عزیز فایلها رو توی سایت آپلود کنید
فایلتون ایراد داره ,خواهشا وقتی فایلی واسه دانلود میذارین چک کنین که واسه کاربرا مشکل ایجاد نشه...

[zacaria]

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

[H4i0 ACP]

سلام
تو همین سایت هم یه اکتیوایکس جالب هستش ، که می تونید استفاده کنید .