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

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

Dim MyDatabase As Database

به این شکل

Dim MyDatabase As DAO.Database

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

کد HTML:

---

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

---

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

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

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

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

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

مشاهده کدها

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

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

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

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

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

با تشکر از شما

با سلام

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

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

    DoCmd.Maximize

    SendKeys "{F5}"

    SendKeys "500"

    SendKeys "{Enter}"

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

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

    DoCmd.Maximize

    SendKeys "{End}"

این دستور کوتاهتر و خواناتره. البته توجه داشته باشید در صورتی که خاصیت AutoResize ریپورت No باشه به صفحه آخر نمیره

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

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

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

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

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

نقل قول:

---

نوشته شده توسط iman56

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

---

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

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

نقل قول:

---

نوشته شده توسط iman56

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

---

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

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

نمونه ارائه شده براي به دست آوردن مشخصات سيستم كاربرد داره اميدوارم به دردتون بخوره
براي اجراي صحيح بايد رفرنس 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=impersonat  e}").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

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

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

نقل قول:

---

نوشته شده توسط rezaicom

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

---

دوست من شما بايد اين رفرنس رو فعال كنيد:Microsoft WMI Scripting v2.1 library
................................
موفق باشيد

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

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

http://www.freeuploadimages.org/imag...gorzzli41x.jpg

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

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

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

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

نقل قول:

---

نوشته شده توسط ryonis

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

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

http://www.freeuploadimages.org/imag...gorzzli41x.jpg

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

---

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

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

نقل قول:

---

نوشته شده توسط abas588

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

---

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

نقل قول:

---

نوشته شده توسط vbnasim

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

---

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

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

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

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

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

DoCmd.DeleteObject acTable, "table1"

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

با سلام

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

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

 SELECT * INTO table1backup

FROM Table1; 

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

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

نقل قول:

---

نوشته شده توسط m_bargostavan_66

سلام چطوری میشه پیغامهایی که اکسس بصورت انگلیسی میده با پیامهای فارسی عوض کرد کد خطاها را هم بگین که خیلی ممنون میشم؟

---

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

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

بازي در اكسس

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

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

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

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

اين براي كيبورد :
https://barnamenevis.org/showthread.p...76#post1167276

ثبت اطلاعات از فرم و ساب فرم به صورت 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

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

نقل قول:

---

نوشته شده توسط صبا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)

 

---

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

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

---

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

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

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

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

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

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

msgbox number3digit( 123456789,2)

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