نجوم المشاركات

قبل فتح التطبيق يتم فقط اضافة ملفات لتنسيقات الصوت والفيديو المختلفة داخل المجلد المرفق باسم sound files يا عينى ع الدلع او بعد فتح التطبيق يتم الضغط على زر الأمر تحديث المكتبة القسم الايمن من الشاشة هو التحكم فى مشغل الوسائط برنامج الميديا بلاير الجزء الاوسط هو التنقل بين الاذاعة الصوتية وتعمل اون لاين او مكتبة ملفاتك من المجلد Sound files واسفل قائمة التشغيل التى تحتوى على الملفات خصائص واعدادات التشغيل والتكرار حاجه دلع الجزء الايسر وهو خاص بالتحكم فى الصوت لجهاز الحاسوب بس خلاص اسف انا باتصفح من الجوال مش قادر اعمل تنسيق للموضوع اكتر من كده ولا عارف ارفق صور فى انتظار ردكم بعد التجربة وفى الختام اتوجه بكل الشكر والتقدير والعرفان بالجميل لكل اساتذتى جميعا واخوانى فى هذا الصرح الشامخ الذين اتعلم منهم دائما وابدا اخص بالشكر الاستاذ القدير @jjafferr 🌹 حيث اننى دمجت بهذا المرفق الكثير مما قدمه من أفكار وتوجيهات عبر اشهر وسنوات وكذلك الاستاذ القدير @ابوخليل 🌹 كذلك استخدمت هنا الكثير من الاكواد التى تعلمتها منه عبر اشهر سنوات وباقى كوكبة اساتذتى الفضلاء واخوانى كل الشكر لكم 🌹🌹🌹 Digital Player App.zip

مرحبا استاذ @ازهر عبد العزيز اولا اعتذر عن التعديل على مرفقك لعدم توفر اكسس لدي لكون عملي حاليا في بيئة عمل مختلفة وفي هذا الرد سوف اضع تلميح لكيفية التحكم بانواع الحقول من خلال الكود واعتذر مقدما اذا لم تجد فيه الجواب المطلوب لتغيير الحقل الى نوع رقم Dim x As Variant x = "ALTER TABLE [tbl1] ALTER COLUMN [tx8] LONG" DoCmd.RunSQL x ويمكن كتابتة بالشكل التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Integer" او DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] LONG" حسب نوع الحقل الرقمي تغيير الحقل الى نوع مزدوج يكون على النحو التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Double" الى نوع نص DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] String" واذا اردنا ان نحدد طول الحقل النص يمكن كتابتة DoCmd.RunSQL ("ALTER TABLE [tbl1] ALTER COLUMN [tx8] TEXT(30);") اما حقل التاريخ فيكون DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] date" النوع العملة يكون على النحو التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Currency" لتحويل تنسيق الحقل الى علمي Set db = CurrentDb db.TableDefs("tbl1").Fields("tx8").Properties.Append db.CreateProperty("Format", dbText, "scientific") بعد تعديل التنسيق بالكود السابق تحتاج الى التعديل اليدوي في حالة الرغبة في التغيير مرة اخرى في جميع الاحوال لا انصح بالعبث في الحقول والمفروض ان التخطيط الجيد قبل واثناء انشاء قواعد البيانات يغني عن الحاجة للتعديلات اضافة الى ان تغيير نوع الحقل قد يؤدي الى فقدان البيانات لهذا الحقل وخصوصا اذا كان الحقل مرتبط بجداول اخرى قد يعطل عمل القاعدة

وعليكم السلام-لك ما طلبت JC new1.xlsx

جرب هذا الماكرو Option Explicit Sub ALL_in_one_cells() Dim ro, st$, i% ro = Cells(Rows.Count, 1).End(3).Row For i = 1 To ro If Cells(i, 1) <> vbNullString Then st = st & Cells(i, 1) & "," End If Next st = Mid(st, 1, Len(st) - 1) & "." Cells(3, 4) = st Cells(3, 4).Columns.AutoFit End Sub الملف مرفق One_for_All.xlsm

