سلام و بسیار ممنون از توابع ذکر شده فقط خواهش داشتم اگر میشه در مورد تابع تبدیل عدد به حرف نحوه بکارگیری این تابع را با مثال توضیح دهید ممنون میشم اخه من تا بحال با ماجواها کارنکردم
Printable View
سلام و بسیار ممنون از توابع ذکر شده فقط خواهش داشتم اگر میشه در مورد تابع تبدیل عدد به حرف نحوه بکارگیری این تابع را با مثال توضیح دهید ممنون میشم اخه من تا بحال با ماجواها کارنکردم
سلام
در اکسس 2007 سورت به صورت عربی انجام میشه. یعنی حرف "ه" در مرتب سازی قبل از "واو" قرار می‌گیره
در حالیکه در توالی زبان فارسی حروف به صورت "ن" "واو" "ه" "ی" هستن.
کسی از دوستان راه حلی برای حلی این مشکل داره؟
جایی که می خوای استفاده کنی نام تابع رو فراخوانی می کنی حالا داخل پرانتز اسم فیلد مورد نظر که شامل عدد هست رو داخل پرانتز بنویسید به همین سادگی
خواهشا يه نمونه بزارين
ما كه خيلي مبتدي هستيم كمي مشكل داريم در دركش
دوستان تا حالا کسی منوی راست به چپ فارسی داشته
من می خواهم منو ها از سمت راست شروع بشه ظاهرا مشکل داره
اگر دوستان کسی می تونه کمک کنه
https://barnamenevis.org/showthread.php?322117
خوشبختانه افرادی اقدام به نشر توابع فارسی و تبدیل عدد به حروف و محاسبات تاریخ در اکسس شده اند و البته اینجانب از طریق وبلاگم در تیر ماه 1385 یکی از آنها را انتشار دادم که کاربرانی از آن استفاده کردند.
در حال حاضر نسخه ارتقا یافته آن به پیوست همین پست ارائه می گردد که شامل یک فایل اکسس و کدها می باشد.
در فایل اکسس چندین مثال کاربردی تاریخ شمسی و تبدیل عدد به حروف ارائه شده است.
- عدم به هم ریختن حروف فارسی و عدم نیاز به تنظیم کنترل پنل
- افزودن حرف میم به آخر تابع تبدیل تاریخ به حروف در Access (ششم مهر ....)
- فایل راهنمای کامل PDF به همراه چندین مثال کاربردی از تبدیل تاریخ به حروف / محاسبه سنوات Access برای کاربرانی که نحوه استفاده از کدها را نمی دانند.
فایل PDF آن را می توانید از اینجا دریافت کنید (اگر یافت نشد از قسمت جستجوی سایت استفاده نمایید)
ممنون. ولی سوال من این است که آیا از 1400 به بعد هم این تابع جواب می دهد؟
با سلام خدمت همگي دوستان و اساتيد
راستش من حسابي گير كردم ، n تا فانكشن ديدم كه براي تبديل تاريخ ميلادي به شمسي هست ولي نميدونم چرا تاريخ 2012/03/16 رو اشتباه تبديل ميكنن ، خواهشن اگه كسي تابه درست حسابي براي تبديل تاريخ ميلادي به شمسي داره بهم بده .(فقط يه فانكشن براي اين كار ميخوام ) مرسي ، يه دنيا ممنون
صفحه مورد نظر پيدا نشد ولي بايد تنظيمات زبان ويندوز رو تو قسمت Advance روي Persian قرار دهند.نقل قول:
نوشته شده توسط mohsenna30ri
سلام
من یک DataBase دارم که با Access 95 ساخته شده است . متاسفانه وقتی که با Office 2003 و یا 2007 بازش می کنم ، اطلاعاتش خرچنگ ، قورباقه شده . یعنی Encoding اش بهم خورده .
وقتی هم از منوی tools اون رو تبدیل به یک دیتابیس 2007 می کنم ، بازم فرقی نداره و خرچنگ قورباقه هست .
آیا راهی هست که DataBase رو خوند ؟ چه طوری Encoding اش رو درست کنیم ؟
خبری نشد دوستان ؟ کسی نظری نداره ؟
سلام
دوستان راهنمایی میخوام
چرا وقتی تو vba به فارسی مینویسیم وقتی کد اجرا میشه بصورت حروف ناخوانا نمایشداده میشه
مثل تابع msgbox "سلام"
به نام خدا
باسلام قبلا در اينمورد بحث شده است. مشكل از دو نقطه است و معمولا در ويندوز سون پيش مي ايد.
1- فونت مورد استفاده سيستم . يعني اغلب وقتي فونت مورد استفاده سيستم را در Appearance تغيير دهيد مشكل حل مي شود
2 - موضوع مربوط به كاركتر هاي يونيكد. وگرنه در كنترل پنل و بخش Regional and Languege و فلان و در تب Advanced فارسي را انتخاب كنيد.
تنشاله مشكل حل مي شود.
دوستان لطفا راهنمایی بفرمایید در Access 2010 برای اینکه دیتا بیس ما هنگام باز شدن در یک فرم مشخص باز شود چه کنیم ؟
مثلا با دبل کلیک کردن روی آیکن دیتا بیس، وارد فرم ثبت نام شود در حالت فول اسکرین
مانند اتوران نرم افزار های مختلف
چگونه امکان پذیر است
با تشکر
برای این کار برید توی access options
بعد توی current database
بعد توی فیلد display form فرم مورد نظرتون رو انتخاب کنید
سلام
خوب ، ما پیام ها را فارسی کردیم و ... با پنجره open file dialog با دگمه های open و cancel و save چه کنیم ؟ آیا این ها را می شه فارسی کرد ؟ اگر می شه لطف کنید نمونه ای بذارید
اگه نمی شه شما تا حالا چه می کردید ؟ قسمتی از برنامه فارسی و قسمتی انگلیسی بود ؟ چه راهکار دیگه ای را بکار
می گیرید ؟
با تشکر
به نام خدا
با سلام. می شود. در همین تاپیک بگردید پیدا می کنید.
نقل قول:
نوشته شده توسط RESMAILY
سلام
من هر چی تو این تاپیک گشتم که نبود
شاید شما خوب متوجه خواسته من نشدید
اگه من اشتباه میکنم لطفا بگید در کدوم پست هست ؟ اگه نیست و شما می گید می شه لطفا فایلی را که گذاشتم اصلاح فرمایید که خیلی منتظر حل این مساله هستم
با تشکر
به نام خدا
با سلام. اين هم نمونه. مي توانيد آن را توسعه هم بدهيد. من حداقل سه چهار تاپيك در خاطر دارم كه در اين باره گفتگويي شد. در تاپيك برنامه هاب كاربردي هم يكي دو نمونه وجود دارد. چند ساعتي وقت بگذاريد چيز هاي ديگري هم بدست مي ايد.
سلام
ببین دوست گرامی من پستی که زدم برای فارسی کردن پیام ها نبود که این در همین تاپیک و .... وجود داره
بلکه در مورد فارسی کردن دگمه های پنجره ای که برای انتخاب فایل از کامپیوتر هست که من در هیچ تاپیکی کاملش را ندیدم که ناقصش را خودم به صورت فایلی که ضمیمه کردم گذاشتم
شما لطف کن فایل را بردار یک نگاهی یکن و اگه فایلی برای این کار داری بذار که این تاپیک جای این را خالی داره و به درد خیلی ها هم خواهد خورد
با تشکر
به نام خدا
با سلام. البته می بخشید که درست دقت نکرده بودم. در مورد دیالوگ باکس و غیره هم گمان کنم که باید خودمان دست به کارشویم و فرم مورد نظررا درست کنیم.(سعی می کنم شما هم سعی بفرمایید) ولی نشدنی نیست. الآن درخاطر ندارم یک از دوستان (شاید اقای دستگردی بود) که روی ویندوز تسلط بیشتری داشت نمونه هایی ر ا در این موارد حل کرده بود. لذا مجددا ا ز شما و خوانندگان تاپیک پوزش و غیره.
به نام خدا
با سلام. برای آن چیزی که شما می خواهید ابزاری در vb وجود دارد که ظاهرا در vba وجود ندارد. اما یکی از راههایی که می شود به هدف مورد نظرتان برسید استفاده از treeview است. (راههای دیگری هم به احتمال زیاد هست) نمونه پیوست را نگاهی بکنید. می توانید آن را بصورتی دلخواه توسعه بدهید و تکمه و برچسب و غیره را اضافه بفرمایید. موفق باشید
سلام
چطور می شه آدرس فایلی را که در این پنجره انتخاب می کنیم در یک text box قرار داد یا به نوعی برگردوند چرا که ما از این مساله در کدها استفاده های زیادی
می کنیم
ضمنا چطور می شه یک دگمه در فرم در زیر پنجره قرار داد که نمایان بشه
اگه شما می تونی یک نمونه لطف کنید بذارید در غیر اینصورت فکر کنم بهتره روی نمونه ای که گذاشتم کار کنید یا راه حل دیگری ارایه دهید
با تشکر منتظر پاسختون هستم
به نام خدا
با سلام. به نظرم کار ساده ای باشد. شما در رویداد "دبل کلیک" treeview الآن یک Msgbox را به عنوان پاسخ دریافت می کنید. آیا نمی شود یک تکست باک اضافه کرد و پاسخ "دبل کلیک" را انتقال اطلاعات "گره"(=Node) یا "زیر گره" مربوطه به داخل تکست باکس درنظر گرفت؟ سپس تکمه و غیره هم به هر شکل اضافه نمود؟
به هرحال در اولین فرصت من هم سعی می کنم این موارد را اضافه نمایم. شماهم کمک کنید.
با سلام و تشکر
منتظر یک نمونه حرفه ای از شما هستم
اما در مورد فارسی سازی دو مورد مهم دیگر هست
1- وقتی از فیلد های Attachment در فرم استفاده می کنیم و روی آن دبل کلیک میکنیم تا فایل ها را اضافه یا کم کنیم یک پنجره باز می شود که تماما انگلیسی است
2- همچنین وقتی از فیلد های textbox که رویداد Allow value List edit آن را yes می کنیم در هنگام وارد کردن متنی یک امکان ویرایش متن های لیست آن را می دهد که این پنجره هم کاملا انگلیسی است
آیا راهی برای فارسی کردن اینها سراغ دارید؟
با تشکر فراوان
سلام
سوال در مورد استفاده از تابع تبدیل تاریخ میلادی به شمسی که در پست 1# ارایه شده است
( البته من از ماژول اصلاح شده جناب آزادي توسط احمد ميرزازاده به تاريخ 1388/7/22 استفاده کردم که سال را 4 رقمی می اندازه )
1- می خوام در فرمی که یک فیلد تاریخ دارم کاربر وقتی می خواد تاریخ را وارد کنه input mask به صورت 01/01/1392 باشه ولی وقتی وارد کرد اتوماتیک به صورت
1392/01/01 نمایش بده کجا ها و چه تنظیماتی باید انجام بدم ؟
در صورتی که ما طبق گفته کاربرد این تابع فیلدهای تاریخ را number تعریف کرده ا یم
من هر کار کردم نتونستم راهی پیدا کنم و در هر دو حالت ورود و نمایش به 1392/01/01 میشه
2- وقتی خاصیت validation rule را برای textbox تعریف می کنم و مقداری را در textbox آن وارد می کنم دیگه اجازه پاک کردن و خالی کردن اون را نمیده و پیغام error میده اشکال کارم کجاست یا اینکه این ماژول این مشکل را داره ؟ و استفاده از اون کلا مشکلی نداره ؟
خیلی ممنون میشم کسی راهکار یا نمونه ای ارایه کنه
با تشکر
سلام به همه دوستان
کسی نیست که به این سوال هام پاسخ بده ؟
با سلام
کامل ترین نمونه تابع تبدیل عدد به حروف که امکان تبدیل اعداد در نمای علمی رو هم به حروف داره .
می تونید از آدرس زیر دریافت کنید .
http://mantis.ir/access-knowledge/ac...-articles.html
سلام ، من ویندوزم 7 / 64 بیتیه این ماژول در قسمت AddressOf خطای Type Mismatch میده باید چه تغییری در سورس بدم ؟نقل قول:
نوشته شده توسط RESMAILY
سلام
از این تاپیک هم کمک بگیرید . ماژول جناب ازادی با کمی تغییرات در مورد تاریخ 2012 هم مشکل نداره
https://barnamenevis.org/showthread.p...8%A8%D8%A7-VBA
سلام دوستان!
من یه دیتابیس توی اکسس دارم که اطلاعاتش با "میل مرج Mail merge" به ورود 2013 وارد میشه. مشکلم اینه که حرف "ی" فارسي رو نميشناسه و در Word 2013 اونو به صورت علامت ؟ می نویسه.
(عکس زیر را ببنید!)
.
.
.
ضمیمه 129589
.
.
می دونم که با Replace کردن حرف "ي" عربی (با زدن Shift+X) با "ی" فارسی و تغيير تمام "ي" ها در دیتابیس مشکلم به صورت موقتی حل میشه ولی می خواستم بدونم که کسی راه حل اساسی برای حل این مشکل نداره؟ مثلا خاصیت یک فرم رو جوری تغییر بدیم که هر وقت من "ی" فارسی رو تایپ کردم اون به صورت اتوماتیک تبدیلش کنه به "ي" عربی. تو هیچ انجمنی نتونستم جوابی برای این سوال پیدا کنم، امیدوارم شما بتونید منو کمک کنید!
جواب شما توی پست 49 همین تاپیکه :لبخندساده:
با سلام خدمت دوستان ..
سوال : در ارتباط با unstable بودن یا ثبات نداشتن فونت در فرم ها ست بخصوص Navigation form .
هر بار که فونتها رو در navigation فرم تغییر میدم بعد از close و open کردن مجدد برنامه فونتها عوض میشن و آن چیزی نیستند که من انتخاب کردم...!!
چرا؟؟راه کار دوستان برای stable ماندن فونتها چیست ؟؟ ممنون
با سلام یه راهنمایی کنید من تابع هجری شمسی رو خریداری کردم اگه ممکنه بگید چطوری به صورت اتوماتیک سن دانش آموز رو به سال بگه میلادی مشکلی ندارم ولی با این تابع تو فرم نمی دونم چطوری انجام بدم.
سلام دوستان
من میخواستم بدونم چطور می شه تاریخ رو به حروف نوشت البته محدودیت سال1399 را نداشته باشه خیلی ممنون میشم یکی جواب بده:تشویق:
به روزرسانی ماژول تبدیل تاریخ شمسی (رفع مشکل 1400 و سال چهار رقمی)
Option Compare Database
Public Function Rooz(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
Rooz = F_Date Mod 100
End Function
'*******************************************
Function mah(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
mah = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function Sal(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
Sal = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlySal As Variant) As Integer
'????? ???? ??? ?????? ???
'??? ???? ????? ???? ??? ?? ??????????
'??? ??? ????? ???? ??? ?? ? ????? ??????? ??? ?? ?? ????????
Kabiseh = 0
If OnlySal >= 1375 Then
If (OnlySal - 1375) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 1370 Then
If (1370 - 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 Integer
' ??? ???? ?????? ?? ??? ????? ?? ?? ??? ????? ???? ???? ????? ?? ???
' ?? ???? ?????? False ???? ??????? ???? True ??? ????? ????? ????
ValidDate = True
S = Sal(F_Date)
m = mah(F_Date)
R = Rooz(F_Date)
'********
If F_Date < 13100101 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 Integer
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 = 13791012
Miladi_mabna = #1/1/2001#
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 Integer
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) & " " & 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 Integer) 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, 6))
End Function
Function MahDays(ByVal Sal As Integer, ByVal mah As Integer) As Integer
'??? ???? ????? ?????? ?? ??? ?? ???? ??????
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 = Mid(D, 1, 4) & "-" & Mid(D, 5, 2) & "-" & Mid(D, 7, 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 Integer
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
سلام و ارادت
ماژول MsgBoxFa مسیج باکس فارسی که در این تاپیک بود را باتوجه به اینکه روی ویندوزهای 64 بیتی عمل نمیکرد اصلاح کردم و در ویندوز 64 و 32 بیتی عمل خواهد کرد
Option Compare Database
'----------------------- MsgBoxFa -------------------------
'https://barnamenevis.org/showthread.php?51987-%D9%85%D8%B4%DA%A9%D9%84%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D9%88-%D8%B3%D9%88%D8%B1%D8%B3-%D9%87%D8%A7%DB%8C-%D9%85%D8%B1%D8%A8%D9%88%D8%B7%D9%87&p=1719291&vie wfull=1#post1719291
'------------------- مسيج باکس فارسي ----------------------
' مناسب سازي شده براي ويندوز 64 و32 بيت '
' توسط محسن آل آقا اصلاح شده '
' 1400/06/29 '
' Hematalea@gmail '
' MsgBox براي استفاده از اين ماژول کافيست بجاي نوشتن تابع '
' .استفاده کنيد MsgBoxFa از تابع '
' '
' ------------------------------------------------------- '
' Integer را به عنوان MsgBox توجه: اگر در جايي که متغير '
' را حذف کنيد Integer ،تعريف کرده ايد '
' '
' :مثال '
' Dim OutPut As Integer <------------ خطا خواهد داد '
' OutPut = MsgBoxFa(".... '
' '
' Dim OutPut <--- بدون خطا اجرا خواهد شد '
' OutPut = MsgBoxFa(".... '
' '
'------------------------- Msgbox -------------------------
Public Const WH_CBT = 5
Public Const GWL_HINSTANCE = (-6)
Public Const HCBT_ACTIVATE = 5
#If VBA7 Then
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As LongPtr
hHook As LongPtr
End Type
Public Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
Public Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As LongPtr
Public Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Public Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
#Else
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As Long
hHook As Long
End Type
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If
'need this declared at module level as
'it is used in the call and the hook proc
Public MSGHOOK As MSGBOX_HOOK_PARAMS
#If VBA7 Then
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As LongPtr
'Wrapper function for the MessageBox API
Dim hwndThreadOwner As LongPtr
#Else
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As Long
Dim hwndThreadOwner As Long
#End If
Dim frmCurrentForm As Form
'On Error Resume Next
Set frmCurrentForm = Screen.ActiveForm
hwndThreadOwner = frmCurrentForm.hwnd
#If VBA7 Then
Dim hInstance As LongPtr
Dim hThreadId As LongPtr
Dim hWndOwner As LongPtr
#Else
Dim hInstance As Long
Dim hThreadId As Long
Dim hWndOwner As Long
#End If
hWndOwner = GetDesktopWindow()
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hWndOwner = hWndOwner
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MsgBoxFa = MessageBox(hwndThreadOwner, Prompt, Tiltle, Buttons)
End Function
#If VBA7 Then
Public Function MsgBoxHookProc(ByVal uMsg As LongPtr, _
ByVal wParam As LongPtr, _
ByVal LParam As LongPtr) As LongPtr
#Else
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long
#End If
If uMsg = HCBT_ACTIVATE Then
SetDlgItemText wParam, vbYes, ChrW(1576) & ChrW(1604) & ChrW(1607) '"بله"
SetDlgItemText wParam, vbNo, ChrW(1582) & ChrW(1740) & ChrW(1585) ' "خير"
SetDlgItemText wParam, vbIgnore, ChrW(1604) & ChrW(1594) & ChrW(1608) ' "لغو"
SetDlgItemText wParam, vbOK, ChrW(1578) & ChrW(1571) & ChrW(1740) & ChrW(1740) & ChrW(1583) ' "تاييد"
SetDlgItemText wParam, vbCancel, ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1585) & ChrW(1575) & ChrW(1601) ' "انصراف"
SetDlgItemText wParam, vbAbort, ChrW(1606) & ChrW(1575) & ChrW(1578) & ChrW(1605) & ChrW(1575) & ChrW(1605) & _
" " & ChrW(1605) & ChrW(1575) & ChrW(1606) & ChrW(1583) & ChrW(1606) ' "ناتمام ماندن"
SetDlgItemText wParam, vbRetry, ChrW(1578) & ChrW(1604) & ChrW(1575) & ChrW(1588) & _
" " & ChrW(1583) & ChrW(1608) & ChrW(1576) & ChrW(1575) & ChrW(1585) & ChrW(1607) ' "تلاش دوباره"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
..........