کاربری
کاربر گرامی به خوش آمدید . اگر این نخستین بازدید شما از سایت است , لطفا ثبت نام کنید:

   

جهت تبلیغات در پرشین فروم کلیک کنید

نمایش نتایج: از شماره 1 تا 1 , از مجموع 1

موضوع: آموزش اکسس (بخش پنجم)

  1. #1

    پیش فرض آموزش اکسس (بخش پنجم)

    آموزش اکسس (بخش پنجم)

    ماجول تاريخ هجري شمسي با توابع جانبي آن
    در بانك اطلاعاتي Access فيلدهاي نوع Date پاسخگوي نياز كاربران فارسي كه با تاريخ هجري شمسي كار مي كنند نيست . البته برنامه هايي مثل پارسا ۹۹ تقويم سيستم را به تقويم هجري شمسي تبديل مي كند و بعد از آن كاربران فارسي مي توانند از فيلدهاي نوع Date اكسس استفاده كنند .بدين ترتيب پارسا مشكل تاريخ هجري شمسي را حل ميكند ولي بعضا تاريخ شمسي سيستم بنا به دلايلي از بين ميرود . مثلا اگربعد از نصب پارسا، Officeنصب شود تاريخ هجري شمسي سيستم به هم مي خورد. براي رهايي از وابستگي برنامه هاي شما به پارسا و ... ، توابع زير مي تواند مشكل شما را بطور كامل حل كند .
    اين ماجول در چندين برنامه تست شده و جواب گرفته است شما هم مي توانيد از آن استفاده كنيد.
    (توجه داشته باشيد كه كدهاي نوشته شده ، در اينجا از چپ به راست نمايش داده شده اند ولي با كپي آن در اكسس ، نمايش آن از چپ به راست خواهد شد)

    در صورت استفاده از اين ماجول ، فيلدهاي از نوع تاريخ را بايد از نوع Number تعريف كنيد. توضيحات بيشتر جهت استفاده از ماجول ، درون خود ماجول نوشته شده است.
    براي استفاده از اين ماجول ، از دو خط پايين تر تا انتهاي متن را در حافظه كپي كرده (Copy) و سپس در يك ماجول جديد در اكسس يا VB قرار دهيد (Paste):


    ' ************************************************** ***********
    ' برنامه نويس : حميد آزادي
    ' Email:
    ایمیل:
    لینک و متن درون کدها فقط برای کسانی که ثبت نام کرده اند قابل مشاهده است لطفا وارد شوید OR ثبت نام کنید.

    ' Web Address:
    Link URL:
    لینک و متن درون کدها فقط برای کسانی که ثبت نام کرده اند قابل مشاهده است لطفا وارد شوید OR ثبت نام کنید.


    ' ************************************************** ***********


    ' 1- تعريف كنيد Number(Long) است را بصورت Date فيلدهايي كه نوع آنها
    ' 2- اين فيلدها را بصورت 00/00/00 تنظيم كنيد InputMask خاصيت
    ' بدليل 6 رقمي در نظر گرفتن فيلد تاريخ ، اين توابع تا سال 1399 كارايي دارد
    ' ...
    ' تاريخ جاري سيستم را به هجري شمسي تبديل مي كند Shamsi() تابع
    ' بكار ببريد Now() را مي توانيد در گزارشات بجاي تابع Dat() تابع
    ' :براي جلوگيري از ورود تاريخ غلط به درون يك فيلد بترتيب زير عمل ميكنيد
    ' :بشكل زير بكار ببريد ValidationRule را در خاصيت ValidDate() تابع
    ' ValidDate([نام فيلد])=True
    ' ...


    '*******************************************
    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


    از آی تی ایران

  2. 3 کاربر برای این پست سودمند از Ahmadreza Jafari عزیز تشکر کرده اند:


  3. Left Ad Image/Code 1 needs to be placed here, no larger than 260 pixels in height.
    Right Ad Image/Code 2 needs to be placed here, no larger than 260 pixels in height.

اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. گوگل از تجسس در جیمیل دانش‌آموزان عقب‌نشینی کرد
    توسط چنگیز در انجمن اخبار و تازه های دنیای کامپیوتر و تکنولوژی , نرم افزار
    پاسخ ها: 0
    آخرين نوشته: 02-05-14, 20:20
  2. آموزش اکسس (بخش چهارم)
    توسط Ahmadreza Jafari در انجمن Microsoft Office Access
    پاسخ ها: 1
    آخرين نوشته: 09-10-09, 17:12
  3. آموزش اکسس (بخش ششم)
    توسط Ahmadreza Jafari در انجمن Microsoft Office Access
    پاسخ ها: 1
    آخرين نوشته: 17-03-09, 17:39
  4. آموزش اکسس (بخش دوم)
    توسط Ahmadreza Jafari در انجمن Microsoft Office Access
    پاسخ ها: 1
    آخرين نوشته: 21-10-07, 13:46
  5. آموزش اکسس (بخش اول)
    توسط Ahmadreza Jafari در انجمن Microsoft Office Access
    پاسخ ها: 0
    آخرين نوشته: 16-06-06, 04:50

کلمات کلیدی این موضوع

علاقه مندی ها (Bookmarks)

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
درباره ما

دوستان ما
لینک های مفید
ابزار ها
session بارگذاری مجدد کد امنیتی مندرج در تصویر را وارد کنید: