نمونه های کاربردی و آموزشی VBA

[مهدی قربانی]

سلام خدمت همه دوستان و کاربران محترم بخش Microsoft Access
با توجه به نیاز روزمره کاربران محترم در ارتباط با انتقال و تبادل اطلاعات در زمینه کدنویسی VBA و همینطور جلوگیری از پراکندگی موارد ، دوستانی که مطلب یا نمونه کدهای مرتبط با موضوع این تاپیک ( در قالب کاربردی و آموزشی ) دارن لطف کنن مطالبشون رو برای استفاده سایرین در این تاپیک قرار بدن .
---------------------------------------------------------------------------------------------------------------------------------

بازیافت جداول حذف شده


منبع : http://support.microsoft.com/?kbid=209874





Function RecoverDeletedTable()




On Error GoTo ExitHere



'*Declarations*


Dim db As DAO.Database


Dim strTableName As String


Dim strSQL As String


Dim intCount As Integer



Dim blnRestored As Boolean


'*Init*


Set db = CurrentDb()


'*Procedure*


For intCount = 0 To db.TableDefs.Count - 1


strTableName = db.TableDefs(intCount).Name


If Left(strTableName, 4) = "~tmp" Then


strSQL = "SELECT DISTINCTROW [" & strTableName & "].* INTO " _


& Mid(strTableName, 5) & " FROM [" & strTableName & "];"


DoCmd.SetWarnings False


DoCmd.RunSQL strSQL


MsgBox "A deleted table has been restored, using the name '" _


& Mid(strTableName, 5) & "'", vbOKOnly, "Restored"



blnRestored = True


End If


Next intCount


If blnRestored = False Then


MsgBox "No recoverable tables found", vbOKOnly


End If


'*EXIT/ERROR*


ExitHere:


DoCmd.SetWarnings True


Set db = Nothing


Exit Function



ErrorHandler:


MsgBox Err.Description


Resume ExitHere


End Function

[مهدی قربانی]

با این کد ساده شما قادر هستید بدون استفاده از Navigation Bar خود اکسس یک شمارشگر رکورد رو در فرمتون به نمایش بگذارید .
یک Text Box در فرم مورد نظر ایجاد کنید و نام اونرو txtRecordCounter بگذارید و کد زیر رو در رویه On Current فرم کپی کنید :


Dim rst As DAO.Recordset
Dim lngCount As Long

Set rst = Me.RecordsetClone

With rst
.MoveFirst
.MoveLast
lngCount = .RecordCount
End With

Me.txtRecordCounter = "رکورد" & Me.CurrentRecord & " از " & lngCount
ضمناً فراموش نکنید اگر در References وی بی ای ، گزینه Microsoft DAO 3.6 Object Library چک نخورده حتماً فعالش کنید .

[مهدی قربانی]

با کد زیر میشه براحتی امکان تائید اطلاعات ثبت شده در یک رکورد رو ایجاد و در صورتیکه کاربر اقدام به تائید کنه مکان نما به رکورد بعدی منتقل میشه در غیر اینصورت رکورد جاری عملاً Undo شده و اطلاعات وارده پاک میشه بنظر من این کد در فرمهای Columnar بیشتر میتونه مورد استفاده قرار بگیره .
- کد زیر رو در رویداد Before Update فیلد مورد نظر که بهتره آخرین فیلد باشه وارد کنید
- بجای FieldName نام فیلد مورد نظرتون رو قرار بدین
- خصوصیت Dirty در زمان آپدیت فیلد True میشه
- ذخیره اطلاعات بوسیله پیغامSave از کاربر سوال میشه


' فیلد مورد نظر کپی کنید Before Update این تیکه کد رو در رخداد
' نام فیلد مورد نظر رو جایگزین کنید FieldName بجای
Private Sub FieldName_BeforeUpdate(Cancel As Integer)
On Error GoTo Err_BeforeUpdate

' در صورتیکه Dirty فرمTrue خصوصیت باشه
If Me.Dirty Then
' اطلاعات از کاربر میکنه Save برنامه اقدام به پرسش برای
If MsgBox("؟ آیا قصد ذخیره اطلاعات وارده را دارید ", vbMsgBoxRight + vbYesNo + _
vbQuestion, "توجه") = vbNo Then
Me.Undo
End If
End If

Exit_BeforeUpdate:
Exit Sub

Err_BeforeUpdate:
MsgBox Err.Number & " " & Err.Description
Resume Exit_BeforeUpdate

End Sub

[مهدی قربانی]

با این تابع می تونید در زمان ورود حروف لاتین در فیلدها و یا TextBox ها عملیات Upper Case یا همون بزرگ کردن حروف رو همزمان با ورود انجام بدید .
اگر قصد دارید که کلیه اطلاعات در فیلدهای متنی یا TextBox ها رو ملزم به ورود حروف بزرگ کنید این تابع رو در رخداد On Key Press فرم قرار بدید و اگر هم فیلد یا TextBox خاصی مورد نظر شماست می تونید این تابع رو در رخداد On Key Press اون فیلد یا TextBox بکار بگیرید .

نمونه اول:

Private Sub Form_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Subنمونه دوم :

Private Sub Text0_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Subالبته بیشتر استفاده از روش و نمونه دوم رو توصیه می کنم .

نمونه مرتبط :

[مهدی قربانی]

با تکه کد زیر استفاده از کلیدهای - و + برای کاهش یا افزایش تاریخ در یک فیلد Date/Time امکانپذیر میشه البته لازم به ذکره که کد فعلی قابلیت کاهش یا افزایش تاریخ رو بصورت روزانه داره که اگر لازم باشه تغییر پارامتر "d" به سایر پارامترها مثل y , m , w برای کاهش یا افزایش ماه سال و هفته امکانپذیره .

کدهای زیر رو در یک Module جدید کپی کنید :




