اكواد مكتوبة حتما ستحتاجها

اكواد تعليمية  اختر ما تحتاجة
كمية كبيرة من الاكواد والشرح
جرب حتما ستحتاجها وقتا ما

Code

Head	Code	Learn
الحفظ بمطالبة	Private Sub Form_BeforeUpdate(Cancel As Integer) Beep If MsgBox("هل ترغب بحفظ التعديلات ؟" & vbCrLf & _ "أضغط (نعـم) للحفظ ، أو (لا) لإلغاء الأمر .", _ vbInformation + vbMsgBoxRight + vbOKCancel + vbDefaultButton2, _ "تنبيـــه : تم تعديل السجل") = vbOK Then Else DoCmd.RunCommand acCmdUndo End If End Sub كود آخر If MsgBox(" هل تريد حفظ السجل ؟ ", vbYesNo, " تنبيه ") -= vbNo Then Cancel = True SendKeys "{ESC}" Exit Sub End If	حدث قبل التحديث
جعل مربع نص يومض	Me!Label1.Visible = Not (Label1.Visible)	حدث عند عداد الوقت ضع الفاصل الزمني لعداد الوقت 800. ladel1 اسم مربع النص
جعل القاعدة بالتاريخ الهجري	في أكسس إكس بي استخدم الكود التالي CurrentDb.Properties("Use hijri calendar").Value = 1 وفي أكسس 2000 و 97 استخدم الكود التالي CurrentDb.Properties("hijricalendar").Value = 1	يوضع الكود في حدث عند الفتح او عند التحميل للنموذج الاول والذي يعمل بمجرد فتح قاعدة البيانات
إخفاء النموذج الفرعي عندما لا توجد سجلات لعرضها.	()Private Sub Form_Current With Me![SubformName].Form (Visible = (.RecordsetClone.RecordCount > 0. End With End Sub
عدم ترك أحد الحقول فارغاً.	If IsNull(Me![أكتب هنا اسم الحقل]) Then MsgBox "لايمكن ترك هذا الحقل بدون بيانات ." Cancel = -1 End If	في حدث عند الخروج للحقل
فتح المربع الخاص بايجاد الصور	On Error GoTo Officena ' employee_pic اسم كائن صورة الموظف هو Me.employee_pic.Action = acOLEInsertObjDlg ExitProcedure: Exit Sub Officena: Select Case Err.Number Case 2001 'هذا الإجراء يقوم بإلغاء العملية السابقة Resume ExitProcedure Case Else MsgBox "خطأ رقم " & Err.Number & ": " & "الرجاء ابلاغ المبرمج بالمشكلة", vbOKOnly + vbInformation, "Officena" Resume ExitProcedure End Select	أدراج كائن ole حدث عند النقر
إدخل بيان جديد فقط	If Me.NewRecord Then Me.AllowEdits = True Else Me.AllowEdits = False End If	عند حدث الحالي On Current لنموذج
إخفاء الجدول وإظهاره بالكود	الكود المسؤول عن إخفاء الجدول CurrentDb.TableDefs("Table_namel").Attributes = dbHiddenObject الكود المسؤول عن إظهار الجدول CurrentDb.TableDefs("table1").Attributes = 0	عند حدث فتح أو تحميل نموذج (أول نموذج يفتح )
إبلاغ المستفيد بعدد الأيام المسموحة له بإستخدام البرنامج.	If Date > #11/18/2003# Then MsgBox "Time Over" DoCmd.Quit Else x = MsgBox("Time remaining" & Str(#11/18/2003# - Date) & " days , do you want to Continue ??", vbYesNo, "www.officena.com") If x = vbNo Then DoCmd.Quit End If End If	في حدث عند الفتح أو التحميل سوف يمر معنا كود أخر بشرح أفضل
عدم تغيير البيانات إلا بكلمة مرور التنبيه في حالة إضافة سجل جديد	Dim m As Integer Dim ctl As Control Dim intnewrec As Integer intnewrec = Me.NewRecord If intnewrec = True Then MsgBox " you insert a new record " Else For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.OldValue <> ctl.Value Then m = InputBox(ctl.ControlName & " value already changed Enter your password to save ?") If m = 1 Then Cancel = False Else Cancel = True ctl.Undo End If End If End If Next ctl End If	عند حدث قبل التحديث للنموذج
غلاق نموذج عن طريق نموذج آخر من خلال زر الأمر	DoCmd.Close acForm, "اسم_النموذج_الآخر_المراد_إغلاقه"
لإخفاء حقل معين أو إظهاره	إظهار حقل معين [اسم_الحقل].Visible = True إخفاء حقل معين [اسم_الحقل].Visible = False
تعطيل رسائل الحذف أو الالحاق .....	DoCmd.SetWarnings False إذا لم ينفع الكود الأول فضع هذا SetOption "Confirm Action Queries", False	ضع هذا الكود فقط قبل أمر تشغيل استعلامات الحذف أو الإلحاق أو التحديث . وذلك لتعطيل الرسائل الافتراضية التي تخرج تلقائياً في الأكسس ( أنت على وشك القيام بحذف ... ألخ ) الكود يكون قبل كود الحذف .............
نقل التركيز إلى حقل معين	[اسم_الحقل_المراد_نقل_التركيز_إليه].SetFocus نقل التركيز إلى حقل معين في نموذج فرعي [DDD]![EEE].SetFocus	DDD هو اسم النموذج الفرعي EEE هو اسم الحقل الذي في النموذج الفرعي
إلغاء الرسالة التي تخرج عند إلغاء الأمر أو حصول خطأ	On Error Resume Next	هذا الأمر يلغي الرسالة التي تخرج عند إلغاء الأمر أو حصول خطأ في الأمر.. توضع قبل الحدث
تشغيل صوت من داخل الجهاز	Call Shell("C:\windows\Sndrec32.exe /play ""C:\My Documents\alarm2.wav"" /close ", 0) يتم تحديد مكان الصوت واسمه داخل الجهاز كما هو مبين في هذا المثال "C:\My Documents\alarm2.wav" مكان الصوت في المثال هذا هو C:\My Documents اسم الصوت في المثال alarm2.wav نوع الصوت wav
تغيير الخط واللون .... في مربع نص	With [اسم مربع النص أو مربع التسمية] .FontName = "Monotype Koufi" 'نوع الخط .FontBold = True 'غامق أو غير غامق .FontSize = 60 'حجم الخط .ForeColor = 255 'لون أحمر .FontUnderline = True ' لوضع تحته خط End With	نوع الخط غامض أو غير غامض حجم الخط لون أحمر لوضع تحته خط
للتحكم في نوع الخط	[اسم مربع النص أو مربع التسمية].FontName = "Monotype Koufi"
للتحكم في كون الخط غامض أو غير غامض	[اسم مربع النص أو مربع التسمية].FontBold = True
للتحكم في حجم الخط	للتحكم في حجم الخط [اسم مربع النص أو مربع التسمية].FontSize = 60
للتحكم في لون الخط	للتحكم في لون الخط [اسم مربع النص أو مربع التسمية].ForeColor = 255 الرقم هو خاص باللون الأحمر
لوضع تحت العنوان خط	لوضع تحته خط [اسم مربع النص أو مربع التسمية].FontUnderline = True
شرح مبسط عن طريقة Select Case	Select Case [اسم_الحقل] Case Is = "ذكر" [حقل_آخر] = "رجل" Case Is = "أنثى" [حقل_آخر] = "إمرأة" End Select	شرح الكود إذا كان الحقل المسمى [اسم_الحقل] يحتوي على كلمة ذكر فتكون البيانات في الحقل المسمى [حقل_آخر] تحتوي على كلمة رجل وإذا كان الحقل المسمى [اسم_الحقل] يحتوي على كلمة أنثى فتكون البيانات في الحقل المسمى [حقل_آخر] تحتوي على كلمة إمرأة
شرح مبسط عن الجملة الشرطية If……then	If اسم_الحقل] = 50] Then DoCmd.OpenForm "نموذج رقم 1" Else DoCmd.OpenForm "نموذج رقم 2" End If	شرح الكود إذا كان الحقل المسمى [اسم_الحقل]يحتوي على الرقم 50 If [اسم_الحقل] = 50 Then فيتم فتح النموذج المسمى نموذج رقم 1 DoCmd.OpenForm "نموذج رقم 1" وإلا Else يتم فتح النموذج المسمى نموذج رقم 2 DoCmd.OpenForm "نموذج رقم 2" نهاية الجملة الشرطية
التحكم في حجم النموذج	التحكم في ارتفاع النموذج.. يتم التغيير في الرقم فقط إلى الحجم المرغوب فيه Me.Form.InsideHeight = 4150 التحكم في عرض النموذج.. يتم التغيير في الرقم فقط إلى الحجم المرغوب فيه Me.Form.InsideWidth = 8070	طريقة تحديد حجم النموذج من ناحية الارتفاع والعرض بواسطة الكود يتم وضع هذا الكود في حدث (عند الفتح) الخاص بالنموذج أو في أي حدث ترغب فيه انت
التحكم في حجم أي شئ	يتم التغيير في الأرقام إلى الحجم المرغوب فيه للارتفاع [اسم مربع النص أو مربع التسمية أو زر الأمر].Height = 2270 لليسار [اسم مربع النص أو مربع التسمية أو زر الأمر].Left = 3599 للأعلى [اسم مربع النص أو مربع التسمية أو زر الأمر].Top = 1060 للعرض [اسم مربع النص أو مربع التسمية أو زر الأمر].Width = 2904	التحكم في حجم مربع النص أو التحكم في حجم مربع التسمية أو التحكم في حجم زر الأمر أو التحكم في حجم الصورة
إظهار البيانات في نموذج من جدول آخر	في مصدر بيانات مربع النص غير المنظم الذ ي نسميه مثلاً(المدرسة) ضع السطر التالي =DLookUp(" [اسم_المدرسة] ";"بيانات_المدرسة") أما في حالة رغبتنا في وضع هذا السطر في حدث عند الفتح لأي نموذج أو تقرير فيه مربع النص هذا فيكون كما يلي المدرسة = Dlookup(" [اسم_المدرسة] ", "بيانات_المدرسة") مع ملاحظة الفرق بينهما بالفاصلة المنقوطة في السطر الأول والفاصلة غير المنقوطة في السطر الثاني	أظهار اسم المدرسة في تقرير أو نموذج مبني على استعلام أو جدول غير موجود فيه بيانات المدرسة لإظهار اسم المدرسة استعمل الكود السابق بيانات_المدرسة اسم الجدول اسم_المدرسة حقل في الجدول
عند إدخال الرقم يخرج لنا اسم الموظف	فى حالة كون حقل الشرط نصي وهو في مثالنا باسم (البطاقة) فضع الاتي اسم = DLookup("الاسم", "موظفين", "[البطاقة] = '" & Me![الرقم] & "'") فى حالة كون حقل الشرط رقمي وهو في مثالنا باسم (البطاقة) فضع الاتي اسم = DLookup("الاسم", "موظفين", "[البطاقة] = " & Me![الرقم]) ونقصد بقولنا رقمي ونصي أي نوع بيانات هذا الحقل نص أو رقم	الدالة DLookUp يسأل أحدهم فيقول : أنا عندي جدول باسم (موظفين) وفيه حقل باسم( البطاقة ) وحقل باسم ( الاسم) أريد أن أنشأ في النموذج مربعي نص غير منظم الأول باسم (الرقم) والثاني باسم ( اسم) وأريد أن أكتب في الحقل(الرقم) أي رقم أريد فيخرج لي الاسم المرتبط بهذا الرقم في الجدول طبعاً وأريد ذلك عن طريق الدالة DLookUp فكيف الطريقة الجواب كما يلي في حدث عند الخروج للحقل (الرقم) ضع الدالة هذه كما هي دون تغيير
نسخ جداول الى فلوبي	MsgBox "تأكد... من وجود قرص مرن فارغ بمحرك الأقراص", vbOKOnly, "برنامج تنظيم المعاملات" Dim wspDefault As Workspace, dbs As Database Set wspDefault = DBEngine.Workspaces(0) Set dbs = wspDefault.CreateDatabase("A:\backup.mdb", dbLangArabic) MsgBox "تم بنجاح إنشاء قاعدة البيانات وسيتم الأن نسخ البيانات إليها ... أنتظر قليلا", vbOKOnly, "برنامج تنظيم المعاملات" DoCmd.CopyObject "a:\backup", "المعاملات", acTable, "المعاملات" DoCmd.CopyObject "a:\backup", "جهة", acTable, "جهة" DoCmd.CopyObject "a:\backup", "ملف", acTable, "ملف" DoCmd.CopyObject "a:\backup", "نوع", acTable, "نوع" MsgBox "لقد تمت عملية النسخ بنجاح", vbOKOnly, "برنامج تنظيم المعاملات"	backup هذا الكود ينشئ قاعدة بيانات باسم وينسخ الجداول المحددة إليها وهناك كود آخر يستورد الجداول
إستيراد جداول من فلوبي	MsgBox "تأكد... من أن القرص المرن المنسوخة عليه البيانات موجود في محرك الأقراص", vbOKOnly, "برنامج تنظيم المعاملات" DoCmd.TransferDatabase acImport, "Microsoft Access", "a:\backup.mdb", acTable, "المعاملات", "المعاملات", False DoCmd.SetWarnings False DoCmd.OpenQuery "mo", acNormal, acEdit DoCmd.DeleteObject acTable, "المعاملات1" DoCmd.TransferDatabase acImport, "Microsoft Access", "a:\backup.mdb", acTable, "جهة", "جهة", False DoCmd.SetWarnings False DoCmd.OpenQuery "je", acNormal, acEdit DoCmd.DeleteObject acTable, "جهة1" DoCmd.TransferDatabase acImport, "Microsoft Access", "a:\backup.mdb", acTable, "ملف", "ملف", False DoCmd.SetWarnings False DoCmd.OpenQuery "ma", acNormal, acEdit DoCmd.DeleteObject acTable, "ملف1" DoCmd.TransferDatabase acImport, "Microsoft Access", "a:\backup.mdb", acTable, "نوع", "نوع", False DoCmd.SetWarnings False DoCmd.OpenQuery "nw", acNormal, acEdit DoCmd.DeleteObject acTable, "نوع1" MsgBox "لقد تمت عملية استرجاع البيانات بنجاح", vbOKOnly, "برنامج تنظيم المعاملات"	يوضع الكود عند النقر لزر. dackup إستيراد الجداول المحددة في الكود من القاعدة
لجعل النموذج شفاف	Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Const LWA_ALPHA = 2 Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000 Private Sub Form_Load() SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA End Sub
إدخال عشرة سجلات فقط في الجدول عن طريق النموذج	If DCount("q", "aa") > 10 Then MsgBox "انتهت مدة استخدام النسخة التجريبية", vbOKOnly + vbInformation, "Officena" DoCmd.Close DoCmd.Quit End If	aa الجدول اسم q اسم الحقل ضع الكود في حدث عند الفتح أو التحديث
كلمة مرور	If IsNull(Me.sss) And [rrr] = "مدير عام" Then DoCmd.Close stDocName = "رئيسي" DoCmd.OpenForm stDocName, , , stLinkCriteria Else If IsNull(Me.sss) Then MsgBox (" فضلاً يجب أن تقوم بإدخال اسم المستخدم ") Me.sss.SetFocus Exit Sub End If If IsNull(Me.rrr) Then MsgBox (" فضلاً يجب أن تقوم بإدخال كلمة المرور ") Me.rrr.SetFocus Exit Sub End If If Me.tt = 4 Then DoCmd.Quit Else If [sss] = DLookup("[ss]", "[aa]") And [rrr] = DLookup("[rr]", "[aa]") Then DoCmd.Close stDocName = "رئيسي" DoCmd.OpenForm stDocName, , , stLinkCriteria Else DoCmd.OpenForm "أعد المحاولة" Me.tt = Me.tt + 1 End If End If End If
لفتح وإغلاق النموذج بشكل جذاب1	Option Explicit Const AW_HOR_POSITIVE = &H1 'Animates the window from left to right. This flag can be used with roll or slide animation. Const AW_HOR_NEGATIVE = &H2 'Animates the window from right to left. This flag can be used with roll or slide animation. Const AW_VER_POSITIVE = &H4 'Animates the window from top to bottom. This flag can be used with roll or slide animation. Const AW_VER_NEGATIVE = &H8 'Animates the window from bottom to top. This flag can be used with roll or slide animation. Const AW_CENTER = &H10 'Makes the window appear to collapse inward if AW_HIDE is used or expand outward if the AW_HIDE is not used. Const AW_HIDE = &H10000 'Hides the window. By default, the window is shown. Const AW_ACTIVATE = &H20000 'Activates the window. Const AW_SLIDE = &H40000 'Uses slide animation. By default, roll animation is used. Const AW_BLEND = &H80000 'Uses a fade effect. This flag can be used only if hwnd is a top-level window. Const AW_ahmed = &H23 Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean '======================== Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long Const Invert = 1 '======================================== Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Const DT_BOTTOM As Long = &H8 Const DT_CALCRECT As Long = &H400 Const DT_CENTER As Long = &H1 Const DT_EXPANDTABS As Long = &H40 Const DT_EXTERNALLEADING As Long = &H200 Const DT_LEFT As Long = &H0 Const DT_NOCLIP As Long = &H100 Const DT_NOPREFIX As Long = &H800 Const DT_RIGHT As Long = &H2 Const DT_SINGLELINE As Long = &H20 Const DT_TABSTOP As Long = &H80 Const DT_TOP As Long = &H0 Const DT_VCENTER As Long = &H4 Const DT_WORDBREAK As Long = &H10 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Sub Explode(Newform As Form, Increment As Integer) On Error GoTo err_handler Dim Size As RECT ' setup form as rect type GetWindowRect Me.hwnd, Size 'Newform.hwnd Dim FormWidth, FormHeight As Integer ' establish dimension variables FormWidth = (Size.Right - Size.Left) FormHeight = (Size.Bottom - Size.Top) Dim tempdc tempdc = GetDC(ByVal 0&) ' obtain memory dc for resizing Dim Count, LeftPoint, TopPoint, nWidth, nHeight As Integer ' establish resizing variables For Count = 1 To Increment ' loop to new sizes nWidth = FormWidth * (Count / Increment) nHeight = FormHeight LeftPoint = Size.Left + (FormWidth - nWidth) / 2 TopPoint = Size.Top + (FormHeight - nHeight) / 2 Rectangle tempdc, LeftPoint, TopPoint, LeftPoint + nWidth, TopPoint + nHeight ' draw rectangles to build form 'Rectangle tempdc, 20, 0, 200, 200 Next Count DeleteDC (tempdc) ' release memory resource Exit Sub err_handler: MsgBox " Error No : " & Str(Err.Number) & " => Error Description :" & Err.Description, " Contact the System Administrator " End Sub Private Sub Form_Load() Explode Me, 3500 ' open this form by number of desired increment End Sub Private Sub Form_Close() 'fSetAccessWindow (SW_SHOWMAXIMIZED) End Sub Private Sub Form_Open(Cancel As Integer) 'fSetAccessWindow (SW_SHOWMINIMIZED) End Sub Private Sub Form_Timer() ' FlashWindow Me.hwnd, Invert End Sub Private Sub Form_Unload(Cancel As Integer) 'Animate the window On Error GoTo ahmed Dim gotoval As Integer Dim gointo As Integer gotoval = Me.InsideHeight / 2 For gointo = 1 To gotoval DoEvents Me.InsideHeight = Me.InsideHeight - 10 If Me.InsideHeight <= 11 Then GoTo horiz Next gointo horiz: Me.InsideHeight = 30 gotoval = Me.InsideWidth / 2 For gointo = 1 To gotoval DoEvents Me.InsideWidth = Me.InsideWidth - 10 If Me.InsideWidth <= 11 Then End Next gointo Beep ahmed: Exit Sub End Sub	ضع عداد الوقت 500
لتفح وإغلاق النموذج بشكل جذاب2	Option Explicit Const AW_HOR_POSITIVE = &H1 'Animates the window from left to right. This flag can be used with roll or slide animation. Const AW_HOR_NEGATIVE = &H2 'Animates the window from right to left. This flag can be used with roll or slide animation. Const AW_VER_POSITIVE = &H4 'Animates the window from top to bottom. This flag can be used with roll or slide animation. Const AW_VER_NEGATIVE = &H8 'Animates the window from bottom to top. This flag can be used with roll or slide animation. Const AW_CENTER = &H10 'Makes the window appear to collapse inward if AW_HIDE is used or expand outward if the AW_HIDE is not used. Const AW_HIDE = &H10000 'Hides the window. By default, the window is shown. Const AW_ACTIVATE = &H20000 'Activates the window. Const AW_SLIDE = &H40000 'Uses slide animation. By default, roll animation is used. Const AW_BLEND = &H80000 'Uses a fade effect. This flag can be used only if hwnd is a top-level window. Const AW_ahmed = &H23 Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean '======================== Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long Const Invert = 1 '======================================== Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Const DT_BOTTOM As Long = &H8 Const DT_CALCRECT As Long = &H400 Const DT_CENTER As Long = &H1 Const DT_EXPANDTABS As Long = &H40 Const DT_EXTERNALLEADING As Long = &H200 Const DT_LEFT As Long = &H0 Const DT_NOCLIP As Long = &H100 Const DT_NOPREFIX As Long = &H800 Const DT_RIGHT As Long = &H2 Const DT_SINGLELINE As Long = &H20 Const DT_TABSTOP As Long = &H80 Const DT_TOP As Long = &H0 Const DT_VCENTER As Long = &H4 Const DT_WORDBREAK As Long = &H10 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Sub Explode(Newform As Form, Increment As Integer) On Error GoTo err_handler Dim Size As RECT ' setup form as rect type GetWindowRect Me.hwnd, Size 'Newform.hwnd Dim FormWidth, FormHeight As Integer ' establish dimension variables FormWidth = (Size.Right - Size.Left) FormHeight = (Size.Bottom - Size.Top) Dim tempdc tempdc = GetDC(ByVal 0&) ' obtain memory dc for resizing Dim Count, LeftPoint, TopPoint, nWidth, nHeight As Integer ' establish resizing variables For Count = 1 To Increment ' loop to new sizes nWidth = FormWidth * (Count / Increment) nHeight = FormHeight LeftPoint = Size.Left + (FormWidth - nWidth) / 2 TopPoint = Size.Top + (FormHeight - nHeight) / 2 Rectangle tempdc, LeftPoint, TopPoint, LeftPoint + nWidth, TopPoint + nHeight ' draw rectangles to build form 'Rectangle tempdc, 20, 0, 200, 200 Next Count DeleteDC (tempdc) ' release memory resource Exit Sub err_handler: MsgBox " Error No : " & Str(Err.Number) & " => Error Description :" & Err.Description, " Contact the System Administrator " End Sub Private Sub Form_Load() Explode Me, 3500 ' open this form by number of desired increment End Sub Private Sub Form_Close() 'fSetAccessWindow (SW_SHOWMAXIMIZED) End Sub Private Sub Form_Open(Cancel As Integer) DoCmd.Beep 'fSetAccessWindow (SW_SHOWMINIMIZED) End Sub Private Sub Form_Unload(Cancel As Integer) 'Animate the window On Error GoTo ahmed Dim gotoval As Integer Dim gointo As Integer gotoval = Me.InsideHeight / 2 For gointo = 1 To gotoval DoEvents Me.InsideHeight = Me.InsideHeight - 10 If Me.InsideHeight <= 11 Then GoTo horiz Next gointo horiz: Me.InsideHeight = 30 gotoval = Me.InsideWidth / 2 For gointo = 1 To gotoval DoEvents Me.InsideWidth = Me.InsideWidth - 10 If Me.InsideWidth <= 11 Then End Next gointo Beep ahmed: Exit Sub End Sub
فتح وإغلاق النموذج بطريقة جذابة3	Option Compare Database Option Explicit Const AW_HOR_POSITIVE = &H1 'Animates the window from left to right. This flag can be used with roll or slide animation. Const AW_HOR_NEGATIVE = &H2 'Animates the window from right to left. This flag can be used with roll or slide animation. Const AW_VER_POSITIVE = &H4 'Animates the window from top to bottom. This flag can be used with roll or slide animation. Const AW_VER_NEGATIVE = &H8 'Animates the window from bottom to top. This flag can be used with roll or slide animation. Const AW_CENTER = &H10 'Makes the window appear to collapse inward if AW_HIDE is used or expand outward if the AW_HIDE is not used. Const AW_HIDE = &H10000 'Hides the window. By default, the window is shown. Const AW_ACTIVATE = &H20000 'Activates the window. Const AW_SLIDE = &H40000 'Uses slide animation. By default, roll animation is used. Const AW_BLEND = &H80000 'Uses a fade effect. This flag can be used only if hwnd is a top-level window. Const AW_ahmed = &H23 Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean '======================== Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long Const Invert = 1 '======================================== Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Const DT_BOTTOM As Long = &H8 Const DT_CALCRECT As Long = &H400 Const DT_CENTER As Long = &H1 Const DT_EXPANDTABS As Long = &H40 Const DT_EXTERNALLEADING As Long = &H200 Const DT_LEFT As Long = &H0 Const DT_NOCLIP As Long = &H100 Const DT_NOPREFIX As Long = &H800 Const DT_RIGHT As Long = &H2 Const DT_SINGLELINE As Long = &H20 Const DT_TABSTOP As Long = &H80 Const DT_TOP As Long = &H0 Const DT_VCENTER As Long = &H4 Const DT_WORDBREAK As Long = &H10 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Sub Explode(Newform As Form, Increment As Integer) On Error GoTo err_handler Dim Size As RECT ' setup form as rect type GetWindowRect Me.hwnd, Size 'Newform.hwnd Dim FormWidth, FormHeight As Integer ' establish dimension variables FormWidth = (Size.Right - Size.Left) FormHeight = (Size.Bottom - Size.Top) Dim tempdc tempdc = GetDC(ByVal 0&) ' obtain memory dc for resizing Dim Count, LeftPoint, TopPoint, nWidth, nHeight As Integer ' establish resizing variables For Count = 1 To Increment ' loop to new sizes nWidth = FormWidth * (Count / Increment) nHeight = FormHeight * (Count / Increment) LeftPoint = Size.Left + (FormWidth - nWidth) / 2 TopPoint = Size.Top + (FormHeight - nHeight) / 2 Rectangle tempdc, LeftPoint, TopPoint, LeftPoint + nWidth, TopPoint + nHeight ' draw rectangles to build form 'Rectangle tempdc, 20, 0, 200, 200 Next Count DeleteDC (tempdc) ' release memory resource Exit Sub err_handler: MsgBox " Error No : " & Str(Err.Number) & " => Error Description :" & Err.Description, " Contact the System Administrator " End Sub Private Sub Form_Load() Explode Me, 3500 ' open this form by number of desired increment End Sub Private Sub Form_Close() fSetAccessWindow (SW_SHOWMAXIMIZED) End Sub Private Sub Form_Open(Cancel As Integer) fSetAccessWindow (SW_SHOWMINIMIZED) End Sub Private Sub Form_Timer() FlashWindow Me.hwnd, Invert End Sub Private Sub Form_Unload(Cancel As Integer) 'Animate the window AnimateWindow Me.hwnd, 4000, AW_CENTER Or AW_HIDE '"|"AW_CENTER Or AW_HIDE '"|"AW_VER_POSITIVE Or End Sub	ملاحظة قد يتطلب هذا الكود كود إخفاء شاشة الاكسس
إخفاء شاشة الاكسس	Option Compare Database Option Explicit Global Const SW_HIDE = 0 Global Const SW_SHOWNORMAL = 1 Global Const SW_SHOWMINIMIZED = 2 Global Const SW_SHOWMAXIMIZED = 3 Private Declare Function apiShowWindow Lib "user32" _ Alias "ShowWindow" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Function fSetAccessWindow(nCmdShow As Long) 'Usage Examples 'Maximize window: ' ?fSetAccessWindow(SW_SHOWMAXIMIZED) 'Minimize window: ' ?fSetAccessWindow(SW_SHOWMINIMIZED) 'Hide window: ' ?fSetAccessWindow(SW_HIDE) 'Normal window: ' ?fSetAccessWindow(SW_SHOWNORMAL) ' Dim loX As Long Dim loForm As Form On Error Resume Next Set loForm = Screen.ActiveForm If Err <> 0 Then 'no Activeform If nCmdShow = SW_HIDE Then 'MsgBox "Cannot hide Access unless " _ & "a form is on screen" Else loX = apiShowWindow(hWndAccessApp, nCmdShow) Err.Clear End If Else If nCmdShow = SW_SHOWMINIMIZED And loForm.Modal = True Then 'MsgBox "Cannot minimize Access with " _ & (loForm.Caption + " ") _ & "form on screen" ElseIf nCmdShow = SW_HIDE And loForm.PopUp <> True Then 'MsgBox "Cannot hide Access with " _ & (loForm.Caption + " ") _ & "form on screen" Else loX = apiShowWindow(hWndAccessApp, nCmdShow) End If End If fSetAccessWindow = (loX <> 0) End Function 'ضع الكود التالي عند فتح النموذج fSetAccessWindow (SW_SHOWMINIMIZED) fSetAccessWindow (SW_HIDE)	أجعل النموذج منبثق شكلي
فتح القاعدة بعدد محدد فقط وتتوقف	Public Function MDNumForOpen() ' لجعل الرقم صفر ازل الفاصلة العلوية ثم اعد التشغيل ثم ضع الفاصلة العلوية ' CurrentDb("NumForOpen").Properties("ConutOpen").Value = 0 'Exit Function Dim رقم As Integer Call CreateMyProperty رقم = CurrentDb("NumForOpen").Properties("ConutOpen").Value If رقم >= 3 Then ' غير الرقم 5 الى عدد المرات المسموح بفتح القاعدة MsgBox "لقد استكملت عدد المرات المسموح لك بها وعددها(" & رقم & ") .", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "شكرا لك لاستخدامك القاعدة" 'الكود التالي لحذف بعض الجداول المهمة في البرنامج ' DoCmd.DeleteObject acTable, "أكتب هنا اسم الجدول المراد حذفه" DoCmd.Quit Else CurrentDb("NumForOpen").Properties("ConutOpen").Value = رقم + 1 End If End Function Private Sub CreateMyProperty() On Error GoTo err_خطأ Dim db As Database, tdf As TableDef, prp As Property Set db = Application.CurrentDb Set tdf = db.TableDefs("NumForOpen") Set prp = tdf.CreateProperty("ConutOpen") prp.Type = dbInteger prp.Value = 1 tdf.Properties.Append prp Exit_err: Exit Sub err_خطأ: If Err = 3367 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_err End If End Sub	فتح القاعدة بعدد محدد فقط وتتوقف عن العمل ويكمنك وضع كود بحذف جدول أو نموذج أو غيره عند التوقف NumForOpen ملاحظة مهمة أنشئ جدول باسم وفيه حقل واحد تحياتي
توقف البرنامج بعد مضئ ثلاث أيام من التشغيل	Private Sub Form_Open(Cancel As Integer) On Error GoTo MyErr: Dim MyFirst As Date Dim MyInDate Dim MyTableName As String MyInDate = DFirst("[Date1]", "[T1]") If Not IsNull(MyInDate) Then MyFirst = MyInDate Else DoCmd.SetWarnings False DoCmd.RunSQL ("INSERT INTO T1 ( Date1 ) SELECT Date();") DoCmd.SetWarnings True MyFirst = Date End If If MyFirst <= Date - 3 Then '[color=green] غير الرقم من 3 الى اي عدد تريد[/color] MsgBox "مضى على التشغيل 3 ايام وسيتم ايقافه" Call TableDelete Else If MyFirst > Date Then MsgBox "تم التلاعب بتاريخ الجهاز وسيتم ايقاف تشغيله" Call TableDelete End If End If Exit Sub MyErr: If Err.Number = 3078 Then MsgBox "تم تعطيل البرنامج" ' Quit 'قمت بتعطيل الامر خروج لتروا الطريقة Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub Function TableDelete() On Error Resume Next Dim MyDb As Database Dim MyTable As TableDef Dim MyTableCount As Integer Set MyDb = Application.CurrentDb MyTableCount = MyDb.TableDefs.Count For i = MyTableCount - 1 To o Step -1 Set MyTable = MyDb.TableDefs(i) MyTableName = MyTable.Name If Left$(MyTableName, 4) <> "Msys" Then MyDb.TableDefs.Delete (MyTableName) Next MyDb.Close End Function	'الشرح 'جربت الكود على السريع بالخطوات التالية : '1- انشئ نموذج وضع الوحدة النمطية كلها قص ولصق فى النموذج وذلك عن طريق ( عرض ثم تعليمات برمجية ) . '2- احفظ النموذج . '3- انشئ جدول وسمه باسم t1 وضع بداخله حقل تاريخ اسمه date1 ولا تضع فيه أي تاريخ '4- قم بتشغيل النموذج ستجد أنه يفتح عادي بدون مشاكل . '5- اذهب وافتح الجدول ستجد تاريخ اليوم بداخله . '6- غير التاريخ إلى قبل تاريخ اليوم بثلاث أو اربع أيام . '7- قم بتشغيل النموذج مرة أخرى . 'ستظهر لك رسائل البرنامج . وستلاحظ أن الجدول قد تم حذفه '8.بإضافة المرجع التالي من قائمة المراجع References : 'Microsoft DAO 3.6 Object Library
لفتح النموذج بشكل جذاب 3	'Add a module to your project (In the menu choose Project -> Add Module, Then click Open) 'Add 1 Command Button to your form. 'Insert the following code to your module: Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal _ hdc As Long) As Long Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal _ crColor As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, _ ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject _ As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Sub ExplodeForm(f As Form, Movement As Integer) Dim myRect As RECT Dim formWidth%, formHeight%, i%, x%, y%, Cx%, Cy% Dim TheScreen As Long Dim Brush As Long GetWindowRect f.hWnd, myRect formWidth = (myRect.Right - myRect.Left) formHeight = myRect.Bottom - myRect.Top TheScreen = GetDC(0) For i = 1 To Movement Cx = formWidth * (i / Movement) Cy = formHeight * (i / Movement) x = myRect.Left + (formWidth - Cx) / 2 y = myRect.Top + (formHeight - Cy) / 2 Rectangle TheScreen, x, y, x + Cx, y + Cy Next i x = ReleaseDC(0, TheScreen) DeleteObject (Brush) End Sub Private Sub ImplodeForm(f As Form, Movement As Integer) Dim myRect As RECT Dim formWidth%, formHeight%, i%, x%, y%, Cx%, Cy% Dim TheScreen As Long Dim Brush As Long GetWindowRect f.hWnd, myRect formWidth = (myRect.Right - myRect.Left) formHeight = myRect.Bottom - myRect.Top TheScreen = GetDC(0) For i = Movement To 1 Step -1 Cx = formWidth * (i / Movement) Cy = formHeight * (i / Movement) x = myRect.Left + (formWidth - Cx) / 2 y = myRect.Top + (formHeight - Cy) / 2 Rectangle TheScreen, x, y, x + Cx, y + Cy Next i x = ReleaseDC(0, TheScreen) DeleteObject (Brush) End Sub 'Insert this code to your form: 'Private Sub Command1_Click() 'Replace all the '500' below with the Speed of the Explode\Implode Effect. 'Call ImplodeForm(Me, 500) 'End 'Set Form1 = Nothing 'End Sub Private Sub Form_Load() Call ExplodeForm(Me, 4000) End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Call ImplodeForm(Me, 4000) End Sub
شاشة حوار الرمز	Private Const VER_PLATFORM_WIN32_NT = 2 Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long Private Declare Function SHChangeIconDialogA Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As String, ByVal Reserved As Long, lpIconIndex As Long) As Long Private Declare Function SHChangeIconDialogW Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As Long, ByVal Reserved As Long, lpIconIndex As Long) As Long 'Detect if the program is running under Windows NT Public Function IsWinNT() As Boolean Dim myOS As OSVERSIONINFO myOS.dwOSVersionInfoSize = Len(myOS) GetVersionEx myOS IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT) End Function Public Function chooseIcon(ByRef strFile As String, ByRef lngIconNum As Long) As Boolean Dim str1 As String * 260 Dim lng1 As Long ' Dummy? Dim lngResult As Long str1 = strFile & vbNullChar 'is this code executed under WinNT? If IsWinNT Then 'if we're in WinNT, we have to call the Unicode version of the function lngResult = SHChangeIconDialogW(Me.hWnd, StrPtr(str1), lng1, lngIconNum) Else 'if we're in Win9x, we have to call the ANSI version of the function lngResult = SHChangeIconDialogA(Me.hWnd, str1, lng1, lngIconNum) End If 'The function itself returns 0 (failed) or 1 (success) 'str1 is adapted to the selected filename chooseIcon = (lngResult <> 0) If chooseIcon Then strFile = Left$(str1, InStr(1, str1, vbNullChar, vbBinaryCompare) - 1) End If End Function Private Sub Form_Load() 'KPD-Team 1999, 2001 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net 'additional coding by Willem Bogaerts, w-p@dds.nl chooseIcon "shell32.dll", 0 End Sub
تكبير النموذج بكامل أجزائه	'ضخ الكود التالي في حدث عند النقر FormResize Me, 1.2 'ضع الكود التالي في وحدة نمطية Public Sub FormResize(ByRef F As Form, N As Single) On Error Resume Next Dim C As Control, S1 As String, S2 As String, k As String Dim R As Integer, I1 As Integer, I2 As Integer, g As Integer With F .InsideHeight = .InsideHeight * N .InsideWidth = .InsideWidth * N .Section(0).Height = .Section(0).Height * N .Section(1).Height = .Section(1).Height * N .Section(2).Height = .Section(2).Height * N End With For Each C In F C.Left = C.Left * N C.Top = C.Top * N C.Width = C.Width * N C.Height = C.Height * N C.FontSize = C.FontSize * N If C.ControlType = 110 Or C.ControlType = 111 Then g = C.ColumnCount - 1 S1 = C.ColumnWidths I1 = 1 S2 = "" For R = 0 To g I2 = InStr(I1, S1, ";") If I2 = 0 Then I2 = Len(S1) + 1 k = Str(Int(Val(Mid(S1, I1, I2 - I1)) * N)) & ";" S2 = S2 + k I1 = I2 + 1 Next C.ColumnWidths = S2 End If Next End Sub
إظهار التقرير في حالة كون خاصية النموذج منبثق	عند فتح التقرير في حدث عند نقر زر أمر ضع DoCmd.OpenReport "اسم التقرير", acViewPreview Me.Visible = False وفي حدث عند الإغلاق للتقرير ضع السطر التالي Forms![اسم النموذج المنبثق].Visible = True
الطباعة على وجهي الورقة	DoCmd.OpenReport "بيانات الموظف" MsgBox "أقلب الورقة لطباعة الإجازات " DoCmd.OpenReport "الإجازات والدورات"	لن تتم طباعة الوجه الثاني في هذه الحالة حتى يضغط زر موافق طريقة طباعة ورقة من جهتين نفرض أن لديك تقريرين الأول اسمه بيانات الموظف والثاني اسمه الإجازات والدورات فنطبع الأول ثم نظهر رسالة تطلب قلب الورقة وفيها زر موافق فإذا ضغط عليه تتم طباعة الوجه الثاني والذي هو الدورات . الطريقة كما يلي : في حدث عند النقر للزر الذي يقوم بطباعة التقرير الأول نضع الكود هذا :
إظهار رسالة تنبيه قبل إلغاء سجل	If MsgBox("ستقوم الآن بحذف سجل :" & vbCrLf _ & [اسم_الحقل] & vbCrLf _ & "هل أنت متأكد ؟" & vbCrLf _ & " " & vbCrLf _ & "أضغط (نعم) للإستمرار أو (لا) لإلغاء الأمر.", vbQuestion + vbYesNo _ + vbMsgBoxRight + vbMsgBoxRtlReading, "تنبيــــه") = vbYes Then Application.SetOption "Confirm Record Changes", False DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70 DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70 End If End Sub	إظهار رسالة تنبيه للمستخدم قبل إلغاء سجل.
السماح بثلاث محاولات لتجربة كلمة المرور	Private Sub amr1_Click() s = s + 1 Select Case s Case 1 form1 = "الواجهة" pass = [Forms]![pass1]![a] If IsNull([a]) Or [a] <> pass Then MsgBox "كلمة المرور غير صحيحة.هذه المحاولة الاولى ،،، باقي لك محاولتان فقط للدخول لقائمة البرنامج!!!!" Else DoCmd.Close DoCmd.OpenForm form1 End If Case 2 form1 = "الواجهة" pass = [Forms]![pass1]![a] If IsNull([a]) Or [a] <> pass Then MsgBox "كلمة المرور غير صحيحة.هذه المحاولة الثانية ،،، باقي لك محاولة واحدة للدخول لقائمة البرنامج !!!!" Else DoCmd.Close DoCmd.OpenForm form1 End If Case 3 form1 = "الواجهة" pass = [Forms]![pass1]![a] If IsNull([a]) Or [a] <> pass Then MsgBox "كلمة المرور غير صحيحة.هذه المحاولة الثالثة والاخيرة للدخول لقائمة البرنامج !!!!" MsgBox "عفوا ،،،، لقد كانت جميع المحاولات للدخول للبرنامج كلها خطأ ،،،، سوف تخرج من البرنامج !!!!" DoCmd.Quit Else DoCmd.Close DoCmd.OpenForm form1 End If End Select End Sub	إذهب للنموذج ( pass4 ) ، و أنشئ عليه حقلين غير منضمين الأول: سمه ( a ) والثاني: سمه ( S ) اجعل القيمة الافتراضية للحقل ( S ) : صفر إي ( 0 ) قم بلصق الكود أعلاه في حدث عند النقر لزر أمر مكتوب عليه ( موافق ) واسمه ( amr1 )
تأكيد خروج	If MsgBox("هل أنت متأكد من الخروج ", vbYesNo, "رسالة تأكيد ") = vbYes Then DoCmd.Quit End If 'وإذا ما نفع a = MsgBox("هل تريد الخروج من البرنامج ؟", vbYesNo, "رسالة تأكيد") If a = vbYes Then DoCmd.Quit
تشغيل صوت عند النقر	r = sndPlaySound("C:\WINDOWS\MEDIA\notify.wav", 1)	ضع الكود التالي في بداية صفحة الأكواد بعد السطر الأول Dim a As Boolean Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
لمعرفة مسار البرنامج	Label1.Caption = CurDir$ mydrive$ = Left$(CurDir$, 1)	Ladel1 نحتاج الى مربع تسمية ونسمية
النسخ الاحتياطي	Option Compare Database Option Explicit Private Type SHITEMID 'mkid cb As Long abID As Byte End Type Private Type ITEMIDLIST 'idl mkid As SHITEMID End Type Private Type BROWSEINFO 'bi hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _ (lpBrowseInfo As BROWSEINFO) As Long Private Const BIF_RETURNONLYFSDIRS = &H1 Private Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Private Const FO_MOVE As Long = &H1 Private Const FO_COPY As Long = &H2 Private Const FO_DELETE As Long = &H3 Private Const FO_RENAME As Long = &H4 Private Const FOF_MULTIDESTFILES As Long = &H1 Private Const FOF_CONFIRMMOUSE As Long = &H2 Private Const FOF_SILENT As Long = &H4 Private Const FOF_RENAMEONCOLLISION As Long = &H8 Private Const FOF_NOCONFIRMATION As Long = &H10 Private Const FOF_WANTMAPPINGHANDLE As Long = &H20 Private Const FOF_CREATEPROGRESSDLG As Long = &H0 Private Const FOF_ALLOWUNDO As Long = &H40 Private Const FOF_FILESONLY As Long = &H80 Private Const FOF_SIMPLEPROGRESS As Long = &H100 Private Const FOF_NOCONFIRMMKDIR As Long = &H200 Private Declare Function apiSHFileOperation Lib "shell32.dll" _ Alias "SHFileOperationA" _ (lpFileOp As SHFILEOPSTRUCT) _ As Long Function fMakeBackup() As Boolean Dim strMsg As String Dim tshFileOp As SHFILEOPSTRUCT Dim lngRet As Long Dim strSaveFile As String Dim lngFlags As Long Dim FolderToCopy Const cERR_USER_CANCEL = vbObjectError + 1 Const cERR_DB_EXCLUSIVE = vbObjectError + 2 On Local Error GoTo fMakeBackup_Err If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE strMsg = "هل تريد عمل نسخة إحتياطية لهذا البرنامج ؟" If MsgBox(strMsg, vbQuestion + vbYesNo + vbMsgBoxRight + _ vbMsgBoxRtlReading, "تأكيد النسخ") = vbNo Then _ Err.Raise cERR_USER_CANCEL lngFlags = FOF_SIMPLEPROGRESS Or _ FOF_FILESONLY Or _ FOF_RENAMEONCOLLISION strSaveFile = CurrentDb.Name With tshFileOp .wFunc = FO_COPY .hwnd = hWndAccessApp .pFrom = CurrentDb.Name & vbNullChar FolderToCopy = BrowseForFolder If Len(FolderToCopy & "") = 1 Then Exit Function Else .pTo = FolderToCopy End If .fFlags = lngFlags End With lngRet = apiSHFileOperation(tshFileOp) fMakeBackup = (lngRet = 0) fMakeBackup_End: Exit Function fMakeBackup_Err: fMakeBackup = False Select Case Err.Number Case cERR_USER_CANCEL: 'do nothing Case cERR_DB_EXCLUSIVE: MsgBox "The current database " & vbCrLf & CurrentDb.Name & vbCrLf & _ vbCrLf & "is opened exclusively. Please reopen in shared mode" & _ " and try again.", vbCritical + vbOKOnly, "Database copy failed" Case Else: strMsg = "Error Information..." & vbCrLf & vbCrLf strMsg = strMsg & "Function: fMakeBackup" & vbCrLf strMsg = strMsg & "Description: " & Err.Description & vbCrLf strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf MsgBox strMsg, vbInformation, "fMakeBackup" End Select Resume fMakeBackup_End End Function Private Function fCurrentDBDir() As String Dim strDBPath As String Dim strDBFile As String strDBPath = CurrentDb.Name strDBFile = Dir(strDBPath) fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1) End Function Function fDBExclusive() As Integer Dim hFile As Integer hFile = FreeFile On Error Resume Next Select Case Err Case 0 fDBExclusive = False Case 70 fDBExclusive = True Case Else fDBExclusive = Err End Select Close hFile On Error GoTo 0 End Function Private Sub أمر0_Click() Call fMakeBackup End Sub Private Function BrowseForFolder() Dim bi As BROWSEINFO Dim IDL As ITEMIDLIST Dim pidl As Long Dim R As Long Dim pos As Integer Dim spath As String Dim lblSelected As String bi.pidlRoot = 0& bi.lpszTitle = " برنامج الدوريات الامنية بمنطقة حائل بحائل حدد وجهة النسخة الاحتياطية ؟" bi.ulFlags = BIF_RETURNONLYFSDIRS pidl& = SHBrowseForFolder(bi) spath$ = Space$(512) R = SHGetPathFromIDList(ByVal pidl&, ByVal spath$) If R Then pos = InStr(spath$, Chr$(0)) 'pos = spath lblSelected = Left(spath$, pos - 0) Else: lblSelected = "" End If BrowseForFolder = lblSelected & "\" End Function	ضغ الكود في وحدة نمطية وسمة وضع زر أمر وغند النقر أكتب التالي =fMakeBackup()
رسالة إدخال كلمة مرور على شكل نجوم	TimerId = SetTimer(0, 0, 1, AddressOf TimerProc) str_Title = "كلمة المرور مطلوبة" str_Prompt = "فضلاً ادخل كلمة المرور الخاصة بالتعديل والكف" If InputBox(str_Prompt, str_Title) = DLookup("[rr]", "[aaa]") Then DoCmd.OpenForm "السيارات للتعديل", acNormal, "", "[tc]=[Forms]![السيارات]![tc]", , acNormal Else MsgBox "من حسن إسلام المرء تركة مالا يعنية" End If	DoCmd.OpenForm "السيارات للتعديل", acNormal, "", "[tc]=[Forms]![السيارات]![tc]", , acNormal شرح الكود أفتح نموذج السيارات للتعديل على نفس السحل المعروض في نموذج السيارات ملاحظة لا بد من وضع كود في وحدة نمطية وهو Declare Function SetTimer Lib "user32" (ByVal hwnd _ As Long, ByVal nIDEvent As Long, ByVal uElapse _ As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long) _ As Long Declare Function FindWindowEx Lib "user32" _ Alias "FindWindowExA" (ByVal hWndParent As _ Long, ByVal hWndChildAfter As Long, ByVal _ lpClassName As String, ByVal lpWindowName _ As String) As Long Declare Function Sendmessagebynum _ Lib "user32" Alias "SendMessageA" (ByVal _ hwnd As Long, ByVal wMsg As Long, ByVal _ wParam As Long, ByVal lParam As Long) _ As Long Const EM_SETPASSWORDCHAR = &HCC Public str_Title$, TimerId& Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) KillTimer 0, TimerId Dim lng_Hwnd& lng_Hwnd = FindWindowEx(0, 0, "#32770", _ Trim(str_Title)) lng_Hwnd = FindWindowEx(lng_Hwnd, 0, _ "Edit", vbNullString) If lng_Hwnd Then Sendmessagebynum lng_Hwnd, EM_SETPASSWORDCHAR, 42, 0 End If End Sub
تغيير عنوان زر الامر	If أمر16.Caption = "إجراء بحث" Then أمر16.Caption = "إنهاء البحث" ElseIf أمر16.Caption = "إنهاء البحث" Then أمر16.Caption = "إجراء بحث"
إنشاء مجلد	Dim Security As SECURITY_ATTRIBUTES Ret& = CreateDirectory("c:\aa", Security) If Ret& = 0 Then MsgBox "Error : Couldn't create directory !", vbCritical + vbOKOnly	ضع الكود التالي في أول الاكواد في الصفحة بعد السطر الأول Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type
تهيئة الفلوبي	Private Sub Command1_Click() 'Place the following code in under a command button or in a menu, etc... Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg% ' DriveLetter = UCase(Drive1.Drive) ' DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0 ' DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Else RetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf & _ "drive! Format this drive?", 276, "SHFormatDrive Example") Select Case RetFromMsg Case 6 'Yes ' UnComment to do it... RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Case 7 'No ' Do nothing End Select End If	ضع الكود التالي في أول صفحة الاكواد Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
نسخ الفلوبي	'Place the following code in under a command button or in a menu, etc... ' DiskCopyRunDll takes two parameters- From and To Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg& ' DriveLetter = UCase(Drive1.Drive) ' DriveNumber = (Asc(DriveLetter) - 65) ' DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " _ & DriveNumber & "," & DriveNumber, 1) 'Notice space after Else ' Just in case 'DiskCopyRunDll RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _ "be diskcopied!", 64, "DiskCopy Example") End If	الكود في أول الصفحة Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
لتأكد من وجود ملف	Private Sub Command1_Click() On Error GoTo Error: Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1 Close MsgBox ("الملف موجود") Exit Sub Error: MsgBox ("الملف غير موجود") End Sub