VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cFardate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Dim mstart As Date
Dim sstart As Date
Dim sbase As Integer
Dim sleapbmp As String
Dim smonths(12) As Integer
'تبديل تابع ميلادي به شمسي
    Public Function MiladiToShamsi(d As Date) As String
      Dim aday, amonth, ayear, value As Integer
      Dim A1, b1, c1 As String
      Dim Tday, Tmonth, Tyear, temp, CabisehYear, TMonthEnd As Integer
      Dim numdays As Long
      Dim now_day As Date
      Dim a As Date
      now_day = DateSerial(year(d), month(d), Day(d))
      numdays = now_day - #3/21/1921#
      aday = 1
      amonth = 1
      ayear = 1300
      CabisehYear = numdays \ 1461 ' then number of kabiseh years
      numdays = numdays - CabisehYear * 1461
      Tyear = numdays \ 365
      If Tyear = 4 Then
        Tyear = Tyear - 1
      End If
      numdays = numdays - Tyear * 365
      Tmonth = numdays \ 31
      If Tmonth > 6 Then
        Tmonth = 6
      End If
      numdays = numdays - Tmonth * 31
      TMonthEnd = 0
      If numdays >= 30 And Tmonth = 6 Then
        TMonthEnd = numdays \ 30
        If TMonthEnd >= 5 Then
         TMonthEnd = 5
        End If
        numdays = numdays - TMonthEnd * 30
      End If
      Tmonth = TMonthEnd + Tmonth
      Tday = numdays
      Tyear = Tyear + CabisehYear * 4
       ayear = ayear + Tyear
      amonth = amonth + Tmonth
      aday = aday + Tday
      A1 = Trim(Str(ayear))
      b1 = Trim(Str(amonth))
      c1 = Trim(Str(aday))
      If Len(b1) = 1 Then
        b1 = "0" & b1
      End If
      If Len(c1) = 1 Then
        c1 = "0" & c1
      End If
      MiladiToShamsi = A1 & "/" & b1 & "/" & c1
 End Function

'تابع چك كردن يك تاريخ . مثلا اين تابع در مقدار "13780532" مقدار
'False برمي گرداند
Public Function checkDate(StrDate As String) As Boolean
 Dim syear, smonth, sday As String
 Dim y, m, d As Integer
 Dim errHappen As Boolean
 errHappen = False
    If Len(StrDate) <> 8 Then
      errHappen = True
    End If
    syear = left(StrDate, 4)
    smonth = left(right(StrDate, 4), 2)
    sday = right(StrDate, 2)
    y = val(syear)
    m = val(smonth)
    d = val(sday)
    If d <= 0 Or d > 31 Then
     errHappen = True
    End If
   If m <= 0 Or m > 12 Then
     errHappen = True
    End If
   If y <= 1304 Or y > 1600 Then
     errHappen = True
    End If
  If m > 6 Then
     If d = 31 Then
     errHappen = True
    End If
  End If
  If m = 12 Then
   If ((y - 1303) Mod 4) <> 0 Then 'يعني كبيسه نيست
     If d >= 30 Then
      errHappen = True
     End If
   End If
  End If
  If errHappen Then
    checkDate = False
  Else
    checkDate = True
  End If
 End Function

'تابع تبديل تاريخ شمسي به ميلادي
Public Function ShamsiToMiladi(ByRef d As String) As Date
On Error GoTo ErrDesc
 Dim start, mid, final As Long
 Dim MiladiStart, dateTemp As Date
 Dim shamsiDate  As String
 Dim NotFound As Boolean
   If checkDate(d) Then
   MiladiStart = #3/21/1921#
 start = 0
 final = 100000 'تعداد روز
 mid = (start + final) \ 2
 Dim IsOk As Boolean
 IsOk = False
 NotFound = True
 While NotFound And mid <> 0
   mid = (start + final) \ 2
   dateTemp = mid + MiladiStart
   shamsiDate = MiladiToShamsi(dateTemp)
   If shamsiDate = d Then
     NotFound = False
     IsOk = True
   Else
     If shamsiDate < d Then
       start = mid
     Else
       final = mid
     End If
   End If
 Wend
 If mid = 0 Then 'خطا
    MsgBox "خطا در محاسبه تاريخ. لطفا موضوع را به مسئول سيستم كزارش دهيد"
    ShamsiToMiladi = Now()
 Else
    ShamsiToMiladi = dateTemp
 End If
 Else
   MsgBox "تاريخ وارد شده نامعتبر است"
 End If
 Exit Function