Public Function PDate(PObj As Object, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyAdd Then
If Shift = 2 Then
PObj = DateAdd("m", 1, PObj)
KeyCode = 0
Else
PObj = DateAdd("d", 1, PObj)
KeyCode = 0
End If
End If

If KeyCode = vbKeySubtract Then
If Shift = 2 Then
PObj = DateAdd("m", -1, PObj)
KeyCode = 0
Else
PObj = DateAdd("d", -1, PObj)
KeyCode = 0
End If
End If
End Function




کد زیر رو هم در رویداد Key Down فیلد مورد نظر که جنسش Date/Time هست کپی کنید :
بجای FieldName نام فیلد مورد نظر رو قرار بدین




PDate Me.FieldName, KeyCode, Shift

[moustafa]

ایجاد گزارش تصویری :

Docmd.OutputTo acReport, "reportname", "SnapshotFormat(*.snp)", "", False, "", 0
با کد فوق کامند دیالوگ باکس ظاهر میشه حتما نام فایل را با پسوند snp ذخیره نمائید

[moustafa]

کنترل یک فایل اکسس از داخل یه فایل اکسس دیگه

Dim obj As Object
Set obj = CreateObject("Access.Application")
obj.OpenCurrentDatabase ("F:\mdbname.mdb")
obj.DoCmd.OpenQuery "Querynamel"
Set obj = Nothing
obj.DoCmd.Quit

ایجاد یک فایل اکسس جدید از داخل اکسس

obj.newCurrentDatabase ("F:\mdbname.mdb")

[مهدی قربانی]

کد زیر رو داخل یک Module کپی کنید



Public Function TextOnly(ByVal strText As String) As Boolean

Dim intCounter As Integer
For intCounter = 1 To Len(strText)
If IsNumeric(Mid(strText, intCounter, 1)) Then
TextOnly = False
Exit Function
End If
Next intCounter
TextOnly = True
End Function



در روال Before Update فرم باند شده به جدول مورد نظر این کد رو اضافه کنید


Private Sub Form_BeforeUpdate(Cancel As Integer)
'بجای FieldName نام فیلد مورد نظر رو جایگزین کنید

If Len(Me.FieldName & vbNullString) = 0 Then
Exit Sub
Else
If Not TextOnly(Me.FieldName) Then
MsgBox "ورود اطلاعات عددی در این فیلد امکانپذیر نمی باشد ", _
vbExclamation, "ورود داده نامعتبر"
Cancel = True
End If
End If

End Sub

[moustafa]

مقاله بهبود دهنده شی Accessبا کدهای vba
http://www.sayan.ir/ViewArticle.aspx?ArticleID=147

[moustafa]

ده نکته‌ای که در کار با مقادیر تهی در اکسس باید مد نظر قرار داد:
http://www.sayan.ir/ViewArticle.aspx?ArticleID=170

[moustafa]

:To remove the Minimize, Maximize, and Restore button from a Report's preview window
http://www.everythingaccess.com/tuto...Preview-Window

[مهدی قربانی]

http://atalebi.com/articles/show.asp?id=640

[مهدی قربانی]

بستن کلید شیفت :


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

[مهدی قربانی]

نمایش / عدم نمایش Navigation Pane در Access 2007

برای عدم نمایش :
بجای TableName نام یکی از Table‌های موجود در بانک خودتون رو جایگزین کنید

'hide the Database Window or Navigation Pane
DoCmd.SelectObject acTable, "TableName", True
DoCmd.RunCommand acCmdWindowHide

برای نمایش :

'show the Database Window or Navigation Pane
DoCmd.SelectObject acTable, "TableName", True

[karmand]

قبلا در رابطه با input mask دوستان فایل متنی را ارسال که بسیار کامل است و بدون کد نویسی این کا را انجام میدهد بطور مثال با علامت سئوال در inputmask کار شما را انجام میدهد

[مهدی قربانی]

با نمونه کد های زیر می تونید اطلاعات موجود در جداول رو پاک کنید
بجای [boxTables]‌میتونید نام ListBox خودتون رو جایگزین کنید
این قسمت رو در رخداد On Activate‌ کپی کنید :


DoCmd.Restore
[boxTables].RowSourceType = "Value List"
For Each Item In Application.CurrentDb.tabledefs
[boxTables].RowSource = [boxTables].RowSource & ";" & I
tem.Name
Next


و این قسمت رو هم در On Click کامند ایجاد شده در فرم کپی کنید :


Dim strSQL As String
For Each Item In Application.CurrentDb.tabledefs
DoCmd.SetWarnings warningsoff
If Item.Name = [boxTables].Value Then
strSQL = "DELETE " & [boxTables].Value & ".* FROM " & _
[boxTables].Value & ";"
DoCmd.RunSQL strSQL
End If
DoCmd.SetWarnings warningson
Next

نمونه مرتبط :

[moustafa]

Dim strSQL As String
Dim i As Integer
Dim Msg As String

'Exit this sub if the combo box is cleared
If NewData = "" Then Exit Sub

Msg = "'" & NewData & "' این گزینه در لیست نمی باشد ." & vbCr & vbCr
Msg = Msg & "آیا می خواهید اضافه شود ؟"

i = MsgBox(Msg, vbQuestion + vbYesNo + vbMsgBoxRight, "مقدار ورودی نامعتبر است ")
If i = vbYes Then
strSQL = "Insert Into table name ([field name]) values ('" & NewData & "')"
CurrentDb.Execute strSQL, dbFailOnError
Response = acDataErrAdded
Else
Response = acDataErrContinue
End If

بهتر در قسمت evente ( on not in list ( فرمی که این لیست باکس رو داره
کد زیر رو بنویسید اونوقت اگه کسی عبارتی رو که تو لیست نیست تایپ کنه اتوماتیک به اون جدول اضافه میشه راستی باید به جای table name و field name نام جدول و فیلد مربوطه رو بنویسی

[سعید مشکین فر]

'ابتدا
'کلیدهای اولین رکورد ،آخرین رکورد،رکورد قبل،رکورد بعد،رکورد و رکورد جدید را
'روی فرم خودتان طراحی کنید
'کدها را در رویداد کلیک هر دکمه فرمان کپی کنید
'************************************************* **********
'This code builds a set of Navigation Buttons consisting of:
'First, Next, Previous, Last, and New
'************************************************* **********
Private Sub cmdFirst_Click()
On Error GoTo Err_cmdFirst_Click

DoCmd.GoToRecord , , acFirst
Me.ID_NO.SetFocus

Exit_cmdFirst_Click:
Exit Sub

Err_cmdFirst_Click:
MsgBox Err.Description
Resume Exit_cmdFirst_Click

End Sub

Private Sub cmdLast_Click()
On Error GoTo Err_cmdLast_Click

DoCmd.GoToRecord , , acLast
Me.ID_NO.SetFocus
'قرار دهید ID_NO نام فیلد خودتان را بجای

Exit_cmdLast_Click:
Exit Sub

Err_cmdLast_Click:
MsgBox Err.Description
Resume Exit_cmdLast_Click

End Sub

Private Sub cmdNew_Click()
On Error GoTo Err_cmdNew_Click

DoCmd.GoToRecord , , acNewRec

Exit_cmdNew_Click:
Exit Sub

Err_cmdNew_Click:
MsgBox Err.Description
Resume Exit_cmdNew_Click

End Sub

Private Sub cmdNext_Click()
On Error GoTo Err_cmdNext_Click

DoCmd.GoToRecord , , acNext
Me.ID_NO.SetFocus
'قرار دهید ID_NO نام فیلد خودتان را بجای

Exit_cmdNext_Click:
Exit Sub

Err_cmdNext_Click:
Call EndTable
Resume Exit_cmdNext_Click

End Sub

Private Sub cmdPrevious_Click()
On Error GoTo Err_cmdPrevious_Click

DoCmd.GoToRecord , , acPrevious
'قرار دهید ID_NO نام فیلد خودتان را بجای
Me.ID_NO.SetFocus

Exit_cmdPrevious_Click:
Exit Sub

Err_cmdPrevious_Click:
Call StartTable
Resume Exit_cmdPrevious_Click

End Sub

'کدها را در رویداد Current کپی کنید

Private Sub Form_Current()
On Error GoTo Err_Form_Current
Dim recClone As Object
Dim intNewRecord As Integer

' Do magic tricks with the form's caption!
If Me.NewRecord Then
' Use appropriate prompt for your database.
Me.Caption = "رکورد جدید: لطفا اطلاعات رکورد را وارد کنید"
Else
Me.Caption = " شماره صفحه فعلی: " & Me!ID_NO.Value 'قرار دهید ID_NO نام فیلد خودتان را بجای

End If

' If this is a "New Record" then
' Disable the <Next>, <New>, <Last> buttons
' Enable the <First> and <Next> buttons
' Then Exit the procedure.
intNewRecord = IsNull(Me![ID_NO])
If intNewRecord Then
cmdFirst.Enabled = True
cmdNext.Enabled = False
cmdPrevious.Enabled = True
cmdLast.Enabled = False
cmdNew.Enabled = False
Me![RecordCount] = "ثبت رکورد جدید"
Me.ID_NO.SetFocus ' Set focus to the PasNo if a "New Record"
Exit Sub
Else
' Else if this is not a new record
' Enable <New> and <Last> buttons
cmdNew.Enabled = True
cmdLast.Enabled = True
End If

' Make a clone of the recordset underlying the form so
' we can move around without affecting the form's recordset
Set recClone = Me.RecordsetClone

' Check to see if there are no records
' If so disable all buttons except for the <New> button
If recClone.RecordCount = 0 Then
cmdNext.Enabled = False
cmdPrevious.Enabled = False
cmdFirst.Enabled = False
cmdLast.Enabled = False
Else
' Synchronise the current pointer in the two recordsets
recClone.Bookmark = Me.Bookmark
' If there are records, see if recordset is on the first record
' If so, disable the <First> and <Previous> buttons
recClone.MovePrevious
cmdFirst.Enabled = Not (recClone.BOF)
cmdPrevious.Enabled = Not (recClone.BOF)
recClone.MoveNext
' And then check whether recordset is on the last record
' If so, disable the <Last> and <Next> buttons
recClone.MoveNext
cmdLast.Enabled = Not (recClone.EOF)
cmdNext.Enabled = Not (recClone.EOF)
recClone.MovePrevious
End If

Me![RecordCount] = "رکورد " & (recClone.AbsolutePosition + 1) & " از " & _
DCount("ID_NO", "[MainTable]")
'قرار دهید MainTable نام تیبل خودتان را بجای

recClone.Close

Exit_Form_Current:
Exit Sub

Err_Form_Current:
If Err = 3021 Then
' Error 3021 means recordset is at Add New Record
' Enable <Previous> and <First> buttons
' Disable <Next> and <Last> buttons
cmdPrevious.Enabled = True
cmdFirst.Enabled = True
cmdNext.Enabled = False
cmdLast.Enabled = False
Resume Exit_Form_Current
Else
MsgBox Err.Description
Resume Exit_Form_Current
End If
End Sub

[moustafa]

با copyfile هم میشه هر فایلی رو رو دیسکت یا هر محل دیگه کپی کرد
در رفرنسها هم باید microsot scripting runtimeرا چک بزنید
ومتغیری به شکل زیر تعریف کنید
کد:

Dim fso As New FileSystemObject

سینتکس آن از راهنمای اکسس
نقل قول:
CopyFile Method


Description

Copies one or more files from one location to another.

Syntax

object.CopyFile source, destination[, overwrite]

The CopyFile method syntax has these parts:

Part Description
object Required. The object is always the name of a FileSystemObject.
source Required. Character string file specification, which can include wildcard characters, for one or more files to be copied.
destination Required. Character string destination where the file or files from source are to be copied. Wildcard characters are not allowed.
overwrite Optional. Boolean value that indicates if existing files are to be overwritten. If True, files are overwritten; if False, they are not. The default is True. Note that CopyFile will fail if destination has the read-only attribute set, regardless of the value of overwrite.



Remarks

Wildcard characters can only be used in the last path component of the source argument. For example, you can use:

FileSystemObject.CopyFile "c:\mydocuments\letters\*.doc", "c:\tempfolder\"

But you can't use:

FileSystemObject.CopyFile "c:\mydocuments\*\R1???97.xls", "c:\tempfolder"

If source contains wildcard characters or destination ends with a path separator (\), it is assumed that destination is an existing folder in which to copy matching files. Otherwise, destination is assumed to be the name of a file to create. In either case, three things can happen when an individual file is copied.

If destination does not exist, source gets copied. This is the usual case.


If destination is an existing file, an error occurs if overwrite is False. Otherwise, an attempt is made to copy source over the existing file.


If destination is a directory, an error occurs.
An error also occurs if a source using wildcard characters doesn't match any files. The CopyFile method stops on the first error it encounters. No attempt is made to roll back or undo any changes made before an error occurs

[مهدی قربانی]

با این ماجول می تونید مجموع زمان رو بطور صحیح و با فرمت 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()

نمونه مرتبط :

[مهدی قربانی]

با این کد در زمان استفاده از Mouse Scrool یا همون Mouse Wheel در صورتیکه فوکوس به فیلدهای اول و آخر منتقل بشه پیغامی مبنی بر اولین رکورد یا آخرین رکود صادر میشه .

کدهای زیر رو در رخداد On Mouse Wheel کپی کنید :

If Count > 0 Then


If Me.CurrentRecord = Me.RecordsetClone.RecordCount + 1 Then


MsgBox "! آخرین رکورد", vbInformation + vbMsgBoxRight, "پیمایش رکوردها"

Else


DoCmd.GoToRecord , , acNext

End If


ElseIf Me.CurrentRecord - 1 = 0 Then


MsgBox "! اولین رکورد", vbInformation + vbMsgBoxRight, "پیمایش رکوردها"

Else

DoCmd.GoToRecord , , acPrevious

End If

[مهدی قربانی]

این نمونه کد وقتی سابفرم خالی باشه اونرو Hide میکنه . ضمناً نمونه فایل هم ضمیمه شده .
بجای Subform نام سابفرم خودتون رو جایگزین کنید .


Private Sub Form_Current()
With Me![Subform].Form


If .RecordsetClone.RecordCount = 0 Then

.Visible = False
Else
.Visible = True
End If
End With
End Sub

[مهدی قربانی]

با استفاده از این تابع API امکان تغییر زبان سیتم فراهم میشه :

تابع :

Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, _
ByVal flags As Long) As Long
حالا می تونید در یکی از رخداد ها بسته به نظر خودتون این کد رو برای فراخوان زبان مورد نظر بنویسید برای مثال میشه در رخداد On Load‌ فرم StartUp برنامه ازش استفاده کرد :

Private Sub Form_Load()

'برای تغییر به فارسی

Call ActivateKeyboardLayout(1, 1)

End Subالبته برای تغییر به انگلیسی اینو بنویسید :

Call ActivateKeyboardLayout(0, 1)

[مهدی قربانی]

Set Custom Zoom for Report Preview

با این کد شما امکان باز کردن یک گزارش رو با مقدار Zoom دلخواه بین 10 تا 2500 درصد خواهید داشت .
تکه کد زیر رو در یک ماجول کپی کنید :


Function PreviewAndZoomReport(strReportName As String, intZoomCoeff As Integer)

On Error GoTo Err_PreviewAndZoomReport

If Not (intZoomCoeff >= 0 And intZoomCoeff <= 2500) Then

intZoomCoeff = 0

End If


With DoCmd

.OpenReport strReportName, acViewPreview

.Maximize

End With

Reports(strReportName).ZoomControl = intZoomCoeff

Exit_PreviewAndZoomReport:

Exit Function

Err_PreviewAndZoomReport:

MsgBox Err.Description

Resume Exit_PreviewAndZoomReport


End Function

و بعد این کد رو در رخداد On Click یک کامند باتون که معمولاً روی فرم سوئیچ برد قرار داره بنویسید :
بجای ReportName نام Report مورد نظرتون رو جایگزین کنید و البته بجای عدد 25 هم هر عددی بین 10 تا 2500 قابل استفاده هست .


Call PreviewAndZoomReport("ReportName", 25)

نمونه مرتبط با کدنویسی کاملتر :

[مهدی قربانی]

نمونه حاضر روش پیشنهادی خود مایکروسافته :


This sample changes the CustomerID field in the Customers table from a five character field to an eight character field.

The sample uses the Nwind database that comes with Visual Basic.

1. In Visual Basic, create a new Standard EXE project.
Form1 is created by default.
2. Add a command button to Form1. Command1 is created by default.
3. On the Project menu, select References.
In the References dialog, select the Microsoft DAO Object Library.
4. On the Project menu, select Add Module to add a Code Module.
Module1 is created by default.
5. Paste the following code into the General Declarations section of Module1's Code Window:


Option Compare Text
Option Explicit

Const CFT_Failed As Long = 55555

Private Const R_NAME = 0, R_ATTRIBUTES = 1, R_TABLE = 2, R_FOREIGNTABLE = 3, R_FIELD = 4, R_FOREIGNFIELD = 5

Private Const I_NAME = 0, I_PRIMARY = 1, I_UNIQUE = 2, I_REQUIRED = 3, I_IGNORENULLS = 4, I_CLUSTERED = 5, I_FIELD = 6, I_FIELDATTRIBUTES = 7


Public Sub ChangeFieldType(db As Database, _
ByVal TableName As String, _
ByVal FieldName As String, _
ByVal NewType As Integer, _
Optional NewSize As Long, _
Optional NewAllowZeroLength As Boolean = False, _
Optional NewAllowNulls As Boolean = True, _
Optional NewAttributes As Long)

' User-defined properties are not maintained

Dim td As TableDef, I As Index, R As Relation, F As Field

' loop iterators for Indexes, Fields, and Relations collections:
Dim I1 As Long, F1 As Long, R1 As Long

Dim colR As Collection, colI As Collection
Dim E_Desc As String, Process As String, SubProcess As String, E As Error
Dim TempFieldName As String, Suffix As Long, OldName As String
Dim Temp As Variant
Dim OrdinalPosition As Long

Set colI = New Collection
Set colR = New Collection
On Error GoTo CFT_Err
DBEngine(0).BeginTrans

' Enumerate relations and save/remove them

DBEngine(0).BeginTrans
Process = "Removing relations on [" & TableName & "]![" & FieldName & "]"
SubProcess = ""
For R1 = db.Relations.Count - 1 To 0 Step -1
Set R = db.Relations(R1)
If R.Table = TableName Then
For F1 = 0 To R.Fields.Count - 1
Set F = R.Fields(F1)
If F.Name = FieldName Then
RecordRelationInfo R, colR
SubProcess = "Removing relation " & R.Name
db.Relations.Delete R.Name
Exit For
End If
Next F1
ElseIf R.ForeignTable = TableName Then
For F1 = 0 To R.Fields.Count - 1
Set F = R.Fields(F1)
If F.ForeignName = FieldName Then
RecordRelationInfo R, colR
SubProcess = "Removing relation " & R.Name
db.Relations.Delete R.Name
Exit For
End If
Next F1
End If
Next R1
Set F = Nothing
Set R = Nothing
DBEngine(0).CommitTrans

' Enumerate indices and save/remove them

DBEngine(0).BeginTrans
Process = "Removing indexes on [" & TableName & "]![" & FieldName & "]"
SubProcess = ""
db.TableDefs.Refresh
Set td = db(TableName)
td.Indexes.Refresh
For I1 = td.Indexes.Count - 1 To 0 Step -1
Set I = td.Indexes(I1)
If I.Foreign <> True Then
For F1 = 0 To I.Fields.Count - 1
Set F = I.Fields(F1)
If F.Name = FieldName Then
RecordIndexInfo I, colI
SubProcess = "Removing index " & I.Name
td.Indexes.Delete I.Name
Exit For
End If
Next F1
End If
Next I1
Set F = Nothing
Set I = Nothing
DBEngine(0).CommitTrans

' Rename Field

DBEngine(0).BeginTrans
Process = "Renaming field"
SubProcess = ""
td.Fields.Refresh
Set F = td(FieldName)
OrdinalPosition = F.OrdinalPosition ' save this value

' determine a field name not in use
Suffix = 0
Do
Suffix = Suffix + 1
TempFieldName = "XXX" & Suffix
Loop While IsField(td, TempFieldName)

' rename the field
SubProcess = "to " & TempFieldName
F.Name = TempFieldName

Set F = Nothing
DBEngine(0).CommitTrans

' Add new Field

DBEngine(0).BeginTrans
Process = "Adding new field"
SubProcess = ""
td.Fields.Refresh
Set F = td.CreateField(FieldName, NewType)
If NewSize Then F.Size = NewSize
F.AllowZeroLength = NewAllowZeroLength
F.Required = Not NewAllowNulls
F.Attributes = NewAttributes
F.OrdinalPosition = OrdinalPosition
td.Fields.Append F
Set F = Nothing
Set td = Nothing
DBEngine(0).CommitTrans

' Copy data

DBEngine(0).BeginTrans
Process = "Copying data from " & TempFieldName & " to " & FieldName
SubProcess = ""
db.Execute "UPDATE [" & TableName & "] SET [" & FieldName & "]=[" & _
TempFieldName & "]", dbFailOnError
DBEngine(0).CommitTrans

' Delete temporary field

DBEngine(0).BeginTrans
Process = "Deleting temporary field " & TempFieldName
SubProcess = ""
Set td = db(TableName)
td.Fields.Delete TempFieldName
DBEngine(0).CommitTrans

' Add back Indices

DBEngine(0).BeginTrans
Process = "Adding indexes back into table"
SubProcess = ""
Set td = db(TableName)
td.Fields.Refresh
td.Indexes.Refresh
OldName = ""
Set I = Nothing
For Each Temp In colI
If Temp(I_NAME) <> OldName Then
If Not (I Is Nothing) Then ' handle first time through case
SubProcess = "Adding index " & I.Name
td.Indexes.Append I
End If
Set I = td.CreateIndex(Temp(I_NAME))
I.Primary = Temp(I_PRIMARY)
I.Unique = Temp(I_UNIQUE)
I.Required = Temp(I_REQUIRED)
I.IgnoreNulls = Temp(I_IGNORENULLS)
I.Clustered = Temp(I_CLUSTERED)
End If
Set F = I.CreateField(Temp(I_FIELD))
F.Attributes = Temp(I_FIELDATTRIBUTES) ' to handle descending index
I.Fields.Append F
Next Temp
If Not (I Is Nothing) Then ' handle case of no indexes
SubProcess = "Adding index " & I.Name
td.Indexes.Append I
End If
Set F = Nothing
Set I = Nothing
Set td = Nothing
DBEngine(0).CommitTrans

' Add back relations

DBEngine(0).BeginTrans
Process = "Adding relations back into database"
SubProcess = ""
OldName = ""
db.Relations.Refresh
Set R = Nothing
For Each Temp In colR
If Temp(I_NAME) <> OldName Then
If Not (R Is Nothing) Then ' handle first time through case
SubProcess = "Adding relation " & R.Name
db.Relations.Append R
End If
Set R = db.CreateRelation(Temp(R_NAME), Temp(R_TABLE), _
Temp(R_FOREIGNTABLE), Temp(R_ATTRIBUTES))
End If
Set F = R.CreateField(Temp(R_FIELD))
F.ForeignName = Temp(R_FOREIGNFIELD)
R.Fields.Append F
Next Temp
If Not (R Is Nothing) Then ' if there are no indexes...
SubProcess = "Adding relation " & R.Name
db.Relations.Append R
End If
Set F = Nothing
Set R = Nothing
DBEngine(0).CommitTrans

' Commit all pending chhanges

DBEngine(0).CommitTrans
Exit Sub

CFT_Abort:
On Error Resume Next
Set F = Nothing
Set td = Nothing
DBEngine(0).Rollback
DBEngine(0).Rollback
Err.Clear
On Error GoTo 0
Err.Raise CFT_Failed, "ChangeFieldType", E_Desc
Exit Sub

CFT_Err:
E_Desc = "Error " & Process
If SubProcess <> "" Then E_Desc = E_Desc & vbCrLf & SubProcess
If DBEngine.Errors.Count = 0 Then
E_Desc = E_Desc & vbCrLf & "Error " & Err.Number & " " & _
Err.Description
Else
For Each E In DBEngine.Errors
E_Desc = E_Desc & vbCrLf & "Error " & E.Number & " (" & _
E.Source & ") " & E.Description
Next E
End If
Debug.Print E_Desc
Resume CFT_Abort
End Sub

Private Sub RecordRelationInfo(ByVal R As Relation, colR As Collection)

' Records information regarding the relationship and its fields
' in the colR collection.

Dim F1 As Long, F As Field
For F1 = 0 To R.Fields.Count - 1
Set F = R.Fields(F1)
colR.Add MakeArray(R.Name, R.Attributes, R.Table, R.ForeignTable, _
F.Name, F.ForeignName)
Next F1
End Sub

Private Sub RecordIndexInfo(ByVal I As Index, colI As Collection)

' Records information about fields in the index and about the index itself
' into the colI collection.

Dim F1 As Long, F As Field
For F1 = 0 To I.Fields.Count - 1
Set F = I.Fields(F1)
colI.Add MakeArray(I.Name, I.Primary, I.Unique, I.Required, _
I.IgnoreNulls, I.Clustered, F.Name, F.Attributes)
Next F1
End Sub

Private Function IsField(td As TableDef, ByVal FieldName As String) _
As Boolean

' Returns TRUE if a field exists in the table with the same name as
' specified in FieldName.
' Returns FALSE otherwise.

Dim F As Field
Err.Clear
On Error Resume Next
Set F = td(FieldName)
IsField = Err.Number = 0
Err.Clear
End Function

Private Function MakeArray(ParamArray X() As Variant) As Variant

' Does the same thing as the Array() function in VB6

MakeArray = X

End Function


6. If necessary, change the CFT_Failed constant to use an error number that conforms to your company's standards.
7. Paste the following code into the General Declarations section of Form1's Code Window:

Private Sub Command1_Click()

Dim strDB As String
strDB = "c:\Program Files\Microsoft Visual Studio\VB98\Nwind.mdb"

Dim db As DAO.Database
Set db = DBEngine(0).OpenDatabase(strDB)
ChangeFieldType db, "Customers", "CustomerID", dbText, 8
db.Close

End Sub


8. If necessary, modify strDB to use your Nwind database.
9. Run the sample project.
Click the command button.
End the project.
10. Examine the table in Microsoft Access or the Visual Basic Visual Database Manager add-in.
Note that the field has been resized.

[مهدی قربانی]

Adding values to lookup tables

Every database application uses combos for selecting a value from a lookup table.

In Access 2007, combos and list boxes have new properties to make it easy to add items to the list. (The old ways still work as well.)
Access 2007

To use the new properties in Access 2007:

1. Open your form in design view.
2. Right-click the combo, and choose Properties.
3. On the Data tab of the Properties box, set Allow Value List Edits to Yes, and List Items Edit Form to the name of the form to use for adding items to the list.

When you are using this form, you can now right-click the combo, and choose Edit List Items.
All versions

By setting the combo's LimitToList property to Yes, you can use the NotInList event to append a new entry to the lookup table.

If several fields are to be entered (e.g. adding a new client), open a data entry form in dialog mode:

DoCmd.OpenForm "MyForm",,,, acAdd, acDialog

Dialog mode pauses your code until the entry is complete. You can then use acDataErrAdded to cause Access to find the new value.

In other situations only a single field is needed, such as a category, or a title like Mr/Ms/Dr/... Opening a form is unnecessary, as the user has already typed the new value. The function below verifies the entry and appends it to the lookup table.

This function identifies the lookup table from the combo's RowSource property. It assumes the field name in the lookup table is the same as the combo's ControlSource, i.e. the primary key name and foreign key name must be the same.

Follow these Steps:

1. Paste the function below into a general module. Save the module.
2. Verify the combo's LimitToList property is Yes.
3. In the NotInList property of your combo, choose [Event Procedure].
4. Click the "..." button so Access opens the code window.
5. Between Sub ... and End Sub, enter:
Response = Append2Table(Me![MyCombo], NewData)
replacing MyCombo with the name of your combo box.
6. Repeat steps 2 - 4 for other combos.

This function will not work with Access 2 without modification.




Function Append2Table(cbo As ComboBox, NewData As Variant) As Integer
On Error GoTo Err_Append2Table
' Purpose: Append NotInList value to combo's recordset.
' Assumes: ControlSource of combo has the same name as the foreign key field.
' Return: acDataErrAdded if added, else acDataErrContinue
' Usage: Add this line to the combo's NotInList event procedure:
' Response = Append2Table(Me.MyCombo, NewData)
Dim rst As DAO.Recordset
Dim sMsg As String
Dim vField As Variant ' Name of the field to append to.

Append2Table = acDataErrContinue
vField = cbo.ControlSource
If Not (IsNull(vField) Or IsNull(NewData)) Then
sMsg = "Do you wish to add the entry " & NewData & " for " & cbo.Name & "?"
If MsgBox(sMsg, vbOKCancel + vbQuestion, "Add new value?") = vbOK Then
Set rst = CurrentDb.OpenRecordset(cbo.RowSource)
rst.AddNew
rst(vField) = NewData
rst.Update
rst.Close
Append2Table = acDataErrAdded
End If
End If

Exit_Append2Table:
Set rst = Nothing
Exit Function

Err_Append2Table:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbInformation, "Append2Table()"
Resume Exit_Append2Table
End Function

[مهدی قربانی]

Function DeleteAllRelationships() As String
' WARNING: Deletes all relationships in the current database.
Dim db As Database ' Current DB
Dim rex As Relations ' Relations of currentDB.
Dim rel As Relation ' Relationship being deleted.
Dim iKt As Integer ' Count of relations deleted.
Dim sMsg As String ' MsgBox string.

sMsg = "About to delete ALL relationships between tables in the current database." & vbCrLf & "Continue?"
If MsgBox(sMsg, vbQuestion + vbYesNo + vbDefaultButton2, "Are you sure?") = vbNo Then
DeleteAllRelationships = "Operation cancelled"
Exit Function
End If

Set db = CurrentDb()
Set rex = db.Relations
iKt = rex.Count
Do While rex.Count > 0
Debug.Print rex(0).Name
rex.Delete rex(0).Name
Loop
DeleteAllRelationships = iKt & " relationship(s) deleted"
End Function

[HAMRAHSOFT.IR]

Adding values to lookup tables

Every database application uses combos for selecting a value from a lookup table.

In Access 2007, combos and list boxes have new properties to make it easy to add items to the list. (The old ways still work as well.)
Access 2007

To use the new properties in Access 2007:

1. Open your form in design view.
2. Right-click the combo, and choose Properties.
3. On the Data tab of the Properties box, set Allow Value List Edits to Yes, and List Items Edit Form to the name of the form to use for adding items to the list.

When you are using this form, you can now right-click the combo, and choose Edit List Items.
All versions

By setting the combo's LimitToList property to Yes, you can use the NotInList event to append a new entry to the lookup table.

If several fields are to be entered (e.g. adding a new client), open a data entry form in dialog mode:

DoCmd.OpenForm "MyForm",,,, acAdd, acDialog

Dialog mode pauses your code until the entry is complete. You can then use acDataErrAdded to cause Access to find the new value.

In other situations only a single field is needed, such as a category, or a title like Mr/Ms/Dr/... Opening a form is unnecessary, as the user has already typed the new value. The function below verifies the entry and appends it to the lookup table.

This function identifies the lookup table from the combo's RowSource property. It assumes the field name in the lookup table is the same as the combo's ControlSource, i.e. the primary key name and foreign key name must be the same.

Follow these Steps:

1. Paste the function below into a general module. Save the module.
2. Verify the combo's LimitToList property is Yes.
3. In the NotInList property of your combo, choose [Event Procedure].
4. Click the "..." button so Access opens the code window.
5. Between Sub ... and End Sub, enter:
Response = Append2Table(Me![MyCombo], NewData)
replacing MyCombo with the name of your combo box.
6. Repeat steps 2 - 4 for other combos.

This function will not work with Access 2 without modification.




Function Append2Table(cbo As ComboBox, NewData As Variant) As Integer
On Error GoTo Err_Append2Table
' Purpose: Append NotInList value to combo's recordset.
' Assumes: ControlSource of combo has the same name as the foreign key field.
' Return: acDataErrAdded if added, else acDataErrContinue
' Usage: Add this line to the combo's NotInList event procedure:
' Response = Append2Table(Me.MyCombo, NewData)
Dim rst As DAO.Recordset
Dim sMsg As String
Dim vField As Variant ' Name of the field to append to.

Append2Table = acDataErrContinue
vField = cbo.ControlSource
If Not (IsNull(vField) Or IsNull(NewData)) Then
sMsg = "Do you wish to add the entry " & NewData & " for " & cbo.Name & "?"
If MsgBox(sMsg, vbOKCancel + vbQuestion, "Add new value?") = vbOK Then
Set rst = CurrentDb.OpenRecordset(cbo.RowSource)
rst.AddNew
rst(vField) = NewData
rst.Update
rst.Close
Append2Table = acDataErrAdded
End If
End If

Exit_Append2Table:
Set rst = Nothing
Exit Function

Err_Append2Table:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbInformation, "Append2Table()"
Resume Exit_Append2Table
End Function


سلام مشه نمونه بزاری برای کدهای که مزارید تا بهتر باشه

[مهدی قربانی]

سلام
ضمن تشکر از شما دوست گرامی بخاطر توجه و همراهیتون ، عرض میشه خدمتتون که حقیر مابین بعضی پستها نمونه هایی رو به همراه کدهای تقدیمی قرار می دم منتها برای اینکه دوستان خوبمون بتونن توانایی کد نویسی و برخورد با مشکلات مربوطه رو تجربه کنن دیدم خیلی مطلوب نیست که کنار همه نمونه کدها نمونه فایل آماده هم قرار بگیره بنابراین اگر اجازه بدید به همین منوال پیش بریم و در این راستا اگر کاربران عزیز مشکل یا سئوالی براشون پیش اومد بهتره که حتماً سئوال یا مشکلشون رو مطرح کنن تا اشکالات ، ابهامات و یا سایر موارد با کمک دوستان برطرف و نهایتاً منتهی به افزایش تجربه و دانسته های هممون بشه حالا اگر دوستان نظرات دیگه ای دارن با کمال میل آماده دریافت و خدمتگذاری هستیم .

[مهدی قربانی]

http://www.sabeti1.blogfa.com/post-20.aspx

[مهدی قربانی]

این کد خصوصیات یک دیتابیس جاری رو مانیتور می کنه .

Function ShowDatabaseProps()
'Purpose: List the properies of the current database.
Dim db As DAO.Database
Dim prp As DAO.Property

Set db = CurrentDb()
For Each prp In db.Properties
Debug.Print prp.Name
Next

Set db = Nothing
End Function

[مهدی قربانی]

با این قطعه کد در صورتی که کاربر بخواد رکوردی که قبلاً ثبت شده رو تغییر بده خصوصیت Allow Edit فرم False میشه و جلوی تغییرات گرفته میشه .
قطعه زیر رو در رخداد On Current فرم کپی کرده و بجای FieldName نام فیلد مورد نظر خودتون رو جایگزین کنید .


If IsNull(Me.FieldName) = True Then
Me.AllowEdits = True
Else
Me.AllowEdits = False

End If

[مهدی قربانی]

با کد زیر می تونید با کمک VBA‌ اقدام به ساخت کوئری کنید :
یک Command Bottun بر روی یک فرم ایجاد کنید و قطعه کد زیر رو در رخداد On Click مربوط به Command Bottun کپی کنید و بجای CommandName نام Command Bottun ( فراموش نکنید که همه عبارات CommandName موجود در قطعه کد باید اصلاح بشن ) و در متغیرهای StrSQL (ذخیره کننده کد SQL که باید کوئری از روی اون ساخته بشه )‌ بجای TableName نام جدول مورد نظر خودتون و StrQryName‌ ( ذخیره کننده نام کوئری جدیدی که ساخته میشه ) نام دلخواه خودتون رو جایگزین کنید

Private Sub CommandName_Click()

On Error GoTo Err_commandName_Click

Dim Db As Database
Dim QryDef As QueryDef
Dim StrSQL As String
Dim StrQryName As String

Set Db = CurrentDb
StrQryName = "QueryName"
StrSQL = "SELECT * FROM TableName"
Db.QueryDefs.Delete StrQryName
Set QryDef = Db.CreateQueryDef(StrQryName, StrSQL)

DoCmd.OpenQuery StrQryName, acViewNormal


Exit_CommandName_Click:
Exit Sub

Err_CommandName_Click:
MsgBox Err.Description
Resume Exit_CommandName_Click

End Sub
ضمناً شما می تونید بنا به خواسته خودتون کد SQL رو توسعه بدید و حتی شرط هم قائل بشید بنابراین اگر با کدنویسی SQL آشنایی ندارید میتونید یک کوئری مطابق با روش مورد نظرتون بسازید و بعد به نمای SQL اون سوئیچ کنید و عبارت SQL‌ رو در متغیر StrSQL کپی کنید .

[مهدی قربانی]

لینک زیر حاوی لیست کامل کلمات غیر قابل استفاده برای نامگذاری فیلدها ، اشیاء و متغیرها در Ms Access هست :


http://support.microsoft.com/kb/286335

[سعید مشکین فر]

کلید خروج را روی فرم یا سویچ برد طراحی کنید و کد ها را در رویداد Click فرم کپی کنید




Private Sub CmdExit_Click()
Dim x As String
x = MsgBoxFa("از برنامه خارج میشود آیا موافقید", vbYesNo + vbQuestion + vbMsgBoxRight, "خروج از برنامه")
If x = 6 Then
DoCmd.Quit
Else
Exit Sub
End If
End Sub

[سعید مشکین فر]

کلید حذف رکورد را در فرم مورد نظر طراحی کنید و کد زیر را در رویداد On Click کلیدتان کپی کنید بعد از آن هر بار که کلید حذف را برای رکورد انتخاب کنید برنامه از شما برای حذف آن رکورد اجازه میخواهد و میتوانید از حذف رکورد انصراف دهید
On Error GoTo Err_DelRec_Click
i = MsgBoxFa("رکورد جاری حذف میشود آیا اطمینان دارید ؟", vbYesNo, "پیام سیستم")
If i = 6 Then
DoCmd.SetWarnings (warningoff)

DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
MsgBoxFa "رکورد انتخاب شده حذف شده", vbOKOnly, "پیام سیستم"
'DoCmd.SetWarnings (warningon)
Exit_DelRecord_Click:
Exit Sub

Err_DelRec_Click:
MsgBox Err.Description

[سعید مشکین فر]

کد زیر را در رویداد On Error فرم وارد کنید پس از آن هنگام ورود رکوردهای تکرارای سیستم به کاربر پیام تکراری بودن رکورد را خواهد داد . میتوانید پیامها را با جملات مورد نیازتان تعویض کنید.یادآوری میشود Data Source فرم شما باید جدولی با یک فیلد یکتا (PrimaryKey) باشد.
Dim StMsg As String
Const ConDupKey = 3022
If DataErr = ConDupKey Then
StMsg = " رکورد تکراری است "
StMsg = StMsg & " ادامه پیام شما "
StMsg = StMsg & "ادامه پیام شما"
MsgBoxFa StMsg
txtPersonID.SetFocus
Response = acDataErrContinue
End If

[مهدی قربانی]

ضمن تشکر از دوستانی که در این تاپیک شرکت کردن ، سایر عزیزان تمایلی به ارائه مطلب و یا نمونه و .... برای استفاده اعضاء ندارن ؟ به هر حال برای رشد معلومات و توانایی ها لازمه که رفقا همکاری و مساعدت بفرمایند .
موفق باشید .

[elham123]

راه حل در زمانیکه برنامه ما MDE نمی شود و هنگ می کند
http://barnamenevis.org/forum/showthread.php?t=101044

[shaghaghi]

برای خوانایی و زیبایی گزارشات بهتر به نظر می آید با ملاک قراردادن زوج یا فرد بودن عدد فیلد ردیف، سطرهای گزارش را بصورت رنگ های دلخواه (سفید،خاکستری) نمایش دهیم:


Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Me.Detail.BackColor = IIf(me.txtRow Mod 2 = 0, 16777215, 14671839)
End Sub

[F_ashigh]

باید از این دوستان که زحمت جمع آوری این برنامه ها را میکشند و در اختیار بقیه قرار می دهند ، بابت تک تک این برنامه ها تشکر کرد که فکر کنم باز هم کم باشه.

[amirzazadeh]

لطفا فایل ضمیمه را ببینید.

[morteza_lll]

برای خوانایی و زیبایی گزارشات بهتر به نظر می آید با ملاک قراردادن زوج یا فرد بودن عدد ردیف سطرهای گزارشات را بصورت رنگ های دلخواه (سفید،خاکستری) نمایش دهیم


سلام دوست عزیز من این کدو استفاده کردم ولی روی کلمه ROW پیغام خطا می دهد


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

[shaghaghi]

ابتدا TextBoxی را با نام دلخواه (مثلا ROw ) در قسمت Detail ریپورت مورد نظرتان ایجاد نمایید و خاصیت Runnig Sum آنرا Over All نمایید (اگر مایل به نمایش ستون ردیف نیستید، Visible آنرا Flase نمایید)
ضمنا اعداد ذکر شده کد رنگهای سفید و خاکستری هستند که به سلیقه شما می تواند تغییر نماید

[shaghaghi]

یقینا بارها از امکان Subdatasheet هنگام کار با جداولی که ارتباط یک به چند با هم دارند کمک گرفته اید، و با اینکار اطلاعات را بصورت منسجم و راحت مشاهده و ویرایش نموده اید
اما اگر مایل هستید این سهولت را به سابفرم هایتان هم منتقل کنید نمونه برنامه زیر این امکان را به شما می دهد

[morteza_lll]

ابتدا TextBoxی را با نام دلخواه (مثلا ROw ) در قسمت Detail ریپورت مورد نظرتان ایجاد نمایید و خاصیت Runnig Sum آنرا Over All نمایید (اگر مایل به نمایش ستون ردیف نیستید، Visible آنرا Flase نمایید)
ضمنا اعداد ذکر شده کد رنگهای سفید و خاکستری هستند که به سلیقه شما می تواند تغییر نماید

متشکرم دوست عزیز مشکل توسط راهنمایی شما حل شد:تشویق:
ولی یک مورد دیگر اینکه پس زمینه back ground کل اون ردیف را عوض می کند در صورت که من می خوام پس زمینه کل فیلدهای آن ردیف را تغییر دهد در صورتی که الان رنگ بیرون از فیلدها هم می رود ممنون می شم در این مورد هم منو راهنمایی کنید

[amirzazadeh]

دوستان این نمونه رو تو یکی از سایتها دیدم به دیدنش می ازرة امیدوارم مفید باشه.

[mahmoud.golzar]

تابع chrw() و تابع chr چه تفاوتی دارن?

[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

[amirzazadeh]

تابع chrw() و تابع chr چه تفاوتی دارن?
تابع chr یک کاراکتر رو برمیگردونه مثلا 96 حرف a رو برمیگردونه.تابع chrw همونکارو برای کاراکترهای یونیکد انجام میده. برای پلاتفرم مکینتاش chrw مناسب نیست چون یونیکد رو ساپورت نمیکنه.

[amirzazadeh]

لطفا نمونه را ببینید در اين نمونه براي حذف ركورد كاربر بايد پسورد لازم رو وارد كنه كه به دلايل امنيتي موقع ورود پسورد به شكل ستاره نشان داده ميشود.
(پسورد حدف رکورد عدد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

[shaghaghi]

اگر شما در یک روال نسبتا طولانی مرتب با خطاهای گوناگون برخورد می نمایید و هر بار مجبورید برای یافتن منبع خطا، با گذاشتن 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



امیدوارم این مطلب برایتان تازگی داشته باشد!

[davood-ahmadi]

آموزش Office VBA که بیشتر در مورد برنامه نویسی توی اکسس و اکسل هست. پیشنهاد می کنم به دوستان که حتماً این را مطالعه کنند. حداقل مواردی توش هستش که بدردشون بخوره.

[مهدی قربانی]

http://www.farsaran.ir/Access_Section/Hejri%20Date%20in%20Access.htm

[مهدی قربانی]

مجموعه فايلهاي آموزشي PDF فارسي در ارتباط با برنامه نويسي پايگاه داده در VB6 ( مناسب براي آشنايي با مباحث VB و همچنين نحوه كاركردن با اينترفيس VB و بانك اطلاعاتي Access )
منبع : http://visualbasic.blogfa.com/

[مهدی قربانی]

با اين كد شما قادر خواهيد بود با يك كامند باتون عمليات Compact And Repair رو اجرا كنيد .
اكسس 2007 اين كد رو پشتيباني نمي كنه و در اصل مخصوص ورژنهاي 2003 به پائين هست
اين كد رو مي تونيد در رخداد On Click كامند باتون روي فرم اصلي (Switchboard) برنامه خودتون قرار بديد :


CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction

[HAMRAHSOFT.IR]

سلام اميدوارم اين فايل بدرد دوستان بخور

[davood-ahmadi]

یک مقاله آموزشی اکسس مفید و روان برای کسانیکه می خواهند یک مطالعه مجدد بر روی اکسس داشته باشند تا به یک سری از ابهاماتشون در مورد اکسس جواب داده بشه.
این هم آدرس و منبع فایل:
http://www.farsaran.ir/Access_Section/Files/Access.pdf

و این هم یک فایل دیگه:
http://www.farsaran.ir/Access_Section/Files/Access_internet.pdf

[shaghaghi]

سلام
مطمئنا تا بحال کادرهای مستطیل با لبه های گرد را در سربرگ اسناد و گزارشات ملاحضه نموده اید، شاید هم آرزوی داشتن آنرا در گزارشاتتان نموده اید! شاید هم به سراغ استفاده از عکس برای این کار رفته اید؟!
برای بهره مندی از این امکان یک ماژول با این محتویات در فایلتان ایجاد کنید:


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]

خیلی از مواقع مجبور هستید منبع رکورد سابفرم را تغییر دهید یا فیلتری روی آن اعمال کنید، در این مواقع اگر مجبور باشید از سابفرم خروجی اکسل داشته باشید مجبورید سراغ رکوردست آن بروید. اما این کار چند مشکل دارد اول اینکه اسامی مستعار فیلدها اعمال نمی شود، فیلدی های کدینگ شده بصورت اصلی شان یعنی کد 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

[HAMRAHSOFT.IR]

با این ماجول می تونید مجموع زمان رو بطور صحیح و با فرمت 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()

نمونه مرتبط :



لطفا نمونه اكسس پروجكت بزاريد عالي ميشه
البته كد

[shaghaghi]

با کمک این نمونه کد شما قادر خواهید بود، همانند ویزارد خود اکسس لیستی از 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]

با سلام خدمت همه عزیزان
بااستفاده از توابع آقای آزادی و دیگر دوستان تابع تبدیل تاریخ شمسی به حروف به همراه نمونه آماده شده
انشاءاله دیگران بتوانند استفاده کنند.

[smderfan]

هنگام طراحی فرم های جدید در پایگاه داده اکسس حتماً توجه کرده اید که اکسس، مشخصه 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

[amirzazadeh]

دوستان نمونه حاضر براي 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

...........................
موفق باشيد

[Ali_Fallah]

اگر می خواهید کاربران برنامه تان را از کلیدهای پیمایش رکوردها محدود کنید
عیناً کد زیرا وارد برنامه خود کنید
در این کد 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

[Ali_Fallah]

اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...

-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر

[Profesorjd]

در خصوص تاپيك 70 و جناب منتظران منتظر :
با سلام و تشكر
1- لطف فرماييد توابع كاربردي آنرا را هم نام ببريد ( مثلاً نحوه استفاده از تاريخ با روز هفته ، تاريخ كوتاه يا بلند و ... )
2- ماژول ديگر كه چه كاربردي دارد ؟ (‌ البته اگر اشتباه جا نمانده باشد !)

[mahdif123]

اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
(شاید از این سایت یا جای دیگر دانلود کرده با شم)
به هر حال اگر از این فایل استفاده کنید دیگر نیازی به استفاده از ماژول نداشته و به راحتی می توانید فیلد خود را از نوع Date / Time انتخاب کرده و تاریخ شمسی را به راحتی ثبت نمائید .
----------
این فایل dll را در پوشه سیستم 32 ویندوز نصب کنید (بجای فایل قبلی)
گزینه * استفاده از تقویم هجری * در Option فایل اکسس را نیز تیک برنید...

-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر

---------------------------------
سلام دوست عزيز

من از فايل شما استفاده كردم ولي در هنگام كپي خطاي باز بودن فايلها و برنامه ها را ميدهد . تمام برنامه هايم را بستم ولي باز هم همان خطا را مي داد . نمونه عكس

[Ali_Fallah]

با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...

اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر

[mahdif123]

با تشکر از شما
برای اینکه بتوانید فایل را کپی کنید
بایستی ویندوز را بصورت Safe Mode راه اندازی کنید
برای اینکار نیز وقتی سیستم را روشن کردید کلید F8 را مرتب برنید تا انتخاب راه اندازی سیستم از طریق Safe Mode میسر شود.
سپس فایل را کپی کنید...

اگر چنانچه در حالت Safe Mode نیز باز همان خطا رخ داد.
ابتدا فایل حاضر در پوشه ویندوز را تغییر نام دهید . مثلاً یک a به اول نام فایل اضافه کنید.
سپس فایل جدید را کپی کنید.
اینکار باید خیلی سریع انجام گیرد کمتر از 2 ثانیه !!
چون ممکن است ویندوز عمل Refresh را انجام دهد. یعنی فایل شما را پاک کرده و فایل خودش را جایگزین کند. بنابراین اینکار باید خیلی سریع انجام گیرد.
این مراحل نیز باید در همان حالت Safe Mode انجام شود.
سپس سیستم را بصورت نرمال راه اندازی کنید و لذت ببرید...
---------------------------------------------------------------------
کسانیکه دانلود کرده .استفاده نمودند لطفاً در همین جا نظرات خودشان را بنویسند...
با تشکر

----------------------------------
سلام دوست عزيز

مطلبي كه فرموديد انجام دادم ولي آن موردي كه گفتيد در Option بايد تيك بزنيد من پيدا نكردم
لطفا كامل توضيح بدهيد و بگوييد خودتان چگونه عمل كرديد اگر ممكن است با عكس توضيح دهيد .

متشكرم

[Ali_Fallah]

Tools > Option > intrnational > use hijri calender

[M.Javad]

سلام
آیا راهی وجود دارد که بدون اینکه ویندوز را از حالت safe Mode بالا بیاوریم این فایل را با فایل قبلی جایگزین نمود یا خیر؟

[مهدی قربانی]

سلام
دوستان ، به نظر ميرسه كه مباحث اين تاپيك داره مقداري از موضوع اصلي اون كه مباحث VBA هست فاصله ميگيره بنابراين پيشنهاد مي كنم در صورتي كه مايل به ادامه بحث در رابطه با موضوع پست آقاي فلاح هستيد ، پستهاي مربوطه به يك تاپيك مجزا منتقل بشه . ( آقاي فلاح PM بديد )

[mazizi]

سلام
چطوری می شود به یک فیلد از نوع namber یک کلید شماره گزار الحاق نمود که رکورد جدید را با عدد افزایشی بدون تکرار کامل کند. متشکرم.
عزیزی

[mazizi]

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

[مهدی قربانی]

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

سلام
دوست گرامي براي شروع اينجا (http://barnamenevis.org/forum/showpost.php?p=506983&postcount=53) رو ببينيد

[Ali_Fallah]

اگر می خواهید برای همیشه خیالتان از بابت استفاده از تاریخ در اکسس راحت باشد از فایل dll زیر استفاده کنید
-------------------------------------------------------------------------------------
هر کاربر محترمی که از این فایل استفاده کرد حتماً در اینجا گزارش کند...
با تشکر

کسی استفاده نکرد ؟

[mahdif123]

کسی استفاده نکرد ؟

-------------------------
با سلام
جناب فلاح بنده استفاده كردم و جواب داد و بسيار مفيد بود از مطالب مفيد شما بسيار ممنونم .

[صبا9841]

بازکردن و وارد کردن فایلها در اکسس

[منتظران منتظر]

در خصوص تاپیک 62 و جناب دلشکسته:
چطور میتوان مجموع زمان را برای بازه ای از زمان در داخل یک تیبل انجام داد.فرضا ما یک فیلد تاریخ در تیبل داریم و می خواهیم جمع ساعات کاری برای یک دوره یک ماهه شخصی را بررسی کنیم به طوری که تاریخ را از داخل یک فرم از ما بخواهد.
ممنونم.

[صبا9841]

دوستان برای شکیلتر شدن برنامه شکل کروسر موس رو به این صورت تغییربدین:
ابتدا این ماجول را کپی کنید:


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)

[amirzazadeh]

با سلام خدمت دوستان
نمونه حاضر براي جلوگيري از ورود مقادير تكراي در سابفرم آماده شده درصورت ورود داده تكراري پيامي صادر و داده حذف ميگردد.براي اين منظور از تابع 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

[saeedyaz]

بستن کلید شیفت :


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 یا جای دیگه....

[مهدی قربانی]

سلام
اين كد رو اول توي يك ماجول كپي و ذخيره كنيد ، بعد مثلاً در لود فرم اصلي برنامه يا يك كامند باتون اين عبارت رو بنويسيد : SetAllowBypassKeyFalse
البته اگر يك بار اين ماجول اجرا بشه ديگه براي هميشه شيفت بسته ميشه و احتياجي نيست كه هر بار برنامه لود ميشه اين عمل تكرار بشه بنابر اين مي تونيد يك فرم در فايل بذاريد به همراه كامند باتون كه فقط در صورت نياز بهش رجوع كنيد . ويك نكته مهم اينكه حتماً قبل از بستن شيفت يك كپي لز فايل رو در جايي ذخيره كنيد .

[amirzazadeh]

نمونه آموزشي براي مديريت فيلدهاي الزامي با پيام هاي فارسي
لطفا فايل ضميمه رو ببينيد:
درصورت عدم ورود فيلدهاي الزامي پيام خطا صادر ميگردد

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

[Ali_Fallah]

در مرحله اول کدهای زیر را در یک ماژول کیی کنید


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 بنویسید
هربار که جدول جدید ایجاد می کنید برای عدم حذف میبایست مرحله دوم را مجدداً تکرار کنید
موفق باشید

[مهدی قربانی]

سلام
آقاي فلاح ضمن تشكر با توجه به اختلال در فونت كدها ، ماجول مربوطه رو در قالب يك فايل اكسس و از طريق ويرايشگر كلاسيك به پستتون اضافه كنيد .

[mahdif123]

مقايسه اي بين SQLserver 2000 و MSAccess 2000

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

----------------------------------------

http://www.macromediax.com/Learn/archive.asp?id=92

[mahdif123]

امنيت در اكسس

فايلهاي Access در حالت عادي از امنيت خوبي برخوردار نيستند . نرم افزار MDB Secure 2008 نام برنامه اي است كه اين كار را براي شما انجام مي دهد . اين برنامه تعدادي از قابليتهاي بانك اكسس را فعال مي كند كه باعث بالا بردن امنيت نهايي فايل MDB مي شود . اين كارها در اين برنامه با چند كليك ، راحت انجام مي شود در حاليكه براي فعال كردن آنها به صورت دستي در اكسس حدود 30 دقيقه براي هر ديتا بيس طول مي كشد .
نسخه اصلي اين برنامه رايگان نمي باشد و شما مي توانيد نسخه Trial آن را دانلود كنيد .

---------------------------------------
http://www.mindwarp-consultancy-software.com/mdbsecure-free-trial-download.html

[amirzazadeh]

ايجاد پشتيبان در مسير دلخواه با درج تاريخ شمسي در انتهاي نام فايل بدون 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

[M.Javad]

جلوگیری از حذف جداول


با تشکر از آقای فلاح
آیا کدی برای جلوگیری از Import/Export شدن جدواول نیز جود د ارد؟

[pmoshir]

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

[مهدی قربانی]

من کد ایجاد جدول با استفاده از فرم را میخوام از دوستانی که میتوانند کمکم کنند خواهش می کنم این کد رو بفرستند.این کد برای ایجاد جدول در دیتابیس جاری کاربرد داره .
دریک فرم کامند باتونی ایجاد و کدهای زیر رو در رخداد کلیک اون کپی کنید و بجای 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
نمونه مرتبط :

[dadsara]

این کد برای ایجاد جدول در دیتابیس جاری کاربرد داره .
دریک فرم کامند باتونی ایجاد و کدهای زیر رو در رخداد کلیک اون کپی کنید و بجای 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" ارور می گیرد
لطفا بفرمائید خطای کار من در کجاست

[مهدی قربانی]

سلام
من برنامه شما را اجرا نمودم و برروی اولین خط "MyDatabase As Database" ارور می گیرد
لطفا بفرمائید خطای کار من در کجاست
سلام
ببینید در قسمت References گزینه Microsoft DAO Objects Library 3.6 تیک خورده ؟

[dadsara]

بله گزینه مورد نظر تیک خورده

[مهدی قربانی]

سلام
این عبارت رو به این شکل تغییر بدید ببینید درست میشه :

Dim MyDatabase As Database

به این شکل


Dim MyDatabase As DAO.Database

[dadsara]

سلام
کد موردنظر را تغییر دادم ارور پیش آمده از روی آن خط عبور کرده و حال برروی خط زیر ارور می گیرد

.Fields.Append .CreateField("Title", dbText, 30)

[مهدی قربانی]

سلام
عجيبه ! من كه نه در 2007 و نه در 2003 به مشكلي برنخوردم ، شما از چه ورژني استفاده مي كنيد و ضمناً اگر مقدوره رفرنسهايي كه تيك خورده رو اعلام كنيد .

[dadsara]

سلام
ضمن تشکر از پیگیری شما
من تصویر رفرنسهای خود را ضمیمه نمودم

[مهدی قربانی]

سلام
رفرنسهاتون هم کاملاً درسته حالا چرا ارور دارین الله اعلم ، این فایل رو روی یک دستگاه دیگه هم تست کنید و نتیجه رو اعلام کنید .

[dadsara]

سلام
بازهم ضمن تشکر از جنابعالی
فایل مورد نظر را روی یک رایانه دیگر اجرا کردم و اجرا شد و یک جدول بنام MP3New ایجاد شد
ولی هنوز متوجه ایراد بوجود آمده روی رایانه خود نشده ام

[مهدی قربانی]

سلام
احتمال میدم که Collection های موجود در VBA شما دچار اشکال شده و درست عمل نمی کنن بنابراین بهتره یکبار Office رو Uninstall و مجدداً نصب کنید .

[مهدی قربانی]

مشاهده کدها (http://barnamenevis.org/forum/showpost.php?p=648641&postcount=2)

[nabeel]

ضمن سلام به حضور dadsara

مطمئناً مشکل در بخش References وجود داره .
عملاً Access در صورت وجود رفرنسی که در کنار آن واژه Missing درج شده باشد , در هنگام اجرای کد با خطا مواجه میشه .
با توجه به استفاده از DAO در داخل کدهای شما , نقیصه الزاماً با برداشتن تیک کنار Reference معیوب رفع میشه

دلایل ایجاد این نقیصه میتونه :

عدم وجود اون Reference بر روی کامپیوتر شما
ناسازگاری نسخه موجود بر روی کامپیوتر شما و کامپیوتری که فایل بر روی آن تهیه شده است
و یا رجیستر نبودن درست Reference بوده باشد

ضمناً توصیه میشه دوستان مقداری هم در خصوص گزینه Priority تحقیق کنن

با تشکر از شما

[e601]

با سلام

شاید برای شما هم پیش اومده باشه که بخواهید به محض باز شدن گزارش و بصورت اتوماتیک به صفحه آخر گزارش منتقل شوید. بدون اینکه لازم باشه منتظر باشید گزارش لود بشه بعد با استفاده از کلیدهای navigator گزارش به صفحه آخر برید

من با کد زیر اینکار رو انجام میدم


DoCmd.Maximize
SendKeys "{F5}"
SendKeys "500"
SendKeys "{Enter}"

کد فوق باید در رویداد OnActive گزارش قرار بگیره

روشی دیگر:
دوستمون آقای پیروزمهر هم روش دیگه ای رو پیشنهاد کردن :


DoCmd.Maximize
SendKeys "{End}"
این دستور کوتاهتر و خواناتره. البته توجه داشته باشید در صورتی که خاصیت AutoResize ریپورت No باشه به صفحه آخر نمیره

به هر حال با توجه به نحوه نمایش گزارشتون دستور مناسب رو انتخاب کنید

موفق باشید...

[vahidparsa]

سلام
من دنبال گزارش یا کدی هستم که بتونم شماره های جا افتاده در یک فیلد رو بهم نشون بده
مثلا یه جدول دارم به نام doc و یه فیلدداره به اسم no.
رکورد های این فیلد هم به صورت زیره:
1,2,4,5,7,9,10
می خوام یه گزارش بسازم که اعداد 3و6و8 که از مجموعه 1 تا 10 جا افتاده رو بهم نشون بده

[dadsara]

سلام
دوست عزیز قبلا یک تاپیک با موضوعی شبیه همین عنوان ایجاد شده بود و به جواب هم رسید
درصورتیکه تاپیک خواسته جنابعالی را اجابت نمی کند نسبت به ایجاد یک تاپیک مستقل اقدام نمائید تا جواب مناسب ارائه گردد

[iman56]

باسلام. یک کد مخفی کننده navigation pan می خوام. اگه دوستی داره، لطفا کمک کنه...
در ضمن ایا روشی برای exe کردن فایل های اکسس وجود داره؟

[amin_rj]

باسلام. یک کد مخفی کننده navigation pan می خوام. اگه دوستی داره، لطفا کمک کنه...
در ضمن ایا روشی برای exe کردن فایل های اکسس وجود داره؟

داخل همین بخش جستو جو کن پیدا میکنید
برای سؤال دوم هم تا حالا روشی برای این کار من نشنیدم و فکر نکنم وجود داشته باشه

[amin_rj]

یک سؤال هم داشتم
در access 2007 کدی هست که کلیدهای باز و بسته و تغییر اندازه بالای ا کسس حذف شود
ممنون میشوم راهنمایی کنید

[مهدی قربانی]

باسلام. یک کد مخفی کننده navigation pan می خوام. اگه دوستی داره، لطفا کمک کنه...
در ضمن ایا روشی برای exe کردن فایل های اکسس وجود داره؟

سلام
براي Navigation Pan به صفحات قبل اين تاپيك رجوع كنيد نمونه گذاشته شده
در مورد سئوال دومتون هم دوست عزيز ظاهراً اصلاً جستجويي نكرديد بارها در اين مورد تاپيك ايجاد شده و موضوع مورد بحث قرار گرفته !!

[amirzazadeh]

اخذ مشخصات سخت افزاري كامپيوتر

نمونه ارائه شده براي به دست آوردن مشخصات سيستم كاربرد داره اميدوارم به دردتون بخوره
براي اجراي صحيح بايد رفرنس Microsoft WMI Scripting v2.1 libraryتيك خورده باشه

Public Function GetPCInfo()
'You need to have Microsoft WMI Scripting v2.1 library Registered in your references
DoCmd.Hourglass True

Dim SWbemSet(Arr) As SWbemObjectSet
Dim SWbemObj As SWbemObject
Dim varObjectToId(Arr) As String
Dim varSerial(Arr) As String
Dim i, j As Integer
Dim fld As String

On Error Resume Next
varObjectToId(1) = "Win32_Processor,Name"
varObjectToId(2) = "Win32_Processor,Manufacturer"
varObjectToId(3) = "Win32_Processor,ProcessorId"
varObjectToId(4) = "Win32_BaseBoard,SerialNumber"
varObjectToId(5) = "Win32_BaseBoard,manufacturer"
varObjectToId(6) = "Win32_Baseboard,product"
varObjectToId(7) = "Win32_BIOS,Manufacturer"
varObjectToId(8) = "Win32_OperatingSystem,SerialNumber"
varObjectToId(9) = "Win32_OperatingSystem,Caption"
varObjectToId(10) = "Win32_DiskDrive,Model"
For i = 1 To Arr
Set SWbemSet(i) = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf(Split(varObjectToId(i), ",")(0))
varSerial(i) = ""
For Each SWbemObj In SWbemSet(i)
varSerial(i) = SWbemObj.Properties_(Split(varObjectToId(i), ",")(1)) 'Property value
varSerial(i) = Trim(varSerial(i))
If Len(varSerial(i)) < 1 Then varSerial(i) = "Unknown value"
Next
fld = "Txt" & i
Forms("FrmSystemInformationReader")(fld) = varSerial(i)
Next
DoCmd.Hourglass False
End Function


.......................
موفق باشيد

[rezaicom]

سلام دوست عزیز من تازه کارم این موردی که گفتین رو نتونستم فعال کنم خطا می ده چه کنم
ضمناً فراموش نکنید اگر در References وی بی ای ، گزینه Microsoft DAO 3.6 Object Library چک نخورده حتماً فعالش کنید .
"Name conflicts with existing module, project, or object library"
ممنون میشم جوابمو بدین

[amirzazadeh]

سلام دوست عزیز من تازه کارم این موردی که گفتین رو نتونستم فعال کنم خطا می ده چه کنم
ضمناً فراموش نکنید اگر در References وی بی ای ، گزینه Microsoft DAO 3.6 Object Library چک نخورده حتماً فعالش کنید .
"Name conflicts with existing module, project, or object library"
ممنون میشم جوابمو بدین
دوست من شما بايد اين رفرنس رو فعال كنيد:Microsoft WMI Scripting v2.1 library
................................
موفق باشيد

[ryonis]

وقتي مي خوام از Common Dialog تو فرم خودم استفاده كنم يه Error عجيب غريب مي گيرم.

تصوير زير رو ببينين :

http://www.freeuploadimages.org/images/0f8ypznrmgorzzli41x.jpg

دوستان گلم، كمك لطفاً ........

[amirzazadeh]

جمع صفحه در گزارش
دوستان سلام
نمونه حاضر در پاسخ به سئوال چند تن از كاربران آماده شده با اين توضيح كه دو تا تكست باكس unbound يكي در page Header با نام nagl و ديگري در Page Footer با نام page total ، اولي براي نشان دادن نقل از صفحه قبل و دومي براي جمع صفحه در نظر گرفته شده.
كدهاي به كار رفته :

Option Compare Database
Option Explicit
Dim curtotal As Currency
Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
If PrintCount = 1 Then curtotal = curtotal + Me.mablagdarkhasti
End Sub

Private Sub PageFooterSection_Format(Cancel As Integer, FormatCount As Integer)
Me.pagetotal = curtotal
End Sub

Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer)
Me.nagl = curtotal
curtotal = 0
End Sub

..........................
موفق باشيد

[alirezabahrami]

براي بدست آوردن مختصات موس (مختصات x و y ) از نمونه كاربردي ضميمه استفاده كنيد!
موفق باشيد

[alirezabahrami]

وقتي مي خوام از Common Dialog تو فرم خودم استفاده كنم يه Error عجيب غريب مي گيرم.

تصوير زير رو ببينين :

http://www.freeuploadimages.org/images/0f8ypznrmgorzzli41x.jpg

دوستان گلم، كمك لطفاً ........
سلام
بخش ماژول را باز كن و از قسمت References گزينه Microsoft Scripting Runtime را انتخاب ،سپس برنامه را ببند و مجدداً اجرا كن!
موفق باشيد

[abas588]

نوشته شده توسط سعید رضایی:لبخندساده:

[vbnasim]

نوشته شده توسط سعید رضایی:لبخندساده:

ضمن تشكر از شما
مي خواستم بدانم چگونه مي توانم به سورس برنامه شما دسترسي داشته باشم

[amirzazadeh]

ضمن تشكر از شما
مي خواستم بدانم چگونه مي توانم به سورس برنامه شما دسترسي داشته باشم
سلام
كافيه در هنگام باز كردن برنامه از كليد شيفت استفاده كنيد.
.........................
موفق باشيد

[linktaz]

انتخاب چند گزینه بطور همزمان از لیست باکس و نمایش اطلاعات مربوط به هر کدام.

[kamkam1]

یک دیالوگ برای Sort گزارش

با این دیالوگ در گزارش هم حالت Ascending و هم حالت Descending را جهت Sort می توان استفاد کرد .

[dadsara]

سلام
با استفاده از این کد می تونید جدول خود را حذف کنید
اگر جای AcTable از Acform یا Acquery یا . . . استفاده کنید این دستور کاربرد دارد

DoCmd.DeleteObject acTable, "table1"

[linktaz]

یک نمونه جالب و کامل از فیلترکردن ریپورت بوسیله optionهای مختلف

[mahdif123]

با سلام

دستور SELECT ... INTO جهت ایجاد جدول جدید شامل رکوردهای نتیجه پرس و جو

با استفاده از این دستور SQL در Query در داخل پایگاه داده می توانید جدول بک‌آپ بسازید :


SELECT * INTO table1backup
FROM Table1;

[smderfan]

سلام
عيد سعيد فطر مبارك.

[linktaz]

سلام.
یک نمونه از ایجاد سطح دسترسی کاربران در اکسس.امیدوارم مفید باشه.

[جعفر88]

سلام چطوری میشه پیغامهایی که اکسس بصورت انگلیسی میده با پیامهای فارسی عوض کرد کد خطاها را هم بگین که خیلی ممنون میشم؟
براي خطا حين اجرا كد ها به نظرم از ابزارهايي نظير سري دستورهاي ...on error goto و شيء Err استفاده كنين ميشه تا حدود زيادي خطاهاي حين اجراي(run-time error) كد رو اداره كرد و پيام خاص خود را به كاربر اعلام نمود . براي خطاهاي فرم نيز از رويداد on error اون استفاده كنين تو روال اين رويداد متغيري به نام Response هست كه اگه مقدار اونو به ثابت acDataErrContinue تغيير بدين پيام خطاهاي داخلي اكسس نمايش داده نميشه و درعوض ميتونين پيامهاي فارسي رو نمايش بدين . براي كد خطاها هم راهنماي اكسس و سايت ميكروسافت منابع خوبي اند . در ضمن اگه سوالات خاص خود رو در بخش عمومي تالار مطرح كنين دوستان بهتر ميتونن پاسخ بدن ، تو اين موضوع فقط سعي كنين نمونه برنامه ارائه كنين .

[zzzzzza]

باز شدن فرم از زواياي مختلف با سرعت هاي مختلف

[zzzzzza]

بازي در اكسس

[zzzzzza]

بازي در اكسس (سئوال و جواب كابردي در اكسس)

از دست ندهيد*******

[zzzzzza]

ديگر از جان اكسس چه ميخواهيد؟

نشان دنده مشخصات هر نوع فايل توسط اكسس
FilePropertyViewer

[stabesh]

اين براي كيبورد :
http://barnamenevis.org/showthread.php?51987&p=1167276#post1167276

[amirzazadeh]

ثبت اطلاعات از فرم و ساب فرم به صورت unbound
نمونه حاضر با استفاده از كد زير آماده شده :

Public Sub CopySelected(ByRef frm As Form)

Dim rs, rs1 As Recordset

Set rs = CurrentDb.OpenRecordset("form", dbOpenDynaset)
rs.AddNew
rs!ncode = Me!ncode
rs!name_family = Me!name_family
rs.Update
Set rs1 = CurrentDb.OpenRecordset("child", dbOpenDynaset)
Dim ctlSource As Control
Dim strItems, stritems2 As String
Dim intCurrentRow As Integer

Set ctlSource = frm!List6

For intCurrentRow = 0 To ctlSource.ListCount - 1
ctlSource.Selected(intCurrentRow) = True
If ctlSource.Selected(intCurrentRow) Then
rs1.AddNew
rs1!ncode = ctlSource.Column(0, intCurrentRow)
rs1!farzand = ctlSource.Column(1, intCurrentRow)
rs1!pncode = Me!ncode
rs1.Update

End If
ctlSource.Selected(intCurrentRow) = False
Next intCurrentRow
rs.Close
rs1.Close
MsgBox "data successfully saved"
End Sub

[royasaz_bam]

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

[bemilove]

دوستان برای شکیلتر شدن برنامه شکل کروسر موس رو به این صورت تغییربدین:
ابتدا این ماجول را کپی کنید:


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)


وقتی می خواهید روی دکمه ای کلیک کنید ارور کمپایل می دهد

[me.alizadeh]

با سلام خدمت استاد محترم
من این کار را انجام دادم در رویداد key down خطا داد
اگر امکانش هست لطف کنید یک فایک پیوست کنید .
با تشکر


با تکه کد زیر استفاده از کلیدهای - و + برای کاهش یا افزایش تاریخ در یک فیلد Date/Time امکانپذیر میشه البته لازم به ذکره که کد فعلی قابلیت کاهش یا افزایش تاریخ رو بصورت روزانه داره که اگر لازم باشه تغییر پارامتر "d" به سایر پارامترها مثل y , m , w برای کاهش یا افزایش ماه سال و هفته امکانپذیره .

کدهای زیر رو در یک Module جدید کپی کنید :


Public Function PDate(PObj As Object, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyAdd Then
If Shift = 2 Then
PObj = DateAdd("m", 1, PObj)
KeyCode = 0
Else
PObj = DateAdd("d", 1, PObj)
KeyCode = 0
End If
End If

If KeyCode = vbKeySubtract Then
If Shift = 2 Then
PObj = DateAdd("m", -1, PObj)
KeyCode = 0
Else
PObj = DateAdd("d", -1, PObj)
KeyCode = 0
End If
End If
End Function



کد زیر رو هم در رویداد Key Down فیلد مورد نظر که جنسش Date/Time هست کپی کنید :
بجای FieldName نام فیلد مورد نظر رو قرار بدین


PDate Me.FieldName, KeyCode, Shift

[mojahed.morteza]

كار نميكنه اين لينك

[مهدی د]

ضمن تشکر ولی وقتی با فشردن دکمه + به آخرین روز ماه برسیم چنانچه مجددا دکمه + را فشار دهیم تاریخ به اولین روز ماه بعد منتقل نمی شود بلکه ادامه پیدا می کند و تعداد روزها بیشتر از تعداد روزهای ماه می شود.

[meli66]

دوست محترم جناب دادرس من اکثرتایپینگ هاراگشتم مشخصا به سئوالم جوابی نیافتم !اگرممکن است خودتون تایپینگ مربوطه رامعرف فرمائید حتمایادتان هست که سئوالم این بودکه : کدی میخواستم که بارسیدن مقدارعددی یک فیلد به اندازه معین آن فیلدتغیررنگ بدهد در رپورت . ممنون

[sajjad_kochekian]

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

Public Function number3digit(num As Currency, state As Integer) As String
Dim ln As Integer
If state = 1 Then number3digit = Right(num, 3)

If state = 2 And Len(Trim(num)) > 3 Then
ln = Len(Right(num, 6)) - 3

number3digit = Left(Right(num, 6), ln)

End If
If state = 3 And Len(Trim(num)) > 6 Then
ln = Len(Right(num, 9)) - 6
number3digit = Left(Right(num, 9), ln)
End If

End Function

[pmoshir]

لطفا ادامه اين فانكشن كه چطور در فرم استفاده بشه رو بزاريد.با تشكر

[sajjad_kochekian]

msgbox number3digit( 123456789,2)

[askar333]

با سلام
مطلب خوبی است برای من که مبتدی هستم بیشتر توضیح دهید
با تشکر..

[abas1388]

جناب biotechsoft (http://barnamenevis.org/member.php?117002-biotechsoft) سلام ،
با تشکر از جنابعالی ، فایل فوق از سایت 4Shared قابل دانلود نیست . لطفاکنترل فرمائید . در صورت امکان در خود سایت آن را ضمیمه نمائید تا همه بتوانند از این مجموعه استفاده نمایند .
با تشکر
با سلام
بنده هم امتحان كردم متأسفانه نمونه ها قابل دانلود نيستند

[ic3300]

برنامه ای که دوست عزیزمون برای صندوق قرض الحسنه فامیلی(به قول خودشون رایگان) نوشتن بعد از مدتی کار کردن کد فعالسازی می خواد که باید برای اون 95000توامن ناقابل بپردازین
در غیر این صورت تمام اطلاعاتتون رو هواست..من قبلا از این نرم افزار استفاده کردم چوبشو خورم
Biotechsoft عزیز این کاراتو نکن تو این سایت یک عده بی ریا به هم کمک میکنن از برنامه های کاربردی که برای دانلود گذاشتی فهمیدم خودت هم همه چیز رو از این سایت باحال یاد گرفتی
در ضمن عیدت مبارک:تشویق:

[ic3300]

با سلام
برنامه شما در بحث گزارشهای صندوق تراکنشهای وام (دریافت و پرداخت وام) رو در موجودی صندوق لحاظ نمیکنه
مثلا اگه به کسی وام دادیم یا قسط گرفتیم از موجودی کل صندوق کم و زیاد نمیشه
در ضمن پست سورس باز برنامه تو ن رو حذف کردم

[mhamedm2008]

به نظر من اکسس فوق العادست.
من نه ماهه دارم برنامه ایی با اکسس می نویسم.حدود 130 فورم و 32 تا تیبل و کلی ریپورت و کوئری داره.اصلا هم کسی که باهاش کار می کنه نمی تونه تشخصی بده این اکسس هست یا یه نرم افزار دیگه.حتی منوی تنظیمات داره که میشه خیلی از قسمت های برنامه رو تنظیم کرد و در صورت نیاز تغیرر داد و یا 500 عمل آخری که توی برنامه کاربر انجام میده رو توی لوگ خودش ذخیره می کنه. تا الان هم سر جمع توی کل تیبل هاش حدود 7500 تا تا الان رکورد ذخیره شده.همه تکس هابکس ها و فرم ها هم به صورت unbound هستن
واقعا اکسس حرف نداره

[mma_ok]

جناب Profesorjd عزیز
خیلی از این حرکت دوستمون ناراحت شدید . البته مشخصه که هدف ایشون تیلبغات و فروش برنامه حسابداری خودشونه البته اگر درست کار کنه
مطمئنا همون طور که شما هم فرمودید برنامه های خیلی بهتر و کاربردی تر و رایگان نیز در دسترس میباشد که هر کس مایل است از اونها استفاده کنه
من یک نمونه را در این قسمت قرار میدم که البته کار من نیست و من یک تغییرات جزئی توش دادم
ضمنا کاملا باز هستش و صاحبش هم اجازه انجام تغییرات رو داده رمز برنامه هم 123 است
http://www.up.98ia.com/images/m51i7m4fxlut88ybimxh.rar

یا از اینجا
http://uploadkon.ir/uploads/bfeec15f6c8c11079cc69d4dd0a8e0ec.rar

[1362mn1362]

با سلام
آقای قربانی این غیر فعال و فعال کردن کلید شیفت رو من اصلا نفهمیدم . شما می تونید توی این زمینه قدم به قدم من راهنمایی بکنید؟
با تشکر

[u.2u.4u]

سلام دوستان.
در اینجا:
http://barnamenevis.org/showthread.php?342320-%D8%AF%D8%B3%D8%AA%D8%B1%D8%B3%DB%8C-%DA%A9%D8%A7%D8%B1%D8%A8%D8%B1-%D8%A8%D9%87-%D9%85%D8%AD%D8%AA%D9%88%DB%8C%D8%A7%D8%AA-%D9%86%D8%B1%D9%85-%D8%A7%D9%81%D8%B2%D8%A7%D8%B1-%D8%AF%D8%B1-%D8%A7%D9%88%D9%84%DB%8C%D9%86-%D8%A7%D8%AC%D8%B1%D8%A7&p=1509986#post1509986
یه سوالی راجع به همین موضوع دارم لطفا جواب بدید. خسته شدم

[u.2u.4u]

در این فایل عملیات مختلف و جالبی مربوط به صادر و وارد کردن فایل اکسس را گنجاندم.
منبع کدها از سایت های مختلف داخلی و خارجی هست. برای یک پروژه نیاز داشتم و پس از جستجوی فراوان هر کدوم از اونها را پیدا کرده و اصلاح کردم. امیدوارم برای دوستان عزیز مفید باشد.
از اساتید محترم هم خواهشمندم به کاملتر شدن اون کمک کنند.
1- صادر کردن جداول با فرمت های متن و Html و اکسل
2- خواندن گزارش ها فرم ها و ... از فایل دیگر
3- وارد کردن گزارش ها، فرم ها و ... از فایل دیگر
4- بازیابی جداول از طریق فایل اکسلی که در مورد 1 صادر شده است.

[RESMAILY]

به نام خدا
با سلام و تشكر ازفايل تان. در ضمن يك جوابكي هم به آن مطلب تان داده ام. نگاهي بفرماييد.

[underworld]

سلام بر مهندسین عزیز

من Vba اکسس رو تقریبا میدونم چیه ولی اخیرا سر یک موضوع کوچیک گیر کردم و اوون اینه که در دیتا بیس اکسس فیلد از نوع attachment دارم که عکس آپلود کردم ولی با vba نمیتونم مقادیر رکوردهارو در image control نشون بدم.
کسی میدونه راه کارش چی هست؟

[mahdytaherian]

سلام
با توجه به تايپيك شماره 22 مي خواستم در صورتي كه ركوردهاي سابفورمم صفر بود (سابفرم نتيجه يك كوئري ميباشد) مقدار يك تكس باكس در فرم را صفر كند در غير اينصورت مقدار تكس باكس برابر كانت سابفرم شود مثلا اگر 10 ركورد داشت تكس باكس عدد 10 را نشان دهد و اگر خالي بود عدد صفر را نشان دهد
با تشكر

[ali.m.a]

سلام
با توجه به تايپيك شماره 22 مي خواستم در صورتي كه ركوردهاي سابفورمم صفر بود (سابفرم نتيجه يك كوئري ميباشد) مقدار يك تكس باكس در فرم را صفر كند در غير اينصورت مقدار تكس باكس برابر كانت سابفرم شود مثلا اگر 10 ركورد داشت تكس باكس عدد 10 را نشان دهد و اگر خالي بود عدد صفر را نشان دهد
با تشكر
درود دوست عزیز طبق قوانین شما باید سوالتون رو تو قسمت تایپیک های معمولی تالار اکسس مطرح کنید .
ولی با این حال فایلتون رو اصلاح کردم
بدرود

[alirezabahrami]

Private Sub Form_Load()
Me.ocxWebBrowser.Object.Navigate CurrentProject.Path & "\NamePicture.gif"
End Sub
Private Sub ocxWebBrowser_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
Me.ocxWebBrowser.Object.Document.Body.Scroll = "no"
End Sub

تذکر:
بجایNamePictureنام تصویر متحرک خود را وارد نمائید.
تصویر متحرک هم باید در کنار برنامه باشد.
موفق باشید

[niloufar_1990]

سلام دوستان
من یک وبسایت در زمینه آموزش های تخصصی اکسس پیدا کردم که مطالب جالبی داره و فکر کنم که براتون مفید باشه
http://www.fardanesh.ir (http://www.fardanesh.ir/)

[hosseinwww]

سلام کسی میتونه اینو انجام بده
سلام
یک نمونه برنامه انبارداری از آقای عطا امینی کابر همین سایت رو دراینجا گذاشتم با اجازه آقای امینی چندتا سوال داشتم اگه از عزیزان کسی میتونه تغییراتو روش انجام بده . رمز برای کاربر عطا امینـﮮ ™ : 7086
دوستانی که از 2007 و بالاتر استفاده می کنند منوهای برنامه در Add-Ins قابل دستیابی می باشد. بازدن کلید f11
1- در تب انبارداری-تعریف کالا دو فیلد (تکست باکس) دیگر اضافه شود یکی عمرانباری(مدت زمان نگهداری در انبار) و دیگری عمر خدمتی(مدت زمانی که یک جنس می تواند کار کند) که این دو فیلد وقتی کالای جدید تعریف می شود توسط کاربر وارد شود.به ماه باشد مثلا عمر انباری یک پیچ 120 ماه و عمر خدمتیش 80 ماه
2- در تب تولید/ورود کالا یک تکس باکس اضافه شود که تاریخ تولید کالا را بتوان وارد کرد (تاریخی که روی جنس نوشته میشود توسط کارخانه)
3- در تب گزارشات یه لیست تنظیم شود که تاریخ انقضا کالا را نشون دهد بدین صورت که تاریخ تولید را به عمر انباری اضافه کند و به صورت شمسی تاریخ انقضا را نشان بدهد.
4- اگر در تب ورود کالا یک جنس به تعداد ده عدد خواستیم وارد کنیم به طوری که این ده جنس ده سریال مختلف دارن اگر بخواهیم ده سریال را وارد کنیم چگونه وارد کنیم باید یک فیلد ساخته شود؟بعد ده تا را چگونه وارد کنیم.
عزیزان هرکسی میتونه تغییراتو انجام بده اصلاح شده رو بزاره تو سایت واسه استفاده همه ، خودم زیاد وارد نیستم لطفا خودتون کاملش کنید
با تشکر از تمامی دوستان
لینک دانلود برنامه اینجا گذاشتم
http://barnamenevis.org/attachment.php?attachmentid=127548&d=1421185291
http://barnamenevis.org/attachment.php?attachmentid=127549&d=1421185303

[hosseinwww]

کسی نمیتونه کمک کنه
من خودم ابتدا تو جدول کالاها دوتا فیلد ساختم با نام عمر انباری و عمر خدمتی ..و بعد در فرم معرفی کالا این دو فیلد رو اضافه کردم اما مشکلی وجود داره که اطلاعاتی که وارد میکنم در اخر میخوام فرمو ببندم پیام میده که the primarycode cannot null در صورتی که این دو فیلد پریمری نیستند و نام کالا پریمری می باشد و در ضمن هرچی تو تین دو فیلد وارد کردم در فرم داخل جدول نیومده چرا؟؟؟

[hosseinwww]

در قسمت انبارداری- تعریف کالا یک کالای جدید که اضافه میکنم و مدت زمان نگهداریش رو هم وارد میکنم موقع بستن فرم این ارور میده idex or primry key cannot contain a null value
در صورتی که اگر مدت زمان نگهداری رو وارد نکنم یعنی خالی بمونه موقع بستن هیچ اروری نمیده

http://s6.picofile.com/file/8266945500/anbar1.rar.html

بخشید نتونستم بفرستمش اینجا لینک دانلودشو گذاشتم
ممنون

[markazeahan]

نمونه هایی از جدول را میتونین توی لینک زیر ببینید

سه راهی گازی (https://www.markazeahan.com/product-category/%D8%B3%D9%87-%D8%B1%D8%A7%D9%87%DB%8C-%DA%AF%D8%A7%D8%B2%DB%8C/)

[gitec1]

سلام دستور ایجاد رکورد جدید در vb می خواستم
لطفا راهنمایی نمایید

[vivapersian@hotmail.com]

سلام
کدی هست که اگه کاربر رکوردی رو تغییر داد یا حذف کرد توی یک تیبل دیگه تغییرات را ثبت کنه
(در واقع تمامی فعالیت های کاربر رو ثبت کنه)

[shahraieni13]

کدی برای قفل نمودن سلول های حاوی فرمول در اکسل
منبع :https://softpluse.ir/

With ActiveSheet

خارج کردن شیت جاری از حالتprotect ‘
.Unprotect
غیر فعال کردن قفل تمام سلول ها ‘
.Cells.Locked = False
تنظیم قفل سلول های دارای فرمول’ .Cells.SpecialCells(xlCellTypeFormulas).Locked = True.Protect AllowDeletingRows:=True

[mai1324]

سلام
ار بخواهیم بعد از ذخیره فرم بسته بشه،docmd.close را در کدام خط باید بنویسیم؟

[naderbahri]

سلام با استفاده از ابزار زیر به راحتی می توانید پیغامهای فارسی را یونیکد کرده و از در برنامه های خود از مسیج باکسهای اختصاصی بهره ببرید

https://officebaz.ir/unicode/

[shhyr1641]

سلام
وقت دوستان بخیر
سوال مهمی دارم اگر امکانش هست راهنماییم کنید:
کدی دارم که به وسیله آن در اکسس و از طریق وب سرویس امکان ارسال پیامک دارم.
شخصا در بخش vba توانمند نیستم، اما تونستم این کد رو برای یک دکمه تنظیم کنم و از مقدار فیلد "تلفن همراه" در فرم جهت ارسال پیامک استفاده کنم. مشکلم در بخش متن این پیامک هست که باید در کدنویسی تغییر بدم. یعنی باید متن ثابتی باشه و از فیلد "نام" فرم در متن استفاده بشه. بطور مثال: مشترک گرامی "نام"
با سلام....
چند هفته ای هست که امکان استفاده از وب سرویس پیامک در اکسس رو دنبال می کردم و دیگه ناامید شده بودم و میخواستم برم سراغ برنامه های روز، اما با این پیشرفتی که داشتم خیلی امیدوار به اکسس شدم و سعی دارم این تجربه رو هم انتقال بدم.
اگر در این مورد راهنمایی کنید ممنون میشم.
با سپاس از متخصصین این حوزه

[shhyr1641]

سلام
وقت دوستان بخیر
سوال مهمی دارم اگر امکانش هست راهنماییم کنید:
کدی دارم که به وسیله آن در اکسس و از طریق وب سرویس امکان ارسال پیامک دارم.
شخصا در بخش vba توانمند نیستم، اما تونستم این کد رو برای یک دکمه تنظیم کنم و از مقدار فیلد "تلفن همراه" در فرم جهت ارسال پیامک استفاده کنم. مشکلم در بخش متن این پیامک هست که باید در کدنویسی تغییر بدم. یعنی باید متن ثابتی باشه و از فیلد "نام" فرم در متن استفاده بشه. بطور مثال: مشترک گرامی "نام"
با سلام....
چند هفته ای هست که امکان استفاده از وب سرویس پیامک در اکسس رو دنبال می کردم و دیگه ناامید شده بودم و میخواستم برم سراغ برنامه های روز، اما با این پیشرفتی که داشتم خیلی امیدوار به اکسس شدم و سعی دارم این تجربه رو هم انتقال بدم.
اگر در این مورد راهنمایی کنید ممنون میشم.
با سپاس

[m3343kh]

با این کد ساده شما قادر هستید بدون استفاده از Navigation Bar خود اکسس یک شمارشگر رکورد رو در فرمتون به نمایش بگذارید .
یک Text Box در فرم مورد نظر ایجاد کنید و نام اونرو txtRecordCounter بگذارید و کد زیر رو در رویه On Current فرم کپی کنید :


Dim rst As DAO.Recordset
Dim lngCount As Long

Set rst = Me.RecordsetClone

With rst
.MoveFirst
.MoveLast
lngCount = .RecordCount
End With

Me.txtRecordCounter = "رکورد" & Me.CurrentRecord & " از " & lngCount
ضمناً فراموش نکنید اگر در References وی بی ای ، گزینه Microsoft DAO 3.6 Object Library چک نخورده حتماً فعالش کنید .



سلام
برای تیک زدن رفرنس یاد شده پیغام زیر ظاهر می شود

https://barnamenevis.org/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAQAAAACiCAYAAAC u0RM3AAAUDUlEQVR4Ae1dWXLcOBLlz8TMMfoO/pKOogPUGebPR5BuML5A/yqiI ZH0YvtsN1eZdkub/K 70t3x8zkxAOYZBIFskgWiyJZTxEIsgggkXiZ ZAAS1Ly119/yZ9//il//PGHfP/ 3ZVv377Jly9f5PPnz/Lp0yf58OGDK /fv5d3797J27dvXXnz5o2gvH79moUY0AdO0AdevXq1gL/Gp8Yr4hex/PHjR1cQ34kNfgT 169fXeCjERqjEwRooGOgly9fyosXL T58 fy7NkzV54 fSosxIA MAwf0LhEjCJWEbNYqBHHWMQR14jxRFd u oj8BH06ICAhwAIhHGfPHkijx8/lkePHsnx8bE8fPjQlQcPHggLMaAPDMMHNC4Ro4hVxC3iF4QAMl AiyAhAV34EPyrRCB0Q7BACw96/f1/u3bsnd /elfl8Lnfu3JHbt2 7cuvWLWEhBvSB/n3g6OhItCj GpeIUcQqYhbxC2JATIMIsMAn2Pfr6o UACs/gn82m7EQA/rARH0AWQFIILH7fuwLkPJj5QcB8IcIEIHpIYDYRiaPTCBB6o8T f5z243AAqz/YgQQwPcNzRkQACCC2sTXA1t4RAF4H6N4faQH2CSQAOgsRmCYCi G2cGeBMINHVH k/DgWQ/qOCBDBN43NWRACxfePGDXcwmGD1x Gfpv94XYD9AQmAjkIEpokAYvvatWtuG5Bg76 n/3jfj4MBvDIgAUzT JwVEUBsX7lyxb22dwRg9/84GMABAQmAjkIEpokAYvvy5cty8 ZNSbD66/4f3/bDASC REACmKbxOSsigNi dOmSHB4eegLA/l/f/ Mbf/g2EQmAjkIEpokAYvvixYty/fp1SZD KwHgABBvAPCKgAQwTeNzVuNDIEkSF7BlmiOY0abuD2L7woUL7i DQEYB /RcHgHgDgL1BPQLYl1mSSDLbj44939uWJNmWvbmIzPdkW jrXt4uD9zQCXbewKVyn72Z4lsO6VNC/TFPNcyD CY4mSGFEnxBcZpKYG60GvhQxuda2K1MFbJA2Ba5iclXSoeG7za zK1McpeyysZo8RwB/re//yNKAlV1ZUMhts fPy9Xr16VBPv/kACwN6hPANuyvV3lvLG6MtXW dwHUx5AxonCYTXYzXM4cN7XVHRyW6ZL8Nw56EzidNuJIqmQEKs VZUPv7ZnMon7SRnaASxsRrk9XclorULtjLNBjz oIRGyfO3fOvQlwBIDf/tNXgMgAmhLAbLZdsmLOSla2Omp23SY0dvjZjLcQaGi7zsAr0yV 8Hn42Ond62 04yASRUel1dVW70q8rOavPqI4EG/D2vk5f2wYEcPbsWfcmoBMC2JsDSBsgc9lzbG8BtvdQB23C1Na3 AaEkKs8FY9iurL9uNcL2kJs/297bK3xeTE29btmKX8gI7DzK55DvIGx7EZcKqy75ACVEWewrBT 3KZNXRKdZGXSTEKt0sldrB61iwmYpyV4xltoGF7Vc6v31sD719 8q1XjTqnWtou29PF57aIO/rlPuF9IJC1ZM57e mWMrFbxvj4BUhW KCBX7YlqCN6DQTgnTHzZwDnDG0BtfcepNzYqrY3Sv7cfy7I1b1 yEAxeQkV7t5 22xGrj46fX 1qVUz/Tb9SHeqMY Qs6KZ6 Pno/j8jRa3OrkbWUp3KsM EiT97COdgtkAuMLTe65jbzMpJCTkLeoyt/dAunZ/WR Rm5zULdSrHzD1dVEp1carZ9vZe9bFyq ecLRzAXBesKP4BJit8HCwBuMOx1JB5wFiAzb0zps0YFBHTBo8i 7TLZrs4y75L2C0EWjKUq6BXy3XxiTps6SUyHZeM4Z9GVxzqb3q sCuAY6uvFMu5isZTq5 hj2y8Yt9snsEOpoxTiTFLeH7mA4Y/RgfphxdtZSt860q5pbDKsF3atllesW9gv8MsCk7UcNflztfVN5 a8kAfEq/LXtI55TRCwCHIBUdyk/CtMGDiEFzI/gezqGSlKkr2weyC7rFIEwDvzAftAvlQE1sWXS1COvN54J llhMm4Iq4XP0ic3VyorgYnUu6FAYzHwIxo30ye0QtDVSshXept ruXm0f9jXzszo7mWV1RkZET98VWwwd02Jl rqG5nNEVvmcTb90/kWfSB ucIkFfOxZnSHWRACOvl0g5CmYBcbee2Pm7VRt2wbP8FkDK04Ia AWwvayq9jHZZjVVFcxVjVjUM5TjO Q6WEdVTNJxsAopOToH0/HjMhfIxvYplZVPINfJyi/DPu 3MG6lHaxsKyOdu843q7L4oK9ZLQtBt6wuhl3J3EqxCnW3n/34WbKyoJuOj4nZftlEjV/mz9rcVQV6VV3ZWOsjALcHU6bF8BYYe691mgprkIdtNOi1nQG9k NKZMZ2hIu0LunhowOhuf51ZOYDMBlxWZXQs08E x5 U0nMLe/BZeC1mZGbj4AbPdS64mvmXybJjZ6teKL8od3H6YfsKO0Rw1SkA 3yJ5 hpHrG5QP44/QPTzzHVZXucPWkNd8TnHzMvzxOBsXcDdHKQafbID3Nq ZHSI4q ItLtCbwR62Q/q0KbuT4cEUHdItiMCMQRM4CxUV9UtNOaDBgiQABqAxabrRKAqy Kvq1qnT9GWTAKZv45HMsCrIq pGMr2BqkkCGKhhqBYR6AMBEkAfKHMMIjBQBEgAAzUM1SICfSBA AugDZY5BBAaKAAlgoIahWkSgDwRIAH2gzDGIwEARIAEM1DBUiw j0gQAJoA UOQYRGCgCJICBGoZqEYE ECAB9IEyxyACA0WABDBQw1AtItAHAiSAPlDmGERgoAiQAAZqGK pFBPpAgATQB8ocgwgMFAESwEANQ7WIQB8IkAD6QJljEIGBIkAC GKhhqBYR6AMBEkAfKHMMIjBQBEgAAzUM1SICfSBAAugDZY5BBA aKAAlgoIahWkSgDwRIAH2gzDGIwEARIAEM1DBUiwj0gQAJoA UOQYRGCgCJICBGoZqEYE ECAB9IEyxyACA0WABDBQw1AtItAHAiSAPlDmGERgoAiQAAZqGK pFBPpAgATQB8ocgwgMFAESwEANQ7WIQB8IjJcAnvxLBIU/RIAItEZgvARw8IMICn IABFojcA4CQAr/78TX5gFtDY OxKBcRLAwQ/yv0uJK8wC6MREoD0C4yOAdPX/z4NEUFwmwCygvQew50YjMD4CSFf//xwngoJMgFnARvswJ78CAuMiALv6pwTALGAF67PrxiMwLgIIVn9 mARvvvwRgRQTGQwCx1Z9ZwIrmZ/dNR2A8BFCy jML2HQX5vxXQWAcBFC1 jMLWMX 7LvhCIyDAJas/swCNtyLOf3WCAyfAEpW/yRJBEWD3135vYDWjsCOm4nA8AmgZPWPEsBavhewL7OUbHTM2f4 6nQXjzaTZEOizJbvzrvSy8troU6UH5HnyVjyTAqB2bJUTe6Z1v K6CwLAJoGT1x2qvzlPIAHAe0HkWMAbn61rHruVZFw1lz2V3K5G cBMJ69I09szJ53xaBYRNAyepfSQCdZwFlzuefz2Zbkmztyjx10 vyzOq6SlV2hw77WfHa89H53lhHeVnSZt32qxk2DLV2Bi7IgI9V 1NjMZhZW9TJ9cxtburpFRNj99HhmjkM3Yeu3DaxcIDJcAKlb/ZQTQbRaQO7XPOjQ998/zIAo/i zPEsnq92cpUcBsi21zY6JOycK3y1ZHyIhuD2yfqnHzUbwOOpdI n4IO9fSx853vbkmSyQjHVXn63BOT3wkU5 JbxJ5pX15XQWC4BFCx i8lgE6zgDLnC583 Ry2tSa0dfYebcLP2s8 t/eRPo5Ewqykqo ts/eh7Ko61TPso89JAIpE39dhEsCS1b8OAXSXBYSOrSYKnzf5HLZV mbjaOnsf1rXos5CF6EpcNY6ts/ehPlV1Zbqmz e7spVlNqGccBwri/erIjBMAliy tcigM6ygJhDxpxysZ1NiaU0 EITWjn2Pjam9i22Kx0XOuiJu8sElAD8ClzYrmTpu5Vt70N9qmS onmEf/Wy2SgUC1H7huPqc11URGB4B1Fj96xJAN1kAnE9TZn/1gRI6ZfgZprF9Ndj0uf1szWjl2PuqfrF2qrMdx hTOOgTEbcKp30KdVa2vY/oUyojnJ/q5q/KSb6V0RG4u8rYMyuT920RGB4B1Fj9axNAZ1lAW3g3t587BHRvR zYXgzHMfFgEUHP1b0IA3WQBYzDlyevoT/51dbeZx8nrRg3iCAyLAGqu/o0IgFlA3PJ8SgREZDgE0GD1BwE0Kp1/O5C QwSmgcBwCKDB6t8o FOy4N8OnIbDchbdIjAMAmix pf LkBZdsAsoFvPobRJIDAMAmix jcmAJ4FTMJhOYluETh5Amix rfZArg zAK69R5KGz0CJ08ALVb/1gTALGD0DssJdIvAyRIAVv fEvnvYSL/PeqpHCZuTP5n4W4didLGicDJEgD u 9PaUD2feV/Fh6nx1LrThE4WQLodCoURgSIQFMESABNEWN7IjAhBEgAEzImp0 IEmiJAAmiKGNsTgQkhQAKYkDE5FSLQFAESQFPE2J4ITAgBEsCE jMmpEIGmCJAAmiLG9kRgQgiQACZkTE6FCDRFgATQFDG2JwITQo AEMCFjcipEoCkCJICmiLE9EZgQAiSACRmTUyECTREgATRFjO2J wIQQIAFMyJicChFoigAJoClibE8EJoQACWBCxuRUiEBTBEgATR FjeyIwIQRIABMyJqdCBJoiQAJoihjbE4EJIUACmJAxORUi0BQB EkBTxNieCEwIARLAhIzJqRCBpgjUJoAPHz4ICzGgD0zLB0gAJD YS wb7AAlgg43P1Xxaq3kbe5IASADMADbYB0gAG2z8NisG 0wrayABkACYAWywD5AANtj4XM2ntZq3sScJgATADGCDfYAEsMH Gb7NisM 0sgYSAAmAGcAG wAJYIONz9V8Wqt5G3uSANZAAMk/j4SlGoM6zvrjjz8KSzUGdXCsakMCIAGcCFlVOaXWIfiPj49ZSj AAPopV2ysJYI0EQOddDF7NjOo4LAlgET/rUySANQRvHcdc1kad3BqL996ZFZtlGKKeBEACWDnFqeNoXbdRJ 2fQLzqwYlMHcxLAIn7Wp5gBMAMY3f6YBFAd1DbAl92TAEgAJIC SA7JlwTOFehIACWCRAM7sSJIkWTl1 sC0OSM7ySk5feBXoTM7iSQ7Z0x9d6tTWYANKwMo4uF1jj0Lcan TJuzT/WcSAAmgELwHp09JkuzImWxVPJDTp2yQG8cFUfQc/AgwEkB3REACIAEYAkCw56t7tgIfnJZTGSkoAeBqiaI7p8zGzUi oKHt8BACs0owqI0zFEXNL70/nmdfOmeKcl2HStp4EQALICaAQ6NYBfRbgndI766kYUZQEbFvnL Os3PALIt0v51iknUmyTPHaWYEMCMFmW24L1Q64kABJATQJQh4b jeocvng1Ywljv/fAIQLHReUeCWzOARMkgbGNl2DqVuZ4rCYAEkBOApqLpAV 2AhcyA3VOva7HMbOxI1nF AjABrfiZfGz96gPP2uf7q8kABKAIYBjKTsEzFd745xIVU dloNIkFYF8Kp14yIAv33K8dMgNji6gE9E2zgb9IQrCYAEUCAAB KcngXxfq47pA9c67rG414A9OasSx7gI4FiOXQaleOre3uLo73d 28AYG7WIZgxJHt1cSAAlggQA00IZ6HRYBdBGQlgy6kFdfBgmAB EAC6HkLs0isJIBR/sJOnV9GadtGV7lFZ6nP7lPtq9jUwRYr3FRx6GJezACYAYwuQEg A3S0CvRDAjRs3BH81pA5js43/G3Pq5LyW/1mwOr7CDKCaLNZOAHfv3hUSQPM/HMnALw98xaYuAcDJWcoxqINjVRss7r/99pv8/vvvkrx7907evHkjL168kMePHwsJoHnwV4HNOuI5NB8oEMD79 9JAAM9Vxia41CfaZBZJQHcu3ePWwASAs9/JuwDIICzZ8/K5cuXJQkzABDA4eEhDwEn7ABcyaexkre14wIBvH37Vl6 fOnOAEgAm 0cbZ2K/cbjNyCAc fOyZUrVySB4UICuHnzJjMAZgDcBkzUB0AA58 fl6tXr3oCwJuAV69eyZMnT T /ftydHREApio8blSj2elXpetQAAXLlyQa9euSfLx40dRAnj69Kk 8fPhQbt26RQIgATADmKgPgAAuXrwo169f9wSgB4HPnz93XzO9c cOCWCixl/XqkK548ksQAD4EhC2 smnT58c0 McwH4ZCI1o1PEYlbairer6AGIb 39k o4A7Dbg2bNnbhuARizEgD4wTR/Aq35k hkBYBvw vVrwTYAXwnGYeDt27ddmoC9Al4ZIG3A3gEHCDhFxKsEfKf4119/lV9 UV /vlnFmJAHzhhH0AsIiYRm4hRxCpi9tKlSy6O8bs iG288k8 f/4syACQPmAbgLcBSgIPHjxwvxsApsCbAbAGOuP0EISAbxJBKIoS AwZiIQb0gZPzAcSixiViFLGKmEX8Io4Rzwh /H2C5MuXL4JzAJAAsgBLAngt OjRIwERoMN8PnedsXfAAQIEIjtAwQDYV7AQA/rAyfoAYlHjEjGKWEXMIn7xy37I7hH8iO/k69evgixADwP1jQAyARwK4kwAWwIQAV4RorMlA6QSEA5mYSEG9 IH fQABrkXxR0wiNrHaI/ARs1jIEcOIZQQ/Mv3k27dvEiMBZAI4E8BXhNEQRIBOIAOwBwRBoBICmAUDsRAD sDJ gBiEQGP2NSgR8widhHDiGXENGI7 f79u4AEsBUIMwGQAP5WgGYDIRGASZQMlBAwIAsxoA cnA8gFlEQm4jRMPCR2SOmEdv/B1ssNS0EiVzhAAAAAElFTkSuQmCC




https://barnamenevis.org/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAQAAAACiCAYAAAC u0RM3AAAUDUlEQVR4Ae1dWXLcOBLlz8TMMfoO/pKOogPUGebPR5BuML5A/yqiI ZH0YvtsN1eZdkub/K 70t3x8zkxAOYZBIFskgWiyJZTxEIsgggkXiZ ZAAS1Ly119/yZ9//il//PGHfP/ 3ZVv377Jly9f5PPnz/Lp0yf58OGDK /fv5d3797J27dvXXnz5o2gvH79moUY0AdO0AdevXq1gL/Gp8Yr4hex/PHjR1cQ34kNfgT 169fXeCjERqjEwRooGOgly9fyosXL T58 fy7NkzV54 fSosxIA MAwf0LhEjCJWEbNYqBHHWMQR14jxRFd u oj8BH06ICAhwAIhHGfPHkijx8/lkePHsnx8bE8fPjQlQcPHggLMaAPDMMHNC4Ro4hVxC3iF4QAMl AiyAhAV34EPyrRCB0Q7BACw96/f1/u3bsnd /elfl8Lnfu3JHbt2 7cuvWLWEhBvSB/n3g6OhItCj GpeIUcQqYhbxC2JATIMIsMAn2Pfr6o UACs/gn82m7EQA/rARH0AWQFIILH7fuwLkPJj5QcB8IcIEIHpIYDYRiaPTCBB6o8T f5z243AAqz/YgQQwPcNzRkQACCC2sTXA1t4RAF4H6N4faQH2CSQAOgsRmCYCi G2cGeBMINHVH k/DgWQ/qOCBDBN43NWRACxfePGDXcwmGD1x Gfpv94XYD9AQmAjkIEpokAYvvatWtuG5Bg76 n/3jfj4MBvDIgAUzT JwVEUBsX7lyxb22dwRg9/84GMABAQmAjkIEpokAYvvy5cty8 ZNSbD66/4f3/bDASC REACmKbxOSsigNi dOmSHB4eegLA/l/f/ Mbf/g2EQmAjkIEpokAYvvixYty/fp1SZD KwHgABBvAPCKgAQwTeNzVuNDIEkSF7BlmiOY0abuD2L7woUL7i DQEYB /RcHgHgDgL1BPQLYl1mSSDLbj44939uWJNmWvbmIzPdkWjrXt4u D9zQCXbewKVyn72Z4lsO6VNC/TFPNcyD CY4mSGFEnxBcZpKYG60GvhQxuda2K1MFbJA2Ba5iclXSoeG7za zK1McpeyysZo8RwB/re//yNKAlV1ZUMhts fPy9Xr16VBPv/kACwN6hPANuyvV3lvLG6MtXW dwHUx5AxonCYTXYzXM4cN7XVHRyW6ZL8Nw56EzidNuJIqmQEKs VZUPv7ZnMon7SRnaASxsRrk9XclorULtjLNBjz oIRGyfO3fOvQlwBIDf/tNXgMgAmhLAbLZdsmLOSla2Omp23SY0dvjZjLcQaGi7zsAr0yV 8Hn42Ond62 04yASRUel1dVW70q8rOavPqI4EG/D2vk5f2wYEcPbsWfcmoBMC2JsDSBsgc9lzbG8BtvdQB23C1Na3 AaEkKs8FY9iurL9uNcL2kJs/297bK3xeTE29btmKX8gI7DzK55DvIGx7EZcKqy75ACVEWewrBT 3KZNXRKdZGXSTEKt0sldrB61iwmYpyV4xltoGF7Vc6v31sD719 8q1XjTqnWtou29PF57aIO/rlPuF9IJC1ZM57e mWMrFbxvj4BUhW KCBX7YlqCN6DQTgnTHzZwDnDG0BtfcepNzYqrY3Sv7cfy7I1b1 yEAxeQkV7t5 22xGrj46fX 1qVUz/Tb9SHeqMY Qs6KZ6 Pno/j8jRa3OrkbWUp3KsM EiT97COdgtkAuMLTe65jbzMpJCTkLeoyt/dAunZ/WR Rm5zULdSrHzD1dVEp1carZ9vZe9bFyq ecLRzAXBesKP4BJit8HCwBuMOx1JB5wFiAzb0zps0YFBHTBo8i 7TLZrs4y75L2C0EWjKUq6BXy3XxiTps6SUyHZeM4Z9GVxzqb3q sCuAY6uvFMu5isZTq5 hj2y8Yt9snsEOpoxTiTFLeH7mA4Y/RgfphxdtZSt860q5pbDKsF3atllesW9gv8MsCk7UcNflztfVN5 a8kAfEq/LXtI55TRCwCHIBUdyk/CtMGDiEFzI/gezqGSlKkr2weyC7rFIEwDvzAftAvlQE1sWXS1COvN54J llhMm4Iq4XP0ic3VyorgYnUu6FAYzHwIxo30ye0QtDVSshXept ruXm0f9jXzszo7mWV1RkZET98VWwwd02Jl rqG5nNEVvmcTb90/kWfSB ucIkFfOxZnSHWRACOvl0g5CmYBcbee2Pm7VRt2wbP8FkDK04Ia AWwvayq9jHZZjVVFcxVjVjUM5TjO Q6WEdVTNJxsAopOToH0/HjMhfIxvYplZVPINfJyi/DPu 3MG6lHaxsKyOdu843q7L4oK9ZLQtBt6wuhl3J3EqxCnW3n/34WbKyoJuOj4nZftlEjV/mz9rcVQV6VV3ZWOsjALcHU6bF8BYYe691mgprkIdtNOi1nQG9k NKZMZ2hIu0LunhowOhuf51ZOYDMBlxWZXQs08E x5 U0nMLe/BZeC1mZGbj4AbPdS64mvmXybJjZ6teKL8od3H6YfsKO0Rw1SkA 3yJ5 hpHrG5QP44/QPTzzHVZXucPWkNd8TnHzMvzxOBsXcDdHKQafbID3Nq ZHSI4q ItLtCbwR62Q/q0KbuT4cEUHdItiMCMQRM4CxUV9UtNOaDBgiQABqAxabrRKAqy Kvq1qnT9GWTAKZv45HMsCrIq pGMr2BqkkCGKhhqBYR6AMBEkAfKHMMIjBQBEgAAzUM1SICfSBA AugDZY5BBAaKAAlgoIahWkSgDwRIAH2gzDGIwEARIAEM1DBUiw j0gQAJoA UOQYRGCgCJICBGoZqEYE ECAB9IEyxyACA0WABDBQw1AtItAHAiSAPlDmGERgoAiQAAZqGK pFBPpAgATQB8ocgwgMFAESwEANQ7WIQB8IkAD6QJljEIGBIkAC GKhhqBYR6AMBEkAfKHMMIjBQBEgAAzUM1SICfSBAAugDZY5BBA aKAAlgoIahWkSgDwRIAH2gzDGIwEARIAEM1DBUiwj0gQAJoA UOQYRGCgCJICBGoZqEYE ECAB9IEyxyACA0WABDBQw1AtItAHAiSAPlDmGERgoAiQAAZqGK pFBPpAgATQB8ocgwgMFAESwEANQ7WIQB8IjJcAnvxLBIU/RIAItEZgvARw8IMICn IABFojcA4CQAr/78TX5gFtDY OxKBcRLAwQ/yv0uJK8wC6MREoD0C4yOAdPX/z4NEUFwmwCygvQew50YjMD4CSFf//xwngoJMgFnARvswJ78CAuMiALv6pwTALGAF67PrxiMwLgIIVn9 mARvvvwRgRQTGQwCx1Z9ZwIrmZ/dNR2A8BFCy jML2HQX5vxXQWAcBFC1 jMLWMX 7LvhCIyDAJas/swCNtyLOf3WCAyfAEpW/yRJBEWD3135vYDWjsCOm4nA8AmgZPWPEsBavhewL7OUbHTM2f4 6nQXjzaTZEOizJbvzrvSy8troU6UH5HnyVjyTAqB2bJUTe6Z1v K6CwLAJoGT1x2qvzlPIAHAe0HkWMAbn61rHruVZFw1lz2V3K5G cBMJ69I09szJ53xaBYRNAyepfSQCdZwFlzuefz2Zbkmztyjx10 vyzOq6SlV2hw77WfHa89H53lhHeVnSZt32qxk2DLV2Bi7IgI9V 1NjMZhZW9TJ9cxtburpFRNj99HhmjkM3Yeu3DaxcIDJcAKlb/ZQTQbRaQO7XPOjQ998/zIAo/i zPEsnq92cpUcBsi21zY6JOycK3y1ZHyIhuD2yfqnHzUbwOOpdI n4IO9fSx853vbkmSyQjHVXn63BOT3wkU5 JbxJ5pX15XQWC4BFCx i8lgE6zgDLnC583 Ry2tSa0dfYebcLP2s8 t/eRPo5Ewqykqo ts/eh7Ko61TPso89JAIpE39dhEsCS1b8OAXSXBYSOrSYKnzf5HLZV mbjaOnsf1rXos5CF6EpcNY6ts/ehPlV1Zbqmz e7spVlNqGccBwri/erIjBMAliy tcigM6ygJhDxpxysZ1NiaU0 EITWjn2Pjam9i22Kx0XOuiJu8sElAD8ClzYrmTpu5Vt70N9qmS onmEf/Wy2SgUC1H7huPqc11URGB4B1Fj96xJAN1kAnE9TZn/1gRI6ZfgZprF9Ndj0uf1szWjl2PuqfrF2qrMdx hTOOgTEbcKp30KdVa2vY/oUyojnJ/q5q/KSb6V0RG4u8rYMyuT920RGB4B1Fj9axNAZ1lAW3g3t587BHRvR zYXgzHMfFgEUHP1b0IA3WQBYzDlyevoT/51dbeZx8nrRg3iCAyLAGqu/o0IgFlA3PJ8SgREZDgE0GD1BwE0Kp1/O5C QwSmgcBwCKDB6t8o FOy4N8OnIbDchbdIjAMAmix pf LkBZdsAsoFvPobRJIDAMAmix jcmAJ4FTMJhOYluETh5Amix rfZArg zAK69R5KGz0CJ08ALVb/1gTALGD0DssJdIvAyRIAVv fEvnvYSL/PeqpHCZuTP5n4W4didLGicDJEgD u 9PaUD2feV/Fh6nx1LrThE4WQLodCoURgSIQFMESABNEWN7IjAhBEgAEzImp0 IEmiJAAmiKGNsTgQkhQAKYkDE5FSLQFAESQFPE2J4ITAgBEsCE jMmpEIGmCJAAmiLG9kRgQgiQACZkTE6FCDRFgATQFDG2JwITQo AEMCFjcipEoCkCJICmiLE9EZgQAiSACRmTUyECTREgATRFjO2J wIQQIAFMyJicChFoigAJoClibE8EJoQACWBCxuRUiEBTBEgATR FjeyIwIQRIABMyJqdCBJoiQAJoihjbE4EJIUACmJAxORUi0BQB EkBTxNieCEwIARLAhIzJqRCBpgjUJoAPHz4ICzGgD0zLB0gAJD YS wb7AAlgg43P1Xxaq3kbe5IASADMADbYB0gAG2z8NisG 0wrayABkACYAWywD5AANtj4XM2ntZq3sScJgATADGCDfYAEsMH Gb7NisM 0sgYSAAmAGcAG wAJYIONz9V8Wqt5G3uSANZAAMk/j4SlGoM6zvrjjz8KSzUGdXCsakMCIAGcCFlVOaXWIfiPj49ZSj AAPopV2ysJYI0EQOddDF7NjOo4LAlgET/rUySANQRvHcdc1kad3BqL996ZFZtlGKKeBEACWDnFqeNoXbdRJ 2fQLzqwYlMHcxLAIn7Wp5gBMAMY3f6YBFAd1DbAl92TAEgAJIC SA7JlwTOFehIACWCRAM7sSJIkWTl1 sC0OSM7ySk5feBXoTM7iSQ7Z0x9d6tTWYANKwMo4uF1jj0Lcan TJuzT/WcSAAmgELwHp09JkuzImWxVPJDTp2yQG8cFUfQc/AgwEkB3REACIAEYAkCw56t7tgIfnJZTGSkoAeBqiaI7p8zGzUi oKHt8BACs0owqI0zFEXNL70/nmdfOmeKcl2HStp4EQALICaAQ6NYBfRbgndI766kYUZQEbFvnL Os3PALIt0v51iknUmyTPHaWYEMCMFmW24L1Q64kABJATQJQh4b jeocvng1Ywljv/fAIQLHReUeCWzOARMkgbGNl2DqVuZ4rCYAEkBOApqLpAV 2AhcyA3VOva7HMbOxI1nF AjABrfiZfGz96gPP2uf7q8kABKAIYBjKTsEzFd745xIVU dloNIkFYF8Kp14yIAv33K8dMgNji6gE9E2zgb9IQrCYAEUCAAB KcngXxfq47pA9c67rG414A9OasSx7gI4FiOXQaleOre3uLo73d 28AYG7WIZgxJHt1cSAAlggQA00IZ6HRYBdBGQlgy6kFdfBgmAB EAC6HkLs0isJIBR/sJOnV9GadtGV7lFZ6nP7lPtq9jUwRYr3FRx6GJezACYAYwuQEg A3S0CvRDAjRs3BH81pA5js43/G3Pq5LyW/1mwOr7CDKCaLNZOAHfv3hUSQPM/HMnALw98xaYuAcDJWcoxqINjVRss7r/99pv8/vvvkrx7907evHkjL168kMePHwsJoHnwV4HNOuI5NB8oEMD79 9JAAM9Vxia41CfaZBZJQHcu3ePWwASAs9/JuwDIICzZ8/K5cuXJQkzABDA4eEhDwEn7ABcyaexkre14wIBvH37Vl6 fOnOAEgAm 0cbZ2K/cbjNyCAc fOyZUrVySB4UICuHnzJjMAZgDcBkzUB0AA58 fl6tXr3oCwJuAV69eyZMnT T /ftydHREApio8blSj2elXpetQAAXLlyQa9euSfLx40dRAnj69Kk 8fPhQbt26RQIgATADmKgPgAAuXrwo169f9wSgB4HPnz93XzO9c cOCWCixl/XqkK548ksQAD4EhC2 smnT58c0 McwH4ZCI1o1PEYlbairer6AGIb 39k o4A7Dbg2bNnbhuARizEgD4wTR/Aq35k hkBYBvw vVrwTYAXwnGYeDt27ddmoC9Al4ZIG3A3gEHCDhFxKsEfKf4119/lV9UV /vlnFmJAHzhhH0AsIiYRm4hRxCpi9tKlSy6O8bs iG288k8 f/4syACQPmAbgLcBSgIPHjxwvxsApsCbAbAGOuP0EISAbxJBKIoS AwZiIQb0gZPzAcSixiViFLGKmEX8Io4Rzwh /H2C5MuXL4JzAJAAsgBLAngt OjRIwERoMN8PnedsXfAAQIEIjtAwQDYV7AQA/rAyfoAYlHjEjGKWEXMIn7xy37I7hH8iO/k69evgixADwP1jQAyARwK4kwAWwIQAV4RorMlA6QSEA5mYSEG9 IH fQABrkXxR0wiNrHaI/ARs1jIEcOIZQQ/Mv3k27dvEiMBZAI4E8BXhNEQRIBOIAOwBwRBoBICmAUDsRAD sDJ gBiEQGP2NSgR8widhHDiGXENGI7 f79u4AEsBUIMwGQAP5WgGYDIRGASZQMlBAwIAsxoA cnA8gFlEQm4jRMPCR2SOmEdv/B1ssNS0EiVzhAAAAAElFTkSuQmCC

[Mordore111]

155068 سلام لطفا راهنمایی فرمائید

[Mordore111]

با سلام : در تصویر بالا می خواهم هر وقت frmsearch را اجرا می کنم در قسمت جستجوی آن مقدار عددی داخل Tbl_search و رکورد shenase قرار بگیرد.

[moustafa]

تابعی که مقدار یک کلید دیکشنری در قالب استرینگ رو بر میگردون

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

[Mehr@ban]

سلام کسی میتونه اینو انجام بده
سلام
یک نمونه برنامه انبارداری از آقای عطا امینی کابر همین سایت رو دراینجا گذاشتم با اجازه آقای امینی چندتا سوال داشتم اگه از عزیزان کسی میتونه تغییراتو روش انجام بده . رمز برای کاربر عطا امینـﮮ ™ : 7086
دوستانی که از 2007 و بالاتر استفاده می کنند منوهای برنامه در Add-Ins قابل دستیابی می باشد. بازدن کلید f11
1- در تب انبارداری-تعریف کالا دو فیلد (تکست باکس) دیگر اضافه شود یکی عمرانباری(مدت زمان نگهداری در انبار) و دیگری عمر خدمتی(مدت زمانی که یک جنس می تواند کار کند) که این دو فیلد وقتی کالای جدید تعریف می شود توسط کاربر وارد شود.به ماه باشد مثلا عمر انباری یک پیچ 120 ماه و عمر خدمتیش 80 ماه
2- در تب تولید/ورود کالا یک تکس باکس اضافه شود که تاریخ تولید کالا را بتوان وارد کرد (تاریخی که روی جنس نوشته میشود توسط کارخانه)
3- در تب گزارشات یه لیست تنظیم شود که تاریخ انقضا کالا را نشون دهد بدین صورت که تاریخ تولید را به عمر انباری اضافه کند و به صورت شمسی تاریخ انقضا را نشان بدهد.
4- اگر در تب ورود کالا یک جنس به تعداد ده عدد خواستیم وارد کنیم به طوری که این ده جنس ده سریال مختلف دارن اگر بخواهیم ده سریال را وارد کنیم چگونه وارد کنیم باید یک فیلد ساخته شود؟بعد ده تا را چگونه وارد کنیم.
عزیزان هرکسی میتونه تغییراتو انجام بده اصلاح شده رو بزاره تو سایت واسه استفاده همه ، خودم زیاد وارد نیستم لطفا خودتون کاملش کنید
با تشکر از تمامی دوستان
لینک دانلود برنامه اینجا گذاشتم
https://barnamenevis.org/attachment.php?attachmentid=127548&d=1421185291
https://barnamenevis.org/attachment.php?attachmentid=127549&d=1421185303

سلام دوستان

من تاپیک مربوط به این برنامه رو پیدا نکردم
دوستان میتونن کمک کنند؟