أخي بلال تفضل الآن بإمكانك تصدير واستيراد بيانات الموظف من القائمة والتعديل على ملف الاكسيل واستيراد التعديلات على ملف الموظف . كما ذكرت لي في الرسالة الخاصة لك . وبالتوفيق آمل التجربة وإخباري بالنتائج استراد وتصدير.accdb

وعليكم السلام 🙂 1. انت محتاج الى هذا الكود لنسخ المرفقات من قاعدة البيانات الى مجلد في الكمبيوتر : ' 'from 'https://docs.microsoft.com/en-us/office/vba/access/Concepts/Data-Access-Objects/work-with-attachments-in-dao ' ' Instantiate the parent recordset. Set rsEmployees = db.OpenRecordset("Employees") 'Code to move to desired employee ' Instantiate the child recordset. Set rsPictures = rsEmployees.Fields("Pictures").Value ' Loop through the attachments. While Not rsPictures.EOF ' Save current attachment to disk in the "My Documents" folder. rsPictures.Fields("FileData").SaveToFile _ "C:\Documents and Settings\Username\My Documents" rsPictures.MoveNext Wend 2. حذف حقول الرفقات من برنامجك ، 3. اذا عندك اكثر من مرفق لنفس السجل ، فالافضل ان تعرض اسماء المرفقات في النموذج ، والمستخدم ينقر على الصورة اللي يريده ، ويشوفها في النموذج : . جعفر

وهذا الكود يقوم بنفس العمل لكن مع عدد متغير من الصفوف يكفي ان تضع في الخلية I1 عدد الصفوف التي تريدا وتضغط على الزر Run مع تحديد نطاق الطباعة حسب الداتا التي حصلنا عليها Option Explicit Sub give_data_by_Y() If ActiveSheet.Name <> "data" Then Exit Sub Dim D As Worksheet, D2 As Worksheet Dim i%, x%, n%, Laste_Row%, Ro%, col%, m%, k%, last_col% Dim arr(), Tile() Dim y Set D = Sheets("data"): Set D2 = Sheets("data2") y = D.Range("i1") Laste_Row = D.Cells(Rows.Count, 1).End(3).Row D2.Cells.Clear x = (Laste_Row \ y) + 1 k = 1 ReDim arr(1 To x) For m = 1 To x arr(m) = y * (k - 1) + 3 k = k + 1 Next Ro = 3: col = 1 '++++++++++++++++++++++++++ Get The Result For k = 1 To UBound(arr) With D2.Cells(Ro, col).Resize(y) .Value = _ D.Range("A" & arr(k)).Resize(y).Value .Offset(, 1).Value = _ D.Range("B" & arr(k)).Resize(y).Value .Offset(, 2).Value = _ D.Range("G" & arr(k)).Resize(, y).Value End With D2.Cells(1, col + 3).ColumnWidth = 0.75 D2.Cells(4, col + 3).Formula = "=""""" col = col + 4 Next '++++++++++++++++++++++++++End Of The Result '__________________________Type The Titles last_col = D2.Cells(3, Columns.Count).End(1).Column Tile = Array("رقم ", "الاسم و اللقب ", "القسم") For m = 1 To last_col Step 4 D2.Cells(2, m + 3).Resize(y + 1). _ Interior.ColorIndex = 40 D2.Cells(2, m).Resize(, 3) = Tile Next '__________________________ End Of Typing The Titles '++++++++++++++++++++++++++ Format The Result With D2.Cells(2, 1).Resize(y + 1, last_col) .Borders.LineStyle = 1: .HorizontalAlignment = 1 .VerticalAlignment = 2: .Font.Size = 14 .Font.Bold = True: .InsertIndent 1 .Columns.AutoFit End With With D2.Cells(2, 1).Resize(, last_col) .HorizontalAlignment = 3 .Interior.ColorIndex = 6 End With n = Application.CountA(D2.Cells(2, last_col - 2).Resize(y)) If n < y Then D2.Cells(n + 2, last_col - 3).Resize(y - n + 1, 5).Clear End If '++++++++++++++++++++++++++ End Of The Format Of Result D2.PageSetup.PrintArea = D2.Range("A2").Resize(y + 1, last_col).Address Set D = Nothing: Set D2 = Nothing Erase arr: Erase Tile End Sub File Included New_std_salim_1.xlsm

انا وانت نعرف الكلمات التي لها معنى لكن الاكسل و كل كمبيوترات العالم لا تعرفها

أحسنت استاذ محمد بارك الله فيك وزادك الله من فضله تم التجربة ويعمل بكل كفاءة

لم اطلع على المرفق ولكني عملت لك هذا حسب ما فهمت Dim i As Integer Private Sub ID_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 13 Then i = i + 1 If i = 3 Then MsgBox "اعمل الإجراء" Exit Sub End If Else i = 0 End If End Sub test1.mdb

ألف سلامة استاذنا الغالى , شفاك الله وعافاك وبارك الله لنا فيك

وعليكم السلام اخى الكريم ,كان عليك استخدام خاصية البحث فى المنتدى فقد تكرر هذا الموضوع مئات المرات ومنه كما ترى: طباعة شيتات مرتب دفعة واحدة تعديل كود : طباعة أوراق محددة .. طباعة كل الشهادات كود طباعة لكل تسلسل الاسماء من نتائج معادلة vlookp من قائمة بمجموعة اسماء

وعليكم السلام-جرب هذا How to Copy or Import VBA Code to Another Workbook أو هذا Copy every worksheet from one excel file to another او يمكنك بطريقة بسيطة بأن تقوم بتحديد كل صفحات الملف بطريقة يدوية ثم بعد ذلك تقوم بالضغط كليك يمين بالماوس ثم اختيار move or Copy ثم بعد ذلك اختيار ملف الإكسيل الذى تريد نقل الصفحات اليه وتحديد كل الصفحات التى تريد نقلها ... فسيتم النقل ايضا بالمعادلات وبنفس تنسيقات الملف القديم اما بالنسبة لنقل الأكواد فقط عليك بفتح الملف القديم والملف الجديد والدخول الى محرر الأكواد بالضغط على Alt F11 ثم الضغط الى الكود الذى تريد نقله وسحبه الى المكان الجديد بالملف الجديد

بارك الله فيك وزادك الله من فضله ورحم الله والديك

جرب هذا تجريبي3.xlsm

حسنا عذرا لاني اكثرت عليك الاسئلة ولكن كنت اريد ان اعرف لو لديك الملف الرئيسي لابد ان يعمل بالكامل وقد نعرف كيفية التعديل عليه لقد توصلت الى شيء واحد وهو ان المشكلة في الملف نفسه لاني عندما قلت لك قم بتعديل الكود كنت قد جربته على ملف اخر وقام بالترحيل دون اي مشاكل فعليك تصميم ملف آخر ولقد قمت بنسخ جميع الاكواد لان الازرار مرتبطة معا بعضها وسؤالي الاخير عن البحث لا يعمل هو لمعرفة اذا كان الخلل من التعديل الاخير ام من البرنامج يمكنك تجربة الملف طبعا بالانجليزي لاني طرحت موضوعك في مواقع اجنبية وبالكاد رد علي موقع 1 من اصل 3 SH.xlsm

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

شكرا استاذ خالد

ستجد بإذن الله تعالى حلك في هذه المشاركة

وعليكم السلام أرفق ملفك .. ووضح طلبك أكثر ..

اخي مهند لقد حصلت على المساعدة من احد المبرمجين قم بتعديل هذا الكود واعلمني For c = 1 To ContColmn Ad = Cells(1, c).Address(0, 0) If Len(Trim(Me.Controls(Ad).Value)) = 0 Then MsgBox "address: " & Cells(1, c).Value & " empty", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "empty cells" Me.Controls(Ad).SetFocus Exit Sub End If Next

هذه المعلومة لم انتبه لها " المهم انك تعرفها "

السلام عليكم ورحمة الله استخدم المعادلة التالية =IF(AND(C3>=32;C3<=34);32;IF(AND(C3>=35;C3<=50);35;IF(AND(C3>=51;C3<=60);40;"")))

الف شكر أستاذ سليم مع تحياتي.🖕

ما شاء الله تبارك الله بصراحة روقت على البرنامج وسأعتمده كصحاب لي أثناء العمل على الكمبيوتر . أعلم أن هذا العمل المبارك أخذ منك وقتاً كثيراً حتى يخرج بهذه الصورة الجميلة التي عوتنا عليها منذو عرفنا شخصيتك الرائعة ، ونحن نحبك في الله ، أدعوا الله لك بالتوفيق والسداد والشفاء العاجل وأن يمد عمرك ويبارك فيه والمسلمين جميعاً . وهدية مقبولة

النتيجة ممتازة حفظك الله و من تحب و رعاكم جميعا

رائع وممتاز .. سلمك الله ورعاك ووقفك لكل خير

Sub ORDER() LRW = ActiveSheet.Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row With ActiveSheet.Sort .SortFields.Add Key:=Range("I2"), ORDER:=xlDescending .SetRange Range("B2:I" & LRW + 1) .Header = xlYes .Apply End With End Sub تفضل ORDER.xlsm

السلام عليكم ربما يجب عليك ترقية متصفحك إلى internet explore 11

اليك هذا الكود للأخ ياسر خليل الكود يقوم بحفظ نسخة احتياطية كلما طرأ تغيير على أي ورقة عمل في مجلد الملف تجد النسخة محفوظة باسم الملف و تاريخ الحفظ الملف مرفق Book1.xlsm

تفضل الكود Private Sub Comand3_Click() If Len(Me.text & vbNullString) = 0 Then 'في حال عدم وجود شرط بحث strcriteria = Replace(strcriteria, " Where ", "") DoCmd.OpenReport "rptItems", acViewPreview, , strcriteria Else 'في حال وجود شرط بحث Dim RName, FldCriteria As String RName = "rptItems" FldCriteria = "[ID]=" & "'" & Me.text & "'" DoCmd.OpenReport RName, acViewPreview, , FldCriteria End If End Sub وبقية التفاضيل في برنامج الخليل في نموذج FrmFilteringQTY

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

اضف هذا السطر الوحيد(بين علاملات الـــ +) في المكان المناسب لم استطع رفع الكود من جديد لضعف النت If m=7 then MsgBox "No Data to transfer": Exit Sub

استاذي الفاضل أحمد يوسف شكرا لك على تشحيعاتك لنا و تنبيهاتك لاعضاء المنتدى استاذ ASUS2020 انسخ هذا الجزء والصقه في الكود بزر "حضور" ويكون هو الاول If TextBox1 = "" Then MsgBox "المرجو ادخال الكود اولا": TextBox1.SetFocus: Exit Sub 'اذا كان التكست بوكس1 فاضي اديني رسالة "المرجو ادخال الكود اولا" واخرج من ساب

وعليكم السلام-لك ما طلبت تحويل الارقام الى عربي عند استدعاء البيانات1.xls

همممم اعتذر منك اخي حسين ، فانا وكما اخبرتك : .لازم تشوف ملف SDK الجهاز ، او ملف التحكم او اوامر الجهاز ، وبعدين ممكن نخطو للخطوة التالية 🙂 جعفر

بعد اذن الاستاذ واتراء للموضوع يمكنك استخدام الكود التالي في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim rng Dim lr lr = Cells(Rows.Count, 1).End(3).Row Set rng = Range("a3:a" & lr) If Not Intersect(Target, rng) Is Nothing Then Range("j3:j" & lr).Formula = "=B3&"" ""&C3&"" ""&D3&"" ""&E3" Value = Value End If End Sub

بالمناسبة جرب تنفيذ هذا الكود و ترى العجائب Sub ARange_sheets() Dim t%, i% Dim col As Object, itm t = Sheets("Main").Index Set col = CreateObject("System.Collections.Arraylist") On Error Resume Next For i = t + 1 To Sheets.Count col.Add CInt(Sheets(i).Name) Next On Error GoTo 0 If col.Count Then col.Sort: col.Reverse For Each itm In col Sheets(itm & "").Move after:=Sheets(t) Next End If Set col = Nothing End Sub

مؤقت بسيط يجعل اكسل يحصي لك الثواني حتى رقم معين تحدده بنفسك ممكن استعماله عند طرح اسئلة معينه و الاجابة مطلوبة خلال فترة لا تتعدى هذا الرقم My_timer.xlsm

بالطبع سيكون عمل ممتاز استاذ سليم بارك الله فيك وزادك الله من فضله

تفضل 201.xlsx

هذا الماكرو يقوم بما تريد Option Explicit Option Base 1 Sub My_code() Dim m%, k%, lr%, i% Dim Main As Worksheet, sh As Worksheet Dim myArray, arr(11), targt$ Set Main = Sheets("Allstudents") Set sh = Sheets("from.school") sh.Range("B7:M1000").Clear targt = "from*" lr = Main.Cells(Rows.Count, "D").End(xlUp).Row m = 7 For i = 3 To 13 arr(i - 2) = i Next myArray = Array(38, 4, 5, 27, 13, 16, 18, 19, 20, 21, 22) For i = 5 To lr If Main.Cells(i, "AD") Like "*" & targt Then For k = 1 To 11 sh.Cells(m, arr(k)) = Main.Cells(i, myArray(k)) Next m = m + 1 End If Next With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With End With End Sub الملف مرفق My_data .xlsm

أحسنت استاذ مجدى عمل رائع بارك الله فيك ورحم الله والديك

' 'هذا الكود للمحترم ياسر العربي Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 Do ' ' لمنع اهتزاز الشاشه Application.ScreenUpdating = False last = Sheets("ناجح").Cells(Rows.Count, "B").End(xlUp).Row If y - 36 >= last Then GoTo 0 ' ' اسم شيت المصدر الذي سيتم حشر الديباجه فيه Sheets("كعب الشيت").Rows("2:7").Copy ' ' اسم شيت الديباجه التى نريد وضعها في الشيت المصدر Sheets("ناجح").Rows(y).Insert Shift:=xlDown ' 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' ' y = y + 36 Loop ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True MsgBox "تم بحمد لله" End Sub ' ' ' ' ' ' ' ' ' ' ' ' ' ' كود لتذييل الصفحه

السلام عليكم اخي هيثم حفظ المرفقات في البرنامج سيجعل حجم البرنامج كبير جدا ، وله عواقب وخيمة لهذا السبب ، فالنصيحة ان تحفظ المرفقات في مجلدات الوندوز ، ولكن تربط المرفق برقم ID السجل مثلا المنتدى مليئ بهذا النوع من الامثلة ، وهنا مجموعة امثلة أخونا الكبير ابو خليل: http://www.officena.net/ib/topic/60554-ادراج-صورة-من-الماسح-_-سحب-الصور/?do=findComment&comment=390508 http://www.officena.net/ib/topic/60554-ادراج-صورة-من-الماسح-_-سحب-الصور/ http://www.officena.net/ib/topic/55050-ادراج-صورة-_-اضافة-وحذف/ http://www.officena.net/ib/topic/62131-جلب-الصور-دفعة-واحدة-الى-مجلد-البرنامج-حسب-الاسم-المعرف/ وهنا مثال موسع لي: http://www.officena.net/ib/topic/62143-هدية-سحب-اكثر-من-صورة-من-الاسكنر-وتحويلها-الي-pdf-او-صور-مسلسلة/ وهذا مثال ، ولكن حيث يتم فتح المرفق بالبرنامج الافتراضي للكمبيوتر: http://www.officena.net/ib/topic/55053-فتح-صورة-بـ-مستعرض-الصور/ جعفر

