ابو ياسين المشولي

اتفضل طريقه الاستاذ جعفر.mdb

من خصائص النموذج انظر الصورة

لم تجبني على سوالي الاخير في هذة المشاركة

نعم اخي جعفر جاب المطلوب تسلم بارك الله فيك منكم نستفيك كما هو شعارك في اعتقادي ، مشاركة أكثر من شخص في الرد على السؤال ، يفتق الاذهان ويدمج التجارب ويبلور الافكار وفائدة للجميع ، فمنه نتعلم الطرق الاخرى للإجابة على السؤال

نعم اخي جعفر انا كان ودي استخدم الكود تبعك لانه بدون ان احدد القاعده لكن للاسف تجي رساله تم الحذف ولكن لم يتم شي وانا استعملت and ولكنه ما اشتغل معي ما اعرف السبب

شكرا اخي جعفر استخدمت الكود حقي وكانت النتيجه المطلوبه If Not (left(tdf.NAME, 4)) = "MSys" And tdf.NAME <> "User" Then للاسف اخي جعفر لم يتم حذف اي جدول

للاسف لم يضبط معي للمعلوميه انا قاعدتي منقسمه واريد احذف كل الجداول بستثناء جدول usre عندي كود يحذف كل الجداول هذا الكود كيف اضيف له شرط يسثني جدول Dim strSQL As String Dim tdf As TableDef Dim BackDB As DAO.Database Dim strPath As String strPath = CurrentProject.Path & "\data\tailor" Set BackDB = OpenDatabase(strPath) For Each tdf In BackDB.TableDefs If Not (left(tdf.NAME, 4)) = "MSys" And tdf.NAME <> "User" Then BackDB.Execute ("delete * from " & tdf.NAME) strSQL = "INSERT INTO " & tdf.NAME & " SELECT " & tdf.NAME & ".* FROM " & tdf.NAME & " IN '" & myfile & "';" BackDB.Execute (strSQL) End If Next DoCmd.Requery BackDB.Close Me.Refresh End If

للاسف اخي جعفر لم يتم حذف اي جدول

استاذ جعفر jjafferr اذا كانت القاعدة منقسمه واريد ان يستثني جدول ما كيف الطريقة

تسلم اخي جعفر بارك الله فيك طيب ممكن نتشرح لي هذا الكود وهو من مشاركتك في هذا الموضوع Dim WshShell, strCurDir Set WshShell = CreateObject("WScript.Shell") strCurDir = WshShell.CurrentDirectory WshShell.Run strCurDir & "\Nasystry.mdb", 2 Set WshShell = Nothing

الاخ jjafferr اذا فهمت قصدي ممكن تشاركني اريد تصغير 2 نموذج مع بعض وعند التكبير يرجعو مع بعض اكون شاكر لك هو الان انا اضفضت هذا ولكنه يعطيني رمزين عند المهام startForm MinimizeToTry Me.hwnd MinimizeToTry Forms!login.hwnd SetFormState 0

كم باسورد vb

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

جرب forms![سمي النموذج الفرعي].Refresh

كلامك صحيح اخي جعفر انا عندما انسخ كود من المنتدى يطلع لي هذة العبارة وانا استخدم في برنامجي ربط تلقائي هذة الداله Public Function Authorization1() ' DoCmd.RunCommand acCmdAppMinimize 'لاخفاء شاشة الاكسس ' DoCmd.ShowToolbar "ribbon", acToolbarNo 'لاخفاء ادوات الاكسس DoCmd.OpenForm "login2" End If ' On Error GoTo MyErr 'Beep 'MyErr: 'MsgBox " عفوا مجلد البيانات تم نقلة أو أعادة تسميتة " & Chr(13) & " لذا سوف يتم اغلاق البرنامج " & Chr(13) & " رجاء أذهب الى مصدر البرنامج وتأكد من وجود مجلد بأسم " & Chr(13) & " بجوار مجلد بـرنـامـج الـخـيـاط DATA ", vbYes, " بـرنـامـج الـخـيـاط : خطــــــأ " ' DoCmd.Quit End Function Public Function Authorization2() Dim obj_FSO As Object, obj_Drive As Object Set obj_FSO = CreateObject("Scripting.FileSystemObject") Set obj_Drive = obj_FSO.GetDrive("C:\") MsgBox "رقم التسجيل الخاص بنسختك هو " & obj_Drive.SerialNumber & " ", vbInformation, " بـرنـامـج الـخـيـاط : ترخيـــــــص " End Function Public Function acbRelink(strPath As String, Optional blnSilent As Boolean) As Boolean On Error GoTo alalal Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...") Set db = CurrentDb() For Each tdf In db.TableDefs If (tdf.Attributes And dbAttachedTable) = _ dbAttachedTable Then tdf.Connect = "D:\بـرنـامـج الـخـيـاط\data\tailor" tdf.RefreshLink End If Next Call SysCmd(acSysCmdClearStatus) If blnSilent Then MsgBox " تم العوده الى النسخه الأصليه مره أخرى ", vbInformation, " بـرنـامـج الـخـيـاط : النسخه الأصليه " End If alalal: If err.Number = 3024 Then Beep MsgBox " عفوا مجلد البيانات تم نقلة أو أعادة تسميتة " & Chr(13) & " لذا سوف يتم اغلاق البرنامج " & Chr(13) & " رجاء أذهب الى مصدر البرنامج وتأكد من وجود مجلد بأسم " & Chr(13) & " بجوار داخـل بـرنـامـج الـخـيـاط DATA ", vbYes, " بـرنـامـج الـخـيـاط : خطــــــأ " DoCmd.Quit End If End Function Public Function DataReceived() DoCmd.Beep If MsgBox(" !!! تـحـذيـر هل أنت متأكد " & Chr(13) & " من رغبتك في العودة للنسخة الاصلية ؟؟؟ ", vbYesNo, " بـرنـامـج الـخـيـاط : النسخه الأصليه ") = vbYes Then Call acbRelink(Trim(Replace(Application.CurrentProject.Path & "\" & "D:\بـرنـامـج الـخـيـاط\data\tailor", Chr$(0), " ")), True) End If End Function Public Function acbRelink2(strPath As String, Optional blnSilent As Boolean) As Boolean On Error GoTo alalal Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...") Set db = CurrentDb() For Each tdf In db.TableDefs If (tdf.Attributes And dbAttachedTable) = _ dbAttachedTable Then tdf.Connect = ";DATABASE=" & "D:\بـرنـامـج الـخـيـاط\data\tailor" tdf.RefreshLink End If Next Call SysCmd(acSysCmdClearStatus) alalal: If err.Number = 3024 Or err.Number = 2001 Then DoCmd.Beep MsgBox " عفوا مجلد البيانات تم نقلة أو أعادة تسميتة " & Chr(13) & " لذا سوف يتم اغلاق البرنامج " & Chr(13) & " رجاء أذهب الى مصدر البرنامج وتأكد من وجود مجلد بأسم " & Chr(13) & " بجوار مجلد بـرنـامـج الـخـيـاط DATA داخل مجلد tailor وملف بأسم DATA ", vbYes, " بـرنـامـج الـخـيـاط : خطــــــأ " DoCmd.Quit End If End Function Public Function DataReceived2() ' HideAccess 'لاخفاء شاشة الاكسس Call acbRelink2(Trim(Replace(Application.CurrentProject.Path & "\" & "D:\بـرنـامـج الـخـيـاط\data\tailor", Chr$(0), " ")), True) End Function