ErrDesc:
 MsgBox "خطا در محاسبه تاريخ"
  End Function
'اين تابع يك ماه به تاريخ وارد شده اضافه مي كند.
Public Function AddOneMonth(StrDate As String) As String
Dim yy, dd, mm As Integer
Dim syear, smonth, sday, A1, b1, c1 As String
 syear = left(StrDate, 4)
 smonth = left(right(StrDate, 4), 2)
 sday = right(StrDate, 2)
 yy = val(syear)
 mm = val(smonth)
 dd = val(sday)
 If (dd = 31 And mm = 6) Or (dd = 30 And mm = 11 And (((yy - 1303) Mod 4) <> 0)) Then
    dd = dd - 1
 End If
 If mm = 12 Then
    mm = 1
    yy = yy + 1
 Else
   mm = mm + 1
 End If
 A1 = Trim(Str(yy))
 b1 = Trim(Str(mm))
 c1 = Trim(Str(dd))
 If Len(b1) = 1 Then
   b1 = "0" & b1
 End If
 If Len(c1) = 1 Then
   c1 = "0" & c1
 End If
 AddOneMonth = A1 & b1 & c1
End Function

'اين تابع تاريخ را با فرمت پايين نشان مي دهد
'بصورت ####/##/##
Public Function ShowDate(StrDate As String) As String
Dim yy, dd, mm As Integer
Dim syear, smonth, sday, A1, b1, c1 As String
 syear = left(StrDate, 4)
 smonth = left(right(StrDate, 4), 2)
 sday = right(StrDate, 2)
 ShowDate = Trim(syear) & "/" & Trim(smonth) & "/" & Trim(sday)
End Function
'اين تابع تعداد مشخصي ماه را به يك تاريخ اضافه مي كند
Public Function AddNMonth(StrDate As String, n As Integer) As String
 Dim yy As Integer
 Dim dd As Integer
 Dim mm As Integer
 Dim FD As Integer
 Dim kk As Integer
 Dim FM As Integer
 Dim FY As Integer
 Dim syear As String
 Dim smonth As String
 Dim sday As String
 Dim A1 As String
 Dim b1 As String
 Dim c1 As String
 syear = left(StrDate, 4)
 smonth = left(right(StrDate, 4), 2)
 sday = right(StrDate, 2)
 
 
 yy = val(syear)
 mm = val(smonth) + n
 dd = val(sday)
 
 FD = 0
 kk = 0
 FM = 0
 FY = 0
 
 FY = FY + (mm \ 12)
 mm = mm Mod 12
 
 If mm = 0 Then
  mm = 12
  FY = FY - 1
 End If
  yy = yy + FY
 If (dd = 31 And mm > 6 And mm < 12) Then
   dd = 30
 End If
 If ((dd = 30 Or dd = 31) And mm = 12) Then
  If (((yy - 1303) Mod 4) <> 0) Then
   dd = 29
  Else
   dd = 30
 End If
End If
 A1 = Trim(Str(yy))
 b1 = Trim(Str(mm))
 c1 = Trim(Str(dd))
 If Len(b1) = 1 Then
   b1 = "0" & b1
 End If
 If Len(c1) = 1 Then
   c1 = "0" & c1
 End If
 AddNMonth = A1 & b1 & c1
End Function
'اين تابع تاريخ ورودي رااگر اشتباه بود تا حد امكان تصحيح مي كند
Public Function CorrectDate(StrDate As String) As String
 Dim syear, smonth, sday As String
 Dim A1, b1, c1 As String
 Dim y, m, d As Integer
 Dim errHappen As Boolean
 errHappen = False
    syear = left(StrDate, 4)
    smonth = left(right(StrDate, 4), 2)
    sday = right(StrDate, 2)
    y = val(syear)
    m = val(smonth)
    d = val(sday)
    If d <= 0 Or d > 31 Then
     errHappen = True
     d = 30
    End If
   If m <= 0 Or m > 12 Then
     errHappen = True
     m = 12
    End If
   If y <= 1304 Or y > 1600 Then
     errHappen = True
     y = 1355
    End If
  If m > 6 Then
     If d = 31 Then
     errHappen = True
      d = 30
     
    End If
  End If
  If m = 12 Then
   If ((y - 1303) Mod 4) <> 0 Then 'يعني كبيسه نيست
     If d >= 30 Then
      errHappen = True
      d = 29
     End If
   End If
  End If
  
 A1 = Trim(Str(y))
 b1 = Trim(Str(m))
 c1 = Trim(Str(d))
 If Len(b1) = 1 Then
   b1 = "0" & b1
 End If
 If Len(c1) = 1 Then
   c1 = "0" & c1
 End If
 CorrectDate = A1 & "/" & b1 & "/" & c1
 End Function

'اين تابع روزهاي يك ماه و سال مشخص را بر مي گرداند
Public Function GetDays(month, year As Integer) As Integer
 Dim DaysPerMonth As Integer
  If month <= 6 Then
   DaysPerMonth = 31
 Else
  If month <= 11 Then
     DaysPerMonth = 30
   Else
     DaysPerMonth = 29
   End If
 End If
 If ((year - 1339) Mod 4 = 0) And month = 12 Then
   DaysPerMonth = 30
 End If
GetDays = DaysPerMonth
End Function
'ماه فعلي
Public Function GetCurrentMonth() As Integer
  GetCurrentMonth = mid(MiladiToShamsi(Now()), 5, 2)
End Function

'سال فعلي
Public Function GetCurrentYear() As Integer
  GetCurrentYear = left(MiladiToShamsi(Now()), 4)
End Function
'روز فعلي
Public Function GetCurrentDay() As Integer
  GetCurrentDay = right(MiladiToShamsi(Now()), 2)
End Function
'اختلاف دو تابع ميلادي را به روز محاسبه مي كند
Public Function DiffMiladiInDay(strDate1 As Date, strDate2 As Date) As Long
  DiffMiladiInDay = Fix(strDate2 - strDate1)
End Function
'اختلاف دو تابع شمسي را به روز محاسبه مي كند
Public Function DiffShamsiInDay(strDate1 As String, strDate2 As String) As Long
  DiffShamsiInDay = Fix(ShamsiToMiladi(strDate2) - ShamsiToMiladi(strDate1))
End Function
'تاريخ امروز را به صورت رشته بر مي گرداند
Public Function today() As String
  today = MiladiToShamsi(Now())
End Function

'
'  تابع تبديل تاريخ شمسي از رشته به عدد
'
'              ورودي : رشته حاوي تاريخ
'
'                              : خروجي
'        صفر  اگر تاريخ غلط باشد
'       عدد تاريخ  اگر تاريخ صحيح باشد

Function StrShamsiDateToLong(StrDate As String) As Long
  Dim StrYear As String
  Dim StrMonth As String
  Dim StrDay As String
  Dim lngYear As Long
  Dim lngMonth As Long
  Dim lngDay As Long
  Dim lngResult As Long
  If checkDate(StrDate) Then
    StrYear = left(StrDate, 4)
    StrMonth = mid(StrDate, 5, 2)
    StrDay = right(StrDate, 2)
    lngYear = StrYear
    lngMonth = StrMonth
    lngDay = StrDay
    StrShamsiDateToLong = lngYear * 10000 + lngMonth * 100 + lngDay
  Else
    StrShamsiDateToLong = 0
  End If
End Function

'
'  تابع تبديل تاريخ شمسي از عدد به رشته
'
'              ورودي : عدد حاوي تاريخ
'
'                              : خروجي
'          اگر تاريخ غلط باشد NULL
'       رشته تاريخ  اگر تاريخ صحيح باشد
Function LongShamsiDateToStr(ShDate As Variant) As String
  Dim strTemp As String
  If ShDate < 10000000 Then
    LongShamsiDateToStr = ""
  Else
    strTemp = CStr(ShDate)
    LongShamsiDateToStr = left(strTemp, 4) + mid(strTemp, 5, 2) + right(strTemp, 2)
  End If
End Function

' تاريخ امروز را با تعدادي روز جمع كرده و تاريخ شمسي نهايي را بر مي گرداند
Public Function AfterDate(days As Integer) As String
AfterDate = MiladiToShamsi(Now() + days)
End Function
'تاريخ امروز را از تعدادي روز كم كرده و تاريخ شمسي نهايي را بر مي گرداند
Public Function BeforeDate(days As Integer) As String
BeforeDate = MiladiToShamsi(Now() - days)
End Function

'اين تابع روزهاي  هفته را به صورت يك عدد بر مي گرداند
'شنبه : 0
'يكشنبه:1
'دوشنبه:2
'سه شنبه:3
'چهار شنبه:4
'پنچشنبه:5
'جمعه:6

Public Function WeekDaysName() As Integer
WeekDaysName = Fix((Now() - ShamsiToMiladi("13800104"))) Mod 7
 'تاريخ 13800104 شنبه مي باشد
End Function
Public Function WeekDaysStrName() As String
Select Case Fix((Now() - ShamsiToMiladi("13800104"))) Mod 7
    Case 0:
        WeekDaysStrName = "شنبه"
    Case 1:
        WeekDaysStrName = "يك شنبه"
    Case 2:
        WeekDaysStrName = "دو شنبه"
    Case 3:
        WeekDaysStrName = "سه شنبه"
    Case 4:
        WeekDaysStrName = "چهارشنبه"
    Case 5:
        WeekDaysStrName = "پنج شنبه"
    Case 6:
        WeekDaysStrName = "جمعه"

End Select
 'تاريخ 13800104 شنبه مي باشد
End Function

'اين تابع نام ماههاي شمسي را به صورت يك رشته بر مي گرداند
Public Function GetMonthName(Month_No As Integer) As String
 Select Case Month_No
   Case 1:
     GetMonthName = "فروردين"
   Case 2:
     GetMonthName = "ارديبهشت"
   Case 3:
     GetMonthName = "خرداد"
   Case 4:
     GetMonthName = "تير"
   Case 5:
     GetMonthName = "مرداد"
   Case 6:
     GetMonthName = "شهريور"
   Case 7:
     GetMonthName = "مهر"
   Case 8:
     GetMonthName = "آبان"
   Case 9:
     GetMonthName = "آذر"
   Case 10:
     GetMonthName = "دي"
   Case 11:
     GetMonthName = "بهمن"
   Case 12:
     GetMonthName = "اسفند"
   Case Else
     GetMonthName = "نامعتبر"
 End Select
End Function

'اين تابع تاريخ روز سرور را به شمسي (8 كاراكتر)  برمي گرداند
'براي استفاده از اين تابع بايستي به قسمتهاي زير مراجعه كرد:
'Database : Common
'Stored Procedure : Server_Today
'   در پروژه ايجاد نماييدServer_Today را با نامCommand  سپس يك

'DataEnviroment : Hprsn_DE
'Connection :CN
'Command Name: Server_Today

'سپس مي توانيد از تابع زير استفاده نماييد:
'به خاطر اينكه اين تابع داراي متغيرهاي خارجي است فعلا غير فعال شده است
'در صورت تمايل به استفاده آنرا بايستي  در پروژه خودتان كپي كرده و فعال كنيد

'Public Function Server_Today() As String
' Dim FLD As Field
' Dim S_Date As Date 'تاريخ ميلادي سرور
'  '  برقرار شده استConnectionفرض بر اين است كه
'  Hprsn_DE.Server_Today
'  For Each FLD In Hprsn_DE.rsServer_Today.Fields
'    S_Date = FLD.value
'  Next
'
'  Hprsn_DE.rsServer_Today.Close
'  Server_Today = MiladiToShamsi(S_Date)
'
'End Function
Public Function m2s(Mdate As Date) As String
Call Init
Dim dt, val As Date
Dim syy As Integer
Dim smm As Integer
Dim sdd As Integer
dt = CDate(Trim(Str(year(Mdate))) + "/" + Trim(Str(month(Mdate))) + "/" + Trim(Str(Day(Mdate))))
val = dt - mstart + 1
syy = year(sstart)
smm = month(sstart)
sdd = Day(sstart)
While val > 365
   If issleap(syy) = True Then
      val = val - 1
   End If
    val = val - 365
    syy = syy + 1
Wend
While val > smonths(smm)
   val = val - smonths(smm)
   smm = smm + 1
Wend
sdd = val
If smm = 12 And sdd = 30 Then
    If Not issleap(syy) Then
        syy = syy + 1
        smm = 1
        sdd = 1
     End If
End If
 m2s = Trim(Str(syy)) + "/" + IIf(Len(Trim(Str(smm))) < 2, "0" & Trim(Str(smm)), Trim(Str(smm))) + "/" + IIf(Len(Trim(Str(sdd))) < 2, "0" & Trim(Str(sdd)), Trim(Str(sdd)))
End Function
Public Function s2m(FD As String) As Date
   Dim syy As Integer
   Dim smm As Integer
   Dim sdd As Integer
   Dim val As Long
   Dim By  As Integer
   If Not fdvalid(FD) Then
      s2m = Format(Date, "yyyy/mm/dd")
      Exit Function
   End If
   syy = fdyear(FD)
   smm = fdmon(FD)
   sdd = fdday(FD)
   By = year(sstart)
   val = 0
   While By < syy
      If issleap(By) Then
         val = val + 1
      End If
      val = val + 365
      By = By + 1
   Wend
   For i = 1 To smm - 1
       val = val + smonths(i)
   Next
   val = val + sdd
   s2m = Format(mstart + val - 1, "yyyy/mm/dd")
End Function
Public Function issleap(Yr As Integer) As Boolean
  ind = (Yr - sbase) Mod 128 + 1
  issleap = IIf(mid(sleapbmp, ind, 1) = "1", True, False)
End Function

Public Function fdyear(FD As String) As Integer
   If InStr(FD, "/") = 0 Then
     fdyear = 0
     Exit Function
   End If
   fdyear = val(left(FD, InStr(FD, "/") - 1))
End Function
Public Function fdday(FD As String) As Integer
   If InStr(FD, "/") = 0 Then
      fdday = 0
      Exit Function
   End If
   fdday = val(mid(FD, InStr(6, FD, "/") + 1))
End Function
Public Function fdmon(FD As String) As Integer
   Dim tstr$
   If InStr(FD, "/") = 0 Then
      fdmon = 0
      Exit Function
   End If
  tstr = mid(FD, InStr(FD, "/") + 1)
  fdmon = val(left(tstr, InStr(tstr, "/") - 1))
End Function
Public Function fdvalid(FD As String) As Boolean
  If right(FD, 2) < 1 Or right(FD, 2) > 31 Then
    fdvalid = False
    Exit Function
  End If
  If mid(FD, 6, 2) < 1 Or mid(FD, 6, 2) > 12 Then
    fdvalid = False
    Exit Function
  End If
  If mid(FD, 6, 2) > 6 And mid(FD, 9, 2) > 30 Then
    fdvalid = False
    Exit Function
  End If
  If mid(FD, 1, 1) = 0 And mid(FD, 2, 1) = 0 Then
    fdvalid = False
    Exit Function
  End If
  If mid(FD, 4, 1) = 0 And mid(FD, 5, 1) = 0 Then
    fdvalid = False
    Exit Function
  End If
  If mid(FD, 7, 1) = 0 And mid(FD, 8, 1) = 0 Then
    fdvalid = False
    Exit Function
  End If
  fdvalid = True
End Function
Public Sub Init()
   sleapbmp = "00001000100010001000100010001000010001000100010001000100010001000010001000100010001000100010001000010001000100010001000100010001"
   sbase = 475
   mstart = #3/21/1900#
   sstart = #1/1/1279#
   'mstart={1900/3/21}
   'sstart={1279/1/1}
   smonths(1) = 31
   smonths(2) = 31
   smonths(3) = 31
   smonths(4) = 31
   smonths(5) = 31
   smonths(6) = 31
   smonths(7) = 30
   smonths(8) = 30
   smonths(9) = 30
   smonths(10) = 30
   smonths(11) = 30
   smonths(12) = 29
End Sub