سلام با استفاده از ابزار زیر به راحتی می توانید پیغامهای فارسی را یونیکد کرده و از در برنامه های خود از مسیج باکسهای اختصاصی بهره ببرید
https://officebaz.ir/unicode/
سلام با استفاده از ابزار زیر به راحتی می توانید پیغامهای فارسی را یونیکد کرده و از در برنامه های خود از مسیج باکسهای اختصاصی بهره ببرید
https://officebaz.ir/unicode/
سلام
وقت دوستان بخیر
سوال مهمی دارم اگر امکانش هست راهنماییم کنید:
کدی دارم که به وسیله آن در اکسس و از طریق وب سرویس امکان ارسال پیامک دارم.
شخصا در بخش vba توانمند نیستم، اما تونستم این کد رو برای یک دکمه تنظیم کنم و از مقدار فیلد "تلفن همراه" در فرم جهت ارسال پیامک استفاده کنم. مشکلم در بخش متن این پیامک هست که باید در کدنویسی تغییر بدم. یعنی باید متن ثابتی باشه و از فیلد "نام" فرم در متن استفاده بشه. بطور مثال: مشترک گرامی "نام"
با سلام....
چند هفته ای هست که امکان استفاده از وب سرویس پیامک در اکسس رو دنبال می کردم و دیگه ناامید شده بودم و میخواستم برم سراغ برنامه های روز، اما با این پیشرفتی که داشتم خیلی امیدوار به اکسس شدم و سعی دارم این تجربه رو هم انتقال بدم.
اگر در این مورد راهنمایی کنید ممنون میشم.
با سپاس از متخصصین این حوزه
سلام
وقت دوستان بخیر
سوال مهمی دارم اگر امکانش هست راهنماییم کنید:
کدی دارم که به وسیله آن در اکسس و از طریق وب سرویس امکان ارسال پیامک دارم.
شخصا در بخش vba توانمند نیستم، اما تونستم این کد رو برای یک دکمه تنظیم کنم و از مقدار فیلد "تلفن همراه" در فرم جهت ارسال پیامک استفاده کنم. مشکلم در بخش متن این پیامک هست که باید در کدنویسی تغییر بدم. یعنی باید متن ثابتی باشه و از فیلد "نام" فرم در متن استفاده بشه. بطور مثال: مشترک گرامی "نام"
با سلام....
چند هفته ای هست که امکان استفاده از وب سرویس پیامک در اکسس رو دنبال می کردم و دیگه ناامید شده بودم و میخواستم برم سراغ برنامه های روز، اما با این پیشرفتی که داشتم خیلی امیدوار به اکسس شدم و سعی دارم این تجربه رو هم انتقال بدم.
اگر در این مورد راهنمایی کنید ممنون میشم.
با سپاس
تابعی که مقدار یک کلید دیکشنری در قالب استرینگ رو بر میگردون
Public Function get_value_by_keydic(ByVal strKeyValues As String, ByVal key As String) As String
Dim strArgument() As String
strArgument = Split(strKeyValues, ",")
Dim i As Integer
For i = 0 To UBound(strArgument)
If InStr(strArgument(i), key) And InStr(strArgument(i), ":") > 0 Then
If Left(strArgument(i), InStr(strArgument(i), ":") - 1) = key Then
get_value_by_keydic = Mid$(strArgument(i), InStr(strArgument(i), ":") + 1)
Exit Function
End If
End If
Next
get_value_by_keydic = ""
End Function
مثال زیر نمره هریک از اشخاص رو که بصورت دیکشنری در قالی استرینگ تعریف شده پیغام میده
Private Sub Command89_Click()
Dim strdic1 As String
strdic1 = "reza:20,ali:19,asghar:18,amir:17"
MsgBox "reza :" & get_value_by_keydic(strdic1, "reza")
MsgBox get_value_by_keydic(strdic1, "ali")
MsgBox get_value_by_keydic(strdic1, "asghar")
MsgBox get_value_by_keydic(strdic1, "amir")
End Sub
باید از این دوستان که زحمت جمع آوری این برنامه ها را میکشند و در اختیار بقیه قرار می دهند ، بابت تک تک این برنامه ها تشکر کرد که فکر کنم باز هم کم باشه.
آخرین ویرایش به وسیله F_ashigh : یک شنبه 25 فروردین 1387 در 15:35 عصر
لطفا فایل ضمیمه را ببینید.
تابع chrw() و تابع chr چه تفاوتی دارن?
تابع chrw() و تابع chr چه تفاوتی دارن?
تابع chr یک کاراکتر رو برمیگردونه مثلا 96 حرف a رو برمیگردونه.تابع chrw همونکارو برای کاراکترهای یونیکد انجام میده. برای پلاتفرم مکینتاش chrw مناسب نیست چون یونیکد رو ساپورت نمیکنه.
لطفا نمونه را ببینید در اين نمونه براي حذف ركورد كاربر بايد پسورد لازم رو وارد كنه كه به دلايل امنيتي موقع ورود پسورد به شكل ستاره نشان داده ميشود.
(پسورد حدف رکورد عدد10)
كدهاي استفاده شده:
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private 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
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function
آخرین ویرایش به وسیله amirzazadeh : پنج شنبه 18 مهر 1387 در 09:21 صبح
سلام اميدوارم اين فايل بدرد دوستان بخور
آخرین ویرایش به وسیله HAMRAHSOFT.IR : شنبه 01 تیر 1387 در 09:29 صبح دلیل: اصلاح لينك دانلود
نقل قول: نمونه های کاربردی و آموزشی VBA
یک مقاله آموزشی اکسس مفید و روان برای کسانیکه می خواهند یک مطالعه مجدد بر روی اکسس داشته باشند تا به یک سری از ابهاماتشون در مورد اکسس جواب داده بشه.
این هم آدرس و منبع فایل:
http://www.farsaran.ir/Access_Section/Files/Access.pdf
و این هم یک فایل دیگه:
http://www.farsaran.ir/Access_Sectio...s_internet.pdf
سلام
مطمئنا تا بحال کادرهای مستطیل با لبه های گرد را در سربرگ اسناد و گزارشات ملاحضه نموده اید، شاید هم آرزوی داشتن آنرا در گزارشاتتان نموده اید! شاید هم به سراغ استفاده از عکس برای این کار رفته اید؟!
برای بهره مندی از این امکان یک ماژول با این محتویات در فایلتان ایجاد کنید:
Public Const conPI As Single = 3.14159
Private Const conTransparent As Long = 0
Public Sub DrawBorderWithRoundedCorners(ByRef rptReport As Report, ByRef ctlBox As Control, Optional sngRadius As Single = 100, Optional lngColour As Long = vbBlack)
Dim lngX As Long, lngY As Long
rptReport.ForeColor = lngColour
ctlBox.BorderStyle = conTransparent
ctlBox.BackStyle = conTransparent
With ctlBox
lngX = .Left + sngRadius
lngY = .Top + sngRadius
rptReport.Circle (lngX, lngY), sngRadius, , conPI / 2, conPI
rptReport.Line (lngX - sngRadius, lngY)-(lngX - sngRadius, lngY + .Height - sngRadius * 2)
rptReport.Circle (lngX, lngY + .Height - sngRadius * 2), sngRadius, , conPI, conPI * 1.5
rptReport.Line (lngX, lngY + .Height - sngRadius)-(lngX + .Width - sngRadius * 2, lngY + .Height - sngRadius)
rptReport.Circle (lngX + .Width - sngRadius * 2, lngY + .Height - sngRadius * 2), sngRadius, , conPI * 1.5, conPI * 2
rptReport.Line (lngX + .Width - sngRadius, lngY + .Height - sngRadius * 2)-(lngX + .Width - sngRadius, .Top + sngRadius)
rptReport.Circle (lngX + .Width - sngRadius * 2, .Top + sngRadius), sngRadius, , conPI * 2, conPI / 2
rptReport.Line (lngX + .Width - sngRadius * 2, .Top)-(lngX, .Top)
End With
End Sub
برای استفاده از این امکان در جای جای گزارشاتتان باید یک کادر (Box) را هر کجای گزارش و با هر سایزی که دوست دارید قرار دهید سپس برای آن Section که کادر را قرار داده اید این کد را بنویسید:
Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer)
DrawBorderWithRoundedCorners Me, HdrBox
End Sub
(این کد برای کادری به نام HdrBox که در Report Header تعبیه شده نوشته شده است)
ضمنا پارامتر سوم و چهارم اختیاری بود و برای تنظیم میزان گرد شدن لبه و رنگ خط دور کادر بکار می رود.
آخرین ویرایش به وسیله shaghaghi : یک شنبه 20 بهمن 1392 در 21:39 عصر دلیل: درخواست نمونه کار
سلام
يك تشكر ويژه از دوستاني كه وقت مي ذارن معلومات و منابع خودشون رو براي استفاده سايرين ارائه مي كنن از بقيه دوستان هم انتظار مي ره به فراخور توانشون در اين امر مشاركت كنن و با مشاركتشون باعث ايجاد انگيزه و رغبت در بين كاربران بشن ، دوستان گرامي رشد و تعالي علمي در گرو تحقيق و مشاركت هست پس فارغ از سطح علمي و معلومات با انجام تحقيق در بين منابع و سورسهاي متنوعي كه در حال حاضر بواسطه كتابها ، جزوات ، سايتها و پورتالهاي اينترنتي در دسترسمون قرار مي گيره سعي كنيم اين منابع و دستاوردها رو در اختيار سايرين بذاريم تا به اين بهانه سهمي در رشد و ارتقاء خود و دوستانمون داشته باشيم .
آخرین ویرایش به وسیله مهدی قربانی : جمعه 21 تیر 1387 در 17:11 عصر
ابتدا TextBoxی را با نام دلخواه (مثلا ROw ) در قسمت Detail ریپورت مورد نظرتان ایجاد نمایید و خاصیت Runnig Sum آنرا Over All نمایید (اگر مایل به نمایش ستون ردیف نیستید، Visible آنرا Flase نمایید)
ضمنا اعداد ذکر شده کد رنگهای سفید و خاکستری هستند که به سلیقه شما می تواند تغییر نماید
متشکرم دوست عزیز مشکل توسط راهنمایی شما حل شدنوشته شده توسط shaghaghi
ولی یک مورد دیگر اینکه پس زمینه back ground کل اون ردیف را عوض می کند در صورت که من می خوام پس زمینه کل فیلدهای آن ردیف را تغییر دهد در صورتی که الان رنگ بیرون از فیلدها هم می رود ممنون می شم در این مورد هم منو راهنمایی کنید
دوستان این نمونه رو تو یکی از سایتها دیدم به دیدنش می ازرة امیدوارم مفید باشه.
سلام
اگر فیلدها را Transparent کنید و آنها را در ابعاد عرض گزارش تنظیم نمایید روش اول ساده تر است، اما اگر مورد خاصی سراغ دارید از این کد استفاده نمایید:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Dim ctl As Control
For Each ctl In Me.Detail.Controls
If TypeOf ctl Is ComboBox Or TypeOf ctl Is TextBox Then
ctl.BackColor = IIf(Me.txtRow Mod 2 = 0, 12632256, 16777215)
End If
Next
End Sub
آخرین ویرایش به وسیله shaghaghi : دوشنبه 02 اردیبهشت 1387 در 13:30 عصر
یقینا بارها از امکان Subdatasheet هنگام کار با جداولی که ارتباط یک به چند با هم دارند کمک گرفته اید، و با اینکار اطلاعات را بصورت منسجم و راحت مشاهده و ویرایش نموده اید
اما اگر مایل هستید این سهولت را به سابفرم هایتان هم منتقل کنید نمونه برنامه زیر این امکان را به شما می دهد
اگر شما در یک روال نسبتا طولانی مرتب با خطاهای گوناگون برخورد می نمایید و هر بار مجبورید برای یافتن منبع خطا، با گذاشتن Break خط به خط، دستورات را دنبال نمایید، می توانید از این روش سریع بهره ببرید.
شما می توانید با شماره گذاری کردن سطرهای کد نویسی و با استفاده از تابع Erl شماره ردیف سطر مولد خطا را به سرعت بیابید و نسبت به رفع آن اقدام نمایید.
به این نمونه خطا توجه نمایید:
Private Sub Cmd1_Click()
On Error GoTo Err_Handler
1 Dim stDocName As String
2 Dim stLinkCriteria As String
3 stDocName = "Form1"
4 DoCmd.OpenReport stDocName, , , stLinkCriteria
Exit Sub
Err_Handler:
MsgBox "Error Line Is: " & Erl() & vbCrLf & Err.Description
End Sub
امیدوارم این مطلب برایتان تازگی داشته باشد!
آموزش Office VBA که بیشتر در مورد برنامه نویسی توی اکسس و اکسل هست. پیشنهاد می کنم به دوستان که حتماً این را مطالعه کنند. حداقل مواردی توش هستش که بدردشون بخوره.
مجموعه فايلهاي آموزشي PDF فارسي در ارتباط با برنامه نويسي پايگاه داده در VB6 ( مناسب براي آشنايي با مباحث VB و همچنين نحوه كاركردن با اينترفيس VB و بانك اطلاعاتي Access )
منبع : http://visualbasic.blogfa.com/
آخرین ویرایش به وسیله مهدی قربانی : دوشنبه 20 خرداد 1387 در 11:47 صبح
با اين كد شما قادر خواهيد بود با يك كامند باتون عمليات Compact And Repair رو اجرا كنيد .
اكسس 2007 اين كد رو پشتيباني نمي كنه و در اصل مخصوص ورژنهاي 2003 به پائين هست
اين كد رو مي تونيد در رخداد On Click كامند باتون روي فرم اصلي (Switchboard) برنامه خودتون قرار بديد :
CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
كار نميكنه اين لينك
ضمن تشکر ولی وقتی با فشردن دکمه + به آخرین روز ماه برسیم چنانچه مجددا دکمه + را فشار دهیم تاریخ به اولین روز ماه بعد منتقل نمی شود بلکه ادامه پیدا می کند و تعداد روزها بیشتر از تعداد روزهای ماه می شود.
با سلام خدمت همه عزیزان
بااستفاده از توابع آقای آزادی و دیگر دوستان تابع تبدیل تاریخ شمسی به حروف به همراه نمونه آماده شده
انشاءاله دیگران بتوانند استفاده کنند.
آخرین ویرایش به وسیله dadsara : یک شنبه 30 تیر 1387 در 07:29 صبح
هنگام طراحی فرم های جدید در پایگاه داده اکسس حتماً توجه کرده اید که اکسس، مشخصه Allow Design Changes را به صورت پیش فرض برابر All View قرار می دهد. به کمک این ویژگی، در هنگام طراحی فرم می توانید مشخصه ای از فرم یا شی کنترلی را مستقیماً در نمای فرم تغییر دهید و نتایج را بلافاصله مشاهده کنید.
هنگامی که برنامه آماده استفاده می شود باید مقدار این مشخصه را در همه فرم ها برابر Design View Only قرار دهید.
روال زیر کلیه فرم های موجود در پایگاه داده را پیدا و مشخصه مورد نظر را تغییر می دهد.
Sub FixAllowDesign()
Dim objFrm As AccessObject, frm As Form
' Go through every form in the database
For Each objFrm In CurrentProject.AllForms
' Open the form in Design view
DoCmd.OpenForm FormName:=objFrm.Name, _
View:=acDesign
' Set the form object for efficiency
Set frm = Forms(objFrm.Name)
' Check and reset the AllowDesignChanges property
If frm.AllowDesignChanges = True Then
frm.AllowDesignChanges = False
' Save the change
DoCmd.RunCommand acCmdSave
End If
' Close the form
DoCmd.Close acForm, objFrm.Name
' Loop to the next form
Next objFrm
End Sub
دوستان نمونه حاضر براي Restore كردن پشتيبان هاي گرفته شده از بانك اطلاعاتي كاربرد دارد . اميدوارم مفيد باشه.(با اين تذكر كه رفرنسهاي تصوير ضميمه بايد add بشه براي اين منظور OCX ضميمه رو توي SYSTEM32 ويندوز كپي كنين و بعد توي اكسس از منوي TOOLS>ACTIVEX CONTROLS رجيستر كنيد.)
Option Compare Database
Dim CommondialogControl2 As Control
Dim backfile As New FileSystemObject
Dim source As String, desti As String
Private Sub Command0_Click()
On Error GoTo err
' Dim source As String, desti As String
source = Application.CurrentProject.path & "\fdc.mdb"
With CommonDialog2
.DialogTitle = "Backup"
.Filter = "mdbfles (*.mdb)|*.mdb"
.ShowSave
desti = .FileName
backfile.CopyFile source, desti, True
MsgBox "Databas has been backup", vbInformation
End With
Exit Sub
err:
Beep
End Sub
Private Sub Command1_Click()
On Error GoTo err
desti = Application.CurrentProject.path & "\fdc.mdb"
If MsgBox("are you sure", vbOKCancel, "restore") = vbOK Then
With CommonDialog2
.DialogTitle = "Restore"
.Filter = "Access Files(*.mdb)|*.mdb"
.ShowOpen
source = .FileName
End With
backfile.CopyFile source, desti, True
MsgBox "Databas has been restored", vbInformation
Else
Cancel = True
End If
Exit Sub
err:
Beep
End Sub
...........................
موفق باشيد
آخرین ویرایش به وسیله amirzazadeh : چهارشنبه 16 مرداد 1387 در 12:18 عصر
اگر می خواهید کاربران برنامه تان را از کلیدهای پیمایش رکوردها محدود کنید
عیناً کد زیرا وارد برنامه خود کنید
در این کد 6 کلید از کار می افتند که خودتان حدس بزنید کدامها هستند...
Option Explicit
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case 33, 34, 37, 38, 39, 40, 9
KeyCode = 0
End Select
End Sub
نمونه های کاربردی و آموزشی VBA
سلام دوستان عزیز
ماژول تبدیل تاریخ میلادی به شمسی را براتون میذارم . این ماژول تقریبا کامله و در vb و اکسس کاربرد داره.
امیدوارم به دردتون بخوره. لطفا نظرتون رو بدید.
شما کار این ماژول رو در فرم می تونید ببینید و خود ماژول رو در قسمت Modules اکسس مشاهده کنید.
نمونه بانک رو براتون میذارم
و من الله التوفیق
Option Compare Database
Option Explicit
Function Miladi(DateToChange As String) As Date
Dim IntMilad As Integer
Dim StrMilad As String
Dim YY1 As Integer
Dim yy As Integer
Dim TempYY As Integer
Dim mm As Byte
Dim dd As Byte
Dim VazYear As Byte
IntMilad = 621
YY1 = Mid(DateToChange, 1, 2)
yy = Mid(DateToChange, 3, 2)
mm = Mid(DateToChange, 6, 2)
dd = Mid(DateToChange, 9, 2)
TempYY = yy
'--------------------------------------------
VazYear = ShamsiVazYear(TempYY)
'--------------------------------------------
' VazYear = 1 ÓÇá ßÈíÓå
' VazYear = 2 ÓÇá ÞÈá ÇÒ ßÈíÓå
'--------------------------------------------
YY1 = YY1 * 100
yy = YY1 + yy
If VazYear = 1 Then
Select Case mm
Case 1
If dd <= 12 Then
dd = dd + 19
mm = 3
yy = yy + IntMilad
Else
dd = dd - 12
mm = 4
yy = yy + IntMilad
End If
Case 2
If dd <= 11 Then
dd = dd + 19
mm = 4
Else
dd = dd - 11
mm = 5
End If
yy = yy + IntMilad
Case 3
If dd <= 11 Then
dd = dd + 20
mm = 5
Else
dd = dd - 11
mm = 6
End If
yy = yy + IntMilad
Case 4
If dd <= 10 Then
dd = dd + 20
mm = 6
Else
dd = dd - 10
mm = 7
End If
yy = yy + IntMilad
Case 5
If dd <= 10 Then
dd = dd + 21
mm = 7
Else
dd = dd - 10
mm = 8
End If
yy = yy + IntMilad
Case 6
If dd <= 10 Then
dd = dd + 21
mm = 8
Else
dd = dd - 10
mm = 9
End If
yy = yy + IntMilad
Case 7
If dd <= 9 Then
dd = dd + 21
mm = 9
Else
dd = dd - 9
mm = 10
End If
yy = yy + IntMilad
Case 8
If dd <= 10 Then
dd = dd + 21
mm = 10
Else
dd = dd - 10
mm = 11
End If
yy = yy + IntMilad
Case 9
If dd <= 10 Then
dd = dd + 20
mm = 11
Else
dd = dd - 10
mm = 12
End If
yy = yy + IntMilad
Case 10
If dd <= 11 Then
dd = dd + 20
mm = 12
yy = yy + IntMilad
Else
dd = dd - 11
mm = 1
yy = yy + IntMilad + 1
End If
Case 11
If dd <= 12 Then
dd = dd + 19
mm = 1
Else
dd = dd - 12
mm = 2
End If
yy = yy + IntMilad + 1
Case 12
If dd <= 10 Then
dd = dd + 18
mm = 2
Else
dd = dd - 10
mm = 3
End If
yy = yy + IntMilad + 1
End Select
' ÓÇáåÇí ÔÜãÓí ÛíÑßÈíÓå
Else:
Select Case mm
Case 1
If dd <= 11 Then
dd = dd + 20 '31
mm = 3
Else
dd = dd - 11
mm = 4
End If
yy = yy + IntMilad
Case 2
If dd <= 10 Then
dd = dd + 20 '30
mm = 4
Else
dd = dd - 10
mm = 5
End If
yy = yy + IntMilad
Case 3
If dd <= 10 Then
dd = dd + 21 '31
mm = 5
Else
dd = dd - 10
mm = 6
End If
yy = yy + IntMilad
Case 4
If dd <= 9 Then
dd = dd + 21 '30
mm = 6
Else
dd = dd - 9
mm = 7
End If
yy = yy + IntMilad
Case 5
If dd <= 9 Then
dd = dd + 22
mm = 7
Else
dd = dd - 9
mm = 8
End If
yy = yy + IntMilad
Case 6
If dd <= 9 Then
dd = dd + 22
mm = 8
Else
dd = dd - 9
mm = 9
End If
yy = yy + IntMilad
Case 7
If dd <= 8 Then
dd = dd + 22
mm = 9
Else
dd = dd - 8
mm = 10
End If
yy = yy + IntMilad
Case 8
If dd <= 9 Then
dd = dd + 22
mm = 10
Else
dd = dd - 9
mm = 11
End If
yy = yy + IntMilad
Case 9
If dd <= 9 Then
dd = dd + 21
mm = 11
Else
dd = dd - 9
mm = 12
End If
yy = yy + IntMilad
Case 10
If dd <= 10 Then
dd = dd + 21
mm = 12
yy = yy + IntMilad
Else
dd = dd - 10
mm = 1
yy = yy + IntMilad + 1
End If
Case 11
If dd <= 11 Then
dd = dd + 20
mm = 1
Else
dd = dd - 11
mm = 2
End If
yy = yy + IntMilad + 1
Case 12
If VazYear = 2 Then
If dd <= 9 Then
dd = dd + 19
mm = 2
Else
dd = dd - 9
mm = 3
End If
Else
If dd <= 9 Then
dd = dd + 19
mm = 2
Else
dd = dd - 9
mm = 3
End If
End If
yy = yy + IntMilad + 1
End Select
End If
StrMilad = yy
StrMilad = StrMilad & "/"
If mm < 10 Then
StrMilad = StrMilad & "0"
End If
StrMilad = StrMilad & mm
StrMilad = StrMilad & "/"
If dd < 10 Then
StrMilad = StrMilad & "0"
End If
StrMilad = StrMilad & dd
Miladi = StrMilad
End Function
Function Shamsi(DateToChange As String) As String
Dim IntSHAMS As Integer
Dim YY1 As Integer
Dim yy As Integer
Dim TempYY As Integer
Dim mm As Byte
Dim dd As Byte
Dim VazYear As Byte
IntSHAMS = 621
YY1 = Mid(DateToChange, 1, 2)
yy = Mid(DateToChange, 3, 2)
mm = Mid(DateToChange, 6, 2)
dd = Mid(DateToChange, 9, 2)
TempYY = yy
'---------------------------------
VazYear = MiladiVazYear(TempYY)
'--------------------------------------------
' VazYear = 1 ÓÇá ßÈíÓå
' VazYear = 2 ÓÇá ÈÚÏ ÇÒ ßÈíÓå
'-------------------------------------------zz-
YY1 = YY1 * 100
yy = YY1 + yy
If VazYear = 1 Then
Select Case mm
Case 1
If dd <= 20 Then
dd = dd + 10
mm = 10
Else
dd = dd - 20
mm = 11
End If
yy = yy - IntSHAMS - 1
Case 2
If dd <= 19 Then
dd = dd + 11
mm = 11
Else
dd = dd - 19
mm = 12
End If
yy = yy - IntSHAMS - 1
Case 3
If dd <= 19 Then
dd = dd + 10
mm = 12
yy = yy - IntSHAMS - 1
Else
dd = dd - 19
mm = 1
yy = yy - IntSHAMS
End If
Case 4
If dd <= 19 Then
dd = dd + 12
mm = 1
Else
dd = dd - 19
mm = 2
End If
yy = yy - IntSHAMS
Case 5
If dd <= 20 Then
dd = dd + 11
mm = 2
Else
dd = dd - 20
mm = 3
End If
yy = yy - IntSHAMS
Case 6
If dd <= 20 Then
dd = dd + 11
mm = 3
Else
dd = dd - 20
mm = 4
End If
yy = yy - IntSHAMS
Case 7
If dd <= 21 Then
dd = dd + 10
mm = 4
Else
dd = dd - 21
mm = 5
End If
yy = yy - IntSHAMS
Case 8
If dd <= 21 Then
dd = dd + 10
mm = 5
Else
dd = dd - 21
mm = 6
End If
yy = yy - IntSHAMS
Case 9
If dd <= 21 Then
dd = dd + 10
mm = 6
Else
dd = dd - 21
mm = 7
End If
yy = yy - IntSHAMS
Case 10
If dd <= 21 Then
dd = dd + 9
mm = 7
Else
dd = dd - 21
mm = 8
End If
yy = yy - IntSHAMS
Case 11
If dd <= 20 Then
dd = dd + 10
mm = 8
Else
dd = dd - 20
mm = 9
End If
yy = yy - IntSHAMS
Case 12
If dd <= 20 Then
dd = dd + 10
mm = 9
Else
dd = dd - 20
mm = 10
End If
yy = yy - IntSHAMS
End Select
Else
Select Case mm
Case 1
If VazYear = 2 Then
If dd <= 19 Then
dd = dd + 11
mm = 10
Else
dd = dd - 19
mm = 11
End If
Else
If dd <= 20 Then
dd = dd + 10
mm = 10
Else
dd = dd - 20
mm = 11
End If
End If
yy = yy - IntSHAMS - 1
Case 2
If VazYear = 2 Then
If dd <= 18 Then
dd = dd + 12
mm = 11
Else
dd = dd - 18
mm = 12
End If
Else
If dd <= 19 Then
dd = dd + 11
mm = 11
Else
dd = dd - 19
mm = 12
End If
End If
yy = yy - IntSHAMS - 1
Case 3
If dd <= 20 Then
If VazYear = 2 Then
dd = dd + 10
Else
dd = dd + 9
End If
mm = 12
yy = yy - IntSHAMS - 1
Else
dd = dd - 20
mm = 1
yy = yy - IntSHAMS
End If
Case 4
If dd <= 20 Then
dd = dd + 11
mm = 1
Else
dd = dd - 20
mm = 2
End If
yy = yy - IntSHAMS
Case 5
If dd <= 21 Then
dd = dd + 10
mm = 2
Else
dd = dd - 21
mm = 3
End If
yy = yy - IntSHAMS
Case 6
If dd <= 21 Then
dd = dd + 10
mm = 3
Else
dd = dd - 21
mm = 4
End If
yy = yy - IntSHAMS
Case 7
If dd <= 22 Then
dd = dd + 9
mm = 4
Else
dd = dd - 22
mm = 5
End If
yy = yy - IntSHAMS
Case 8
If dd <= 22 Then
dd = dd + 9
mm = 5
Else
dd = dd - 22
mm = 6
End If
yy = yy - IntSHAMS
Case 9
If dd <= 22 Then
dd = dd + 9
mm = 6
Else
dd = dd - 22
mm = 7
End If
yy = yy - IntSHAMS
Case 10
If dd <= 22 Then
dd = dd + 8
mm = 7
Else
dd = dd - 22
mm = 8
End If
yy = yy - IntSHAMS
Case 11
If dd <= 21 Then
dd = dd + 9
mm = 8
Else
dd = dd - 21
mm = 9
End If
yy = yy - IntSHAMS
Case 12
If dd <= 21 Then
dd = dd + 9
mm = 9
Else
dd = dd - 21
mm = 10
End If
yy = yy - IntSHAMS
End Select
End If
Shamsi = yy
Shamsi = Shamsi & "/"
If mm < 10 Then
Shamsi = Shamsi & "0"
End If
Shamsi = Shamsi & mm
Shamsi = Shamsi & "/"
If dd < 10 Then
Shamsi = Shamsi & "0"
End If
Shamsi = Shamsi & dd
End Function
Function ShamsiVazYear(YearShamsi As Integer)
ShamsiVazYear = 0
Start:
If YearShamsi = 3 Then
ShamsiVazYear = 1
ElseIf YearShamsi = 2 Or YearShamsi = 0 Then
ShamsiVazYear = 2
ElseIf YearShamsi < 3 Then
Exit Function
Else
YearShamsi = YearShamsi - 4
GoTo Start
End If
End Function
Function MiladiVazYear(YearMiladi As Integer)
MiladiVazYear = 0
Start:
If YearMiladi = 0 Then
MiladiVazYear = 1
ElseIf YearMiladi = 1 Then
MiladiVazYear = 2
ElseIf YearMiladi < 0 Then
Exit Function
Else
YearMiladi = YearMiladi - 4
GoTo Start
End If
End Function
Function TestDate(MozdStrTempDate As String)
Dim yy As Integer
Dim mm As Byte
Dim dd As Byte
yy = Mid(MozdStrTempDate, 3, 2)
mm = Mid(MozdStrTempDate, 6, 2)
dd = Mid(MozdStrTempDate, 9, 2)
If mm = 1 Or mm = 2 Or mm = 3 _
Or mm = 4 Or mm = 5 Or mm = 6 Then
If dd < 0 Or dd > 31 Then
TestDate = 0
Exit Function
End If
ElseIf mm = 7 Or mm = 8 Or mm = 9 _
Or mm = 10 Or mm = 11 Then
If dd < 0 Or dd > 30 Then
TestDate = 0
Exit Function
End If
ElseIf mm = 12 Then
If ShamsiVazYear(yy) = 1 Then
If dd < 0 Or dd > 30 Then
TestDate = 0
Exit Function
End If
Else
If dd > 29 Then
TestDate = 0
Exit Function
End If
End If
ElseIf mm > 12 Then
TestDate = 0
Exit Function
End If
TestDate = 1
End Function
Function RetYearMonthDay(StrTemp As String, Vaz As Byte) As String
If Vaz = 0 Then
RetYearMonthDay = HowMonth(Mid(StrTemp, 6, 2))
ElseIf Vaz = 1 Then
RetYearMonthDay = Mid(StrTemp, 1, 4)
End If
End Function
Function HowMonth(Vaz As Byte)
Select Case Vaz
Case 1
HowMonth = "ÝÑæÑÏíä"
Case 2
HowMonth = "ÇÑÏíÈåÔÊ"
Case 3
HowMonth = "ÎÜÑÏÇÏ"
Case 4
HowMonth = "ÊíÜÜÑ"
Case 5
HowMonth = "ãÜÑÏÇÏ"
Case 6
HowMonth = "ÔåÑíÜæÑ"
Case 7
HowMonth = "ãÜåÑ"
Case 8
HowMonth = "ÂÈÜÜÇä"
Case 9
HowMonth = "ÂÐÑ"
Case 10
HowMonth = "Ïí"
Case 11
HowMonth = "ÈåÜãä"
Case 12
HowMonth = "ÇÓÜÝäÏ"
End Select
End Function
Function NumOfDate(DateToNum As String) As Integer
Dim yy As Integer
Dim mm As Integer
Dim TempMM As Integer
Dim dd As Integer
yy = Mid(DateToNum, 1, 4)
mm = Mid(DateToNum, 6, 2)
dd = Mid(DateToNum, 9, 2)
If mm <= 6 Then
TempMM = 31 * (mm - 1)
ElseIf mm <= 11 Then
TempMM = 186 + (30 * (mm - 7))
ElseIf mm = 12 Then
TempMM = 336
End If
NumOfDate = yy + TempMM + dd
End Function
Function HowDay(StrTemp As String)
Select Case StrTemp
Case "ÔäÈå", "Saturday"
HowDay = "ÔäÈå"
Case "íßÔäÈå", "Sunday"
HowDay = "íßÔäÈå"
Case "ÏæÔäÈå", "Monday"
HowDay = "ÏæÔäÈå"
Case "ÓåÔäÈå", "Tuesday"
HowDay = "ÓåÔäÈå"
Case "åÇÑÔäÈå", "Wednesday"
HowDay = "åÇÑÔäÈå"
Case "äÌÔäÈå", "Thursday"
HowDay = "äÌÔäÈå"
Case "ÌãÚå", "Friday"
HowDay = "ÌãÚå"
Case Else
HowDay = StrTemp
End Select
End Function
Function HowYear(StrTemp As String)
Dim YY1 As Integer
Dim YY2 As Integer
Dim MM1 As Byte
Dim MM2 As Byte
Dim DD1 As Byte
Dim DD2 As Byte
YY1 = Int(Left(Shamsi(Format(Date, "yyyy/mm/dd")), 4))
MM1 = Int(Mid(Shamsi(Format(Date, "yyyy/mm/dd")), 6, 2))
DD1 = Int(Right(Shamsi(Format(Date, "yyyy/mm/dd")), 2))
YY2 = Int(Left(StrTemp, 4))
MM2 = Int(Mid(StrTemp, 6, 2))
DD2 = Int(Right(StrTemp, 2))
HowYear = 0
If YY1 > YY2 Then
If MM1 > MM2 Then
HowYear = YY1 - YY2
ElseIf MM1 = MM2 Then
If DD1 >= DD2 Then
HowYear = YY1 - YY2
ElseIf DD1 < DD2 Then
HowYear = (YY1 - YY2) - 1
End If
ElseIf MM1 < MM2 Then
HowYear = (YY1 - YY2) - 1
End If
End If
End Function
آخرین ویرایش به وسیله مهدی قربانی : پنج شنبه 24 مرداد 1387 در 14:20 عصر
در خصوص تاپيك 70 و جناب منتظران منتظر :
با سلام و تشكر
1- لطف فرماييد توابع كاربردي آنرا را هم نام ببريد ( مثلاً نحوه استفاده از تاريخ با روز هفته ، تاريخ كوتاه يا بلند و ... )
2- ماژول ديگر كه چه كاربردي دارد ؟ ( البته اگر اشتباه جا نمانده باشد !)
اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر
---------------------------------
سلام دوست عزيز
من از فايل شما استفاده كردم ولي در هنگام كپي خطاي باز بودن فايلها و برنامه ها را ميدهد . تمام برنامه هايم را بستم ولي باز هم همان خطا را مي داد . نمونه عكس
کسی استفاده نکرد ؟
-------------------------
با سلام
جناب فلاح بنده استفاده كردم و جواب داد و بسيار مفيد بود از مطالب مفيد شما بسيار ممنونم .
بازکردن و وارد کردن فایلها در اکسس
در خصوص تاپیک 62 و جناب دلشکسته:
چطور میتوان مجموع زمان را برای بازه ای از زمان در داخل یک تیبل انجام داد.فرضا ما یک فیلد تاریخ در تیبل داریم و می خواهیم جمع ساعات کاری برای یک دوره یک ماهه شخصی را بررسی کنیم به طوری که تاریخ را از داخل یک فرم از ما بخواهد.
ممنونم.
با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...
اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر
آخرین ویرایش به وسیله مهدی قربانی : پنج شنبه 31 مرداد 1387 در 03:04 صبح
----------------------------------
سلام دوست عزيز
مطلبي كه فرموديد انجام دادم ولي آن موردي كه گفتيد در Option بايد تيك بزنيد من پيدا نكردم
لطفا كامل توضيح بدهيد و بگوييد خودتان چگونه عمل كرديد اگر ممكن است با عكس توضيح دهيد .
متشكرم
Tools > Option > intrnational > use hijri calender
پاسخ با نقل قول
