كشكول VBA ... متجدد

[أبو آدم]

بناء الجمل ومحددات الصيغ ......... The syntax & delimiters

عند كتابة معايير لقيمة منطقية (صواب/خطأ)، أرقام، السلاسل، والتواريخ، يتطلب بناء الجملة محددات للسلاسل (الجمل) والتواريخ.

ويكون بناء الجملة في حالاتها كما يلي :

للقيم المنطقية والارقام لا نستخدم شيئا مميزا >> Boolean & numbers

x = DLookUp("[MyField]", "MyTable", "[OtherField] = " & Me.txtTextbox

سلاسل استخدام صيغ (أو "علامات الاقتباس المفردة"). >> Strings

x = DLookUp("[MyField]", "MyTable", "[OtherField] = '" & Me.txtTextbox & "'"

وللتاريخ تستخدم الصيغة الخاصة بها مع علامة المربع المشهورة. >> Dates

x = DLookUp("[MyField]", "MyTable", "[OtherField] = #" & Me.txtTextbox & "#"

[ابو ياسر]

زادك الله علما وأسبغ عليك نعمه

[أبو آدم]

شرفت بمرورك أخي ابو ياسر

شكرا لدعائك الطيب

[أبو آدم]

معايير التقرير (التاريخ) ...... report parameters

غالبا ما نستخدم حصر نتائج التقرير بين تاريخين ، تاريخ بداية و تاريخ نهاية ، وكل له فيها طريقة ، اريد انشاء نموذج لتمرير التواريخ للتقرير ، التقارير عندي يومية واسبوعية وشهرية وسنوية (لنفس التقرير) ، اريد طريقة بحيث لا اضطر لكتابة التواريخ وإحتساب الفترات ، أو استخدام التقويم ؟!!

بسيطة ...

ننشيئ النموذج بمربعي نص الاول txtdatefrom لتاريخ البداية ، والثاني txtDateTo لتاريخ النهاية ، ثم ننشيئ أربعة أزرار أمر :

الاول لضبط نطاق التاريخ للتقرير اليومي ، ونسميه cmdtoday ، ونضع خلفه الكود

Private Sub cmdtoday_Click()

	Me!txtdatefrom = Date

	Me!txtDateTo = Date

End Sub

الثاني لضبط نطاق التاريخ الاسبوعي ، ونسميه cmdweek ، ونضع خلفه الكود

Private Sub cmdweek_Click()

	Dim today

	today = Weekday(Date)


	Me!txtdatefrom = DateAdd("d", (today * -1) + 2, Date)

	Me!txtDateTo = DateAdd("d", 6 - today, Date)

End Sub

الثالث لضبط نطاق التاريخ الشهري ، ونسميه cmdmonth ، ونضع خلفه الكود

Private Sub cmdmonth_Click()

	Me!txtdatefrom = CDate("01/" & Month(Date) & "/" & Year(Date))

	Me!txtDateTo = DateAdd("d", -1, DateAdd("m", 1, Me!txtdatefrom))

End Sub

والرابع لضبط نطاق التاريخ السنوي ، ونسميه cmdyear ، ونضع خلفه الكود

Private Sub cmdyear_Click()

	Me!txtdatefrom = CDate("01/01/" & Year(Date))

	Me!txtDateTo = DateAdd("d", -1, DateAdd("yyyy", 1, Me!txtdatefrom))


End Sub

وأخيرا ننشيئ زر أمر للتأكد من ادخال البيانات الى الحقلين المعنيين ، ثم للطباعة أو الغاء الامر ، ونسميه cmdReport ، ونضع خلفه الكود

Private Sub cmdReport_Click()

	On Error GoTo Err_cmdReport_Click

	Dim stDocName As String

	stDocName = "rptDateParameterReport"


	If Len(Me.txtdatefrom & vbNullString) = 0 Or Len(Me.txtDateTo & vbNullString) = 0 Then

		MsgBox "Please ensure that a report date range is entered into the form", _

			   vbInformation, "Required Data..."

		Exit Sub

	Else

		DoCmd.OpenReport stDocName, acPreview

	End If

Exit_cmdReport_Click:

	Exit Sub

Err_cmdReport_Click:

	MsgBox Err.Description

	Resume Exit_cmdReport_Click

End Sub

وكفى ...

وصحتين وعافية ... جرب

..........

[أبو آدم]

عدم وجود معلومات في النموذج ... No records to support form display

في نموذج البحث وعند محاولة عرض نتائج البحث في نموذج ثاني منفصل ، وعند عدم وجود نتائج للبحث يظهر النموذج فارغا أو تظهر رسالة خطأ.

أريد رسالة تنبيه بعدم وجود معلومات في النموذج كنتائج بحث ، كما في التقارير !!!

الحل في الكود التالي ، وينسخ في حدث عند الفتح للنموذج الثاني (إظهار نتائج البحث) ، حيث يتم تنبيه المستخدم برسالة ، ثم يعود لنموذج البحث ويفرغ حقل نص البحث .

Private Sub Form_Open(Cancel As Integer)

On Error Resume Next

	If Me.RecordsetClone.RecordCount = 0 Then

	MsgBox "No records to support form display", vbExclamation, "System Message"

	DoCmd.CancelEvent

	Forms!frmSearchD!txtSearchText.SetFocus

	Forms!frmSearchD!txtSearchText = ""

	Exit Sub

	End If

End Sub

بسيطة ؟

..............

[أبو آدم]

نطاق السنوات ... Year Loop

نحتاج قائمة تحرير وسرد توفر لنا في صفوفها لإختيار السنوات عشرٌ مرت وعشرٌ قادمات ، بحيث لا يكون مصدر الصف جدول أو قائمة قيم ، بحيث تكون متغيرة عبر السنوات بدون أن نضطر لتغييرها وتعديلها ، مستندة للسنة الحالية !!

كل ما عليك فعله : إنشاء وحدة نمطية جديدة ولصق الكود التالي بها ، ومن ثم حفظها ...

Function YearLoop() As String

Dim YearHold As Date

Dim strSQL   As String

Dim i	    As Integer

Dim n	    As Integer

    n = 10

    strSQL = ""


    For i = -10 To n

	   YearHold = DateSerial(Year(Date) + i, 1, 1)

	   strSQL = strSQL & Format(YearHold, "yyyy") & "; "

    Next i


    YearLoop = strSQL

End Function

وفي حدث عند الفتح للنموذج نضع الكود لتكون نتائج الوحدة النمطية مصدر الصف لقائمة التحرير والسرد Text7

Private Sub Form_Load()

Me.Text7.RowSource = YearLoop()

End Sub

وحين نفتح النموذج يكون أمامك عشر سنوات سابقة بالاضافة للسنة الحالية وعشر سنوات قادمات ......... للإختيار منها

[الصمت المتحدث]

ما شاء الله عليك أخي نارت

ما كل هذه الدرر

صراحة زاد يستحق الثتبيت حتى تعم الفائدة و إظفاء الجديد من بنات الأفكار على الكشكول

[الصمت المتحدث]

نطاق السنوات ... Year Loop

نحتاج قائمة تحرير وسرد توفر لنا في صفوفها لإختيار السنوات عشرٌ مرت وعشرٌ قادمات ، بحيث لا يكون مصدر الصف جدول أو قائمة قيم ، بحيث تكون متغيرة عبر السنوات بدون أن نضطر لتغييرها وتعديلها ، مستندة للسنة الحالية !!

كل ما عليك فعله : إنشاء وحدة نمطية جديدة ولصق الكود التالي بها ، ومن ثم حفظها ...

Function YearLoop() As String

Dim YearHold As Date

Dim strSQL   As String

Dim i		As Integer

Dim n		As Integer

	n = 10

	strSQL = ""


	For i = -10 To n

	   YearHold = DateSerial(Year(Date) + i, 1, 1)

	   strSQL = strSQL & Format(YearHold, "yyyy") & "; "

	Next i


	YearLoop = strSQL

End Function

وفي حدث عند الفتح للنموذج نضع الكود لتكون نتائج الوحدة النمطية مصدر الصف لقائمة التحرير والسرد Text7

Private Sub Form_Load()

Me.Text7.RowSource = YearLoop()

End Sub

وحين نفتح النموذج يكون أمامك عشر سنوات سابقة بالاضافة للسنة الحالية وعشر سنوات قادمات ......... للإختيار منها

هل يمكن تطبيق نفس المثال على الأشهر؟

[أبو آدم]

قيمة تلقائية في مربع التحرير و السرد !!

لدي مربع تحرير وسرد يعتمد في مربع تحرير وسرد آخر ، أريد بعد الخروج من المربع الأول أن يظهر في المربع الثاني قيمة الصف الأول بشكل تلقائي قبل الإختيار !!!

نستخدم الكود التالي في المكان المناسب حسب الحال ( مثلاً :في حدث بعد التحديث أو حدث عند الخروج للمربع الأول )

	  Me!ValueToFind.Requery

	  Me!ValueToFind.Value = Me!ValueToFind.ItemData(0)

على إعتبار أن ValueToFind إسم مربع التحرير والسرد المستهدف (بالإجراء) !!! ...

.................

[أبو آدم]

عند التعامل مع الجداول المرتبطة يفضل عند تشغيل التطبيق إجراء الربط ، وعند إنهاء التطبيق إلغاء الإرتباط بحذف الجداول المرتبطة ، ولإجراء هذا الأخير نستخدم الوحدة النمطية التالية :

Public Function DetachAllTables()

Dim db As Database

Dim tdf As Object

Set db = CurrentDb()

For Each tdf In db.TableDefs

If tdf.Attributes = dbAttachedTable Then

DoCmd.DeleteObject acTable, tdf.Name

End If

Next tdf

db.TableDefs.Refresh

Set db = Nothing

End Function

كلمات مفتاحية : وحدة نمطية ، حذف الجداول المرتبطة

والله من وراء القصد ...........

.......................

[أبو آدم]

لجلب قيمة لقاعدة البيانات الحالية من قاعدة بيانات خارجية ، من جدول محدد ومن حقل محدد على شرط القيمة الأعلى (مثلاً) أو غير ذلك من تصفية أو بحث أو غيره ، وذلك عن طريق جملة SQL ، فالأمر يتعلق بفتح القاعدة الخارجية و إجراء اللازم ثم مغادرتها بعد الحصول على النتائج المرجوة.

المسار :

E:\NA_LinkDetach2003.mdb

الجدول:

Symbols_Companies_markets

الحقل:

NoID

اسم مربع النص في النموذج :

vMaxField1

بالتالي يصبح الكود كما يلي:

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim strSQL As String

strSQL = "SELECT Max([Symbols_Companies_markets].[NoID]) AS [MaxOffield1]" _

& "FROM [Symbols_Companies_markets] IN 'E:\NA_LinkDetach2003.mdb';"

Set db = CurrentDb

Set rs = db.OpenRecordset(strSQL)

vMaxField1 = rs!MaxOfField1

rs.Close

Set rs = Nothing

[أبو آدم]

نحتاج أحياناً لإستخدام ملفات صوتية من امتداد WAV ، وفي أحوال معينة نحتاج للتعرف على الفترة الزمنية للتشغيل (طول الملف بالدقيقة) ، وللحصول على هذه المعلومة

أنشيئ وحدة نمطية جديدة وإنسخ اليها:

Option Compare Database

Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Function GetMediaLength(FileName As String)

Dim MediaLength As Long

Dim RetString As String * 256

Dim CommandString As String

'open the media file

CommandString = "Open " & FileName & " alias MediaFile"

mciSendString CommandString, vbNullString, 0, 0&

'get the media file length

CommandString = "Set MediaFile time format milliseconds"

mciSendString CommandString, vbNullString, 0, 0&

CommandString = "Status MediaFile length"

mciSendString CommandString, RetString, Len(RetString), 0&

GetMediaLength = CLng(RetString)

'close the media file

CommandString = "Close MediaFile"

mciSendString CommandString, vbNullString, 0, 0&

End Function

وعند الحاجة إستدعي الوحدة النمطية كما يلي:

Dim Seconds, Minutes As Integer

Dim MilliSeconds As Long

' replace "E:\working.wav" with the path to your media file

MilliSeconds = GetMediaLength("E:\working.wav")

' the function GetMediaLength return the media length in milliseconds,

' so we will calculate the total minutes and seconds

Seconds = Int(MilliSeconds / 1000) Mod 60

Minutes = Int(MilliSeconds / 60000)

MilliSeconds = MilliSeconds Mod 1000

TotalTime = Minutes & ":" & Seconds & ":" & MilliSeconds

MsgBox (TotalTime)

جرّب ......

والله من وراء القصد ... وهو حسبي

[أبو آدم]

الإستيراد والربط من المشاكل التي تؤرق الكثيرين ... وتكون محور ضعف ... دعونا نبدأ مع الإكسيل نستورد أو نربط ملف الإكسيل وتتعدد المناهج والطرق وبين أخذ وردّ ، والورقة الأولى و الثانية و ...... دعونا نختصر الموضوع ... نربط أو نستورد جميع الأوراق ... وحين يتم الربط نختلف على مكان الملف وبحث وذهاب وإياب و ... و... ، دعونا نختصر الموضوع ونضع ملف الإكسيل في نفس مجلد القاعدة ، ونقوم بما يسميه أبو آدم "الربط الممنهج " ونقوم بالربط حين نحتاجه ، ثم حين تنتهي الحاجة ، نسقط ونلغى عملية الربط .

كل هذا بهدوء وبدون ضغط قاعدة البيانات أو ازعاجها وبضغطة زر يتم الربط وباخرى ينتهي الربط ، و لجميع الأوراق

Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean

Dim lngCount As Long

Dim objExcel As Object, objWorkbook As Object

Dim colWorksheets As Collection

Dim strPathFile As String

Dim strPassword As String

On Error Resume Next

Set objExcel = GetObject(, "Excel.Application")

If Err.Number <> 0 Then

	  Set objExcel = CreateObject("Excel.Application")

	  blnEXCEL = True

End If

Err.Clear

On Error GoTo 0

blnHasFieldNames = True

strPathFile = CurrentProject.Path & "\Book1.xls"

strPassword = "passwordtext"

blnReadOnly = True

Set colWorksheets = New Collection

Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _

	  strPassword)

For lngCount = 1 To objWorkbook.Worksheets.Count

	  colWorksheets.Add objWorkbook.Worksheets(lngCount).Name

Next lngCount

objWorkbook.Close False

Set objWorkbook = Nothing

If blnEXCEL = True Then objExcel.Quit

Set objExcel = Nothing

For lngCount = colWorksheets.Count To 1 Step -1

	  DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9, _

			"tbl" & colWorksheets(lngCount), strPathFile, blnHasFieldNames, _

			colWorksheets(lngCount) & "$"


Next lngCount

Set colWorksheets = Nothing

End Sub

ولنودع الربط ...

Public Sub DetachAllTables()

Dim db As Database

Dim tdf As Object

Set db = CurrentDb()

For Each tdf In db.TableDefs

If tdf.Attributes = dbAttachedTable Then

DoCmd.DeleteObject acTable, tdf.Name

End If

Next tdf

db.TableDefs.Refresh

Set db = Nothing

End Sub

والسلام ختام

........... ...........

........................................

[أبو آدم]

إخوتي الفضلاء

طبعاً يتعذر في مثل هذه المواضيع قبول المشاركات ... لا تقليلاً لاسمح الله من أهميتها ولكن منعاً لتضخم الموضوع ومشاركاته ، وما يتبع ذلك من جهد تنقيح المشاركات للقادمين من بعدنا.

ولكنني التمس من اخوتي المساهمة بالتعبير عن إستفادتهم من الموضوع ومشاركاته وأجزائه المتلاحقة بإذن الله .

وذلك بالضغط على زر التقدير في أسفل يسار المشاركة التي يكون قد استفاد منها أو أعجبته أو إستخدم ما تحوى

وشكرا للجميع تقديركم وتشجيعكم لي للمتابعة ....

[أبو آدم]

الكود التالي يعيد كافة القيم الإفتراضية لحقول النموذج ، وكأننا ننتقل لسجل جديد ...

Private Sub btnClear_Click()


    Dim ctl As Control


    On Error Resume Next


    For Each ctl In Me.Controls

	    ctl.Value = ctl.DefaultValue

    Next


    Set ctl = Nothing


End Sub

والسلام ختام

[أبو آدم]

منعاً لترك أي حقل ( مربع نص أو مربع تحرير وسرد ) فارغاً ، خلف زر أمر للتدقيق ، ضع الكود التالي :

Private Sub cmdChick_Click()

Dim ctl As Control

Dim vIndex As Long

For Each ctl In Me.Controls

If ctl.ControlType = acTextBox Or acComboBox Then

With ctl

If IsNull(Me.Controls.Item(vIndex)) = True Then

MsgBox vIndex & ": " & Me.Controls.Item(vIndex).Name & "  Value:Empty Field"

Me.Controls.Item(vIndex).SetFocus

Exit Sub

End If

End With

End If

'This is used to track the actual Item Number.

vIndex = vIndex + 1

Next ctl

End Sub

...........

[أبو آدم]

أرفق لكم الكود معدلاً ليقوم باستثناء حقول محددة من النموذج من عملية التدقيق ، ليصبح الكود :

Private Sub Title_Exit(Cancel As Integer)

Dim ctl As Control

Dim vIndex As Long

For Each ctl In Me.Controls

If ctl.ControlType = acTextBox Or acComboBox Then

With ctl

If IsNull(Me.Controls.Item(vIndex)) = True Then

If ctl.Name <> "Title" And ctl.Name <> "CompanyName" Then

MsgBox vIndex & ": " & Me.Controls.Item(vIndex).Name & "  Value:Empty Field"

Me.Controls.Item(vIndex).SetFocus

Exit Sub

End If

End If

End With

End If

'This is used to track the actual Item Number.

vIndex = vIndex + 1

Next ctl

End Sub

ويوضع الكود في حدث عند الخروج لآخر حقل في النموذج ، حيث تتم عملية التدقيق لكافة الحقول بإستثناء التي قررنا عدم التدقيق عليها

[أبو آدم]

في كثير من الأحيان نحتاج عدد السجلات في جدول معين

ننشيئ وحدة نمطية جديدة وننسخ لها الكود التالي :

Public Function GetRecordCount(MyTable As String)

Dim rst As DAO.Recordset

Dim lngCount As Long

Set rst = CurrentDb.OpenRecordset(MyTable)

With rst

.MoveFirst

.MoveLast

lngCount = .RecordCount

End With

MsgBox "Number of Records  " & lngCount, vbInformation, " Note That ...."

End Function

وكلما إحتجنا الكود ونتائجة نقوم بإستدعائه ، بتحديد اسم الجدول ...

GetRecordCount ("tblFiles")

........

[أبو آدم]

في التقرير أريد أخفاء مربع نص من الصفحة الأولى  فقط على أن يظهر في الثانية وما بعدها !!

 

بسيطة ... في page header format نضع الكود التالي :

 

 

 

If page > 1 Then 
Me.controlname.visible = false 
. . . 
Else 
Me.controlname.visible = true 
. . . 
End If
 

[أبو آدم]

أريد إحتساب مدّة الدوام (الحضور) في النموذج ، لدي AttendanceStart لوقت الحضور و AttendanceEnd لوقت المغادرة ، والنتيجة في AttendanceTotal 

 

بسيطة ... الكود يكون :

 

 

 

Me.AttendanceTotal = Nz(Me.AttendanceEnd, 0) - Nz(Me.AttendanceStart, 0)
 

[أبو آدم]

لنحصل على شريط متحرك بالعبارة التى نريدها بدلاً عن إسم النموذج ، نقوم بما يلي :

 

في بداية صفحة الفيجوال

 

 

Option Compare Database
Private strText As String
 

 

 

 

في حدث عند التحميل

​Private Sub Form_Load()
strText = "النص الذي نود أن يظهر في الشريط المتحرك ...... 2013"
strText = Space(110) & strText
PutButtons Me
End Sub

 

 

في حدث عند التوقيت للنموذج

 

 

Private Sub Form_Timer()
strText = Mid(strText, 2) & left(strText, 1)
Me.Caption = strText
End Sub
 

 

وفي خصائص النموذج نحدد الفاصل الزمني في Timet Interval ليكون 150 أو 200 أو غيرها

 

وكفى ......

[أبو آدم]

من النموذج الرئيسي تم استدعاء نموذج منبثق لإظهار معلومات معينة

عند إغلاق النموذج المنبثق (الثاني) أريد أن أعود بالتركيز لحقل معين في النموذج الرئيسي .. !!

بسيطة ...

في حدث عند الإغلاق للنموذج المنبثق (الثاني) نضع الكود التالي :

 

 

Private Sub Form_Close()
[Forms]![MainForm]![TaxBox].SetFocus
End Sub
 

 

[أبو آدم]

من خلال النموذج الرئيسي لدي نموذج فرعي إسمه frmDicl

أريد إخفاء النموذج الفرعي حال عدم وجود سجلات فيه ... !!

 

بسيطة ...

 

في حدث عند الحالي للنموذج الرئيسي نضع الكود التالي :

 

 

With Me![frmDicl].Form.Visible = (.RecordsetClone.RecordCount > 0)
End With
 

[أبو آدم]

من خلال النموذج الرئيسي لدي نموذج فرعي إسمه frmSub

أريد تبديل النموذج الفرعي حسب الحاجة بين أكثر من نموذج فرعي frm_Sub_4  .. frm_Sub_3 .. frm_Sub_2.. frm_Sub_1 ... !!

 

بسيطة ...

 

خلف حدث عند الضغط  لزر أمر في النموذج الرئيسي نضع الكود التالي :

 

 

 

Me.frmSub.SourceObject = "frm_Sub_2"
 

أو

 

 

Me.frmSub.SourceObject = "frm_Sub_3"
 

وهكذا ....

 

.. 

[أبو آدم]

كود إنشاء رسالة تنبيه تحوي ثلاثة خيارات  Yes و  No  و  Cancel

 

 

 

Select Case MsgBox("This is an exclemated normal Yes/No/Cancel Msgbox!", vbYesNoCancel Or vbDefaultButton1 Or vbExclamation, "Title: Click Yes, No Or Cancel!")
Case vbYes
MsgBox ("You pressed 'yes'!")
Case vbNo
MsgBox ("You pressed 'no'!")
Case vbCancel
MsgBox ("You pressed 'cancel'!")
End Select
 

ومكان رسالة التنبيه الفرعية بتوضيح الخيار يمكننا وضع كود يناسب الوضع الذي تم إختياره .