صفحه 1 از 5 123 ... آخرآخر
نمایش نتایج 1 تا 40 از 168

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

  1. #1
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

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

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

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



    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
    آخرین ویرایش به وسیله مهدی قربانی : چهارشنبه 18 اسفند 1389 در 14:29 عصر

  2. #2
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    شمارشگر رکوردها Navigation Records

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

  3. #3
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    پرسش از کاربر جهت ذخیره اطلاعات

    با کد زیر میشه براحتی امکان تائید اطلاعات ثبت شده در یک رکورد رو ایجاد و در صورتیکه کاربر اقدام به تائید کنه مکان نما به رکورد بعدی منتقل میشه در غیر اینصورت رکورد جاری عملاً 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

  4. #4
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    Ucase ، ورود حروف لاتین بزرگ

    با این تابع می تونید در زمان ورود حروف لاتین در فیلدها و یا 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
    البته بیشتر استفاده از روش و نمونه دوم رو توصیه می کنم .

    نمونه مرتبط :

    فایل های ضمیمه فایل های ضمیمه

  5. #5
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    کاهش یا افزایش تاریخ با استفاده از کلیدهای - و +

    با تکه کد زیر استفاده از کلیدهای - و + برای کاهش یا افزایش تاریخ در یک فیلد 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
    آخرین ویرایش به وسیله مهدی قربانی : چهارشنبه 18 اسفند 1389 در 14:30 عصر

  6. #6
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    ایجاد گزارش تصویری :
    Docmd.OutputTo acReport, "reportname", "SnapshotFormat(*.snp)", "", False, "", 0

    با کد فوق کامند دیالوگ باکس ظاهر میشه حتما نام فایل را با پسوند snp ذخیره نمائید

  7. #7
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    کنترل یک فایل اکسس از داخل یه فایل اکسس دیگه
    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")

  8. #8
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    جلوگیری از ورود مقادیر عددی در یک فیلد با جنس Text

    کد زیر رو داخل یک 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

  9. #9
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    مقاله بهبود دهنده شی Accessبا کدهای vba
    http://www.sayan.ir/ViewArticle.aspx?ArticleID=147

  10. #10
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    ده نکته‌ای که در کار با مقادیر تهی در اکسس باید مد نظر قرار داد:
    http://www.sayan.ir/ViewArticle.aspx?ArticleID=170

  11. #11
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    :To remove the Minimize, Maximize, and Restore button from a Report's preview window
    http://www.everythingaccess.com/tuto...Preview-Window

  12. #12
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    مجموعه ها در اکسس


  13. #13
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    Allow Bypass Key

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

    Public Function SetAllowBypassKeyFalse()

    '----- کنترل خطا
    On Error GoTo Err_SetAllowBypassKeyFalse


    Dim db As DAO.Database, prp As DAO.Property

    '----- در صورت موجود بودن Property ست کردن
    Set db = CurrentDb

    db.Properties("AllowBypassKey") = False

    Set db = Nothing


    Exit_SetAllowBypassKeyFalse:

    Exit Function

    '----- کنترل خطا
    Err_SetAllowBypassKeyFalse:

    '----- خطا در صورت موجود نبودن Property
    '----- اگر قبلاً ساخته نشده Property ساخت
    If Err = 3270 Then

    Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, False)
    db.Properties.Append prp

    Resume Next

    Else

    '----- در صورت بروز خطاهای غیر منتظره
    MsgBox "SetAllowBypassKeyFalse", Err.Number, Err.Description

    Resume Exit_SetAllowBypassKeyFalse

    End If

    End Function


  14. #14
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    Hide/Unhide Navigation Pane with code

    نمایش / عدم نمایش 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

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

  16. #16
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    پاک کردن اطلاعات موجود در جداول

    با نمونه کد های زیر می تونید اطلاعات موجود در جداول رو پاک کنید
    بجای [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


    نمونه مرتبط :
    فایل های ضمیمه فایل های ضمیمه

  17. #17
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    نقل قول نوشته شده توسط navi2002 مشاهده تاپیک

    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 نام جدول و فیلد مربوطه رو بنویسی

  18. #18
    کاربر تازه وارد آواتار سعید مشکین فر
    تاریخ عضویت
    خرداد 1384
    محل زندگی
    موطن آدمی در قلب کسانی است که دوستش میدارند
    پست
    42

    ساخت Navigation Buttons توسط کدهای VBA در فرم

    'ابتدا
    'کلیدهای اولین رکورد ،آخرین رکورد،رکورد قبل،رکورد بعد،رکورد و رکورد جدید را
    'روی فرم خودتان طراحی کنید
    'کدها را در رویداد کلیک هر دکمه فرمان کپی کنید
    '************************************************* **********
    '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

  19. #19
    کاربر دائمی
    تاریخ عضویت
    آذر 1384
    محل زندگی
    هر کجا هستم باشم آسمان مال من است پنجره -فکر- هوا- عشق- زمین مال من است.
    پست
    819
    با 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

  20. #20
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    محاسبه مجموع زمان ( ساعات کارکرد )

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


    نمونه مرتبط :
    فایل های ضمیمه فایل های ضمیمه

  21. #21
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    استفاده از رخداد Mouse Wheel

    با این کد در زمان استفاده از 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

  22. #22
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    Hide کردن سابفرم در صورتیکه تعداد رکورد آن صفر باشد

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

  23. #23
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

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

    با استفاده از این تابع 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)

  24. #24
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    تعیین مقدار Zoom گزارش در زمان باز شدن

    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)


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

  25. #25
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    تغییر Data Type فیلدهای جدول با استفاده از کدهای VBA

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

    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.

  26. #26
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    استفاده از رخداد Not In List کامبوباکس جهت اضافه کردن اطلاعات جدید

    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

  27. #27
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    حذف کلیه Relationship های موجود در دیتابیس

    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

  28. #28
    کاربر دائمی آواتار HAMRAHSOFT.IR
    تاریخ عضویت
    مرداد 1385
    محل زندگی
    هرجا كه غم و ناراحتي باشه
    پست
    1,173
    نقل قول نوشته شده توسط mehdi-gh مشاهده تاپیک
    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

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

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

  30. #30
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    آشنایی با برنامه نویسی VBA


  31. #31
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    خصوصیات دیتابیس

    این کد خصوصیات یک دیتابیس جاری رو مانیتور می کنه .
    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

  32. #32
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    جلوگیری از تغییر رکوردهای قبلی در فرم

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

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

    End If
    آخرین ویرایش به وسیله مهدی قربانی : سه شنبه 21 اسفند 1386 در 15:40 عصر دلیل: اصلاح كد

  33. #33
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

    ساخت کوئری با کد VBA

    با کد زیر می تونید با کمک 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 کپی کنید .
    آخرین ویرایش به وسیله مهدی قربانی : پنج شنبه 23 اسفند 1386 در 10:33 صبح دلیل: با تشكر از bad_boy_2007 ، كد اصلاح شد .

  34. #34
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435

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

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


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

  35. #35
    کاربر تازه وارد آواتار سعید مشکین فر
    تاریخ عضویت
    خرداد 1384
    محل زندگی
    موطن آدمی در قلب کسانی است که دوستش میدارند
    پست
    42

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

    کلید خروج را روی فرم یا سویچ برد طراحی کنید و کد ها را در رویداد 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
    آخرین ویرایش به وسیله سعید مشکین فر : شنبه 17 فروردین 1387 در 01:14 صبح دلیل: تصحیح

  36. #36
    کاربر تازه وارد آواتار سعید مشکین فر
    تاریخ عضویت
    خرداد 1384
    محل زندگی
    موطن آدمی در قلب کسانی است که دوستش میدارند
    پست
    42

    پرسش از کاربر برای حذف رکورد در فرمها

    کلید حذف رکورد را در فرم مورد نظر طراحی کنید و کد زیر را در رویداد 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
    آخرین ویرایش به وسیله سعید مشکین فر : شنبه 17 فروردین 1387 در 01:12 صبح دلیل: تصحیح

  37. #37
    کاربر تازه وارد آواتار سعید مشکین فر
    تاریخ عضویت
    خرداد 1384
    محل زندگی
    موطن آدمی در قلب کسانی است که دوستش میدارند
    پست
    42

    اعلام پیام از سیستم برای رکوردهای تکراری

    کد زیر را در رویداد 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

  38. #38
    کاربر دائمی آواتار مهدی قربانی
    تاریخ عضویت
    اسفند 1385
    محل زندگی
    تهران
    پست
    2,435
    ضمن تشکر از دوستانی که در این تاپیک شرکت کردن ، سایر عزیزان تمایلی به ارائه مطلب و یا نمونه و .... برای استفاده اعضاء ندارن ؟ به هر حال برای رشد معلومات و توانایی ها لازمه که رفقا همکاری و مساعدت بفرمایند .
    موفق باشید .

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

  40. #40
    کاربر دائمی آواتار shaghaghi
    تاریخ عضویت
    اسفند 1386
    محل زندگی
    تهران
    پست
    250

    تغییر رنگ سطرهای ریپورت بصورت یک در میان

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

    Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
    Me.Detail.BackColor = IIf(me.txtRow Mod 2 = 0, 16777215, 14671839)
    End Sub
    عکس های ضمیمه عکس های ضمیمه
    آخرین ویرایش به وسیله shaghaghi : دوشنبه 02 اردیبهشت 1387 در 13:25 عصر دلیل: اضافه نمودن تصویر ضمیمه

صفحه 1 از 5 123 ... آخرآخر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •