دروب مبرمج

ما شاء الله لا قوة الا بالله شغل احترافي و تصميم جميل و مبدع

عندك مشكلة في اسم الصفحات في الاكسل الصفحة Feuil1006 فيها مسافة نهاية الجملة هذا فقط للعلم مرفق التعديل تفضل Excel_Bilal_Yamen.zip

الموضوع ممتع و شيق تفضل هذه الفكرة الخطوة الأولى: تجهيز النموذج (Form) أنشئ نموذجاً جديداً (Form) أضف 9 أزرار أمر (Command Buttons) وقم بتسميتها برمجياً كالتالي: btn1, btn2, btn3 (للصف الأول) btn4, btn5, btn6 (للصف الثاني) btn7, btn8, btn9 (للصف الثالث) أضف زر عاشر باسم btnReset لإعادة اللعبة. أضف "تسمية" (Label) باسم lblStatus لعرض حالة اللعبة (دور من؟ أو من الفائز؟). الكود البرمجي Option Compare Database Option Explicit ' متغيرات عامة للتحكم في حالة اللعبة Dim GameOver As Boolean ' عند تحميل النموذج Private Sub Form_Load() ResetGame End Sub ' زر إعادة تشغيل اللعبة Private Sub btnReset_Click() ResetGame End Sub ' الإجراء الرئيسي عند ضغط اللاعب على أي مربع Private Sub PlayMove(btn As CommandButton) ' التأكد أن المربع فارغ وأن اللعبة لم تنتهِ If btn.Caption = "" And Not GameOver Then btn.Caption = "X" btn.ForeColor = RGB(0, 0, 150) ' لون أزرق لعلامة اللاعب If CheckWinner("X") Then lblStatus.Caption = "مبروك! لقد فزت." lblStatus.ForeColor = RGB(0, 150, 0) ' لون أخضر عند الفوز Beep ' صوت تنبيه GameOver = True Else ' إذا لم يفز اللاعب، يأتي دور النظام CPUMove End If End If End Sub ' منطق ذكاء النظام (الكمبيوتر) Private Sub CPUMove() If GameOver Then Exit Sub Dim moveIndex As Integer ' 1. محاولة الفوز (الهجوم) moveIndex = FindBestMove("O") ' 2. سد الطريق على اللاعب (الدفاع) If moveIndex = 0 Then moveIndex = FindBestMove("X") ' 3. محاولة السيطرة على المركز (الخانة رقم 5) If moveIndex = 0 And Me.btn5.Caption = "" Then moveIndex = 5 ' 4. اختيار أول خانة متاحة إذا فشلت الاستراتيجيات أعلاه If moveIndex = 0 Then Dim i As Integer For i = 1 To 9 If Me.Controls("btn" & i).Caption = "" Then moveIndex = i Exit For End If Next i End If ' تنفيذ حركة النظام If moveIndex > 0 Then With Me.Controls("btn" & moveIndex) .Caption = "O" .ForeColor = RGB(200, 0, 0) ' لون أحمر لعلامة النظام End With ' التحقق هل فاز النظام؟ If CheckWinner("O") Then lblStatus.Caption = "للأسف! فاز النظام." lblStatus.ForeColor = vbRed ' لون أحمر للنص عند الخسارة Beep GameOver = True End If End If ' التحقق من حالة التعادل (إذا امتلأت الخانات ولم يفز أحد) If Not GameOver Then Dim IsDraw As Boolean: IsDraw = True Dim j As Integer For j = 1 To 9 If Me.Controls("btn" & j).Caption = "" Then IsDraw = False: Exit For Next j If IsDraw Then lblStatus.Caption = "تعادل!" lblStatus.ForeColor = vbBlack Beep GameOver = True End If End If End Sub ' دالة ذكية للبحث عن أفضل حركة (فوز أو دفاع) Private Function FindBestMove(PlayerSign As String) As Integer Dim WinPatterns As Variant Dim i As Integer, count As Integer, emptyPos As Integer Dim pos() As String ' جميع احتمالات الفوز الممكنة WinPatterns = Array("1,2,3", "4,5,6", "7,8,9", "1,4,7", "2,5,8", "3,6,9", "1,5,9", "3,5,7") For i = 0 To 7 pos = Split(WinPatterns(i), ",") count = 0 emptyPos = 0 Dim j As Integer For j = 0 To 2 If Me.Controls("btn" & pos(j)).Caption = PlayerSign Then count = count + 1 ElseIf Me.Controls("btn" & pos(j)).Caption = "" Then emptyPos = CInt(pos(j)) End If Next j ' إذا وجد خانتين لنفس اللاعب والثالثة فارغة، يعيد رقم الخانة الفارغة If count = 2 And emptyPos <> 0 Then FindBestMove = emptyPos Exit Function End If Next i FindBestMove = 0 End Function ' دالة التحقق من الفوز Private Function CheckWinner(Player As String) As Boolean Dim WinPatterns As Variant Dim i As Integer Dim pos() As String WinPatterns = Array("1,2,3", "4,5,6", "7,8,9", "1,4,7", "2,5,8", "3,6,9", "1,5,9", "3,5,7") For i = 0 To 7 pos = Split(WinPatterns(i), ",") If Me.Controls("btn" & pos(0)).Caption = Player And _ Me.Controls("btn" & pos(1)).Caption = Player And _ Me.Controls("btn" & pos(2)).Caption = Player Then CheckWinner = True Exit Function End If Next i CheckWinner = False End Function ' إعادة ضبط اللعبة للحالة الأصلية Private Sub ResetGame() Dim i As Integer For i = 1 To 9 Me.Controls("btn" & i).Caption = "" Me.Controls("btn" & i).ForeColor = vbBlack Next i GameOver = False lblStatus.Caption = "دورك الآن (X)" lblStatus.ForeColor = vbBlack End Sub ' ربط أحداث النقر للأزرار (Events) Private Sub btn1_Click(): PlayMove btn1: End Sub Private Sub btn2_Click(): PlayMove btn2: End Sub Private Sub btn3_Click(): PlayMove btn3: End Sub Private Sub btn4_Click(): PlayMove btn4: End Sub Private Sub btn5_Click(): PlayMove btn5: End Sub Private Sub btn6_Click(): PlayMove btn6: End Sub Private Sub btn7_Click(): PlayMove btn7: End Sub Private Sub btn8_Click(): PlayMove btn8: End Sub Private Sub btn9_Click(): PlayMove btn9: End Sub مرفق مثال على ذلك اكس او.accdb

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

تفضل التعديل Lab5.zip

تفضل التعديل تم اصلاح حذف الملفات تم اصلاح حذف المجلد في حال كان فارغ Lab4.zip

تفضل التعديل LAB33.zip

تفضل التعديل JO.accdb

الافضل اخفي الفورم مرفق التعديل Control_Up_bar_Form_On_Ms_Access_V1.accdbControl_Up_bar_Form_On_Ms_Access_V1.zip

تفضل هذه بعض الاكواد قد تجد بها ضالتك Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim strConnString As String strConnString = "Provider=SQLOLEDB;Data Source=Server_Name;Persist Security Info=True;User ID=Your_UserName;Password=Your_Password;" Set conn = New ADODB.Connection conn.Open strConnString Set rs = conn.Execute("SELECT * FROM TabolName") If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) TextBox1= rs.Fields(0).Value rs.MoveNext Wend End If rs.Close Set rs = Nothing مع اضافة المكتبة

اخي العزيز تفضل التعديل JO.accdb

في البداية لا يجب حفظ المسار كامل في قاعدة البيانات و مع ذلك هذه ليست مشكلة سوف نقوم بالإعلان عن ثلاث متغييرات لغرض تخزين اسم المجلد و مسار الملف Dim strPath As String, fileName As String, sFile As String و هنا سنقوم بإستخلاص اسم المجلد لكل مسار في قاعدة البيانات strPath = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=" & MyList.Column(0)) و هنا سنقوم بإستخراج اسم الملف من المسار المخزن في قاعدة البيانات fileName = Right$(strPath, Len(strPath) - InStrRev(strPath, "\")) و الآن نقوم بجمع النتائج اعلاه في مسار واحد sFile = CurrentProject.Path & "\MY_Files\" & P_NAMES.Column(1) & "\" & fileName و الآن سنقوم بإضافة المسار الجديد للمستعرض [Forms]![Attacheds]![Show_Files]![MY_PDF].ControlSource = "=""" & sFile & """" و النتيجة تفضل التعديل LAB2.zip

تفضل هذا التعديل البسيط Database4.zip

تفضل هذا التعديل البسيط البحث وتعديل درجات8.zip

تفضل هذه الفكرة فكرة قوائم.zip

النموذج sub1 مرتبط بإستعلام جدولي لا يمكن التعديل على البيانات اثناء الاستعلام اقترح بأن تستخدم جمل الاضافة لإضافة البيانات للجداول المرتبطة sub2 و sub3 قم بتشغل اذونات التحرير مرفق النموذج بعد التعديل up_ChangeSubForm.mdb

انشئ نموذج جديد وا ضف فيه مستعرض ويب و في حدث عند النقر على قائمة الملفات ضع الكود التالي Dim wb As Object Set wb = WebBrowser0.Object ' ضورة اضافة اسم عنصر التحكم لمستعرض الويب Dim filelocation As String filelocation = "C:\Users\File1.pdf" ' ضع هنا اسم عنصر التحكم الذي يحتوي على اسم الملف لعرضه wb.silent = True With wb .navigate2 "about:blank" Do Until .ReadyState = 4 DoEvents Loop .Document.Open .Document.write "<!doctype html><html><head><title>my title</title></head><body scroll=""auto"" style=""margin: 0px; padding: 0px;"">" & _ "<embed style='padding: 70px;' src=""" & filelocation & """ width=""50%"" height=""100%"" />" & _ "</body></html>" .Document.close End With

تفضل هذه المحاولة مع معلمي القديم @عمر ضاحى 1.accdb

وتفضل هذه مشاركة مع الاخوان DD409.accdb

لإرسال رسالة واتس اب اولاً / يجب تثبيت الواتس اب على الكبيوتر الخاص بك ثانياً / هذه هي الشفرة الأساسية للإرسال whatsapp://send?phone=" & "" & "&text=" & "" ثالثاً انشئ موديول جديد و الصق فيه الشفرة التالية Public Function SendMsg(Phon_Number As Variant, TexTMag As String) Dim StrURL As Variant Dim StrToNumber As Variant Dim StrMsg As Variant StrToNumber = Phon_Number StrMsg = EncodeQP2(TexTMag) StrURL = "whatsapp://send?phone=" & StrToNumber & "&text=" & StrMsg CreateObject("WScript.Shell").Run StrURL, 1, False Call StartTimer(3) Call SendKeys("{ENTER}") End Function Public Function EncodeQP2(s As String) As String Dim i As Long Dim p1 As Long Dim p2 As Long Dim r As String Dim n As Long For i = 1 To Len(s) n = AscW(Mid(s, i, 1)) If n < 128 Then r = r & "%" & Hex(n) ElseIf n < 2048 Then p1 = n \ 64 r = r & "%" & Hex(p1 + 192) p2 = n Mod 64 r = r & "%" & Hex(p2 + 128) Else End If Next i EncodeQP2 = r End Function Public Function StartTimer(NumberOfSeconds As Variant) On Error Resume Next Dim PauseTime, Start, Finish, TotalTime PauseTime = NumberOfSeconds Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Finish = Timer TotalTime = Finish - Start End Function ثم في النموذج الخاص بك و في ازرار الارسال Call SendMsg("966590000000", "السلام عليكم")

استخدم دالة التجميع الشرطية DCount مثال على ذلك DCount("*","Table_Name","[ID]=" & [Forms]![Forms_Name]![TextBox1]) هنا نكون قد طلبنا من الدالة عدد السجلات التي تحمل نفس الرقم في مربع النص TextBox1 و يمكن بهذا الطريقة اضافة شرط كما يلي If DCount("*", "Table_Name", "[ID]=" & [Forms]![Forms_Name]![TextBox1]) <> 0 Then If MsgBox("تم تسجيل الصنف من قبل" & _ vbNewLine & "هل تريد اضافة الصنف مرة أخرى؟" _ , vbQuestion + vbMsgBoxRight + vbYesNo, "تنبيه") = vbYes Then DoCmd.RunCommand acCmdSave MsgBox "تم اضافة صنف مشابه بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" Else DoCmd.RunCommand acCmdUndo MsgBox "تم التراجع عن الحفظ", vbCritical + vbMsgBoxRight, "تأكيد" End If Else MsgBox "تم تسجيل الصنف بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" End If يجب عليك الغاء المفاتيح الاساسية لكي تستطيع تنفيذ الشروط اعلاه

يكون المعيار بهذا الشكل WHERE Year([datein] Between Year(Now()) And Year(Now())-3 النتيجة New Microsoft Access Database 1.accdb

ما تحتاج كود لأن الكود يقوم بإنشاء نسخة مماثلة من النسخة الاساسية يعني ما راح يفتح الملف و يقرأ الجداول

تفضل هذا هو كود النسخة الاحتياطية بإختصار لإنشاء نسخة احتياطة من القاعدة الحالية Dim MyFile As String Dim DstFile As String Dim Syso As Object Dim GetType As Variant MyFile = CurrentProject.FullName ' مسار القاعدة الحالية GetType = Right$(MyFile, Len(MyFile) - InStrRev(MyFile, ".")) DstFile = CurrentProject.Path & "\" & Format(Now, "dd-mm-yyyy-nss") & "." & GetType ' الاسم الجديد للنسخة الاحتياطية DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing Name DstFile As DstFile & ".ptc" DBEngine.CompactDatabase DstFile & ".ptc", DstFile Kill DstFile & ".ptc" لإنشاء نسخة احتياطية لقاعدة البيانات في حال ان القاعدة منفصلة عن الواجهة Dim MyFile As String Dim DstFile As String Dim Syso As Object Dim GetType As Variant MyFile = CurrentProject.FullName ' مسار قاعدة البيانات GetType = Right$(MyFile, Len(MyFile) - InStrRev(MyFile, ".")) DstFile = CurrentProject.Path & "\" & Format(Now, "dd-mm-yyyy-hnss") & "." & GetType ' الاسم الجديد للنسخة الاحتياطية Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing

ضع هذا الكود في ازرار التقرير If Not IsNull(TxtFrom) And IsNull(TxtTo) Then DoCmd.OpenReport "HR Data", acViewReport, _ , "EmployeeHiring = #" & TxtFrom & "#" ElseIf Not IsNull(TxtFrom) And Not IsNull(TxtTo) Then DoCmd.OpenReport "HR Data", acViewReport, _ , "EmployeeHiring Between #" & TxtFrom & "# And #" & TxtTo & "#" ElseIf IsNull(TxtFrom) And IsNull(TxtTo) Then DoCmd.OpenReport "HR Data", acViewReport End If تفضل التعديل Test (1).accdb