باید از این دوستان که زحمت جمع آوری این برنامه ها را میکشند و در اختیار بقیه قرار می دهند ، بابت تک تک این برنامه ها تشکر کرد که فکر کنم باز هم کم باشه.
باید از این دوستان که زحمت جمع آوری این برنامه ها را میکشند و در اختیار بقیه قرار می دهند ، بابت تک تک این برنامه ها تشکر کرد که فکر کنم باز هم کم باشه.
آخرین ویرایش به وسیله F_ashigh : یک شنبه 25 فروردین 1387 در 16:35 عصر
لطفا فایل ضمیمه را ببینید.
ابتدا TextBoxی را با نام دلخواه (مثلا ROw ) در قسمت Detail ریپورت مورد نظرتان ایجاد نمایید و خاصیت Runnig Sum آنرا Over All نمایید (اگر مایل به نمایش ستون ردیف نیستید، Visible آنرا Flase نمایید)
ضمنا اعداد ذکر شده کد رنگهای سفید و خاکستری هستند که به سلیقه شما می تواند تغییر نماید
یقینا بارها از امکان Subdatasheet هنگام کار با جداولی که ارتباط یک به چند با هم دارند کمک گرفته اید، و با اینکار اطلاعات را بصورت منسجم و راحت مشاهده و ویرایش نموده اید
اما اگر مایل هستید این سهولت را به سابفرم هایتان هم منتقل کنید نمونه برنامه زیر این امکان را به شما می دهد
دوستان این نمونه رو تو یکی از سایتها دیدم به دیدنش می ازرة امیدوارم مفید باشه.
تابع chrw() و تابع chr چه تفاوتی دارن?
سلام
اگر فیلدها را 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 در 14:30 عصر
تابع 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 در 10:21 صبح
اگر شما در یک روال نسبتا طولانی مرتب با خطاهای گوناگون برخورد می نمایید و هر بار مجبورید برای یافتن منبع خطا، با گذاشتن 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 در 12:47 عصر
با اين كد شما قادر خواهيد بود با يك كامند باتون عمليات Compact And Repair رو اجرا كنيد .
اكسس 2007 اين كد رو پشتيباني نمي كنه و در اصل مخصوص ورژنهاي 2003 به پائين هست
اين كد رو مي تونيد در رخداد On Click كامند باتون روي فرم اصلي (Switchboard) برنامه خودتون قرار بديد :
CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
سلام اميدوارم اين فايل بدرد دوستان بخور
آخرین ویرایش به وسیله HAMRAHSOFT.IR : شنبه 01 تیر 1387 در 10:29 صبح دلیل: اصلاح لينك دانلود
یک مقاله آموزشی اکسس مفید و روان برای کسانیکه می خواهند یک مطالعه مجدد بر روی اکسس داشته باشند تا به یک سری از ابهاماتشون در مورد اکسس جواب داده بشه.
این هم آدرس و منبع فایل:
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 در 22:39 عصر دلیل: درخواست نمونه کار
سلام
يك تشكر ويژه از دوستاني كه وقت مي ذارن معلومات و منابع خودشون رو براي استفاده سايرين ارائه مي كنن از بقيه دوستان هم انتظار مي ره به فراخور توانشون در اين امر مشاركت كنن و با مشاركتشون باعث ايجاد انگيزه و رغبت در بين كاربران بشن ، دوستان گرامي رشد و تعالي علمي در گرو تحقيق و مشاركت هست پس فارغ از سطح علمي و معلومات با انجام تحقيق در بين منابع و سورسهاي متنوعي كه در حال حاضر بواسطه كتابها ، جزوات ، سايتها و پورتالهاي اينترنتي در دسترسمون قرار مي گيره سعي كنيم اين منابع و دستاوردها رو در اختيار سايرين بذاريم تا به اين بهانه سهمي در رشد و ارتقاء خود و دوستانمون داشته باشيم .
آخرین ویرایش به وسیله مهدی قربانی : جمعه 21 تیر 1387 در 18:11 عصر
خیلی از مواقع مجبور هستید منبع رکورد سابفرم را تغییر دهید یا فیلتری روی آن اعمال کنید، در این مواقع اگر مجبور باشید از سابفرم خروجی اکسل داشته باشید مجبورید سراغ رکوردست آن بروید. اما این کار چند مشکل دارد اول اینکه اسامی مستعار فیلدها اعمال نمی شود، فیلدی های کدینگ شده بصورت اصلی شان یعنی کد 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
با کمک این نمونه کد شما قادر خواهید بود، همانند ویزارد خود اکسس لیستی از 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
حذف و اضافه كردن ركوردهاي دو جدول با استفاده از 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
نمونه مرتبط :
با سلام خدمت همه عزیزان
بااستفاده از توابع آقای آزادی و دیگر دوستان تابع تبدیل تاریخ شمسی به حروف به همراه نمونه آماده شده
انشاءاله دیگران بتوانند استفاده کنند.
آخرین ویرایش به وسیله dadsara : یک شنبه 30 تیر 1387 در 08: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 در 13: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
سلام دوستان عزیز
ماژول تبدیل تاریخ میلادی به شمسی را براتون میذارم . این ماژول تقریبا کامله و در 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 در 15:20 عصر
اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر
در خصوص تاپيك 70 و جناب منتظران منتظر :
با سلام و تشكر
1- لطف فرماييد توابع كاربردي آنرا را هم نام ببريد ( مثلاً نحوه استفاده از تاريخ با روز هفته ، تاريخ كوتاه يا بلند و ... )
2- ماژول ديگر كه چه كاربردي دارد ؟ ( البته اگر اشتباه جا نمانده باشد !)
با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...
اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر
آخرین ویرایش به وسیله مهدی قربانی : پنج شنبه 31 مرداد 1387 در 04:04 صبح
Tools > Option > intrnational > use hijri calender
سلام
آیا راهی وجود دارد که بدون اینکه ویندوز را از حالت safe Mode بالا بیاوریم این فایل را با فایل قبلی جایگزین نمود یا خیر؟
سلام
دوستان ، به نظر ميرسه كه مباحث اين تاپيك داره مقداري از موضوع اصلي اون كه مباحث VBA هست فاصله ميگيره بنابراين پيشنهاد مي كنم در صورتي كه مايل به ادامه بحث در رابطه با موضوع پست آقاي فلاح هستيد ، پستهاي مربوطه به يك تاپيك مجزا منتقل بشه . ( آقاي فلاح PM بديد )
سلام
چطوری می شود به یک فیلد از نوع namber یک کلید شماره گزار الحاق نمود که رکورد جدید را با عدد افزایشی بدون تکرار کامل کند. متشکرم.
عزیزی
سلام
لطفاً در مورد تعیین فرمانها و نحوی اجرای ماژولها در Access توضیح دهید.متشکرم
عزیزی
سلام
دوست گرامي براي شروع اينجا رو ببينيد