اكواد تعليمية اختر ما تحتاجة
كمية كبيرة من الاكواد والشرح
جرب حتما ستحتاجها وقتا ما
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 '
غير الرقم من 3 الى اي عدد تريد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.nlchooseIcon "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