-
1 ضمیمه
INPUTBOX با پوشانه ورودی(PASSWORD MASK)
لطفا نمونه را ببینید در اين نمونه براي حذف ركورد كاربر بايد پسورد لازم رو وارد كنه كه به دلايل امنيتي موقع ورود پسورد به شكل ستاره نشان داده ميشود.
(پسورد حدف رکورد عدد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
-
پیدا کردن سریع سطر منبع خطای حین اجرا (Run time Error)
اگر شما در یک روال نسبتا طولانی مرتب با خطاهای گوناگون برخورد می نمایید و هر بار مجبورید برای یافتن منبع خطا، با گذاشتن 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
امیدوارم این مطلب برایتان تازگی داشته باشد!
-
1 ضمیمه
آموزش Office VBA که بیشتر در مورد برنامه نویسی توی اکسس و اکسل هست. پیشنهاد می کنم به دوستان که حتماً این را مطالعه کنند. حداقل مواردی توش هستش که بدردشون بخوره.
-
آموزش استفاده از توابع هجری شمسی در اکسس و تبدیل عدد به حروف
-
5 ضمیمه
مجموعه فايلهاي PDF آموزش برنامه نویسی پایگاه داده در ویژوال بیسیک 6
مجموعه فايلهاي آموزشي PDF فارسي در ارتباط با برنامه نويسي پايگاه داده در VB6 ( مناسب براي آشنايي با مباحث VB و همچنين نحوه كاركردن با اينترفيس VB و بانك اطلاعاتي Access )
منبع : http://visualbasic.blogfa.com/
-
نقل قول: اجراي Comact And Repair با كد
با اين كد شما قادر خواهيد بود با يك كامند باتون عمليات Compact And Repair رو اجرا كنيد .
اكسس 2007 اين كد رو پشتيباني نمي كنه و در اصل مخصوص ورژنهاي 2003 به پائين هست
اين كد رو مي تونيد در رخداد On Click كامند باتون روي فرم اصلي (Switchboard) برنامه خودتون قرار بديد :
CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
-
1 ضمیمه
فايل آموزشي PDF
سلام اميدوارم اين فايل بدرد دوستان بخور
-
نقل قول: نمونه های کاربردی و آموزشی VBA
یک مقاله آموزشی اکسس مفید و روان برای کسانیکه می خواهند یک مطالعه مجدد بر روی اکسس داشته باشند تا به یک سری از ابهاماتشون در مورد اکسس جواب داده بشه.
این هم آدرس و منبع فایل:
http://www.farsaran.ir/Access_Section/Files/Access.pdf
و این هم یک فایل دیگه:
http://www.farsaran.ir/Access_Sectio...s_internet.pdf
-
2 ضمیمه
گرد کردن لبه های BOX در گزارش
سلام
مطمئنا تا بحال کادرهای مستطیل با لبه های گرد را در سربرگ اسناد و گزارشات ملاحضه نموده اید، شاید هم آرزوی داشتن آنرا در گزارشاتتان نموده اید! شاید هم به سراغ استفاده از عکس برای این کار رفته اید؟!
برای بهره مندی از این امکان یک ماژول با این محتویات در فایلتان ایجاد کنید:
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 تعبیه شده نوشته شده است)
ضمنا پارامتر سوم و چهارم اختیاری بود و برای تنظیم میزان گرد شدن لبه و رنگ خط دور کادر بکار می رود.
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
يك تشكر ويژه از دوستاني كه وقت مي ذارن معلومات و منابع خودشون رو براي استفاده سايرين ارائه مي كنن از بقيه دوستان هم انتظار مي ره به فراخور توانشون در اين امر مشاركت كنن و با مشاركتشون باعث ايجاد انگيزه و رغبت در بين كاربران بشن ، دوستان گرامي رشد و تعالي علمي در گرو تحقيق و مشاركت هست پس فارغ از سطح علمي و معلومات با انجام تحقيق در بين منابع و سورسهاي متنوعي كه در حال حاضر بواسطه كتابها ، جزوات ، سايتها و پورتالهاي اينترنتي در دسترسمون قرار مي گيره سعي كنيم اين منابع و دستاوردها رو در اختيار سايرين بذاريم تا به اين بهانه سهمي در رشد و ارتقاء خود و دوستانمون داشته باشيم .
-
خروجی اکسل از سابفرم
خیلی از مواقع مجبور هستید منبع رکورد سابفرم را تغییر دهید یا فیلتری روی آن اعمال کنید، در این مواقع اگر مجبور باشید از سابفرم خروجی اکسل داشته باشید مجبورید سراغ رکوردست آن بروید. اما این کار چند مشکل دارد اول اینکه اسامی مستعار فیلدها اعمال نمی شود، فیلدی های کدینگ شده بصورت اصلی شان یعنی کد Export می شوند و سایر مشکلات.
اینجا از ترفند ساده ای برای این عمل استفاده شده، به گونه ای که تمام رکوردهای سابفرم یکجا select شده در یک فایل اکسل Paste می شوند
Private Sub cmdExport_Click()
If Me.sform1.Form.Recordset.EOF Then Exit Sub
Me.sform1.SetFocus
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.add
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Application.Visible = True
xlSheet.Paste
End Sub
-
نقل قول: محاسبه مجموع زمان ( ساعات کارکرد )
نقل قول:
نوشته شده توسط
mehdi-gh
با این ماجول می تونید مجموع زمان رو بطور صحیح و با فرمت HH:MM محاسبه کنید و مشکلی که بعضی از دوستان در محاسبه مجموع زمان با اون برخورد می کنند ( عدم محاسبه بیشتر از 24 ساعت ) رو حل می کنه .
کدهای زیر رو در یک ماجول کپی کنید :
Function GetTimeRoozanehTotal()
Dim db As Database, rs As Recordset
Dim totalhours As Long, totalminutes As Long
Dim days As Long, Hours As Long, Minutes As Long
Dim interval As Variant, j As Integer
Set db = DBEngine.Workspaces(0).Databases(0)
Set rs = db.OpenRecordset("TimeRoozaneh")
interval = #12:00:00 AM#
'
While Not rs.EOF
interval = interval + rs![Roozaneh]
rs.MoveNext
Wend
totalhours = Int(CSng(interval * 24))
totalminutes = Int(CSng(interval * 1440))
Hours = totalhours Mod 24
Minutes = totalminutes Mod 60
' در صورتیکه مایل به استفاده عبارات ساعت و دقیقه هستید خط زیر رو فعال کنید
' GetTimeRoozanehTotal = totalhours & " ساعت و " & Minutes & " دقیقه"
GetTimeRoozanehTotal = totalhours & ":" & Minutes
End Function
بعد این تابع رو در Control Source یک TextBox در فرم کپی کنید :
=GetTimeRoozanehTotal()
نمونه مرتبط :
لطفا نمونه اكسس پروجكت بزاريد عالي ميشه
البته كد
-
بدست آوردن لیستی از Sheet های موجود در یک فایل اکسل
با کمک این نمونه کد شما قادر خواهید بود، همانند ویزارد خود اکسس لیستی از sheet های یک فایل اکسل را بدست آورده و مطابق با آیتم های موجود آن تصمیم گیری نمایید و از بروز خطا در مواردی که فایل اکسل شامل sheet1 (مقدار پیش فرض) نمی باشد جلوگیری نمایید
Dim objExcel As Excel.Application
Dim objWorkBook As Excel.Workbook
Dim totalWorkSheets As Excel.Worksheet
Dim objWorkSheets As Excel.Worksheet
Set objExcel = CreateObject("Excel.Application")
Set objWorkBook = objExcel.Workbooks.Open("C:\myExcel.xls")
' this code gets the names off all the worksheets
For Each totalWorkSheets In objWorkBook.Worksheets
MsgBox totalWorkSheets.Name
Next totalWorkSheets
-
1 ضمیمه
نقل قول: كار با ListBox
حذف و اضافه كردن ركوردهاي دو جدول با استفاده از ListBox
با كدهاي زير شما قادر خواهيد بود تا گزينه هاي موجود در دو ListBox رو بين هم رد و بدل كنيد البته اين ListBox ها از نوع Unbound نيستند و در اصل هر كدام به جدولي مرتبط شده اند .
براي ملموس تر شدن فرآيندهاي بكار گرفته شده نمونه كاربردي هم تقديم دوستان ميشه .
Private Sub Command4_Click()
On Error GoTo Err_Command4_Click
Dim Rst1 As DAO.Recordset
Dim Rst2 As DAO.Recordset
Dim strSQL As String
Dim strSQL1 As String
strSQL1 = "SELECT Table1.id, Table1.name FROM Table1 WHERE (((Table1.id)='" & Me.List0 & "'));"
strSQL2 = "DELETE Table1.id, Table1.name FROM Table1 WHERE (((Table1.id)='" & Me.List0 & "'));"
Set Rst1 = CurrentDb.OpenRecordset(strSQL1)
Set Rst2 = CurrentDb.OpenRecordset("table2")
'ÇÑ ÊÚÏÇ Òíäå åÇí áíÓÊ ÈÇßÓ ÕÝÑ ÈÇÔå æ ÑßæÑÏí åã ÏÑ ÑßæÑÏÓÊ ãæÌæÏ äÈÇÔå
If Rst1.RecordCount = 0 And Me.List0.ListCount = 0 Then
MsgBox "ãÞÏÇÑí ãæÌæÏ äãí ÈÇÔÏ", vbMsgBoxRight + vbExclamation, "ÊæÌå" ' íÛÇã ÚÏã ãæÌæÏí
Exit Sub ' ÎÑæÌ ÇÒ ÑÎÏÇÏ
' ÇÑ ÑßæÑÏÓÊ ÕÝÑ ÈÇÔå æáí ÊÚÏÇÏ Òíäå åÇí áíÓÊ ÈÇßÓ ÈíÔÊÑ ÇÒ ÕÝÑ ÈÇÔå
ElseIf Rst1.RecordCount = 0 And Me.List0.ListCount > 0 Then
'íÛÇã ÚÏã ÇäÊÎÇÈ Òíäå
MsgBox "Òíäå Çí ÇÒ áíÓÊ ÇäÊÎÇÈ äÔÏå ÇÓÊ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
Me.List0.SetFocus ' ÇäÊÞÇá ÝæßæÓ Èå áíÓÊ ÈÇßÓ
Me.List0.Selected(1) = True ' ÇäÊÎÇÈ Çæáíä Òíäå ãæÌæÏ ÏÑ áíÓÊ
Exit Sub ' ÎÑæÌ ÇÒ ÑÎÏÇÏ
Else ' ÏÑ ÛíÑ ÇíäÕæÑÊ
Rst2.AddNew ' ÇÖÇÝå ßÑÏä ÑßæÑÏ ÌÏíÏ ÏÑ ÑßæÑÏÓÊ
' ÇäÊÞÇá ÇØáÇÚÇÊ ãæÌæÏ ÏÑ áíÓÊ ÈÇßÓ Èå ÑßæÑÏÓÊ
Rst2.Fields("id").Value = Me.List0.Column(0)
Rst2.Fields("name").Value = Me.List0.Column(1)
Rst2.Update
' ÇÌÑÇí ßÏ ÇÓ ßíæ Çá ãÑÈæØ Èå ÍÐÝ ÑßæÑÏ ãÊäÇÙÑ ÈÇ áíÓÊ ÈÇßÓ ÇÒ ÌÏæá
DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL2)
DoCmd.SetWarnings True
End If
' ÈÇÒ ÎæÇäí áíÓÊ ÈÇßÓåÇ
Me.List0.Requery
Me.List2.Requery
Me.List0.SetFocus ' ÇäÊÞÇá ÝæßæÓ Èå áíÓÊ ÈÇßÓ ÌÇÑí
List0.Selected(1) = True ' ÇäÊÞÇá Èå Òíäå Çæá áíÓÊ ÈÇßÓ ÌÇÑí
Set Rst = Nothing
Set Rst1 = Nothing
Exit_Command4_Click:
Exit Sub
Err_Command4_Click:
MsgBox Err.Description
Resume Exit_Command4_Click
End Sub
Private Sub Command5_Click()
On Error GoTo Err_Command5_Click
Dim Rst3 As DAO.Recordset
Dim Rst4 As DAO.Recordset
Dim strSQL3 As String
Dim strSQL4 As String
strSQL3 = "SELECT Table2.id, Table2.name FROM Table2 WHERE (((Table2.id)='" & Me.List2 & "'));"
strSQL4 = "DELETE Table2.id, Table2.name FROM Table2 WHERE (((Table2.id)='" & Me.List2 & "'));"
Set Rst3 = CurrentDb.OpenRecordset(strSQL3)
Set Rst4 = CurrentDb.OpenRecordset("table1")
If Rst3.RecordCount = 0 And Me.List2.ListCount = 0 Then
MsgBox "ãÞÏÇÑí ãæÌæÏ äãí ÈÇÔÏ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
Exit Sub
ElseIf Rst3.RecordCount = 0 And Me.List2.ListCount > 0 Then
MsgBox "Òíäå Çí ÇÒ áíÓÊ ÇäÊÎÇÈ äÔÏå ÇÓÊ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
Me.List2.SetFocus
Me.List2.Selected(1) = True
Exit Sub
Else
Rst4.AddNew
Rst4.Fields("id").Value = Me.List2.Column(0)
Rst4.Fields("name").Value = Me.List2.Column(1)
Rst4.Update
DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL4)
DoCmd.SetWarnings True
End If
Me.List0.Requery
Me.List2.Requery
Me.List2.SetFocus
Me.List2.Selected(1) = True
Set Rst = Nothing
Set Rst1 = Nothing
Exit_Command5_Click:
Exit Sub
Err_Command5_Click:
MsgBox Err.Description
Resume Exit_Command5_Click
End Sub
نمونه مرتبط :
-
1 ضمیمه
نقل قول: تبدیل تاریخ شمسی به حروف
با سلام خدمت همه عزیزان
بااستفاده از توابع آقای آزادی و دیگر دوستان تابع تبدیل تاریخ شمسی به حروف به همراه نمونه آماده شده
انشاءاله دیگران بتوانند استفاده کنند.
-
غیر فعال کردن نمای طراحی فرم
هنگام طراحی فرم های جدید در پایگاه داده اکسس حتماً توجه کرده اید که اکسس، مشخصه 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
-
3 ضمیمه
Restore of Backup
دوستان نمونه حاضر براي 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
...........................
موفق باشيد
-
نقل قول: نمونه های کاربردی و آموزشی VBA
اگر می خواهید کاربران برنامه تان را از کلیدهای پیمایش رکوردها محدود کنید
عیناً کد زیرا وارد برنامه خود کنید
در این کد 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
-
1 ضمیمه
نمونه های کاربردی و آموزشی 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
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر
-
نقل قول: نمونه های کاربردی و آموزشی VBA
در خصوص تاپيك 70 و جناب منتظران منتظر :
با سلام و تشكر
1- لطف فرماييد توابع كاربردي آنرا را هم نام ببريد ( مثلاً نحوه استفاده از تاريخ با روز هفته ، تاريخ كوتاه يا بلند و ... )
2- ماژول ديگر كه چه كاربردي دارد ؟ ( البته اگر اشتباه جا نمانده باشد !)
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
نوشته شده توسط
Ali_Fallah
اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر
---------------------------------
سلام دوست عزيز
من از فايل شما استفاده كردم ولي در هنگام كپي خطاي باز بودن فايلها و برنامه ها را ميدهد . تمام برنامه هايم را بستم ولي باز هم همان خطا را مي داد . نمونه عكس
-
نقل قول: نمونه های کاربردی و آموزشی VBA
با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...
اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
نوشته شده توسط
Ali_Fallah
با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...
اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر
----------------------------------
سلام دوست عزيز
مطلبي كه فرموديد انجام دادم ولي آن موردي كه گفتيد در Option بايد تيك بزنيد من پيدا نكردم
لطفا كامل توضيح بدهيد و بگوييد خودتان چگونه عمل كرديد اگر ممكن است با عكس توضيح دهيد .
متشكرم
-
نقل قول: نمونه های کاربردی و آموزشی VBA
Tools > Option > intrnational > use hijri calender
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
آیا راهی وجود دارد که بدون اینکه ویندوز را از حالت safe Mode بالا بیاوریم این فایل را با فایل قبلی جایگزین نمود یا خیر؟
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
دوستان ، به نظر ميرسه كه مباحث اين تاپيك داره مقداري از موضوع اصلي اون كه مباحث VBA هست فاصله ميگيره بنابراين پيشنهاد مي كنم در صورتي كه مايل به ادامه بحث در رابطه با موضوع پست آقاي فلاح هستيد ، پستهاي مربوطه به يك تاپيك مجزا منتقل بشه . ( آقاي فلاح PM بديد )
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
چطوری می شود به یک فیلد از نوع namber یک کلید شماره گزار الحاق نمود که رکورد جدید را با عدد افزایشی بدون تکرار کامل کند. متشکرم.
عزیزی
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
لطفاً در مورد تعیین فرمانها و نحوی اجرای ماژولها در Access توضیح دهید.متشکرم
عزیزی
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
نوشته شده توسط
mazizi
سلام
لطفاً در مورد تعیین فرمانها و نحوی اجرای ماژولها در Access توضیح دهید.متشکرم
عزیزی
سلام
دوست گرامي براي شروع اينجا رو ببينيد
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
نوشته شده توسط
Ali_Fallah
اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر
کسی استفاده نکرد ؟
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
نوشته شده توسط
Ali_Fallah
کسی استفاده نکرد ؟
-------------------------
با سلام
جناب فلاح بنده استفاده كردم و جواب داد و بسيار مفيد بود از مطالب مفيد شما بسيار ممنونم .
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
بازکردن و وارد کردن فایلها در اکسس
-
نقل قول: محدود کردن محاسبه مجموع زمان در یک بازه زمانی خاص
در خصوص تاپیک 62 و جناب دلشکسته:
چطور میتوان مجموع زمان را برای بازه ای از زمان در داخل یک تیبل انجام داد.فرضا ما یک فیلد تاریخ در تیبل داریم و می خواهیم جمع ساعات کاری برای یک دوره یک ماهه شخصی را بررسی کنیم به طوری که تاریخ را از داخل یک فرم از ما بخواهد.
ممنونم.
-
نقل قول: نمونه های کاربردی و آموزشی VBA
دوستان برای شکیلتر شدن برنامه شکل کروسر موس رو به این صورت تغییربدین:
ابتدا این ماجول را کپی کنید:
Option Compare Database
'*********************** Code Starts Here **********************************
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'================================================= ====================
' Globals for cursor handling
Global Const GCL_HCURSOR = (-12)
Global hSwapCursor As Long
Global hAniCursor As Long
'================================================= ====================
Public Const IDC_ARROW = 32512&
Public Const IDC_IBEAM = 32513&
Public Const IDC_WAIT = 32514&
Public Const IDC_CROSS = 32515&
Public Const IDC_UPARROW = 32516&
Public Const IDC_ICON = 32641&
Public Const IDC_SIZENWSE = 32642&
Public Const IDC_SIZENESW = 32643&
Public Const IDC_SIZEWE = 32644&
Public Const IDC_SIZENS = 32645&
Public Const IDC_SIZEALL = 32646&
Public Const IDC_NO = 32648&
Public Const IDC_HAND = 32649&
Public Const IDC_APPSTARTING = 32650&
Declare Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" _
(ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Declare Function LoadCursorFromFile Lib "user32" Alias _
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Declare Function SetCursor Lib "user32" _
(ByVal hCursor As Long) As Long
'
Public Function Arrow_Pointer()
Screen.MousePointer = 1
End Function
Function ChangeCursor(strPathToCursor As String)
On Error GoTo Error_On_ChangeCursor
If Dir(strPathToCursor) <> "" Then
Dim lngRet As Long
lngRet = LoadCursorFromFile(strPathToCursor)
lngRet = SetCursor(lngRet)
End If
Exit_ChangeCursor:
Exit Function
Error_On_ChangeCursor:
Resume Exit_ChangeCursor
End Function
Public Function Default_Pointer()
Screen.MousePointer = 0
End Function
Public Function IBeam_Pointer()
Screen.MousePointer = 3
End Function
Function MouseCursor(CursorType As Long)
Dim lngRet As Long
lngRet = LoadCursorBynum(0&, CursorType)
lngRet = SetCursor(lngRet)
End Function
Public Function Replace_Cursor(PathToFile As String)
hAniCursor = LoadCursorFromFile(PathToFile)
hSwapCursor = SetClassLong(Screen.ActiveForm.hWnd, GCL_HCURSOR, hAniCursor)
End Function
Public Function Restore_Cursor()
hSwapCursor = SetClassLong(Screen.ActiveForm.hWnd, GCL_HCURSOR, hSwapCursor)
End Function
بعد روی رویداد MouseMove مورد نظرتان هر کدام از کدهایی که میخواید صدا بزنید مثلا برای تغییر شکل بصورت دست این کد را بزنید:
Call MouseCursor(32649)
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
با سلام خدمت دوستان
نمونه حاضر براي جلوگيري از ورود مقادير تكراي در سابفرم آماده شده درصورت ورود داده تكراري پيامي صادر و داده حذف ميگردد.براي اين منظور از تابع DCOUNT بهره گيري شده است .اميدوارم قابل استفاده باشه.
Private Sub girande_BeforeUpdate(Cancel As Integer)
Dim SID As String
Dim stLinkCriteria As String
Dim rsc As DAO.Recordset
Set rsc = Me.RecordsetClone
SID = Me.girande.Value
stLinkCriteria = "[girande]=" & "'" & SID & "'"
If DCount("girande", "query3", _
stLinkCriteria) > 0 Then
'Undo duplicate entry
Me.Undo
'Message box warning of duplication
MsgBox "Warning data " _
& SID & " has already been entered." _
& vbCr & vbCr, vbInformation, "Duplicate Information"
End If
Set rsc = Nothing
End Sub
-
نقل قول: Allow Bypass Key
نقل قول:
نوشته شده توسط
مهدی قربانی
بستن کلید شیفت :
Public Function SetAllowBypassKeyFalse()
'----- کنترل خطا
On Error GoTo Err_SetAllowBypassKeyFalse
Dim db As DAO.Database, prp As DAO.Property
'----- در صورت موجود بودن Property ست کردن
Set db = CurrentDb
db.Properties("AllowBypassKey") = False
Set db = Nothing
Exit_SetAllowBypassKeyFalse:
Exit Function
'----- کنترل خطا
Err_SetAllowBypassKeyFalse:
'----- خطا در صورت موجود نبودن Property
'----- اگر قبلاً ساخته نشده Property ساخت
If Err = 3270 Then
Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, False)
db.Properties.Append prp
Resume Next
Else
'----- در صورت بروز خطاهای غیر منتظره
MsgBox "SetAllowBypassKeyFalse", Err.Number, Err.Description
Resume Exit_SetAllowBypassKeyFalse
End If
End Function
مهندس این کد رو چه جوری اجرایی کنم تو on loud یا جای دیگه....
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
اين كد رو اول توي يك ماجول كپي و ذخيره كنيد ، بعد مثلاً در لود فرم اصلي برنامه يا يك كامند باتون اين عبارت رو بنويسيد : SetAllowBypassKeyFalse
البته اگر يك بار اين ماجول اجرا بشه ديگه براي هميشه شيفت بسته ميشه و احتياجي نيست كه هر بار برنامه لود ميشه اين عمل تكرار بشه بنابر اين مي تونيد يك فرم در فايل بذاريد به همراه كامند باتون كه فقط در صورت نياز بهش رجوع كنيد . ويك نكته مهم اينكه حتماً قبل از بستن شيفت يك كپي لز فايل رو در جايي ذخيره كنيد .
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
نمونه آموزشي براي مديريت فيلدهاي الزامي با پيام هاي فارسي
لطفا فايل ضميمه رو ببينيد:
درصورت عدم ورود فيلدهاي الزامي پيام خطا صادر ميگردد
Option Compare Database
Private Sub Form_Error(DataErr As Integer, Response As Integer)
'If an error occurs because of missing data in a required field
'display our own custom error message
Const conErrRequiredData = 3314
Const conErrNotSavedData = 2169
If DataErr = conErrRequiredData Then
MsgBox ("درج اطلاعات در اين فيلد الزامي است")
If IsNull(Me.NationalId) Then
Me.NationalId.SetFocus
Me.NationalId.BackColor = vbYellow
ElseIf IsNull(Me.tel) Then
Me.tel.SetFocus
Me.tel.BackColor = vbYellow
End If
Response = acDataErrContinue
ElseIf DataErr = conErrNotSavedData Then
MsgBox ("داده ذخيره نشد")
Response = acDataErrContinue
Else
'Display a standard error message
Response = acDataErrDisplay
End If
End Sub
Private Sub NationalId_AfterUpdate()
Me.NationalId.BackColor = vbWhite
End Sub
Private Sub tel_AfterUpdate()
Me.tel.BackColor = vbWhite
End Sub
-
1 ضمیمه
جلوگیری از حذف جداول
در مرحله اول کدهای زیر را در یک ماژول کیی کنید
Option Compare Database
Public Function StopManualTableDelete(YesOrNo As String)
Dim fld As DAO.Field
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim SQL_CreateConstraint As String, SQL_DropConstraint As String
Dim strConstraint As String ' this variable holds the name of the constraint
Dim i As Integer
Dim tblNames As String, DeleteInfo As String
Set db = CurrentDb()
i = 0
For Each tbl In db.TableDefs
' Bypass system tables with autonumbers
' Also any hidden table that starts with "~"
If Mid(tbl.Name, 1, 4) <> "MSys" Then
If Left(tbl.Name, 1) <> "~" Then
For Each fld In db.TableDefs(tbl.Name).Fields
If dbAutoIncrField = (fld.Attributes And dbAutoIncrField) Then 'Find autonumber
DoCmd.Hourglass True
strConstraint = "con_" & fld.Name & "_" & tbl.Name 'Build constraint name
If YesOrNo = "YES" Then
i = i + 1
'Drop any existing autonumber field constraints if there is one.
If FindCheckConstraint(strConstraint) = True Then
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & _
" DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
End If
DoEvents ' await a while just in case
'create the new constraint to disallow the table from being deleted.
SQL_CreateConstraint = " ALTER TABLE " & tbl.Name & " ADD " & _
" CONSTRAINT " & strConstraint & _
" CHECK (" & fld.Name & " IS NOT NULL))"
'Debug.Print SQL_CreateConstraint
CurrentProject.Connection.Execute SQL_CreateConstraint
DeleteInfo = "äãí ÊæÇäíÏ"
End If
If YesOrNo = "NO" Then
'Drop any existing autonumber field constraints.
If FindCheckConstraint(strConstraint) = True Then
i = i + 1
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & _
" DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
DeleteInfo = "ãí ÊæÇäíÏ"
End If
End If
tblNames = tblNames & tbl.Name & vbNewLine
Exit For
End If
Next fld
End If
End If
Next tbl
db.Close
Set db = Nothing
DoCmd.Hourglass False
If i > 0 Then
MsgBox i & " ÊäÙíãÇÊ ÑÇ ÈÕæÑÊí ÇäÌÇã ÏÇÏå ÇíÏ ˜å " & DeleteInfo & " ÌÏÇæá ÑÇÈÕæÑÊ ÏÓÊí ÍÐÝ ˜äíÏ æ ÊÚÏÇÏÔÇä" _
& vbNewLine & ": ãæÑÏãí ÈÇÔÏ. Çíä ÌÏÇæá ÔÇãá" & vbNewLine & vbNewLine & tblNames
Else
MsgBox "There are no tables with Autonumber fields present in this database." _
& vbNewLine & "Therefore this code did not have any effect on this database."
End If
End Function
''''''''''''''''''''''''''''''
Public Function FindCheckConstraint(MyConstraint As String) As Boolean
'this function checks to see if a check constraint already exist on the autonumber field.
Dim fld As ADODB.Field
Dim rst As ADODB.Recordset
Set rst = CurrentProject.Connection.OpenSchema(adSchemaCheck Constraints)
Do Until rst.EOF
For Each fld In rst.Fields
If fld.Name = "CONSTRAINT_NAME" Then
If fld.Value = MyConstraint Then
'Debug.Print fld.Value
FindCheckConstraint = True
Exit For
End If
End If
Next fld
rst.MoveNext
Loop
End Function
'StopManualTableDelete("Yes") ÈÇ ÇäÊÎÇÈ Çíä Òíäå Úãá ÍÐÝ ÇäÌÇã äãíÔæÏ
'StopManualTableDelete("NO") ÈÇ ÇäÊÎÇÈ Çíä Òíäå Úãá ÍÐÝ ÇäÌÇã ãíÔæÏ
در مرحله دوم در نمای ماژول کلید Ctl+G را همزمان فشرده تا قسمت Immediate نمایش داده شود سپس کد زیر را در آنجا کپی کرده و دکمه Enter برنید
StopManualTableDelete("Yes")
حالت yes باعث عدم حذف جداول و حالت No باعث حذف جداول میشود.
میتوانید فقط بجای Yes _ کلمه No بنویسید
هربار که جدول جدید ایجاد می کنید برای عدم حذف میبایست مرحله دوم را مجدداً تکرار کنید
موفق باشید
-
نقل قول: نمونه های کاربردی و آموزشی VBA
سلام
آقاي فلاح ضمن تشكر با توجه به اختلال در فونت كدها ، ماجول مربوطه رو در قالب يك فايل اكسس و از طريق ويرايشگر كلاسيك به پستتون اضافه كنيد .
-
نقل قول: نمونه های کاربردی و آموزشی VBA
مقايسه اي بين SQLserver 2000 و MSAccess 2000
دوستان سايت زير مقايسه اي بين اين دو برنامه انجام داده است كه مقايسه جالبي است . فكر مي كنم نگاه كردن به آن خالي از لطف نباشد .
----------------------------------------
http://www.macromediax.com/Learn/archive.asp?id=92
-
نقل قول: نمونه های کاربردی و آموزشی VBA
امنيت در اكسس
فايلهاي Access در حالت عادي از امنيت خوبي برخوردار نيستند . نرم افزار MDB Secure 2008 نام برنامه اي است كه اين كار را براي شما انجام مي دهد . اين برنامه تعدادي از قابليتهاي بانك اكسس را فعال مي كند كه باعث بالا بردن امنيت نهايي فايل MDB مي شود . اين كارها در اين برنامه با چند كليك ، راحت انجام مي شود در حاليكه براي فعال كردن آنها به صورت دستي در اكسس حدود 30 دقيقه براي هر ديتا بيس طول مي كشد .
نسخه اصلي اين برنامه رايگان نمي باشد و شما مي توانيد نسخه Trial آن را دانلود كنيد .
---------------------------------------
http://www.mindwarp-consultancy-soft...-download.html
-
1 ضمیمه
نقل قول: نمونه های کاربردی و آموزشی VBA
ايجاد پشتيبان در مسير دلخواه با درج تاريخ شمسي در انتهاي نام فايل بدون overwrite روي پشتيبان هاي قبلي
لطفا نمونه را ببينيد:(با ذكر اين نكته كه براي توليد نام پشتيبان از توابع دستكاري شده جناب آزادي بهره گرفته شده است)
قبل از اجرا فايل comdlg32.ocx را در داخل پوشه سيستم 32 كپي و رجسيتر نماييد.
Option Compare Database
Dim CommondialogControl2 As Control
Dim backfile As New FileSystemObject
Dim source As String, desti As String
Dim x, y, z As Integer
Private Sub Command0_Click()
On Error GoTo err
source = Application.CurrentProject.FullName
x = Len(Application.CurrentProject.Name)
desti = Mid(Application.CurrentProject.Name, 1, x - 4) & Make_Date(Shamsi(Date)) & ".mdb"
With CommonDialog2
.DialogTitle = "Backup"
.Filter = "mdbfles (*.mdb)|*.mdb"
.FileName = desti
FileName = .FileName
check2:
If Dir(FileName) = "" Then
.FileName = FileName
.ShowSave
FileName = .FileName
backfile.CopyFile source, FileName, False
Else
GoTo check
check:
FileName = .FileName
y = Len(FileName)
z = z + 1
FileName = Mid(FileName, 1, y - 4) & "(" & z & ")" & ".mdb"
GoTo check2
End If
MsgBox "Databas has been backedup in" & " " & FileName, vbInformation
End With
Exit Sub
err:
Beep
End Sub
Private Sub Command1_Click()
On Error GoTo err
desti = Application.CurrentProject.FullName
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
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
جلوگیری از حذف جداول
با تشکر از آقای فلاح
آیا کدی برای جلوگیری از Import/Export شدن جدواول نیز جود د ارد؟
-
نقل قول: نمونه های کاربردی و آموزشی VBA
با تشکر فراوان از جناب فلاح برای کدهای کاربردی که نوشته اند.
من کد ایجاد جدول با استفاده از فرم را میخوام از دوستانی که میتوانند کمکم کنند خواهش می کنم این کد رو بفرستند.
-
1 ضمیمه
ساخت جدول با کد VBA و کلکسیون DAO
نقل قول:
من کد ایجاد جدول با استفاده از فرم را میخوام از دوستانی که میتوانند کمکم کنند خواهش می کنم این کد رو بفرستند.
این کد برای ایجاد جدول در دیتابیس جاری کاربرد داره .
دریک فرم کامند باتونی ایجاد و کدهای زیر رو در رخداد کلیک اون کپی کنید و بجای Command0 نام کامند باتون مورد نظرتون رو جایگزین کنید
Private Sub Command0_Click()
Dim MyDatabase As Database
Dim NewTable As TableDef
Dim MyArtist As DAO.Index
Dim MyIndex2 As DAO.Index
Dim MyIndex3 As DAO.Index
' open database
Set MyDatabase = CurrentDb 'OpenDatabase(App.Path + "\mp3Base.mdb")
'create the table
Set NewTable = MyDatabase.CreateTableDef("mp3New")
On Error Resume Next
'delete the table if it already exists
MyDatabase.TableDefs.Delete NewTable.Name
'add the fields in the table, those used below are just an example
With NewTable
.Fields.Append .CreateField("Title", dbText, 30)
.Fields.Append .CreateField("Artist", dbText, 30)
.Fields.Append .CreateField("Album", dbText, 30)
.Fields.Append .CreateField("Year", dbText, 4)
.Fields.Append .CreateField("Comment", dbText, 30)
.Fields.Append .CreateField("Genre", dbText, 1)
.Fields.Append .CreateField("Position", dbText, 10)
End With
'add indexes in the table
Set MyArtist = NewTable.CreateIndex("Artist")
MyArtist.Fields.Append MyArtist.CreateField("Artist")
NewTable.Indexes.Append MyArtist
Set MyIndex2 = NewTable.CreateIndex("Title")
MyIndex2.Fields.Append MyIndex2.CreateField("Title")
NewTable.Indexes.Append MyIndex2
Set MyIndex3 = NewTable.CreateIndex("Position")
MyIndex3.Fields.Append MyIndex3.CreateField("Position")
NewTable.Indexes.Append MyIndex3
NewTable.Indexes.Refresh
MyDatabase.TableDefs.Append NewTable
MsgBox "جدول با موفقیت ایجاد شد"
'close database
MyDatabase.Close
End Sub
نمونه مرتبط :
-
نقل قول: ساخت جدول با کد VBA و کلکسیون DAO
نقل قول:
نوشته شده توسط
مهدی قربانی
این کد برای ایجاد جدول در دیتابیس جاری کاربرد داره .
دریک فرم کامند باتونی ایجاد و کدهای زیر رو در رخداد کلیک اون کپی کنید و بجای Command0 نام کامند باتون مورد نظرتون رو جایگزین کنید
Private Sub Command0_Click()
Dim MyDatabase As Database
Dim NewTable As TableDef
Dim MyArtist As DAO.Index
Dim MyIndex2 As DAO.Index
Dim MyIndex3 As DAO.Index
' open database
Set MyDatabase = CurrentDb 'OpenDatabase(App.Path + "\mp3Base.mdb")
'create the table
Set NewTable = MyDatabase.CreateTableDef("mp3New")
On Error Resume Next
'delete the table if it already exists
MyDatabase.TableDefs.Delete NewTable.Name
'add the fields in the table, those used below are just an example
With NewTable
.Fields.Append .CreateField("Title", dbText, 30)
.Fields.Append .CreateField("Artist", dbText, 30)
.Fields.Append .CreateField("Album", dbText, 30)
.Fields.Append .CreateField("Year", dbText, 4)
.Fields.Append .CreateField("Comment", dbText, 30)
.Fields.Append .CreateField("Genre", dbText, 1)
.Fields.Append .CreateField("Position", dbText, 10)
End With
'add indexes in the table
Set MyArtist = NewTable.CreateIndex("Artist")
MyArtist.Fields.Append MyArtist.CreateField("Artist")
NewTable.Indexes.Append MyArtist
Set MyIndex2 = NewTable.CreateIndex("Title")
MyIndex2.Fields.Append MyIndex2.CreateField("Title")
NewTable.Indexes.Append MyIndex2
Set MyIndex3 = NewTable.CreateIndex("Position")
MyIndex3.Fields.Append MyIndex3.CreateField("Position")
NewTable.Indexes.Append MyIndex3
NewTable.Indexes.Refresh
MyDatabase.TableDefs.Append NewTable
MsgBox "جدول با موفقیت ایجاد شد"
'close database
MyDatabase.Close
End Sub
نمونه مرتبط :
سلام
من برنامه شما را اجرا نمودم و برروی اولین خط "MyDatabase As Database" ارور می گیرد
لطفا بفرمائید خطای کار من در کجاست
-
نقل قول: نمونه های کاربردی و آموزشی VBA
نقل قول:
سلام
من برنامه شما را اجرا نمودم و برروی اولین خط "MyDatabase As Database" ارور می گیرد
لطفا بفرمائید خطای کار من در کجاست
سلام
ببینید در قسمت References گزینه Microsoft DAO Objects Library 3.6 تیک خورده ؟
-
نقل قول: نمونه های کاربردی و آموزشی VBA
بله گزینه مورد نظر تیک خورده