يمكن استحدام هذا الماكرو Sub select_last_cell() Dim UR As Range Dim LastCell As Range Set UR = ActiveSheet.UsedRange Set LastCell = UR(UR.Cells.Count) LastCell.Select End Sub

وعليكم السلام لأني انا اثرت الموضوع ، فراح ادلو بدلوي بإختصار 1. الخطأ A problem occured while MyDB was communicating with the OLE server or Active X Control احد اسبابه هو لغة الكمبيوتر ، وهذا رابط ماكروسوفت يشرح الموضوع http://support.microsoft.com/kb/907337/ar وببساطة ، اذا عملت برنامجك وفي VBA حروف عربية (UniCode) او اسم احد الكائنات او اسم الحقول او اسم المسميات في النماذج و.... ، الآن اذا اراد شخص لا يملك اللغة العربية في كمبيوتره (يعني لا دعم للعربية او Fonts) ، فكيف سيتعامل مع حروف برنامجك؟ لذلك ، يظهر لك الخطأ ، وعلشان تصلحه: أ. يا انك تنصب اللغة ، ب. تحذف اي مسميات غير انجليزية من برنامجك ، وهذه الطريقة الافضل ، لأن الحروف العربية تقلب الكود سواء في VBA او فالاستعلام او في اي مكان تكتب فيه كود. 2. صيغة التاريخ: معظم العرب يستخدمون صيغة dd/mm/yyyy ، لهذا السبب نستخدم هذه الصيغة في عرض التاريخ في النماذج والتقارير و... ، ولكن عندما يريد ان نستخدم صيغة التاريخ في كود ، ستلاحظ ان الاكسس لا يحترم صيغتك ، وانما يستخدم صيغة التاريخ في الوندوز ، وما دمنا على موضوع التاريخ ، فالحقيقة ان صيغة التاريخ في الاكسس هو بضيغة امريكية mm/dd/yyyy ، بغض النظر عن الصيغ الاخرى ، وبعد معاناة طويلة معه في الكود (لا تنسى ، ان برنامجك الاكسس سيعمل على كمبيوترات مختلفة ، والكثير منها لم يتم تغيير صيغة التاريخ فيه ، فالكود لن يعمل بطريقة صحيحة الى ان رأيت الوحدة النمطية في المادة رقم 2 في الرابط http://allenbrowne.com/ser-36.html للمبرمج Allen Browne ، وبها والحمدلله ما عندي مشاكل جعفر

السلام عليكم تم توسيع النطاق ، الآن يمكنكم تفقيط الأرقام حتى طول 21 خانة والكسور حتى 6 خانات ، كما تمت بعض التنقيحات الأخرى . تحياتي . Num2Text_20060728.rar

