PERSONAL.ATA
چهارشنبه 25 اردیبهشت 1387, 20:13 عصر
با اهدا سلام و خسته نباشید . بنده کد مربوط به تبديل تاريخ ميلادی به شمسی را از اينترنت ديده ام که خيلی طولانی است استدعا دارد اگر کدی کوتاهتر مد نظرتون هست برايم ارسال کنيد و در موردکد زير هم نحوه کد نویسی تاریخ شمسی در رابطه با متغیر هاو تابع استفاده شده در ان توضيحاتی ارسال فرماييد
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
چهارشنبه 25 اردیبهشت 1387, 20:37 عصر
سلام دوست عزیز شما باید از همون کد طولانی استفاده کنی چون این کد ریزره ها درست کار نمیکنن. شاید فقط برای بعضی روزها درست کار کنن ولی در کل مشکل دارن. من برات یه کد میزارم که اونم طولانیه:
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
چهارشنبه 25 اردیبهشت 1387, 20:39 عصر
سورس کد بالا رو میتونی از اینجا دانلود کنی.
http://v-basic.persiangig.com/VB6/Source/Shamsi_Date.zip
.:KeihanCPU:.
چهارشنبه 25 اردیبهشت 1387, 21:50 عصر
دوست عزیز فایلها رو توی سایت آپلود کنید
فایلتون ایراد داره ,خواهشا وقتی فایلی واسه دانلود میذارین چک کنین که واسه کاربرا مشکل ایجاد نشه...
zacaria
چهارشنبه 25 اردیبهشت 1387, 22:23 عصر
سلام
دوست عزيز ببين اين بدرت ميخوره
موفق باشيد
H4i0 ACP
چهارشنبه 25 اردیبهشت 1387, 22:38 عصر
سلام
تو همین سایت هم یه اکتیوایکس جالب هستش ، که می تونید استفاده کنید .
vBulletin® v4.2.5, Copyright ©2000-1403, Jelsoft Enterprises Ltd.