صفحه 2 از 2 اولاول 12
نمایش نتایج 41 تا 75 از 75

نام تاپیک: ماژول کامل تاریخ شمسی در اکسس با VBA

  1. #41
    کاربر تازه وارد آواتار aimaz23
    تاریخ عضویت
    مرداد 1386
    محل زندگی
    اهواز
    پست
    98

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    یه سوال ازاین ماژول ها چطوری میشه در تیبل استفاده کرد یا فقط در کوئری ریپورت فرم قابل استفاده هستند
    ممنون میشم راهنمایی کنید

  2. #42

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام من تازه کارم ببخشید می تونم بپرسم چطوری میتونم از ماژول های شما عزیزان در برنامه خودم استفاده کنم فعلا در خد ساخت فرم و جدول هستم 2 روزه کار عملی شروع کردم

  3. #43

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام به همه دوستان
    میشه بگید چه جوری باید از این ماژول استفاده کرد؟
    من می خوام جدولم یه فیلدش از نوع تاریخ شمسی باشه
    ممنون

  4. #44
    کاربر دائمی آواتار Rasool-GH
    تاریخ عضویت
    دی 1387
    محل زندگی
    خراسان
    پست
    704

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    دوستان در جهت تکمیل توضیحات پست اول و دوم اظهار نظر کنید لطفا

  5. #45
    کاربر دائمی آواتار Rasool-GH
    تاریخ عضویت
    دی 1387
    محل زندگی
    خراسان
    پست
    704

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

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

  6. #46
    کاربر دائمی آواتار Rasool-GH
    تاریخ عضویت
    دی 1387
    محل زندگی
    خراسان
    پست
    704

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام
    این نسخه تازه تکمیل شده و یک سری تغییرات رو اعمال کردم که امکان داره با نسخه های قبلی در بعضی موارد و نام توابع همخوانی نداشته باشه
    ضمنا توابع مربوط به محاسبه چندمین روز سال و نام روز و ماه هم اصلاح و اضافه شده
    فایل های ضمیمه فایل های ضمیمه

  7. #47

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    آقا رسول عزیز متشکرم از زحماتتون. فقط من میخوام بدونم ماسک 0000/00/00 با ماسکی که پیشنهاد شده یعنی -,0000/00/0,0 چه تفاوتی داره؟
    البته ماسک رو وقتی میذاریم به این شکل تبدیل میشه:
    \-,0000/00/0,0
    در واقع شیوه نمایش تاریخ به این صورته:
    -,1404/02/2,4

  8. #48

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط noorionline مشاهده تاپیک
    آقا رسول عزیز متشکرم از زحماتتون. فقط من میخوام بدونم ماسک 0000/00/00 با ماسکی که پیشنهاد شده یعنی -,0000/00/0,0 چه تفاوتی داره؟
    البته ماسک رو وقتی میذاریم به این شکل تبدیل میشه:
    \-,0000/00/0,0
    در واقع شیوه نمایش تاریخ به این صورته:
    -,1404/02/2,4
    سلام دوست عزیز.
    ماسک رو به این صورت وارد کن
    0000/00/00;0;-

    نتیجه اینطوری میشه
    1395/02/25


    یاحق

  9. #49

    نقل قول: ماژول کامل تاریخ شمسی 8 رقمی در اکسس

    بینهایت سپاسگزارم

  10. #50

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    آقا کارت خیلی درسته خیلی ممنونم ازت که همچین چیزی رو گذاشتی ملت استفاده کنن مرسی انشالله که 50 در دنیا صد در آخرت نصیبت بشه

  11. #51
    کاربر دائمی آواتار Mehr@ban
    تاریخ عضویت
    آبان 1389
    محل زندگی
    بچه محله امام رضا
    پست
    562

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام

    دوتا مطلب

    اول اینکه این ماژول ارزشمند که توسط آقا رسول عزیز تجمیع و منتشر شد، آپدیت نشده و یا دیگر دوستان بروز رسانی برای این ماژول ندادن؟
    دوم اینکه اگر بخوام محدوده بین دو تاریخ شمسی رو بدست بیارم که اکثرا برای تهیه گزارش کاربرد داره رو بدست بیارم چطور هست؟ همون دستور Between

  12. #52
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام از تابع Diff ماژول استفاده كنيد:
    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

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  13. #53
    کاربر دائمی آواتار Mehr@ban
    تاریخ عضویت
    آبان 1389
    محل زندگی
    بچه محله امام رضا
    پست
    562

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    من هر کاری کردم نشد
    میشه این نمونه رو یه بازبینی بکنید؟
    فایل های ضمیمه فایل های ضمیمه

  14. #54
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام
    نمونه شما تغيير دادم ببينيد مشكل برطرف شده.
    فایل های ضمیمه فایل های ضمیمه

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  15. #55
    کاربر دائمی آواتار Mehr@ban
    تاریخ عضویت
    آبان 1389
    محل زندگی
    بچه محله امام رضا
    پست
    562

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط amirzazadeh مشاهده تاپیک
    سلام
    نمونه شما تغيير دادم ببينيد مشكل برطرف شده.
    تشکر
    پس دستور like با دستور between قابل ادغام نیست مستقیما؟
    ضمن اینکه بعد از انجام دستورفیلتر سازی، با کلیک بر روی دکمه حذف فیلتر، سابفرم کلا خالی میشه و داده ای رو نشون نمیده!

    در مورد بازه زمانی برای ساعت هم به همین نحو نوشته میشه؟

  16. #56
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام
    با دستور like قابل اجرا هست ولي چون يكي از جداول برنامه اپلود نشده بود خطا ميداد.اگه نمونه شامل جداول مرتبط اپلود بشه بهتر ميشه جواب داد.

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  17. #57
    کاربر دائمی آواتار Mehr@ban
    تاریخ عضویت
    آبان 1389
    محل زندگی
    بچه محله امام رضا
    پست
    562

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    ممنونم بابت پیگیری
    ولی جدول مرتبط با این فرم همین یکی هست که در ضمیمه موجوده
    یعنی هم فیلدهای فرم و هم سابفرم به یک جدول مرتبط هست
    جدول دومی نیست

  18. #58
    منتظر تایید آدرس ایمیل
    تاریخ عضویت
    اسفند 1394
    پست
    39

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط Mehr@ban مشاهده تاپیک
    سلام

    دوتا مطلب

    اول اینکه این ماژول ارزشمند که توسط آقا رسول عزیز تجمیع و منتشر شد، آپدیت نشده و یا دیگر دوستان بروز رسانی برای این ماژول ندادن؟
    دوم اینکه اگر بخوام محدوده بین دو تاریخ شمسی رو بدست بیارم که اکثرا برای تهیه گزارش کاربرد داره رو بدست بیارم چطور هست؟ همون دستور Between
    سلام !
    نیازی به استفاده از تابع ماژول تاریخ شمسی نیست ، در همون نمونه اولیه خودت برای فیلتر کردن از از کد های زیر استفاده کن !

    Me.frm_sublogs.Form.Filter = "log_EventDate >= '" & txtStartDate & "' and log_EventDate <= '" & txtEndDate & "'"
    Me.frm_sublogs.Form.FilterOn = True
    Me.frm_sublogs.Requery


    ضمناً نام سابفرم را خلاصه تر کن ، من آن را به frm_sublogs تغییر دادم

    برای حذف فیلتر هم Me.frm_sublogs.Form.Filter را مساوی "" قرار بده
    یا علی

  19. #59

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    واسه چی همه ضمیمه ها فقط حاوی فرم هستش و جدول نداره پس اطلاعات به چه روشی در جدول ذخیره بشه

  20. #60

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    خیلی خوب بود واقعا ممنونم

  21. #61

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    با سلام به همه استادان عزیز من از یک ماژول شمسی در یک برنامه استفاده کردم ولی متاسفانه از اول دسامبر دیگه کار نمی کنه چرا لطفا از دوستان راهنمایی بفرمایید قبلا سپاسگزارم

  22. #62

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    با سلام به اساتید محترم
    من در یک برنامه از ماژول تاریخ شمسی استفاده کردم ولی متاسفانه از اول سپتامبر دیگه جواب نمی ده و با باز کردن برنامه پیغام خطای Run-time error '6':over flow رو میده مشکل کجاست ممنون

  23. #63
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط hosain937 مشاهده تاپیک
    با سلام به اساتید محترم
    من در یک برنامه از ماژول تاریخ شمسی استفاده کردم ولی متاسفانه از اول سپتامبر دیگه جواب نمی ده و با باز کردن برنامه پیغام خطای Run-time error '6':over flow رو میده مشکل کجاست ممنون
    لطفا نمونه كارتون رو اپلود كنيد.

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  24. #64

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    Option Compare Database
    'Çíä ãÊÛííÑ ãÞÏÇÑ ßáíß ÔÏå ÏÑ ÝÑã ÊÞæíã Ñæ ÈÕæÑÊ ÓÑÇÓÑí ÏÑ ÎæÏÔ ÐÎíÑå ãíßäå
    Public STRDATE As String
    '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    ' Ç' ãÇŽæá ÇÕáÇÍ ÔÏå ÌäÇÈ ÂÒÇÏí ÊæÓØ ÑÓæá ÛáÇãí Èå ÊÇÑíÎ 1390/10/15
    ' 1- ÊÚÑíÝ ßäíÏ Number(Long) ÇÓÊ ÑÇ ÈÕæÑÊ Date Ç' ÝíáÏåÇíí ßå äæÚ ÂäåÇ
    ' 2- Çíä ÝíáÏåÇ ÑÇ ÈÕæÑÊ 0000/00/00 ÊäÙíã ßäíÏ InputMask Ç' ÎÇÕíÊ
    ' Ç' ÈÏáíá 8 ÑÞãí ÏÑ äÙÑ ÑÝÊä ÝíáÏ ÊÇÑíÎ ¡ Çíä ÊæÇÈÚ ÊÇ ÓÇá 9999 ßÇÑÇíí ÏÇÑÏ
    ' ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå åÌÑí ÔãÓí ÊÈÏíá ãí ßäÏ Shamsi() Ç' ÊÇÈÚ
    ' ÈßÇÑ ÈÈÑíÏ Now() ÑÇ ãí ÊæÇäíÏ ÏÑ ÒÇÑÔÇÊ ÈÌÇí ÊÇÈÚ Dat() Ç' ÊÇÈÚ
    ' Èå ßÇÑ ÈÈÑíÏ / ÑÇ ãíÊæÇäíÏ ÌåÊ ÏÑÌ ÊÇÑíÎ ÏÑ ÌÏÇæá Èå åãÑÇå ShamsiDat() Ç' ÊÇÈÚ
    ' Ç' ÈÑÇí ÌáæíÑí ÇÒ æÑæÏ ÊÇÑíÎ ÛáØ Èå ÏÑæä íß ÝíáÏ ÈÊÑÊíÈ ÒíÑ Úãá ãíßäíÏ
    ' ÝíáÏ ãæÑÏ äÙÑ ÈßÇÑ ÈÈÑíÏ ValidationRule ÑÇ ÏÑ ÎÇÕíÊ ValidDate([Field Name])=True Ç' ÊÇÈÚ
    '/////////////////////////////////////////////////////////////////////////////////////////////


    Public Static Function Shamsi() As Long
    'Çíä ÊÇÈÚ ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå ÊÇÑíÎ åÌÑí ÔãÓí ÊÈÏíá ãí ßäÏ
    Dim Shamsi_Mabna As Long
    Dim Miladi_mabna As Date
    Dim Dif As Long
    'ÏÑ ÇíäÌÇ 78/10/11 ÈÇ 2000/01/01 ãÚÇÏá ÞÑÇÑÏÇÏå ÔÏå
    Shamsi_Mabna = 13781011
    Miladi_mabna = #1/1/2000#
    Dif = DateDiff("d", Miladi_mabna, Date)
    If Dif < 0 Then
    MsgBox "ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÔãÇ äÇÏÑÓÊ ÇÓÊ , ÂäÑÇ ÇÕáÇÍ ßäíÏ."
    Else
    Shamsi = AddDay(Shamsi_Mabna, Dif)
    End If
    End Function


    Public Function dat() As String
    ' ÈßÇÑ ÈÈÑíÏ Now() ÑÇ ãí ÊæÇäíÏ ÏÑ ÒÇÑÔÇÊ ÈÌÇí ÊÇÈÚ Dat() ÊÇÈÚ
    dat = DayWeek(Shamsi) & " - " & Slash(Shamsi)
    End Function


    Public Function Slash(F_Date As Variant) As String
    ' Çíä ÊÇÈÚ íß ÊÇÑíÎ ÑÇ ÏÑíÇÝÊ æ ÈÕæÑÊ íß ÑÔÊå 10 ÑÞãí ÔÇãá / æ åÇÑ ÑÞã ÈÑÇí ÓÇá ÈÇÒãíÑÏÇäÏ
    F_Date = Replace(F_Date, "/", "")
    Dim a As Long
    a = CLng(F_Date)
    Slash = Format(IL(a), "0000") & "/" & Format(ay(a), "00") & "/" & Format(Guon(a), "00")
    End Function


    Function ValidDate(F_Date As Variant) As Boolean
    ' Çíä ÊÇÈÚ ÇÚÊÈÇÑ íß ÚÏÏ æÑæÏí ÑÇ ÇÒ äÙÑ ÊÇÑíÎ åÌÑí ÔãÓí ÈÑÑÓí ãí ßäÏ
    ' ÑÇ ÈÑãí ÑÏÇäÏ False æÇÑ äÇãÚÊÈÑ ÈÇÔÏ True ÇÑ ÊÇÑíÎ ãÚÊÈÑ ÈÇÔÏ
    On Error GoTo Err_ValidDate
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim M, s, R As Byte
    F_Date = Replace(F_Date, "/", "")
    R = Guon(CLng(F_Date))
    M = ay(CLng(F_Date))
    s = IL(CLng(F_Date))
    If F_Date < 10000101 Then Exit Function
    If M > 12 Or M = 0 Or R = 0 Then Exit Function
    If R > ayDays(s, M) Then Exit Function
    ValidDate = True


    Exit_ValidDate:
    On Error Resume Next
    Exit Function
    Err_ValidDate:
    Select Case err.Number
    Case 0
    Resume Exit_ValidDate:
    Case 94
    ValidDate = True
    Case Else
    MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function ValidDate"
    Resume Exit_ValidDate:
    End Select
    End Function


    Public Function AddDay(ByVal F_Date As Variant, ByVal add As Long) As Long
    'Çíä ÊÇÈÚ ÊÚÏÇÏ ÑæÒ ÏáÎæÇå ÑÇ Èå ÊÇÑíÎ ÑæÒ ÇÖÇÝå ãíßäÏ
    On Error GoTo Err_AddDay
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    F_Date = Replace(F_Date, "/", "")
    Dim K, M, R, Days As Byte
    Dim s As Integer
    R = Guon(CLng(F_Date))
    M = ay(CLng(F_Date))
    s = IL(CLng(F_Date))
    K = Kabiseh(s)
    'ÊÈÏíá ÑæÒ Èå ÚÏÏ 1 ÌåÊ ÇÏÇãå ãÍÇÓÈÇÊ æ íÇ ÇÊãÇã ãÍÇÓÈå
    Days = ayDays(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 = ayDays(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 = CLng(s & Format(M, "00") & Format(R, "00"))


    Exit_AddDay:
    On Error Resume Next
    Exit Function
    Err_AddDay:
    Select Case err.Number
    Case 0
    Resume Exit_AddDay:
    Case 94
    AddDay = 0
    Case Else
    MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function AddDay"
    Resume Exit_AddDay:
    End Select
    End Function


    Function SubDay(ByVal F_Date As Variant, ByVal Subtract As Long) As Long
    'Èå ÊÚÏÇÏ ÑæÒ ãÚíäí ÇÒ íß ÊÇÑíÎ ßã ßÑÏå æ ÊÇÑíÎ ÍÇÕáå ÑÇ ÇÑÇÆå ãíßäÏ
    On Error GoTo Err_SubDay
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    F_Date = Replace(F_Date, "/", "")
    Dim K, M, s, R, Days As Byte
    R = Guon(CLng(F_Date))
    M = ay((CLng(F_Date)))
    s = IL((CLng(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 = ayDays(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
    SubDay = (s * 10000) + (M * 100) + (R)


    Exit_SubDay:
    On Error Resume Next
    Exit Function
    Err_SubDay:
    Select Case err.Number
    Case 0
    Resume Exit_SubDay:
    Case 94
    SubDay = 0
    Case Else
    MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function SubDay"
    Resume Exit_SubDay:
    End Select
    End Function


    Public Function DayWeekNo(F_Date As Variant) As Byte
    'Çíä ÊÇÈÚ íß ÊÇÑíÎ ÑÇ ÏÑíÇÝÊ ßÑÏå æ ÔãÇÑå ÑæÒ åÝÊå ÑÇ ãÔÎÕ ãí ßäÏ
    'ÇÑ ÔäÈå ÈÇÔÏ ÚÏÏ 0
    'ÇÑ 1ÔäÈå ÈÇÔÏ ÚÏÏ 1
    '......
    'ÇÑ ÌãÚå ÈÇÔÏ ÚÏÏ 6
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    F_Date = Replace(F_Date, "/", "")
    Dim day As String
    Dim Shmsi_Mabna As Long
    Dim Dif As Long
    'ãÈäÇ 80/10/11
    Shmsi_Mabna = 13801011
    Dif = Diff(Shmsi_Mabna, CLng(F_Date))
    If Shmsi_Mabna > CLng(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


    Public Function DayWeek(F_Date As Variant) 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 Diff(ByVal date1 As Variant, ByVal Date2 As Variant) As Long
    'Çíä ÊÇÈÚ ÊÚÏÇÏ ÑæÒåÇí Èíä Ïæ ÊÇÑíÎ ÑÇ ÇÑÇÆå ãí ßäÏ
    On Error GoTo Err_Diff
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    date1 = Replace(date1, "/", "")
    Date2 = Replace(Date2, "/", "")
    Dim tmp As Long
    Dim S1, M1, R1, S2, M2, R2 As Integer
    Dim Sumation As Single
    Dim Flag As Boolean
    Flag = False
    If CLng(date1) = 0 Or IsNull(CLng(date1)) = True Or CLng(Date2) = 0 Or IsNull(CLng(Date2)) = True Then
    Diff = 0
    Exit Function
    End If
    'ÇÑ ÊÇÑíÎ ÔÑæÚ ÇÒ ÊÇÑíÎ ÇíÇä ÈÒѐÊÑ ÈÇÔÏ ÂäåÇ ãæÞÊÇ ÌÇÈÌÇ ãí ÔæäÏ
    If CLng(date1) > CLng(Date2) Then
    Flag = True
    tmp = CLng(date1)
    date1 = CLng(Date2)
    Date2 = tmp
    End If
    R1 = Guon(CLng(date1))
    M1 = ay(CLng(date1))
    S1 = IL(CLng(date1))
    R2 = Guon(CLng(Date2))
    M2 = ay(CLng(Date2))
    S2 = IL(CLng(Date2))
    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


    Exit_Diff:
    On Error Resume Next
    Exit Function
    Err_Diff:
    Select Case err.Number
    Case 0
    Resume Exit_Diff:
    Case 94
    Diff = 0
    Case Else
    MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function Diff"
    Resume Exit_Diff:
    End Select
    End Function


    Function ayName(ByVal ay_no As Byte) As String
    'Çíä ÊÇÈÚ íß ÊÇÑíÎ ÑÇ ÏÑíÇÝÊ ßÑÏå æ ãÔÎÕ ãí ßäÏ å ãÇåí ÇÒ ÓÇá ÇÓÊ
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Select Case ay_no
    Case 1
    ayName = "ÝÑæÑÏíä"
    Case 2
    ayName = "ÇÑÏíÈåÔÊ"
    Case 3
    ayName = "ÎÑÏÇÏ"
    Case 4
    ayName = "撄"
    Case 5
    ayName = "ãÑÏÇÏ"
    Case 6
    ayName = "ÔåÑíæÑ"
    Case 7
    ayName = "ãåÑ"
    Case 8
    ayName = "ÂÈÇä"
    Case 9
    ayName = "ÂÐÑ"
    Case 10
    ayName = "Ïí"
    Case 11
    ayName = "Èåãä"
    Case 12
    ayName = "ÇÓÝäÏ"
    End Select
    End Function


    Function ayDays(ByVal IL As Integer, ByVal ay As Byte) As Byte
    'Çíä ÊÇÈÚ ÊÚÏÇÏ ÑæÒåÇí íß ãÇå ÑÇ ÈÑãí ÑÏÇäÏ
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Select Case ay
    Case 1 To 6
    ayDays = 31
    Case 7 To 11
    ayDays = 30
    Case 12
    If Kabiseh(IL) = 1 Then
    ayDays = 30
    Else
    ayDays = 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 = Mid(d, 1, 4) & "/" & Mid(d, 5, 2) & "/" & Mid(d, 7, 2)
    End If
    End Function


    Function ILay(ByVal F_Date As Long) As Long
    'ÔÔ ÑÞã Çæá ÊÇÑíÎ ßå ãÚÑÝ ÓÇá æ ãÇå ÇÓÊ ÑÇ ÈÑãí ÑÏÇäÏ
    ILay = Val(Left$(F_Date, 6))
    End Function


    Public Function Guon(F_Date As Long) As Byte
    'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ÑæÒ íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
    Guon = F_Date Mod 100
    End Function


    Function ay(F_Date As Long) As Byte
    'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ãÇå íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
    ay = Int((F_Date Mod 10000) / 100)
    End Function


    Public Function IL(F_Date As Long) As Integer
    'Çíä ÊÇÈÚ ÚÏÏ ãÑÈæØ Èå ÓÇá íß ÊÇÑíÎ ÑÇ ÈÑãÑÏÇäÏ
    IL = Int(F_Date / 10000)
    End Function


    Public Function Kabiseh(ByVal OnlyIL As Variant) As Byte
    'æÑæÏí ÊÇÈÚ ÚÏÏ ÏæÑÞãí ÇÓÊ
    'Çíä ÊÇÈÚ ßÈíÓå ÈæÏä ÓÇá ÑÇ ÈÑãíÑÏÇäÏ
    'ÇÑ ÓÇá ßÈíÓå ÈÇÔÏ ÚÏÏ íß æ ÏÑÛíÑ ÇíäÕæÑÊ ÕÝÑ ÑÇ ÈÑ ãíÑÏÇäÏ
    Kabiseh = 0
    If OnlyIL >= 1375 Then
    If (OnlyIL - 1375) Mod 4 = 0 Then
    Kabiseh = 1
    Exit Function
    End If
    ElseIf OnlyIL <= 1370 Then
    If (1370 - OnlyIL) Mod 4 = 0 Then
    Kabiseh = 1
    Exit Function
    End If
    End If
    End Function


    Function Nextay(ByVal IL_ay As Long) As Long
    If (IL_ay Mod 100) = 12 Then
    Nextay = (Int(IL_ay / 100) + 1) * 100 + 1
    Else
    Nextay = IL_ay + 1
    End If
    End Function


    Function Previousay(ByVal IL_ay As Long) As Long
    If (IL_ay Mod 100) = 1 Then
    Previousay = (Int(IL_ay / 100) - 1) * 100 + 12
    Else
    Previousay = IL_ay - 1
    End If
    End Function


    Public Function Firstday(IL As Integer, ay As Integer) As Long
    'ÔãÇÑå Çæáíä ÑæÒ ãÇå
    Dim strfd As Long
    strfd = IL & Format(ay, "00") & Format(1, "00")
    Firstday = DayWeekNo(strfd)
    End Function


    Public Function Guon1(F_Date As Long) As Byte
    'Çíä ÊÇÈÚ ãÔÎÕ ãí ˜äÏ ˜å í˜ ÊÇÑíÎ äÏãíä ÑæÒ ÓÇá ÇÓÊ
    ILROOZ = ay(Shamsi()) - 1
    If ay(Shamsi()) < 6 Then
    Guon1 = (F_Date Mod 100) + (ILROOZ * 30) + (ay(Shamsi())) - 1
    Else
    Guon1 = (F_Date Mod 100) + (ILROOZ * 30) + 6
    End If


    End Function

  25. #65

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام
    من با access 2016 , windows 10 این ماژولهای شمسی را امتحان کردم، مشکله برام پیش آماده که امیدوارم بتونین کمکم کنین.
    وقتی که فرم های نمونه را بررسی میکنم تمامی کدها درست کار میکنند و لی به محض وارد شدن به پنجره build و خروج error به شرح زیر پیغام میدهد.
    the expression you entered contains invalid syntax
    you may enteredan operandwithout an operator

  26. #66
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام
    دو تا پيشنهاد دارم اميدوارم به دردتون بخوره:
    1-اگر ويندوز و افيس شما 32 بيتي هست با كليد G+Ctrl وارد محيط كد نويسي بشيد و يكبار كدهاتون رو كامپايل كنيد اگر كدها مشكلي داشته باشند برنامه متوقف و روي كد مشكل دار متوقف ميشه.
    2-اگر ويندوز وافيس 64 بيت هست بايد براي declare متغير ها از ptrsafe استفاده كنيد.
    ........................
    موفق باشيد

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  27. #67
    کاربر دائمی آواتار bemilove
    تاریخ عضویت
    مهر 1385
    محل زندگی
    ایران سرای من است
    پست
    328

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    باسلام
    میشه مورد 2 را بیشتر توضیح بدهید
    من این مشکل the expression you entered contains invalid syntax access را در کوئری دارم


    DLookUp("lngEmpID"؛"t_login"؛"name='" & DMax("[name]"؛"q_login") & "'  ")


    یه علامتی تو این کد مشکل داره..البته اولین بار که باز میکنم مشکلی ندارد ، به محضی که می خواهم کد جدیدی در قسمت or اضاقه کنم ، پیام ارور بالا می دهد

    قسمت مشکل داره اینه :
    ؛
    عکس های ضمیمه عکس های ضمیمه
    آخرین ویرایش به وسیله bemilove : یک شنبه 07 مرداد 1397 در 10:44 صبح

  28. #68

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    با سلام
    من در اکسل از این دستور استفاده میکنم
    ay(shamsi)
    که ماه را به صورت تک رقمی میده مثلا 1 و میخواهم داده را به صورت 01 بدهد و نمیخواهم Format cell را تغییر دهم

    من از این دستور میکنم
    Private Sub Date21_Click()
    ActiveCell.Select
    ActiveCell = IL(Shamsi()) & "/" & ay(Shamsi()) & "/" & Me.ActiveControl.Caption
    Unload Me

    End Sub


    چون زمانیکه از دستور DayWeek استفاده میکنم نمیتواند ماه را بخواند و سیستم هنگ میکند.
    اگر 1398/01/18 دیتا باشد DayWeek کار میکند اما اگر 1398/1/18 باشد DayWeek نمیتواند روز هفته را محاسبه کند


    ممنون میشوم من را راهنمایی کنید

  29. #69

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام . برای قسمت ماه فرمت تعریف کنید.
    ("00",(()format(ay(Shami

  30. #70

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط mosaArabi مشاهده تاپیک
    سلام . برای قسمت ماه فرمت تعریف کنید.
    ("00",(()format(ay(Shami
    با سلام
    این کار که شما میگیند یعنی فرمت سل را عوض کنم؟؟

  31. #71

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    درود
    این ماژول سال ۱۴۰۰ به بعد رو صحیح نمایش میده؟

  32. #72

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام اکثر کدها درست کار میکنه

  33. #73

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    سلام دوستان
    میخواستم از اکتیوایکس جناب آقای پیروزمهر در کوئری استفاده کنم تابع مورد نظر IsDateBetween است که باید به یک فانکشن تبدیل بشه کسی میتونه در این مورد کمک کنه که چطوری این تابع را در کوئری استفاده کنم

  34. #74

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    با سلام و عرض ادب خدمت دوستان گرامی

    ببخشین میشه بفرمایین چجوری میشه بازه سال رو تغییر داد؟ واسه من از سال 1381 الی 1430 وجود داره که میخام این بازه به سال 1320 تا 1430 تغییر پیدا کنه.

  35. #75

    نقل قول: ماژول کامل تاریخ شمسی در اکسس با VBA

    نقل قول نوشته شده توسط mahdi545 مشاهده تاپیک
    با سلام و عرض ادب خدمت دوستان گرامی

    ببخشین میشه بفرمایین چجوری میشه بازه سال رو تغییر داد؟ واسه من از سال 1381 الی 1430 وجود داره که میخام این بازه به سال 1320 تا 1430 تغییر پیدا کنه.
    دوستان مشکلم حل شد ممنون

صفحه 2 از 2 اولاول 12

قوانین ایجاد تاپیک در تالار

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