بارك الله فيك

الوزير دائما هو السباق انا كنت عدلتها الى هذا =DSum("[Alkmiah]";"Hrakatsanf";"[ID_Sanf]='" & [ID_Sanf] & "'" & "and [Atarih] >=#" & [t] & "#")

بارك الله في الجميع

اتفضل اخفار واظهار.accdb

في اي امر تختارة في النموذج

كود لاخفاء الجداول والاستعلامات كلمة السر 123 Dim db As Database Dim obj As AccessObject, dbs As Object Dim tdf As TableDef Dim qry As QueryDefs Set dbs = Application.CurrentData Set db = CurrentDb For Each obj In dbs.AllTables Set tdf = db.TableDefs(obj.NAME) If left(tdf.NAME, 4) <> "msys" And tdf.Attributes <> 1073741824 Then tdf.Attributes = tdf.Attributes + dbHiddenObject End If Next For Each obj In dbs.AllQueries SetHiddenAttribute acQuery, obj.NAME, True Next obj Application.SetOption "Show Hidden Objects", 0 Application.SetOption "Show System Objects", 0 Set tdf = Nothing db.Close Set db = Nothing وهذا اظهار الاستعلامات Retry: TimerId = SetTimer(0, 0, 1, AddressOf TimerProc) Dim MyPassword As String str_Title = "كلمة السر مطلوبه" str_Prompt = "أدخـل كـلـمـة الـسـر لاظهار الجداول والاستعلامات" MyPassword = InputBox(str_Prompt, str_Title) Select Case MyPassword Case "123" Beep MsgBox "الأن... يـمكـنـك اظهار الجدالول", vbOKOnly + vbInformation Case Else Beep If MsgBox(" عــفــوا .. كــلــمــة الــســر خــاطــئــة " & vbCrLf & " مــن حــســن إســـلام الـمــرء تــركــه مــا لا يــعــنــيــه ", vbInformation + vbRetryCancel) = vbRetry Then GoTo Retry Exit Sub MsgBox "تم الرجوع", vbInformation, "إلغاء العملية" End Select Dim db As Database Dim obj As AccessObject, dbs As Object Dim qry As QueryDefs Set dbs = Application.CurrentData Set db = CurrentDb For Each obj In dbs.AllQueries SetHiddenAttribute acQuery, obj.NAME, False Next obj Set dbs = CurrentDb For Each tdf In dbs.TableDefs If left(tdf.NAME, 4) <> "msys" And tdf.Attributes <> 1073741824 _ And tdf.Attributes = 1 Then tdf.Attributes = tdf.Attributes - dbHiddenObject End If Next tdf Set dbs = Nothing db.Close Set db = Nothing

بعد اذن اخي الوزير تصحيح فقط لانه عمله على كود vb ويفرق بينهم , وهذة ; =Nz(DSum("[Price]";"[selling]";"[selling Case]<>'deleted '");0)

كل عام والجميع بخير كيف ممكن ان نصغر اكثر من نموذج ونستعيدها بنفس الوقت اقصد بجوار الساعه

العفو اخي ابو زاهر بالتوفيق