الطريقة الثانية لتعطيل مفاتيح لوحة المفاتيح كما لاحظتم اعزائي الكرام من الطريقة الاولى انه تم استخدام رقم المفتاح ورقم الشفت الخاص به . اما في هذه الطريقة التي نحن بصدد شرحها فتختلف قليلا لاننا سوف نستخدم اسم المفتاح مباشرة في الكود والان دعونا نتعرف على اسماء المفاتيح وكيفية استخدامها مفتاح Control vbKeyControl مفتاح Alt vbkeymenu مفتاح الادخال Enter vbKeyReturn مفتاح Back Space vbKeyBack مفتاح Tab vbKeyTab مفتاح Shift vbKeyShift مفتاح Caps Lock vbKeyCapital مفتاح Esc vbKeyEscape مفتاح Space Bar vbKeySpace مفتاح Page Up vbKeyPageUp مفتاح Page Down vbKeyPageDown مفتاح End vbKeyEnd مفتاح Home vbKeyHome مفتاح Left arrow vbKeyLeft مفتاح Up arrow vbKeyUp مفتاح Right Arrow vbKeyRight مفتاح Down Arrow vbKeyDown مفتاح Print Screen vbKeyPrint مفتاح Pause vbKeyPause مفتاح Insert vbKeyInsert مفتاح Delete vbKeyDelete مفتاح Help vbKeyHelp مفتاح Numlock vbKeyNumlock مفتاح F1 vbKeyF1 مفتاح F2 vbKeyF2 مفتاح F3 vbKeyF3 مفتاح F4 vbKeyF4 مفتاح F5 vbKeyF5 مفتاح F6 vbKeyF6 مفتاح F7 vbKeyF7 مفتاح F8 vbKeyF8 مفتاح F9 vbKeyF9 مفتاح F10 vbKeyF10 مفتاح F11 vbKeyF11 مفتاح F12 vbKeyF12 مفتاح A vbKeya ينطبق هذا على مفاتيح جميع الاحرف حتى مفتاح Z vbKeyz مفاتيح الارقام التي في الجهة اليمنى من لوحة المفاتيح وينطبق عليها ما ينطبق على مفتاح الرقم صفر vbKey0 vbKey1 vbKey2 vbKey3 vbKey4 vbKey5 vbKey6 vbKey7 vbKey8 vbKey9 طريقة الاستخدام هذه الطريقة لا تحتاج الى مفتاح تغيير ( shift ) وانما يوضع فقط اسم المفتاح ومثال ذلك على المفاتيح Control و Alt و Delete ملاحظة : هذا الكود يعمل مع ويندوز 98 و ME و 2000 اما ويندوز XP فالطريقة تختلف وسنوردها في الطريقة الثالثة . Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Dim CTRL_1 As Boolean Dim CTRL_2 As Boolean Dim CTRL_3 As Boolean CTRL_1 = vbKeyControl CTRL_2 = vbKeyMenu CTRL_3 = vbKeyDelete On Error Resume Next Select Case KeyCode Case vbKeyControl CTRL_1 = True Case vbKeyMenu CTRL_2 = True Case vbKeyDelete CTRL_3 = True End Select If CTRL_1 And CTRL_2 And CTRL_3 Then CTRL_1 = False CTRL_2 = False CTRL_3 = False End If End Sub وهذا مثال مرفق Disable_Key_In_Form.rar

