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

مشاركةً مع اساتذتي تفضل استاذ @salah.sarea محاولتي . 1- ضغط واصلاح القاعدة الخلفية للقاعدة الحالية (القاعدة الخلفية محمية بكلمة مرور) . 2- ضغط واصلاح اي قاعدة تختارها (القاعدة محمية بكلمة مرور) . 3- ضغط واصلاح اي قاعدة تختارها (القاعدة غير محمية ) . ووافني بالرد . compact and repair.rar

بناءا على طلب احد الاخوة مرفق قاعدة البيانات الرقم السري 12345 اتمنى من الاحبة الخبراء اثراء الموضوع بطرق اخرى اكثر احترافية رقم سري.accdb

اسف اخي على التاخير في الرد بسبب ظروف العمل وضيق الوقت لدي تفضل جرب هدا حاولت تعديل الاكواد قدر المستطاع للحصول على نفس الشكل المطلوب اتمنى ان يلبي طلبك Book معدل.xls

السلام عليكم وجدت برنامج مصمم بالاكسس مجاني من صاحبه لاكن لم استطع التعديل عليه بما يناسب احتياجاتي كالعناوين وغيرها فهل من حل

احسنت ا/ حسونة حسين أنه يعمل شكرا جزيلا على هذا المجهود الرائع

أخي @Zooro1 ، ربي يسلمك من كل مكروه لنبدأ غداً إن شاء الله في توضيح بعض النقاط والأساسيات ثم البدء بتصميم الجداول .

تفضل أخي @SAROOK ، تم التعديل على مديول المرفق وتوسيعه ليشمل كلمة "بن" أينما وردت بين مقاطع الإسم ، في الكود التالي :- Public Function qsplit(FullName As String, i As Integer) As String Dim parts() As String Dim j As Integer Dim namePart As String parts = Split(FullName, " ") For j = 0 To UBound(parts) - 1 If InStr(parts(j), "بن") > 0 Then parts(j) = parts(j) & " " & parts(j + 1) parts(j + 1) = "" End If Next j Dim count As Integer For j = 0 To UBound(parts) If parts(j) <> "" Then If count = i Then qsplit = parts(j) Exit Function End If count = count + 1 End If Next j End Function مع بقاء الإستدعاء كما هو في الملف المرفق لك ، وهذا ملفك بعد التعديل :- Splite Names.accdb

الله يعطيك الف الف عافيه والف شكر لك تحياتي

وهذه طريفة اخرى اقل اكواد <><><><><><><> Dim db As DAO.Database Set db = CurrentDb() db.Execute "DELETE template.UsrID, * FROM template WHERE (((template.UsrID) In (SELECT No_Common FROM QRFingerDelete)))", dbFailOnError Set db = Nothing

وعليكم السلام تفضل <><><><><><><><> Dim rs As DAO.Recordset Dim R As Integer Set rs = CurrentDb.OpenRecordset(" SELECT TB_1.No_Common " & _ " FROM TB_1 INNER JOIN TB_2 ON TB_1.No_Common = TB_2.No_Common " & _ " WHERE (((TB_2.End_Date)<=Date()-1) AND ((TB_2.Case_Com)=102) AND ((TB_2.jadd)=False));", dbOpenDynaset) rs.MoveLast rs.MoveFirst R = rs.RecordCount For i = 1 To R DoCmd.SetWarnings False DoCmd.RunSQL "DELETE template.id, template.FingerTmplate, template.UsrID " & _ " FROM template " & _ " WHERE (((template.UsrID)=" & rs!No_Common & "));" DoCmd.SetWarnings True rs.MoveNext Next i rs.Close Set rs = Nothing

تفضل اخى الكود بطريقه ثانيه لعلها تكون المطلوبه Private Sub TextBox2_Change() Application.OnTime Now() + TimeValue("00:00:02"), "ورقة1.test" End Sub Sub test() If TextBox2 = "" Then AutoFilterMode = False Else Range("H1").AutoFilter , field:=8, Criteria1:=TextBox2.Text Dim X X = Application.Match(Val(TextBox2), ورقة3.Columns(4), 0) If Not IsError(X) Then With ورقة3.Cells(X, "B") .Value = ورقة1.Cells(1, "I").Value .Interior.ColorIndex = 30 .Font.ColorIndex = 20 End With End If End If End Sub

الف لا باس عليكم واجر وعافية ان شاء الله وفي انتظار التعديلات

تفصل اخی If Forms!separet!Check71 = "-1" Then DoCmd.OpenReport "SeparetrBySelection", acViewPreview, "", "", acNormal DoCmd.PrintOut Else DoCmd.OpenReport "separetr", acViewPreview, "", "", acNormal DoCmd.PrintOut End If

اشكرك على الاهتمام استاذ @Moosak يبدو ان الموضوع الذي نصحتني به شيق ومفيد جزاك الله خيرا

ضع كلمة المرور بين علامتي التنصيص ، جرب وبانتظار ردك 🤗

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

أعتذر عن التأخير والمتابعة بسبب ظرف صحي . أخي @salah.sarea و الأخ @kamelnet5 على العموم يا صديقي بعد التركيز في مشاركتي السابقة يبدو أنني قد توجهت بشكل خاطئ للمطلوب . القاعدة المقسمة والمرتبطة بقاعدة بيانات الواجهة الرئيسية ( الأمامية ) لا بد من أنها ترتبط مع الجداول دون أن تقوم بإدخال الباسوورد بشكل يدوي كل مرة هل هذا صحيح ؟؟ وعليه وإن كان / أو لم يكن هناك كلمة مرور لقاعدة بيانات الجداول جرب هذا المرفق يعمل معي بكفاءة . وهذا كود الدالة :- Public Function compactDb(ByVal mydb As String, ByVal mypass As String, Optional openIt As Boolean = False) Dim f As Integer Dim filenoext As String, extension As String, Access As String Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE""" filenoext = Left(mydb, InStrRev(mydb, ".")) extension = Right(mydb, Len(mydb) - InStrRev(mydb, ".")) f = FreeFile Open CurrentProject.Path & "\compact.bat" For Output As f Print #f, "CHCP 1256" Print #f, ":checkldb1" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb1" Print #f, Access & " """ & mydb & """" & mypass & " /compact" If openIt Then Print #f, ":checkldb2" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb2" Print #f, Access & " """ & mydb & """" Else Print #f, "del ""%~f0""" End If Close f End Function Public Function CopactMyDb() On Error Resume Next Dim Mypath As String Mypath = CurrentProject.Path & "\" & CurrentProject.Name Call compactDb(Mypath, "", True) Shell """" & Left(Mypath, InStrRev(Mypath, "\")) & "\compact.bat""", 0 DoCmd.Quit acQuitSaveAll End Function ويتم الإستدعاء في أي زر = CopactMyDb Compact.accdb

السلام عليكم ورحمه الله وبركاته وبها نبدأ جرب هذا التعديل اخى @mahmoud nasr alhasany Gestion Stocks Magasin1.xlsm

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

وعليكم السلام ورحمة الله وبركاته اخي @salah.sarea . ضع هذا الكود في حدث عند النقر لزر الإصلاح ، مع تحديد مسار قاعدة البيانات B_Be حسب ما تريد . Private Sub btnRepair_Click() Dim strConnect As String Dim strPassword As String strPassword = "123" strConnect = "MS Access;PWD=" & strPassword & ";DATABASE=path_to_b_be.accdb" Application.CompactRepair SourceFile:="path_to_b_be.accdb", DestinationFile:="path_to_b_be.accdb", _ Password:=strPassword MsgBox "تم إصلاح قاعدة البيانات بنجاح!", vbInformation End Sub طبعا على افتراض أن اسم الزر btnRepair.

تقصد ان هدا الشكل لا يناسبك هل قمت بتجربة هدا Sub test() Dim lCol As Long, MyRng As Range Set desWS = ActiveSheet: Set ws = Sheet2 If Len(desWS.[CA328].Value) = 0 Then Exit Sub ws.Cells.Clear For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i Set MyRng = desWS.[BW330:CK372] Application.ScreenUpdating = False MyRng.Copy If ws.[D9] = "" Then MyRng.Copy With ws.[c5] .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With Else lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column + 5 MyRng.Copy With ws.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With End If Application.CutCopyMode = False Application.ScreenUpdating = True Next i End Sub 2024-04-11 الفواتير من 2024-04-05 الى.pdf

السلام عليكم الاخ الكريم / aburajai بارك الله فيك لتنفيذ ما تريده قم بوضع الاكواد التاليه باكواد الفورم واليك ملف مرفق به فورم مع الاكواد المذكورة لالغاء الشريط الازرق من الفورم ( ترويسه الفورم ) Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 Private Sub UserForm_Initialize() On Error Resume Next Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) End Sub Private Sub CommandButton1_Click() End End Sub جزاك الله خيرا الغاء الترويسه من الفورم.rar