صفحه 2 از 5 اولاول 1234 ... آخرآخر
نمایش نتایج 41 تا 80 از 180

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

  1. #41
    کاربر دائمی آواتار F_ashigh
    تاریخ عضویت
    آذر 1386
    محل زندگی
    اصفهان
    پست
    146
    باید از این دوستان که زحمت جمع آوری این برنامه ها را میکشند و در اختیار بقیه قرار می دهند ، بابت تک تک این برنامه ها تشکر کرد که فکر کنم باز هم کم باشه.
    آخرین ویرایش به وسیله F_ashigh : یک شنبه 25 فروردین 1387 در 16:35 عصر

  2. #42
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    ایجاد پشتیبان از جداول ACCESS در مسیر دلخواه

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

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  3. #43
    کاربر دائمی آواتار morteza_lll
    تاریخ عضویت
    تیر 1386
    محل زندگی
    ايران / اهواز
    پست
    349

    Question سوال

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

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


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

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

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

    بکارگیری Subdatasheet در سابفرم

    یقینا بارها از امکان Subdatasheet هنگام کار با جداولی که ارتباط یک به چند با هم دارند کمک گرفته اید، و با اینکار اطلاعات را بصورت منسجم و راحت مشاهده و ویرایش نموده اید
    اما اگر مایل هستید این سهولت را به سابفرم هایتان هم منتقل کنید نمونه برنامه زیر این امکان را به شما می دهد
    عکس های ضمیمه عکس های ضمیمه
    • نوع فایل: jpg SDS.JPG‏ (23.8 کیلوبایت, 3105 دیدار)
    فایل های ضمیمه فایل های ضمیمه

  6. #46
    کاربر دائمی آواتار morteza_lll
    تاریخ عضویت
    تیر 1386
    محل زندگی
    ايران / اهواز
    پست
    349
    نقل قول نوشته شده توسط shaghaghi مشاهده تاپیک
    ابتدا TextBoxی را با نام دلخواه (مثلا ROw ) در قسمت Detail ریپورت مورد نظرتان ایجاد نمایید و خاصیت Runnig Sum آنرا Over All نمایید (اگر مایل به نمایش ستون ردیف نیستید، Visible آنرا Flase نمایید)
    ضمنا اعداد ذکر شده کد رنگهای سفید و خاکستری هستند که به سلیقه شما می تواند تغییر نماید
    متشکرم دوست عزیز مشکل توسط راهنمایی شما حل شد
    ولی یک مورد دیگر اینکه پس زمینه back ground کل اون ردیف را عوض می کند در صورت که من می خوام پس زمینه کل فیلدهای آن ردیف را تغییر دهد در صورتی که الان رنگ بیرون از فیلدها هم می رود ممنون می شم در این مورد هم منو راهنمایی کنید

  7. #47
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    نمونه جامع برای نحوه کارکردن با فرمها

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

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  8. #48
    کاربر تازه وارد آواتار mahmoud.golzar
    تاریخ عضویت
    بهمن 1386
    محل زندگی
    تهران
    پست
    39

    تفاوت

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

  9. #49
    کاربر دائمی آواتار shaghaghi
    تاریخ عضویت
    اسفند 1386
    محل زندگی
    تهران
    پست
    250
    نقل قول نوشته شده توسط morteza_lll مشاهده تاپیک
    ولی یک مورد دیگر اینکه پس زمینه 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
    آخرین ویرایش به وسیله shaghaghi : دوشنبه 02 اردیبهشت 1387 در 14:30 عصر

  10. #50
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947
    تابع chrw() و تابع chr چه تفاوتی دارن?
    تابع chr یک کاراکتر رو برمیگردونه مثلا 96 حرف a رو برمیگردونه.تابع chrw همونکارو برای کاراکترهای یونیکد انجام میده. برای پلاتفرم مکینتاش chrw مناسب نیست چون یونیکد رو ساپورت نمیکنه.

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  11. #51
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    INPUTBOX با پوشانه ورودی(PASSWORD MASK)

    لطفا نمونه را ببینید در اين نمونه براي حذف ركورد كاربر بايد پسورد لازم رو وارد كنه كه به دلايل امنيتي موقع ورود پسورد به شكل ستاره نشان داده ميشود.
    (پسورد حدف رکورد عدد10)
    كدهاي استفاده شده:
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
    ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
    ByVal dwThreadId As Long) As Long

    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

    Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
    (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long

    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

    'Constants to be used in our API functions
    Private Const EM_SETPASSWORDCHAR = &HCC
    Private Const WH_CBT = 5
    Private Const HCBT_ACTIVATE = 5
    Private Const HC_ACTION = 0

    Private hHook As Long

    Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long

    If lngCode < HC_ACTION Then
    NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
    Exit Function
    End If

    strClassName = String$(256, " ")
    lngBuffer = 255

    If lngCode = HCBT_ACTIVATE Then 'A window has been activated

    RetVal = GetClassName(wParam, strClassName, lngBuffer)

    If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox

    'This changes the edit control so that it display the password character *.
    'You can change the Asc("*") as you please.
    SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
    End If

    End If

    'This line will ensure that any other hooks that may be in place are
    'called correctly.
    CallNextHookEx hHook, lngCode, wParam, lParam

    End Function

    Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
    Optional YPos, Optional HelpFile, Optional Context) As String
    Dim lngModHwnd As Long, lngThreadID As Long

    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)

    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook
    End Function
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله amirzazadeh : پنج شنبه 18 مهر 1387 در 10:21 صبح

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

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

    پیدا کردن سریع سطر منبع خطای حین اجرا (Run time Error)

    اگر شما در یک روال نسبتا طولانی مرتب با خطاهای گوناگون برخورد می نمایید و هر بار مجبورید برای یافتن منبع خطا، با گذاشتن Break خط به خط، دستورات را دنبال نمایید، می توانید از این روش سریع بهره ببرید.
    شما می توانید با شماره گذاری کردن سطرهای کد نویسی و با استفاده از تابع Erl شماره ردیف سطر مولد خطا را به سرعت بیابید و نسبت به رفع آن اقدام نمایید.
    به این نمونه خطا توجه نمایید:


    Private Sub Cmd1_Click()
    On Error GoTo Err_Handler
    1 Dim stDocName As String
    2 Dim stLinkCriteria As String
    3 stDocName = "Form1"
    4 DoCmd.OpenReport stDocName, , , stLinkCriteria

    Exit Sub
    Err_Handler:
    MsgBox "Error Line Is: " & Erl() & vbCrLf & Err.Description

    End Sub



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

  13. #53
    کاربر دائمی آواتار davood-ahmadi
    تاریخ عضویت
    بهمن 1385
    محل زندگی
    تهران
    پست
    568

    Smile

    آموزش Office VBA که بیشتر در مورد برنامه نویسی توی اکسس و اکسل هست. پیشنهاد می کنم به دوستان که حتماً این را مطالعه کنند. حداقل مواردی توش هستش که بدردشون بخوره.
    فایل های ضمیمه فایل های ضمیمه
    • نوع فایل: rar vba.rar‏ (1.16 مگابایت, 7316 دیدار)

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

    آموزش استفاده از توابع هجری شمسی در اکسس و تبدیل عدد به حروف


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

    مجموعه فايلهاي PDF آموزش برنامه نویسی پایگاه داده در ویژوال بیسیک 6

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

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

    نقل قول: اجراي Comact And Repair با كد

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

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

  17. #57
    کاربر دائمی آواتار HAMRAHSOFT.IR
    تاریخ عضویت
    مرداد 1385
    محل زندگی
    هرجا كه غم و ناراحتي باشه
    پست
    1,175

    فايل آموزشي PDF

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

    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله HAMRAHSOFT.IR : شنبه 01 تیر 1387 در 10:29 صبح دلیل: اصلاح لينك دانلود

  18. #58
    کاربر دائمی آواتار davood-ahmadi
    تاریخ عضویت
    بهمن 1385
    محل زندگی
    تهران
    پست
    568

    Smile نقل قول: نمونه های کاربردی و آموزشی VBA

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

    و این هم یک فایل دیگه:
    http://www.farsaran.ir/Access_Sectio...s_internet.pdf

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

    گرد کردن لبه های BOX در گزارش

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

    Public Const conPI As Single = 3.14159
    Private Const conTransparent As Long = 0

    Public Sub DrawBorderWithRoundedCorners(ByRef rptReport As Report, ByRef ctlBox As Control, Optional sngRadius As Single = 100, Optional lngColour As Long = vbBlack)
    Dim lngX As Long, lngY As Long


    rptReport.ForeColor = lngColour
    ctlBox.BorderStyle = conTransparent
    ctlBox.BackStyle = conTransparent

    With ctlBox
    lngX = .Left + sngRadius
    lngY = .Top + sngRadius

    rptReport.Circle (lngX, lngY), sngRadius, , conPI / 2, conPI
    rptReport.Line (lngX - sngRadius, lngY)-(lngX - sngRadius, lngY + .Height - sngRadius * 2)

    rptReport.Circle (lngX, lngY + .Height - sngRadius * 2), sngRadius, , conPI, conPI * 1.5
    rptReport.Line (lngX, lngY + .Height - sngRadius)-(lngX + .Width - sngRadius * 2, lngY + .Height - sngRadius)

    rptReport.Circle (lngX + .Width - sngRadius * 2, lngY + .Height - sngRadius * 2), sngRadius, , conPI * 1.5, conPI * 2
    rptReport.Line (lngX + .Width - sngRadius, lngY + .Height - sngRadius * 2)-(lngX + .Width - sngRadius, .Top + sngRadius)

    rptReport.Circle (lngX + .Width - sngRadius * 2, .Top + sngRadius), sngRadius, , conPI * 2, conPI / 2
    rptReport.Line (lngX + .Width - sngRadius * 2, .Top)-(lngX, .Top)
    End With
    End Sub

    برای استفاده از این امکان در جای جای گزارشاتتان باید یک کادر (Box) را هر کجای گزارش و با هر سایزی که دوست دارید قرار دهید سپس برای آن Section که کادر را قرار داده اید این کد را بنویسید:

    Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer)
    DrawBorderWithRoundedCorners Me, HdrBox
    End Sub

    (این کد برای کادری به نام HdrBox که در Report Header تعبیه شده نوشته شده است)
    ضمنا پارامتر سوم و چهارم اختیاری بود و برای تنظیم میزان گرد شدن لبه و رنگ خط دور کادر بکار می رود.
    عکس های ضمیمه عکس های ضمیمه
    • نوع فایل: gif box.GIF‏ (2.4 کیلوبایت, 3068 دیدار)
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله shaghaghi : یک شنبه 20 بهمن 1392 در 22:39 عصر دلیل: درخواست نمونه کار

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

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

    سلام
    يك تشكر ويژه از دوستاني كه وقت مي ذارن معلومات و منابع خودشون رو براي استفاده سايرين ارائه مي كنن از بقيه دوستان هم انتظار مي ره به فراخور توانشون در اين امر مشاركت كنن و با مشاركتشون باعث ايجاد انگيزه و رغبت در بين كاربران بشن ، دوستان گرامي رشد و تعالي علمي در گرو تحقيق و مشاركت هست پس فارغ از سطح علمي و معلومات با انجام تحقيق در بين منابع و سورسهاي متنوعي كه در حال حاضر بواسطه كتابها ، جزوات ، سايتها و پورتالهاي اينترنتي در دسترسمون قرار مي گيره سعي كنيم اين منابع و دستاوردها رو در اختيار سايرين بذاريم تا به اين بهانه سهمي در رشد و ارتقاء خود و دوستانمون داشته باشيم .
    آخرین ویرایش به وسیله مهدی قربانی : جمعه 21 تیر 1387 در 18:11 عصر

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

    خروجی اکسل از سابفرم

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

  22. #62
    کاربر دائمی آواتار HAMRAHSOFT.IR
    تاریخ عضویت
    مرداد 1385
    محل زندگی
    هرجا كه غم و ناراحتي باشه
    پست
    1,175

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

    نقل قول نوشته شده توسط mehdi-gh مشاهده تاپیک
    با این ماجول می تونید مجموع زمان رو بطور صحیح و با فرمت HH:MM محاسبه کنید و مشکلی که بعضی از دوستان در محاسبه مجموع زمان با اون برخورد می کنند ( عدم محاسبه بیشتر از 24 ساعت ) رو حل می کنه .

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

    Function GetTimeRoozanehTotal()
    Dim db As Database, rs As Recordset
    Dim totalhours As Long, totalminutes As Long
    Dim days As Long, Hours As Long, Minutes As Long
    Dim interval As Variant, j As Integer

    Set db = DBEngine.Workspaces(0).Databases(0)
    Set rs = db.OpenRecordset("TimeRoozaneh")
    interval = #12:00:00 AM#
    '
    While Not rs.EOF
    interval = interval + rs![Roozaneh]
    rs.MoveNext
    Wend
    totalhours = Int(CSng(interval * 24))
    totalminutes = Int(CSng(interval * 1440))
    Hours = totalhours Mod 24
    Minutes = totalminutes Mod 60
    ' در صورتیکه مایل به استفاده عبارات ساعت و دقیقه هستید خط زیر رو فعال کنید
    ' GetTimeRoozanehTotal = totalhours & " ساعت و " & Minutes & " دقیقه"
    GetTimeRoozanehTotal = totalhours & ":" & Minutes
    End Function


    بعد این تابع رو در Control Source یک TextBox در فرم کپی کنید :
    =GetTimeRoozanehTotal()


    نمونه مرتبط :


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

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

    بدست آوردن لیستی از Sheet های موجود در یک فایل اکسل

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

    Dim objExcel As Excel.Application
    Dim objWorkBook As Excel.Workbook
    Dim totalWorkSheets As Excel.Worksheet
    Dim objWorkSheets As Excel.Worksheet

    Set objExcel = CreateObject("Excel.Application")

    Set objWorkBook = objExcel.Workbooks.Open("C:\myExcel.xls")
    ' this code gets the names off all the worksheets
    For Each totalWorkSheets In objWorkBook.Worksheets
    MsgBox totalWorkSheets.Name
    Next totalWorkSheets


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

    نقل قول: كار با ListBox

    حذف و اضافه كردن ركوردهاي دو جدول با استفاده از ListBox

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

    Private Sub Command4_Click()
    On Error GoTo Err_Command4_Click
    Dim Rst1 As DAO.Recordset
    Dim Rst2 As DAO.Recordset
    Dim strSQL As String
    Dim strSQL1 As String
    strSQL1 = "SELECT Table1.id, Table1.name FROM Table1 WHERE (((Table1.id)='" & Me.List0 & "'));"
    strSQL2 = "DELETE Table1.id, Table1.name FROM Table1 WHERE (((Table1.id)='" & Me.List0 & "'));"
    Set Rst1 = CurrentDb.OpenRecordset(strSQL1)
    Set Rst2 = CurrentDb.OpenRecordset("table2")
    'ÇÑ ÊÚÏÇ Òíäå åÇí áíÓÊ ÈÇßÓ ÕÝÑ ÈÇÔå æ ÑßæÑÏí åã ÏÑ ÑßæÑÏÓÊ ãæÌæÏ äÈÇÔå
    If Rst1.RecordCount = 0 And Me.List0.ListCount = 0 Then
    MsgBox "ãÞÏÇÑí ãæÌæÏ äãí ÈÇÔÏ", vbMsgBoxRight + vbExclamation, "ÊæÌå" ' íÛÇã ÚÏã ãæÌæÏí
    Exit Sub ' ÎÑæÌ ÇÒ ÑÎÏÇÏ

    ' ÇÑ ÑßæÑÏÓÊ ÕÝÑ ÈÇÔå æáí ÊÚÏÇÏ Òíäå åÇí áíÓÊ ÈÇßÓ ÈíÔÊÑ ÇÒ ÕÝÑ ÈÇÔå
    ElseIf Rst1.RecordCount = 0 And Me.List0.ListCount > 0 Then
    'íÛÇã ÚÏã ÇäÊÎÇÈ Òíäå
    MsgBox "Òíäå Çí ÇÒ áíÓÊ ÇäÊÎÇÈ äÔÏå ÇÓÊ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
    Me.List0.SetFocus ' ÇäÊÞÇá ÝæßæÓ Èå áíÓÊ ÈÇßÓ
    Me.List0.Selected(1) = True ' ÇäÊÎÇÈ Çæáíä Òíäå ãæÌæÏ ÏÑ áíÓÊ
    Exit Sub ' ÎÑæÌ ÇÒ ÑÎÏÇÏ
    Else ' ÏÑ ÛíÑ ÇíäÕæÑÊ
    Rst2.AddNew ' ÇÖÇÝå ßÑÏä ÑßæÑÏ ÌÏíÏ ÏÑ ÑßæÑÏÓÊ
    ' ÇäÊÞÇá ÇØáÇÚÇÊ ãæÌæÏ ÏÑ áíÓÊ ÈÇßÓ Èå ÑßæÑÏÓÊ
    Rst2.Fields("id").Value = Me.List0.Column(0)
    Rst2.Fields("name").Value = Me.List0.Column(1)
    Rst2.Update
    ' ÇÌÑÇí ßÏ ÇÓ ßíæ Çá ãÑÈæØ Èå ÍÐÝ ÑßæÑÏ ãÊäÇÙÑ ÈÇ áíÓÊ ÈÇßÓ ÇÒ ÌÏæá
    DoCmd.SetWarnings False
    DoCmd.RunSQL (strSQL2)
    DoCmd.SetWarnings True
    End If
    ' ÈÇÒ ÎæÇäí áíÓÊ ÈÇßÓåÇ
    Me.List0.Requery
    Me.List2.Requery
    Me.List0.SetFocus ' ÇäÊÞÇá ÝæßæÓ Èå áíÓÊ ÈÇßÓ ÌÇÑí
    List0.Selected(1) = True ' ÇäÊÞÇá Èå Òíäå Çæá áíÓÊ ÈÇßÓ ÌÇÑí
    Set Rst = Nothing
    Set Rst1 = Nothing

    Exit_Command4_Click:
    Exit Sub
    Err_Command4_Click:
    MsgBox Err.Description
    Resume Exit_Command4_Click

    End Sub


    Private Sub Command5_Click()
    On Error GoTo Err_Command5_Click
    Dim Rst3 As DAO.Recordset
    Dim Rst4 As DAO.Recordset
    Dim strSQL3 As String
    Dim strSQL4 As String
    strSQL3 = "SELECT Table2.id, Table2.name FROM Table2 WHERE (((Table2.id)='" & Me.List2 & "'));"
    strSQL4 = "DELETE Table2.id, Table2.name FROM Table2 WHERE (((Table2.id)='" & Me.List2 & "'));"
    Set Rst3 = CurrentDb.OpenRecordset(strSQL3)
    Set Rst4 = CurrentDb.OpenRecordset("table1")
    If Rst3.RecordCount = 0 And Me.List2.ListCount = 0 Then
    MsgBox "ãÞÏÇÑí ãæÌæÏ äãí ÈÇÔÏ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
    Exit Sub
    ElseIf Rst3.RecordCount = 0 And Me.List2.ListCount > 0 Then

    MsgBox "Òíäå Çí ÇÒ áíÓÊ ÇäÊÎÇÈ äÔÏå ÇÓÊ", vbMsgBoxRight + vbExclamation, "ÊæÌå"
    Me.List2.SetFocus
    Me.List2.Selected(1) = True
    Exit Sub
    Else
    Rst4.AddNew
    Rst4.Fields("id").Value = Me.List2.Column(0)
    Rst4.Fields("name").Value = Me.List2.Column(1)
    Rst4.Update
    DoCmd.SetWarnings False
    DoCmd.RunSQL (strSQL4)
    DoCmd.SetWarnings True

    End If

    Me.List0.Requery
    Me.List2.Requery
    Me.List2.SetFocus
    Me.List2.Selected(1) = True
    Set Rst = Nothing
    Set Rst1 = Nothing

    Exit_Command5_Click:
    Exit Sub
    Err_Command5_Click:
    MsgBox Err.Description
    Resume Exit_Command5_Click

    End Sub


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

  25. #65
    کاربر دائمی
    تاریخ عضویت
    اردیبهشت 1387
    محل زندگی
    هرجا که چیزی برای یادگرفتن باشد
    پست
    1,260

    نقل قول: تبدیل تاریخ شمسی به حروف

    با سلام خدمت همه عزیزان
    بااستفاده از توابع آقای آزادی و دیگر دوستان تابع تبدیل تاریخ شمسی به حروف به همراه نمونه آماده شده
    انشاءاله دیگران بتوانند استفاده کنند.
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله dadsara : یک شنبه 30 تیر 1387 در 08:29 صبح

  26. #66
    کاربر دائمی آواتار smderfan
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    OFFICE11\MSACCESS
    پست
    721

    غیر فعال کردن نمای طراحی فرم

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

  27. #67
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

    Restore of Backup

    دوستان نمونه حاضر براي Restore كردن پشتيبان هاي گرفته شده از بانك اطلاعاتي كاربرد دارد . اميدوارم مفيد باشه.(با اين تذكر كه رفرنسهاي تصوير ضميمه بايد add بشه براي اين منظور OCX ضميمه رو توي SYSTEM32 ويندوز كپي كنين و بعد توي اكسس از منوي TOOLS>ACTIVEX CONTROLS رجيستر كنيد.)
    Option Compare Database
    Dim CommondialogControl2 As Control
    Dim backfile As New FileSystemObject
    Dim source As String, desti As String

    Private Sub Command0_Click()
    On Error GoTo err
    ' Dim source As String, desti As String
    source = Application.CurrentProject.path & "\fdc.mdb"
    With CommonDialog2
    .DialogTitle = "Backup"
    .Filter = "mdbfles (*.mdb)|*.mdb"
    .ShowSave
    desti = .FileName
    backfile.CopyFile source, desti, True
    MsgBox "Databas has been backup", vbInformation
    End With
    Exit Sub
    err:
    Beep
    End Sub

    Private Sub Command1_Click()
    On Error GoTo err
    desti = Application.CurrentProject.path & "\fdc.mdb"
    If MsgBox("are you sure", vbOKCancel, "restore") = vbOK Then
    With CommonDialog2

    .DialogTitle = "Restore"
    .Filter = "Access Files(*.mdb)|*.mdb"
    .ShowOpen
    source = .FileName
    End With
    backfile.CopyFile source, desti, True
    MsgBox "Databas has been restored", vbInformation
    Else
    Cancel = True
    End If
    Exit Sub
    err:
    Beep
    End Sub

    ...........................
    موفق باشيد
    عکس های ضمیمه عکس های ضمیمه
    • نوع فایل: jpg ref.jpg‏ (96.3 کیلوبایت, 3035 دیدار)
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله amirzazadeh : چهارشنبه 16 مرداد 1387 در 13:18 عصر

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

  28. #68
    کاربر دائمی آواتار Ali_Fallah
    تاریخ عضویت
    مهر 1384
    محل زندگی
    همین نزدیکی ها
    پست
    791

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

    اگر می خواهید کاربران برنامه تان را از کلیدهای پیمایش رکوردها محدود کنید
    عیناً کد زیرا وارد برنامه خود کنید
    در این کد 6 کلید از کار می افتند که خودتان حدس بزنید کدامها هستند...

    Option Explicit
    Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case 33, 34, 37, 38, 39, 40, 9
    KeyCode = 0
    End Select
    End Sub

  29. #69
    کاربر جدید
    تاریخ عضویت
    تیر 1387
    محل زندگی
    تهران
    پست
    26

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

    سلام دوستان عزیز
    ماژول تبدیل تاریخ میلادی به شمسی را براتون میذارم . این ماژول تقریبا کامله و در vb و اکسس کاربرد داره.
    امیدوارم به دردتون بخوره. لطفا نظرتون رو بدید.
    شما کار این ماژول رو در فرم می تونید ببینید و خود ماژول رو در قسمت Modules اکسس مشاهده کنید.

    نمونه بانک رو براتون میذارم
    و من الله التوفیق

    Option Compare Database
    Option Explicit
    Function Miladi(DateToChange As String) As Date
    Dim IntMilad As Integer
    Dim StrMilad As String
    Dim YY1 As Integer
    Dim yy As Integer
    Dim TempYY As Integer
    Dim mm As Byte
    Dim dd As Byte
    Dim VazYear As Byte

    IntMilad = 621
    YY1 = Mid(DateToChange, 1, 2)
    yy = Mid(DateToChange, 3, 2)
    mm = Mid(DateToChange, 6, 2)
    dd = Mid(DateToChange, 9, 2)
    TempYY = yy
    '--------------------------------------------
    VazYear = ShamsiVazYear(TempYY)
    '--------------------------------------------
    ' VazYear = 1 ÓÇá ßÈíÓå
    ' VazYear = 2 ÓÇá ÞÈá ÇÒ ßÈíÓå
    '--------------------------------------------
    YY1 = YY1 * 100
    yy = YY1 + yy
    If VazYear = 1 Then
    Select Case mm
    Case 1
    If dd <= 12 Then
    dd = dd + 19
    mm = 3
    yy = yy + IntMilad
    Else
    dd = dd - 12
    mm = 4
    yy = yy + IntMilad
    End If
    Case 2
    If dd <= 11 Then
    dd = dd + 19
    mm = 4
    Else
    dd = dd - 11
    mm = 5
    End If
    yy = yy + IntMilad
    Case 3
    If dd <= 11 Then
    dd = dd + 20
    mm = 5
    Else
    dd = dd - 11
    mm = 6
    End If
    yy = yy + IntMilad
    Case 4
    If dd <= 10 Then
    dd = dd + 20
    mm = 6
    Else
    dd = dd - 10
    mm = 7
    End If
    yy = yy + IntMilad
    Case 5
    If dd <= 10 Then
    dd = dd + 21
    mm = 7
    Else
    dd = dd - 10
    mm = 8
    End If
    yy = yy + IntMilad
    Case 6
    If dd <= 10 Then
    dd = dd + 21
    mm = 8
    Else
    dd = dd - 10
    mm = 9
    End If
    yy = yy + IntMilad
    Case 7
    If dd <= 9 Then
    dd = dd + 21
    mm = 9
    Else
    dd = dd - 9
    mm = 10
    End If
    yy = yy + IntMilad
    Case 8
    If dd <= 10 Then
    dd = dd + 21
    mm = 10
    Else
    dd = dd - 10
    mm = 11
    End If
    yy = yy + IntMilad
    Case 9
    If dd <= 10 Then
    dd = dd + 20
    mm = 11
    Else
    dd = dd - 10
    mm = 12
    End If
    yy = yy + IntMilad
    Case 10
    If dd <= 11 Then
    dd = dd + 20
    mm = 12
    yy = yy + IntMilad
    Else
    dd = dd - 11
    mm = 1
    yy = yy + IntMilad + 1
    End If
    Case 11
    If dd <= 12 Then
    dd = dd + 19
    mm = 1
    Else
    dd = dd - 12
    mm = 2
    End If
    yy = yy + IntMilad + 1
    Case 12
    If dd <= 10 Then
    dd = dd + 18
    mm = 2
    Else
    dd = dd - 10
    mm = 3
    End If
    yy = yy + IntMilad + 1
    End Select
    ' ÓÇáåÇí ÔÜãÓí ÛíÑßÈíÓå
    Else:
    Select Case mm
    Case 1
    If dd <= 11 Then
    dd = dd + 20 '31
    mm = 3
    Else
    dd = dd - 11
    mm = 4
    End If
    yy = yy + IntMilad
    Case 2
    If dd <= 10 Then
    dd = dd + 20 '30
    mm = 4
    Else
    dd = dd - 10
    mm = 5
    End If
    yy = yy + IntMilad
    Case 3
    If dd <= 10 Then
    dd = dd + 21 '31
    mm = 5
    Else
    dd = dd - 10
    mm = 6
    End If
    yy = yy + IntMilad
    Case 4
    If dd <= 9 Then
    dd = dd + 21 '30
    mm = 6
    Else
    dd = dd - 9
    mm = 7
    End If
    yy = yy + IntMilad
    Case 5
    If dd <= 9 Then
    dd = dd + 22
    mm = 7
    Else
    dd = dd - 9
    mm = 8
    End If
    yy = yy + IntMilad
    Case 6
    If dd <= 9 Then
    dd = dd + 22
    mm = 8
    Else
    dd = dd - 9
    mm = 9
    End If
    yy = yy + IntMilad
    Case 7
    If dd <= 8 Then
    dd = dd + 22
    mm = 9
    Else
    dd = dd - 8
    mm = 10
    End If
    yy = yy + IntMilad
    Case 8
    If dd <= 9 Then
    dd = dd + 22
    mm = 10
    Else
    dd = dd - 9
    mm = 11
    End If
    yy = yy + IntMilad
    Case 9
    If dd <= 9 Then
    dd = dd + 21
    mm = 11
    Else
    dd = dd - 9
    mm = 12
    End If
    yy = yy + IntMilad
    Case 10
    If dd <= 10 Then
    dd = dd + 21
    mm = 12
    yy = yy + IntMilad
    Else
    dd = dd - 10
    mm = 1
    yy = yy + IntMilad + 1
    End If
    Case 11
    If dd <= 11 Then
    dd = dd + 20
    mm = 1
    Else
    dd = dd - 11
    mm = 2
    End If
    yy = yy + IntMilad + 1
    Case 12
    If VazYear = 2 Then
    If dd <= 9 Then
    dd = dd + 19
    mm = 2
    Else
    dd = dd - 9
    mm = 3
    End If
    Else
    If dd <= 9 Then
    dd = dd + 19
    mm = 2
    Else
    dd = dd - 9
    mm = 3
    End If
    End If
    yy = yy + IntMilad + 1
    End Select
    End If
    StrMilad = yy
    StrMilad = StrMilad & "/"
    If mm < 10 Then
    StrMilad = StrMilad & "0"
    End If
    StrMilad = StrMilad & mm
    StrMilad = StrMilad & "/"
    If dd < 10 Then
    StrMilad = StrMilad & "0"
    End If
    StrMilad = StrMilad & dd
    Miladi = StrMilad
    End Function
    Function Shamsi(DateToChange As String) As String
    Dim IntSHAMS As Integer
    Dim YY1 As Integer
    Dim yy As Integer
    Dim TempYY As Integer
    Dim mm As Byte
    Dim dd As Byte
    Dim VazYear As Byte

    IntSHAMS = 621
    YY1 = Mid(DateToChange, 1, 2)
    yy = Mid(DateToChange, 3, 2)
    mm = Mid(DateToChange, 6, 2)
    dd = Mid(DateToChange, 9, 2)
    TempYY = yy
    '---------------------------------
    VazYear = MiladiVazYear(TempYY)
    '--------------------------------------------
    ' VazYear = 1 ÓÇá ßÈíÓå
    ' VazYear = 2 ÓÇá ÈÚÏ ÇÒ ßÈíÓå
    '-------------------------------------------zz-
    YY1 = YY1 * 100
    yy = YY1 + yy
    If VazYear = 1 Then
    Select Case mm
    Case 1
    If dd <= 20 Then
    dd = dd + 10
    mm = 10
    Else
    dd = dd - 20
    mm = 11
    End If
    yy = yy - IntSHAMS - 1
    Case 2
    If dd <= 19 Then
    dd = dd + 11
    mm = 11
    Else
    dd = dd - 19
    mm = 12
    End If
    yy = yy - IntSHAMS - 1
    Case 3
    If dd <= 19 Then
    dd = dd + 10
    mm = 12
    yy = yy - IntSHAMS - 1
    Else
    dd = dd - 19
    mm = 1
    yy = yy - IntSHAMS
    End If
    Case 4
    If dd <= 19 Then
    dd = dd + 12
    mm = 1
    Else
    dd = dd - 19
    mm = 2
    End If
    yy = yy - IntSHAMS
    Case 5
    If dd <= 20 Then
    dd = dd + 11
    mm = 2
    Else
    dd = dd - 20
    mm = 3
    End If
    yy = yy - IntSHAMS
    Case 6
    If dd <= 20 Then
    dd = dd + 11
    mm = 3
    Else
    dd = dd - 20
    mm = 4
    End If
    yy = yy - IntSHAMS
    Case 7
    If dd <= 21 Then
    dd = dd + 10
    mm = 4
    Else
    dd = dd - 21
    mm = 5
    End If
    yy = yy - IntSHAMS
    Case 8
    If dd <= 21 Then
    dd = dd + 10
    mm = 5
    Else
    dd = dd - 21
    mm = 6
    End If
    yy = yy - IntSHAMS
    Case 9
    If dd <= 21 Then
    dd = dd + 10
    mm = 6
    Else
    dd = dd - 21
    mm = 7
    End If
    yy = yy - IntSHAMS
    Case 10
    If dd <= 21 Then
    dd = dd + 9
    mm = 7
    Else
    dd = dd - 21
    mm = 8
    End If
    yy = yy - IntSHAMS
    Case 11
    If dd <= 20 Then
    dd = dd + 10
    mm = 8
    Else
    dd = dd - 20
    mm = 9
    End If
    yy = yy - IntSHAMS
    Case 12
    If dd <= 20 Then
    dd = dd + 10
    mm = 9
    Else
    dd = dd - 20
    mm = 10
    End If
    yy = yy - IntSHAMS
    End Select
    Else
    Select Case mm
    Case 1
    If VazYear = 2 Then
    If dd <= 19 Then
    dd = dd + 11
    mm = 10
    Else
    dd = dd - 19
    mm = 11
    End If
    Else
    If dd <= 20 Then
    dd = dd + 10
    mm = 10
    Else
    dd = dd - 20
    mm = 11
    End If
    End If
    yy = yy - IntSHAMS - 1
    Case 2
    If VazYear = 2 Then
    If dd <= 18 Then
    dd = dd + 12
    mm = 11
    Else
    dd = dd - 18
    mm = 12
    End If
    Else
    If dd <= 19 Then
    dd = dd + 11
    mm = 11
    Else
    dd = dd - 19
    mm = 12
    End If
    End If
    yy = yy - IntSHAMS - 1
    Case 3
    If dd <= 20 Then
    If VazYear = 2 Then
    dd = dd + 10
    Else
    dd = dd + 9
    End If
    mm = 12
    yy = yy - IntSHAMS - 1
    Else
    dd = dd - 20
    mm = 1
    yy = yy - IntSHAMS
    End If
    Case 4
    If dd <= 20 Then
    dd = dd + 11
    mm = 1
    Else
    dd = dd - 20
    mm = 2
    End If
    yy = yy - IntSHAMS
    Case 5
    If dd <= 21 Then
    dd = dd + 10
    mm = 2
    Else
    dd = dd - 21
    mm = 3
    End If
    yy = yy - IntSHAMS
    Case 6
    If dd <= 21 Then
    dd = dd + 10
    mm = 3
    Else
    dd = dd - 21
    mm = 4
    End If
    yy = yy - IntSHAMS
    Case 7
    If dd <= 22 Then
    dd = dd + 9
    mm = 4
    Else
    dd = dd - 22
    mm = 5
    End If
    yy = yy - IntSHAMS
    Case 8
    If dd <= 22 Then
    dd = dd + 9
    mm = 5
    Else
    dd = dd - 22
    mm = 6
    End If
    yy = yy - IntSHAMS
    Case 9
    If dd <= 22 Then
    dd = dd + 9
    mm = 6
    Else
    dd = dd - 22
    mm = 7
    End If
    yy = yy - IntSHAMS
    Case 10
    If dd <= 22 Then
    dd = dd + 8
    mm = 7
    Else
    dd = dd - 22
    mm = 8
    End If
    yy = yy - IntSHAMS
    Case 11
    If dd <= 21 Then
    dd = dd + 9
    mm = 8
    Else
    dd = dd - 21
    mm = 9
    End If
    yy = yy - IntSHAMS
    Case 12
    If dd <= 21 Then
    dd = dd + 9
    mm = 9
    Else
    dd = dd - 21
    mm = 10
    End If
    yy = yy - IntSHAMS
    End Select
    End If
    Shamsi = yy
    Shamsi = Shamsi & "/"
    If mm < 10 Then
    Shamsi = Shamsi & "0"
    End If
    Shamsi = Shamsi & mm
    Shamsi = Shamsi & "/"
    If dd < 10 Then
    Shamsi = Shamsi & "0"
    End If
    Shamsi = Shamsi & dd
    End Function
    Function ShamsiVazYear(YearShamsi As Integer)
    ShamsiVazYear = 0
    Start:
    If YearShamsi = 3 Then
    ShamsiVazYear = 1
    ElseIf YearShamsi = 2 Or YearShamsi = 0 Then
    ShamsiVazYear = 2
    ElseIf YearShamsi < 3 Then
    Exit Function
    Else
    YearShamsi = YearShamsi - 4
    GoTo Start
    End If
    End Function
    Function MiladiVazYear(YearMiladi As Integer)
    MiladiVazYear = 0
    Start:
    If YearMiladi = 0 Then
    MiladiVazYear = 1
    ElseIf YearMiladi = 1 Then
    MiladiVazYear = 2
    ElseIf YearMiladi < 0 Then
    Exit Function
    Else
    YearMiladi = YearMiladi - 4
    GoTo Start
    End If
    End Function
    Function TestDate(MozdStrTempDate As String)
    Dim yy As Integer
    Dim mm As Byte
    Dim dd As Byte
    yy = Mid(MozdStrTempDate, 3, 2)
    mm = Mid(MozdStrTempDate, 6, 2)
    dd = Mid(MozdStrTempDate, 9, 2)
    If mm = 1 Or mm = 2 Or mm = 3 _
    Or mm = 4 Or mm = 5 Or mm = 6 Then
    If dd < 0 Or dd > 31 Then
    TestDate = 0
    Exit Function
    End If
    ElseIf mm = 7 Or mm = 8 Or mm = 9 _
    Or mm = 10 Or mm = 11 Then
    If dd < 0 Or dd > 30 Then
    TestDate = 0
    Exit Function
    End If
    ElseIf mm = 12 Then
    If ShamsiVazYear(yy) = 1 Then
    If dd < 0 Or dd > 30 Then
    TestDate = 0
    Exit Function
    End If
    Else
    If dd > 29 Then
    TestDate = 0
    Exit Function
    End If
    End If
    ElseIf mm > 12 Then
    TestDate = 0
    Exit Function
    End If
    TestDate = 1
    End Function
    Function RetYearMonthDay(StrTemp As String, Vaz As Byte) As String
    If Vaz = 0 Then
    RetYearMonthDay = HowMonth(Mid(StrTemp, 6, 2))
    ElseIf Vaz = 1 Then
    RetYearMonthDay = Mid(StrTemp, 1, 4)
    End If
    End Function
    Function HowMonth(Vaz As Byte)
    Select Case Vaz
    Case 1
    HowMonth = "ÝÑæÑÏíä"
    Case 2
    HowMonth = "ÇÑÏíÈåÔÊ"
    Case 3
    HowMonth = "ÎÜÑÏÇÏ"
    Case 4
    HowMonth = "ÊíÜÜÑ"
    Case 5
    HowMonth = "ãÜÑÏÇÏ"
    Case 6
    HowMonth = "ÔåÑíÜæÑ"
    Case 7
    HowMonth = "ãÜåÑ"
    Case 8
    HowMonth = "ÂÈÜÜÇä"
    Case 9
    HowMonth = "ÂÐÑ"
    Case 10
    HowMonth = "Ïí"
    Case 11
    HowMonth = "ÈåÜãä"
    Case 12
    HowMonth = "ÇÓÜÝäÏ"
    End Select
    End Function
    Function NumOfDate(DateToNum As String) As Integer
    Dim yy As Integer
    Dim mm As Integer
    Dim TempMM As Integer
    Dim dd As Integer
    yy = Mid(DateToNum, 1, 4)
    mm = Mid(DateToNum, 6, 2)
    dd = Mid(DateToNum, 9, 2)

    If mm <= 6 Then
    TempMM = 31 * (mm - 1)
    ElseIf mm <= 11 Then
    TempMM = 186 + (30 * (mm - 7))
    ElseIf mm = 12 Then
    TempMM = 336
    End If

    NumOfDate = yy + TempMM + dd

    End Function
    Function HowDay(StrTemp As String)
    Select Case StrTemp
    Case "ÔäÈå", "Saturday"
    HowDay = "ÔäÈå"
    Case "íßÔäÈå", "Sunday"
    HowDay = "íßÔäÈå"
    Case "ÏæÔäÈå", "Monday"
    HowDay = "ÏæÔäÈå"
    Case "ÓåÔäÈå", "Tuesday"
    HowDay = "ÓåÔäÈå"
    Case "åÇÑÔäÈå", "Wednesday"
    HowDay = "åÇÑÔäÈå"
    Case "ä̝ÔäÈå", "Thursday"
    HowDay = "ä̝ÔäÈå"
    Case "ÌãÚå", "Friday"
    HowDay = "ÌãÚå"
    Case Else
    HowDay = StrTemp
    End Select
    End Function
    Function HowYear(StrTemp As String)
    Dim YY1 As Integer
    Dim YY2 As Integer
    Dim MM1 As Byte
    Dim MM2 As Byte
    Dim DD1 As Byte
    Dim DD2 As Byte
    YY1 = Int(Left(Shamsi(Format(Date, "yyyy/mm/dd")), 4))
    MM1 = Int(Mid(Shamsi(Format(Date, "yyyy/mm/dd")), 6, 2))
    DD1 = Int(Right(Shamsi(Format(Date, "yyyy/mm/dd")), 2))
    YY2 = Int(Left(StrTemp, 4))
    MM2 = Int(Mid(StrTemp, 6, 2))
    DD2 = Int(Right(StrTemp, 2))
    HowYear = 0
    If YY1 > YY2 Then
    If MM1 > MM2 Then
    HowYear = YY1 - YY2
    ElseIf MM1 = MM2 Then
    If DD1 >= DD2 Then
    HowYear = YY1 - YY2
    ElseIf DD1 < DD2 Then
    HowYear = (YY1 - YY2) - 1
    End If
    ElseIf MM1 < MM2 Then
    HowYear = (YY1 - YY2) - 1
    End If
    End If
    End Function

    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله مهدی قربانی : پنج شنبه 24 مرداد 1387 در 15:20 عصر

  30. #70
    کاربر دائمی آواتار Ali_Fallah
    تاریخ عضویت
    مهر 1384
    محل زندگی
    همین نزدیکی ها
    پست
    791

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

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

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

  31. #71
    کاربر دائمی
    تاریخ عضویت
    مهر 1385
    محل زندگی
    تهران
    پست
    393

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

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

  32. #72

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

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

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

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

  33. #73
    کاربر دائمی آواتار Ali_Fallah
    تاریخ عضویت
    مهر 1384
    محل زندگی
    همین نزدیکی ها
    پست
    791

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

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

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

  34. #74

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

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

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

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

    متشكرم

  35. #75
    کاربر دائمی آواتار Ali_Fallah
    تاریخ عضویت
    مهر 1384
    محل زندگی
    همین نزدیکی ها
    پست
    791

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

    Tools > Option > intrnational > use hijri calender

  36. #76
    کاربر تازه وارد
    تاریخ عضویت
    اردیبهشت 1387
    محل زندگی
    ايران
    پست
    38

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

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

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

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

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

  38. #78
    کاربر جدید
    تاریخ عضویت
    خرداد 1386
    محل زندگی
    بیرجند
    پست
    4

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

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

  39. #79
    کاربر جدید
    تاریخ عضویت
    خرداد 1386
    محل زندگی
    بیرجند
    پست
    4

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

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

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

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

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

صفحه 2 از 5 اولاول 1234 ... آخرآخر

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

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

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