اعزائي الكرام جميعا اخي ابو شاهر السلام عليكم ورحمة الله وبركاته سأورد لكم ثلاث طرق للحل تستطيعون تطبيقها لحل هذه المشكلة اما الطريقتين الاولى والثانية فهي سهلة وسأقوم بشرحها والتطبيق عليها بأمثلة اما الطريقة الثالثة فهي متقدمة جدا وتحتاج الى ذوي خبره عالية في برنامج الاكسيس وفي نفس الوقت خطره لمن لا يعرف طريقة تطبيقها وسأوردها بعد ان نحترف الطريقتين الاولى والثانية وأعلم ان الجميع يرغب في معرفة الطريقة الثالثة وعموما هي ( اعطاء قيم من خلال برنامج الاكسيس الى محرر الريجستري الخاص بالويندوز ) ولهذا اقول انها متقدمة جدا وخطره في نفس الوقت لمن لا يعرف الطريقة لان اي خطأ في كتابة الكود وارساله للريجستري سيؤدي مباشرة الى توقف الويندوز مباشرة لهذا سندعها في الوقت الراهن ونبدأ بشرح الطريقتين الاولى والثانية . الطريقة الاولى : كما يعلم الجميع ان اي مفتاح في لوحة المفاتيح Keyboard يحمل رقم خاص به ( KeyCode ) ورقم تغيير ( ShiftCode ) دعونا نرى على سبيل المثال مفتاحي PageUP و PageDown فلهم القيم التالية : PageUP رقم المفتاح 33 رقم الشفت 0 PageDown رقم المفتاح 34 رقم الشفت 0 وطريقة استخدامها مع برنامج الاكسيس سهلة جدا من خلال اختيار حدث عند ضغط المفتاح للاسفل واختيار مفتاح العرض التمهيدي على نعم KeyPreview: Yes كالتالي : Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case 33, 34 KeyCode = 0 End Select End Sub كما نرى من خلال الكود ان الارقام 33 و 34 هي ارقام محجوزه لمفتاحي الصفحة لأعلى والصفحة لأسفل ورقم الشفت الخاص بهما هو صفر ومهمة رقم الشفت هو تعطيل المفتاح عن العمل لحظة الضغط عليه وهذا ينطبق على بقية مفاتيح لوحة المفاتيح . ستجد مثال يمكن الاستفادة منه في معرفة رقم اي مفتاح على لوحة المفاتيح كل ما عليك هو الضغط على المفتاح وسيظهر لك مباشرة رقم المفتاح ورقم الشفت الخاص به ومن ثم تستطيع استخدام الكود السابق لايقاف عمل المفتاح . بعض من ارقام لوحة المفاتيح : مفتاح Shift رقم المفتاح 16 رقم الشفت 1 مفتاح Control رقم المفتاح 17 رقم الشفت 1 مفتاح Alt رقم المفتاح 18 رقم الشفت 4 مفتاح Win رقم المفتاح 91 رقم الشفت 0 مفتاح Delete رقم المفتاح 46 رقم الشفت 0 مفتاح الحرف D رقم المفتاح 68 رقم الشفت 0 مفتاح F1 رقم المفتاح 112 رقم الشفت 0 مفتاح F2 رقم المفتاح 113 رقم الشفت 0 مفتاح F3 رقم المفتاح 114 رقم الشفت 0 مفتاح F4 رقم المفتاح 115 رقم الشفت 0 مفتاح F5 رقم المفتاح 116 رقم الشفت 0 مفتاح F6 رقم المفتاح 117 رقم الشفت 0 مفتاح F7 رقم المفتاح 118 رقم الشفت 0 مفتاح الهروب Esc رقم المفتاح 27 رقم الشفت 0 تستطيعون اكمال الباقي واستخراج بقية المفاتيح بواسطة المثال المرفق . تطبيق عملي على استخدام تعطيل مفتاح Home Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case 36 KeyCode = 0 End Select End Sub تطبيق عملي مع مثال مرفق على تعطيل عدة مفاتيح دفعة واحدة ( مفاتيح المساعدة ) من F1 الى F12 لهم نفس رقم الشفت Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case 112,113,114,115,116,117,118,119,120,121,122,123 KeyCode = 0 End Select End Sub تطبيق عملي على تعطيل عدة مفاتيح دفعة واحدة لهم ارقام شفت مختلفه مفتاح Esc ومفتاح Shift ومفتاح Alt Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case 27 KeyCode = 0 Case 16 KeyCode = 1 Case 18 KeyCode = 4 End Select End Sub نلاحظ من الاكواد السابقة انه اذا كان مفتاح التغيير ( الشفت ) لمجموعة مفتاح يحمل نفس القيمه فيكتفى بوضعه لمرة واحده فقط كما في كود تعطيل مفاتيح المساعدة F1 - F12 واذا اختلف مفتاح التغيير ( الشفت ) للمفاتيح فيوضع كل مفتاح على حده كما في الكود الاخير . لا تنسى اختيار مفتاح العرض التمهيدي ووضعه على نعم KeyPreview: Yes تابع معنا الطريقة الثانية لتعطيل مفاتيح لوحة المفتايح اختكم زهره KeyCode.rar NoHelp.rar