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

بعد اذن الاخ الغالي عبد السلام حل اخر على الصفحة الثانية ورقة عمل Microsoft Excel salim.rar

جرب الملف تم التعديل MultiCat UDF Function2.rar

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة كتاب الكترونى من محمد يحياوى _هدية للاخ ياسر خليل تم ارفاق كود الحل من المبدع / هدية من محمد يحياوي الى ياسر خليل أبو البراء و لا تنسونا من صالح الدعاء تحياتى دورة المبتدئين (1).rar

السلام عليكم عدة أيام ولم تظهر أي مشاركة للأستاذ ياسر أبو البراء مما أدى إلى تغير الصفحة الأولى في منتدانا القيم هذا أصبح شكلها غريباً بعض الشيء!!!! عسى يكون الأمر خيراً

شكرا لك استاذى العزيز / ناصر سعيد وعلى كلماتك الرقيقة

بعد اذن الأستاذ رجب جاويش قمت بالتعديل على الملف لحل مشكلة ترحيل ناجح وراسب بوضع زر فى صفحة الشيت للترحيل اما بالنسبة للأستاذ غريب لم افهم ما المقصود بالنسبة واليكم التعديل فى هذا الملف http://www.mediafire.com/download/4sczzx1xk1fkoyw/كنترول_الإعدادى__رجب_جاويش_الإصدار__15.rar

اخى العزيز ارجو ان يفى هذا الملف بالغرض المطلوب تحياتى السن فى 1-10.rar

سلمت يداك بجد عمل احترافى على اعلى مستوى

جزاك الله خيراً اخ عبد السلام والحمد لله أن تم المطلوب على خير ووفقك الله وبارك لك في وقتك وعلمك وجهدك وعمرك

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

جرب ورقة عمل Microsoft Excel جديد.rar

اضف هذا الكود الى حدث التفيير في الصفحة مغ الاختفاظ بالكود السابق salim Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Count = 1 And Target.Row > 7 Then Select Case Target.Column Case 3, 5, 7 salim End Select End If Application.EnableEvents = True End Sub

اخي وبعد اذن الاخ الحبيبي ياسر قمت بترتيب الشيت وعملت رؤوس للاعمدة يمكنك تغير اسمائها فيما عدا العامود الثاني لانه سيرحل له كل كود جديد وغير مكرر لمجرد كتابته في العامود4 ومن ثم عمل مدي يتجدد باستمرار وما عليك الا اختيار الكود من عامود 8 فقط وسيتم عمل المطلوب عموما جرب الملف MultiCat UDF Function.rar

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

الشكل النهائي

بارك الله فيك استاذ ابو عارف

ربما كان المطلوب salim رقم الهوية.rar

السلام عليكم وبعد اذن اخي العزيز طارق محمود اخي كيف تاتيك رسالة بالاستمرار في حالة عدم وجود الفئة التي تريد الصرف منها؟ عموما تم عمل المرفق بحيث تأتيك رسالة تفيدك بالفئة التي من المفروض ان تعدل فيها سواء في الفردي او في الرزم خزينة تجربة3.rar

اخي هذا الرنامج جيد ولكن المشكلة تكمن لو كان ملفك باللغة العربية https://app.box.com/s/4gkgkm9h4wvye5jkqh8ccbz70e5s8ni7

تفضل اخي علما بان تم تغير اسم جدول year الى yyear و كذالك اسماء حقول في جداول بهذالاسم لان year كلمة محجوزة في اكسس و اليك المرفق New Microsoft Access Database1.zip

مشكور اخي الكريم محي على اللفته الطيبة هذه اخي ابو البراء متغيب قليلا لظروف عمله وفقنا الله واياكم تقبلو تحياتي

لوسمحتم حد يرد عليّ ضروري انا سجلت درجات الطلاب علي شيت اعدادي ٢٠١٦ لكن كشوف ناجح وراسب فارغة لم يتم ترحيل النتيجة اليها الرجاء سرعة الرد ولكم الشكر

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة ( موضوع مميز ) استخراج الأسماء المكررة في قائمة بدأه الاستاذ / ياسر خليل أبو البراء تم ارفاق كود الحل من الافاضل/ الحسامي_ الخالدي _ بن علية حاجي _ ياسر خليل أبو البراء _ أبوعبد الله_ عبد الفتاح كيرة _ يحيى حسين_ وائل مراد 700 و لا تنسونا من صالح الدعاء تحياتى اسماء مكرره_الحسامى.rar قائمة الاسماء المكررة _الخالدى).rar الاسماء المكررة1 _بن عليه حاجى).rar ListOfRepeatedNames تعديل ابو البراء_.rar NEW_PROGRAM-kemas (1).zip قائمة بالمكرر وعدد مرات التكرار وعناوين المكرر -ابو عبدالله_2.rar _ابو عبدالله _3_قائمة بالمكرر وعدد مرات التكرار وعناوين المكرر مع شرح الكود.rar Test2 عبد الفتاح كيره_.rar www.Excel4Us.com يحيى حسين.rar _الخالدى_الانتقال بين المكررات.rar فحص المكرر وائل مراد).rar قائمة بالمكرر وعدد مرات التكرار وعناوين المكرر _ابو عبدالله).rar

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة هل يمكن عمل قائمة لتنفيذ اكثر من ماكرو تم ارفاق كود الحل من الفاضل/ علي السحيب و لا تنسونا من صالح الدعاء تحياتى قاموس مصطلحات بزر امر.rar

وهذا ملف آخر add chape.rar يهمني رأيكم

لا أعلم لماذا تتكرر المشكلة.. سأعاود إرفاق الملف add shapes.rar

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

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

وعليكم السلام أخي علي لقد قمت بالرد على هذا الموضوع في منتدى الفريق العربي للبرمجة ، وهنا اضع لك نفس الرد 1. في برنامج الواجهات ، وليس برنامج الجداول ، احفظ هذا الكود في وحدة نمطية ، سميها basJStreetAccessRelinker : '----------------------------------------------- 'VERSION 2 BETA '- Supports both 32-bit and 64-bit versions of Access 2010. '- Supports encrypted (password-protected) back-end Access databases. The password is stored in the front-end database unencrypted, so care should be taken to protect the front-end application. '----------------------------------------------- 'This database contains the module and macros necessary to implement an automatic linked Access table validity checker. 'It also allows the user to change the current backend databases (whether currently valid or not). 'You can try this feature using the ChangeTableLinks macro. 'This utility supports multiple back-end Access databases. It does not need a separate "list of tables" in a table, 'INI file or anywhere else. In order to have it check and relink new tables, just link them. 'This version of the utility supports only Access linked tables. It does not support ODBC tables such as SQL Server, 'SharePoint linked table, or any other kind of linked tables. Linked tables other than Access tables are ignored. 'To implement, import all modules and macros into an Access database. If there is already an AutoExec macro, 'copy the one line from this one into the existing one. 'Note: Since Access doesn't always refresh the TableDefs collection when a new table is first linked, 'you may need to close and reopen the database when you first link new tables so that the utility will detect them. 'On startup, all linked tables will be checked automatically. 'For slow networks, or for databases with many (say over 100) linked tables, you can use the "Quick" mode. 'This checks only 1 table in each backend database, and assumes the rest are okay. 'You can use this mode by calling jstCheckTableLinks_Quick. 'To change backend databases, even if the current one is valid, have a form button invoke the code: 'jstCheckTableLinks_Prompt 'This can be useful for switching the backend database between Production, Test and Training, for example. 'For any selected mode (Full, Prompt or Quick) a fourth, optional parameter called CheckAppFolder forces table links 'to a database that resides in the same folder as the application. For example, if a table in ProjectApplication.mdb is 'linked to \\Server\Share\Folder\ProjectData.mdb and there is a database of the same name in the same folder 'as the application, then the table link will be changed to reference the ProjectData.mdb file in the application folder. 'This behavior overrides all prompting for a new location; tables linked to a database in the same folder as the 'application will never be prompted. This mode is helpful for local "work databases" or single user applications. 'If you are using the Display Form default in Access you will need to change that default to (None) so that the 'AutoExec macro will execute to link the files before your first form is displayed. 'To get the form you want to display after the files are linked you need to add a line of code to Open Form 'at the end of the AutoExec. 'This code requires the DAO library to be selected in your References List (e.g. “Microsoft DAO 3.6 Object Library”) 'For more information from the function (such as whether the links are okay and whether the user changed them) call 'Sub jstCheckTableLinks directly and check the value of its output parameters. See the comments in the Sub for more 'details. 'This utility has been used successfully in Access 95, 97, 2000, XP/2002, 2003, 2007 and 2010. It works with MDB and 'ACCDB back-end databases. To link to ACCDB/ACCDE back-end databases, this code must be running in an ACCDB/ACCDE 'front-end application. 'This utility contains some techniques that are backward compatible with older versions of Access, such as InStrRight. 'You may use and distribute this code in your own applications, provided that you leave all comments and notices intact. 'J Street Technology offers this code "as is" and does not assume any liability for bugs or problems with any of the code. 'In addition, we do not provide free technical support for this code. 'Developed by J Street Technology, Inc. 'Www.JStreetTech.com '© 1997 - 2011 '-------------------------------------------------------------------- ' ' Copyright 1996-2013 J Street Technology, Inc. ' www.JStreetTech.com ' ' This code may be used and distributed as part of your application ' provided that all comments remain intact. ' ' J Street Technology offers this code "as is" and does not assume ' any liability for bugs or problems with any of the code. In ' addition, we do not provide free technical support for this code. ' ' Code for Password-masked InputBox was originally written by ' Daniel Klann in March 2003 and has been adapted & updaed for 64-bit ' compatiblity '-------------------------------------------------------------------- Option Compare Database Option Explicit 'Revised Type Declare for compatability with NT 'Re-revised for 64-bit compatibility #If VBA7 Then Type tagOPENFILENAME lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr lpstrFilter As String lpstrCustomFilter As Long nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As Long End Type Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean 'APIs for Password-masked Inputbox Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _ ByVal hHook As LongPtr, _ ByVal ncode As Long, _ ByVal wParam As LongPtr, _ lparam As Any _ ) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _ ByVal lpModuleName As String _ ) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As LongPtr, _ ByVal hmod As LongPtr, _ ByVal dwThreadId As Long _ ) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As LongPtr _ ) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _ ByVal hDlg As LongPtr, _ ByVal nIDDlgItem As Long, _ ByVal wMsg As Long, _ ByVal wParam As LongPtr, _ ByVal lparam As LongPtr _ ) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _ ByVal hWnd As LongPtr, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long _ ) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long Private hHook As LongPtr #Else Type tagOPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As Long nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As Long End Type Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long 'APIs for Password-masked Inputbox Private Declare Function CallNextHookEx Lib "user32" ( _ ByVal hHook As Long, _ ByVal ncode As Long, _ ByVal wParam As Long, _ lparam As Any _ ) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _ ByVal lpModuleName As String _ ) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long _ ) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As Long _ ) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _ ByVal hDlg As Long, _ ByVal nIDDlgItem As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lparam As Long _ ) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _ ByVal hWnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long _ ) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Private hHook As Long #End If 'Constants used by Password-masked Inputbox Private Const EM_SETPASSWORDCHAR As Long = &HCC Private Const WH_CBT As Long = 5 Private Const HCBT_ACTIVATE As Long = 5 Private Const HC_ACTION As Long = 0 Private Sub HandleError(strLoc As String, strError As String, intError As Integer) MsgBox strLoc & ": " & strError & " (" & intError & ")", 16, "CheckTableLinks" End Sub Private Function TableLinkOkay(strTableName As String) As Boolean 'Function accepts a table name and tests first to determine if linked 'table, then tests link by performing refresh link. 'Error causes TableLinkOkay = False, else TableLinkOkay = True Dim CurDB As DAO.Database Dim tdf As TableDef Dim strFieldName As String On Error GoTo TableLinkOkayError Set CurDB = DBEngine.Workspaces(0).Databases(0) Set tdf = CurDB.TableDefs(strTableName) TableLinkOkay = True If tdf.Connect <> "" Then '#BGC updated to be more thorough in checking the link by opening a recordset 'ACS 10/31/2013 Added brackets to support spaces in table and field names strFieldName = CurDB.OpenRecordset("SELECT TOP 1 [" & tdf.Fields(0).Name & "] FROM [" & tdf.Name & "];", dbOpenSnapshot, dbReadOnly).Fields(0).Name 'Do not test if nonlinked table End If TableLinkOkay = True TableLinkOkayExit: Exit Function TableLinkOkayError: TableLinkOkay = False GoTo TableLinkOkayExit End Function '---------------------------------------------------------------- Private Function Relink(tdf As TableDef) As Boolean 'Function accepts a tabledef and tests first to determine if linked 'table, then links table by performing refresh link. 'Error causes Relink = False, else Relink = True On Error GoTo RelinkError Relink = True If tdf.Connect <> "" Then tdf.RefreshLink 'Do not test if local or system table End If Relink = True RelinkExit: Exit Function RelinkError: Relink = False GoTo RelinkExit End Function '--------------------------------------------------------------------------- Private Sub RelinkTables(strCurConnectProp As String, intResultcode As Integer) 'This subroutine accepts a table connect property and displays a dialog to allow 'modification of table links. Routine verifies link for each modification. 'intResultcode = 0 if cancel ocx or no link change, 1 if new links OK, and '2 if link check fails. Dim CurDB As DAO.Database Dim NewDB As Database Dim tdf As TableDef Dim strFilter As String Dim strDefExt As String Dim strTitle As String Dim OPENFILENAME As tagOPENFILENAME Dim strFileName As String Dim strFileTitle As String Dim APIResults As Long Dim intSlashLoc As Integer Dim intConnectCharCt As Integer Dim strDBName As String Dim strPath As String Dim strNewConnectProp As String Dim intNumTables As Integer Dim intTableIndex As Integer Dim strTableName As String Dim strSaveCurConnectProp As String Dim strMsg As String Dim varReturnVal Dim strAccExt As String Dim strPassword As String Const OFN_PATHMUSTEXIST = &H1000 Const OFN_FILEMUSTEXIST = &H800 Const OFN_HIDEREADONLY = &H4 On Error GoTo RelinkTablesError 'Returned by GetOpenFileName 'Revised to handle to the Win32 structure 'strFileName = Space$(256) 'strFileTitle = Space$(256) strFileName = String(256, 0) strFileTitle = String(256, 0) Set CurDB = DBEngine.Workspaces(0).Databases(0) strSaveCurConnectProp = strCurConnectProp 'Parse table connect property to get data base name intSlashLoc = 1 intConnectCharCt = Len(strCurConnectProp) Do Until InStr(intSlashLoc, strCurConnectProp, "\") = 0 intSlashLoc = InStr(intSlashLoc, strCurConnectProp, "\") + 1 Loop strDBName = Right$(strCurConnectProp, intConnectCharCt - intSlashLoc + 1) strPath = Right$(strCurConnectProp, intConnectCharCt - 10) strPath = Left$(strPath, intSlashLoc - 12) 'Set up display of dialog 'October 2009 - now handles Access 2007 formats ACCDB and ACCDE strAccExt = "*.accdb; *.mdb; *.mda; *.accda; *.mde; *.accde" strFilter = "Microsoft Office Access (" & strAccExt & ")" & Chr$(0) & strAccExt & Chr$(0) & _ "All Files (*.*)" & Chr$(0) & "*.*" & _ Chr$(0) & Chr$(0) strTitle = "Find new location of " & strDBName strDefExt = "mdb" 'Revisions to handle to the Win32 structure 'See changes to type declare 'Changed from Len to LenB for 64-bit compatibility '----------------------------------------------------------- With OPENFILENAME .lStructSize = LenB(OPENFILENAME) .hwndOwner = Application.hWndAccessApp .lpstrFilter = strFilter .nFilterIndex = 1 .lpstrFile = strDBName & String(256 - Len(strDBName), 0) .nMaxFile = Len(strFileName) - 1 .lpstrFileTitle = strFileTitle .nMaxFileTitle = Len(strFileTitle) - 1 .lpstrTitle = strTitle .Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY .lpstrDefExt = strDefExt .hInstance = 0 .lpstrCustomFilter = 0 .nMaxCustFilter = 0 .lpstrInitialDir = strPath .nFileOffset = 0 .nFileExtension = 0 .lCustData = 0 .lpfnHook = 0 .lpTemplateName = 0 End With '----------------------------------------------------------- APIResults = GetOpenFileName(OPENFILENAME) intResultcode = APIResults If APIResults = 1 Then '1 if user selected file strNewConnectProp = ";DATABASE=" & OPENFILENAME.lpstrFile If Trim(strNewConnectProp) <> Trim(strSaveCurConnectProp) Then 'Open New Database and create New Connect Property DoCmd.Hourglass True '#BGC Moved to a separate routine and handle the password 'Set NewDB = OpenDatabase(OPENFILENAME.lpstrFile, False, True) strPassword = ExtractPassword(strSaveCurConnectProp) Set NewDB = GetDatabase(OPENFILENAME.lpstrFile, strPassword) If Not NewDB Is Nothing Then 'Set tables connect property to new connect & test If Len(strPassword) Then strNewConnectProp = "MS Access;PWD=" & strPassword & strNewConnectProp End If intNumTables = CurDB.TableDefs.Count varReturnVal = SysCmd(acSysCmdInitMeter, "Linking Access Database", intNumTables) For intTableIndex = 0 To intNumTables - 1 DoEvents varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex) Set tdf = CurDB.TableDefs(intTableIndex) If tdf.Connect = strCurConnectProp Then tdf.Connect = strNewConnectProp strTableName = tdf.Name If Not Relink(tdf) Then 'Link failed, restore previous connect property and generate msgs tdf.Connect = strCurConnectProp intResultcode = 2 'Link failed '#BGC changed the Right to Mid$ and searching on the DATABASE key to handle different starting length strSaveCurConnectProp = Mid$(strSaveCurConnectProp, InStr(1, strSaveCurConnectProp, ";DATABASE=") + 10) strMsg = "Access Table: " & strTableName & " link failed using selected database." & vbCrLf & vbCrLf & "Table is still linked to previous database path: " & strSaveCurConnectProp & "." strTitle = "Failed Access Table Link" MsgBox strMsg, 16, strTitle End If End If Next intTableIndex varReturnVal = SysCmd(acSysCmdRemoveMeter) Else 'Unable to connect to the database, return link failed intResultcode = 2 strMsg = "Relinking selected database failed." & vbCrLf & vbCrLf & "Table(s) are still linked to previous database path: " & Mid$(strSaveCurConnectProp, InStr(1, strSaveCurConnectProp, ";DATABASE=") + 10) & "." strTitle = "Failed Access Table Link" MsgBox strMsg, 16, strTitle End If Else intResultcode = 0 'No change in Link End If End If RelinkTablesExit: Exit Sub RelinkTablesError: HandleError "RelinkTables", Error, Err Resume RelinkTablesExit Resume End Sub '------------------------------------------------------------------ Public Sub jstCheckTableLinks(CheckMode As String, LinksChanged As Boolean, LinksOK As Boolean, Optional CheckAppFolder As Boolean) ' 'INPUT: 'CheckMode = "prompt", Subroutine queries operator for location of ' each database required by linked tables. Msgbox for each failed link ' and summary Msgbox on final link status (success or failure) if any ' links were changed. If no links changed, then no summary status. ' 'CheckMode = "full", Subroutine identifies invalid table links ' and queries operator for location of database(s) required to satisfy ' failed links. Msgbox for each failed link and summary Msgbox ' if link failures. No Msgbox appears if all links are valid. ' 'CheckMode = "quick", same as "full" except that only the first table for ' each linked database is checked. If the link is not valid, the user is ' is prompted for the location of the database and all tables in that ' database are relinked. ' 'CheckAppFolder = True, override linked table connections if the same database name ' exists in the application folder. If False or not specified, no override occurs. ' 'OUTPUT: 'LinksChanged = true if at least one table link was changed. ' false if no links where changed. 'LinksOK = true if all links are OK upon subroutine exit. ' false if least one table link was not successful. '-------------------------------------------------------------------- Dim CurDB As Database Dim tdf As TableDef Dim TableConnectPropBadArray() As String, intDBBadCount As Integer Dim TableConnectPropChkArray() As String, intDBChkCount As Integer Dim UniquePathArray() As Variant, intDBCount As Integer, intDBIndex As Integer, intDBOverrideIndex As Integer Dim bOverride As Boolean Dim bPathFound As Boolean Dim strUniqueDBPath As String Dim strFileSearch As String Dim intTableIndex As Integer Dim intNumTables As Integer Dim strTableName As String Dim strFieldName As String Dim intBadIndex As Integer Dim intChkIndex As Integer Dim fFound As Integer Dim fAllFound As Integer Dim fLinkGood As Integer Dim strCurConnectProp As String Dim intResultcode As Integer Dim strMsg As String Dim strTitle As String Dim intNoLinksChanged As Integer Dim varReturnVal As Variant Dim strPassword As String On Error GoTo CheckTableLinksError DoCmd.Hourglass True varReturnVal = SysCmd(acSysCmdSetStatus, "Checking linked databases.") Set CurDB = DBEngine.Workspaces(0).Databases(0) 'Get number of tables. intNumTables = CurDB.TableDefs.Count ReDim TableConnectPropBadArray(intNumTables) 'Set largest size ReDim TableConnectPropChkArray(intNumTables) 'Set largest size ReDim UniquePathArray(intNumTables, 1) 'If app configured to first check in applicaiton folder for linked databases If CheckAppFolder = True Then For intTableIndex = 0 To intNumTables - 1 Set tdf = CurDB.TableDefs(intTableIndex) 'If there is a connect string If tdf.Connect & "" <> "" Then '#BGC Commented -- the loop is not needed when doing CheckAppFolder since we're overriding ' bPathFound = False ' 'Loop through the array to check for pre-existence of database to preserve uniqueness of db paths ' For intDBIndex = 0 To (intNumTables - 1) ' If tdf.Connect = UniquePathArray(intTableIndex, 0) Then ' bPathFound = True ' Exit For ' End If ' Next ' 'If the path was not found in the array, add it to the unique array of paths. ' If bPathFound = False Then UniquePathArray(intDBCount, 1) = 0 UniquePathArray(intDBCount, 0) = tdf.Connect intDBCount = intDBCount + 1 ' End If End If Next 'Loop through all databases in array; set Override 'flag'(second column of array) For intDBIndex = 0 To intDBCount strUniqueDBPath = UniquePathArray(intDBIndex, 0) UniquePathArray(intDBIndex, 1) = ExistsInAppFolder(strUniqueDBPath) Next End If 'Set up Array of Databases (all if forcelink is true, failed links if ' forcelink is false) (local and system tables will pass test). varReturnVal = SysCmd(acSysCmdInitMeter, "Checking linked databases.", intNumTables) LinksOK = True 'Assume success For intTableIndex = 0 To intNumTables - 1 DoEvents varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex) Set tdf = CurDB.TableDefs(intTableIndex) fFound = False If tdf.Connect Like "*;DATABASE=*" Then 'BGC -- changed from NOT "ODBC" to = ";DATABASE=" explicitly to get Access tables only strCurConnectProp = tdf.Connect If CheckAppFolder = True Then bOverride = False For intDBOverrideIndex = 0 To intDBCount If tdf.Connect & "" <> "" And tdf.Connect = UniquePathArray(intDBOverrideIndex, 0) And UniquePathArray(intDBOverrideIndex, 1) = True Then bOverride = True strFileSearch = UniquePathArray(intDBOverrideIndex, 0) strPassword = ExtractPassword(tdf.Connect) If Len(strPassword) Then strPassword = "MS Access;PWD=" & strPassword End If tdf.Connect = strPassword & ";DATABASE=" & PathOnly(CurDB.Name) & FileOnly(strFileSearch) Exit For End If Next End If If bOverride = True Then If Not Relink(tdf) Then 'Link failed, restore previous connect property and generate msgs tdf.Connect = strCurConnectProp 'intResultcode = 2 'Link failed strMsg = "Application Folder Table: " & tdf.Name & " link failed." & vbCrLf & vbCrLf & "The current path for this linked table is: " & Mid$(strCurConnectProp, InStr(1, strCurConnectProp, ";DATABASE=") + 10) & "." strTitle = "Failed Table Link" MsgBox strMsg, 16, strTitle End If Else ' regular table, not overridden Select Case CheckMode Case "prompt" ' put each connect string into the Bad array to force prompting later For intBadIndex = 0 To intDBBadCount If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then fFound = True Exit For End If Next intBadIndex If Not fFound Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 End If Case "full" ' check each link, and put each bad connect string into ' the Bad array to prompt later For intBadIndex = 0 To intDBBadCount If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then fFound = True Exit For End If Next intBadIndex If Not fFound Then If Not TableLinkOkay(tdf.Name) Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 LinksOK = False End If End If Case "quick" ' for each link, see if it has already been checked. ' if it hasn't, add it to the checked array, ' and check it. If the link is bad, add it to the bad array to prompt later. For intChkIndex = 0 To intDBChkCount If tdf.Connect = TableConnectPropChkArray(intChkIndex) Then fFound = True Exit For End If Next intChkIndex If Not fFound Then TableConnectPropChkArray(intDBChkCount) = tdf.Connect intDBChkCount = intDBChkCount + 1 If Not TableLinkOkay(tdf.Name) Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 LinksOK = False End If End If Case Else MsgBox "CheckMode parameter """ & CheckMode & """ is not valid. It must be ""prompt"", ""full"" or ""quick"".", vbCritical + vbOKOnly LinksChanged = False GoTo CheckTableLinksExit End Select End If ' overridden table End If ' an Access linked table Next intTableIndex varReturnVal = SysCmd(acSysCmdRemoveMeter) 'Prompt user to locate each database in TableConnectPropBadArray. varReturnVal = SysCmd(acSysCmdSetStatus, "Linking databases.") fAllFound = True 'Assume success in relinking all tables. intNoLinksChanged = 0 'Avoid successful message if no links were changed. For intBadIndex = 0 To intDBBadCount - 1 DoEvents strCurConnectProp = TableConnectPropBadArray(intBadIndex) RelinkTables strCurConnectProp, intResultcode intNoLinksChanged = intNoLinksChanged + intResultcode If CheckMode = "prompt" Then If intResultcode = 2 Then fAllFound = False 'Failed relink. Else If Not intResultcode = 1 Then fAllFound = False End If Next intBadIndex 'Display summary messages based upon forcelink value strTitle = "Database Links" If fAllFound = False Then strMsg = "One or more Access database tables may not be correctly linked." MsgBox strMsg, 16, strTitle LinksOK = False Else If CheckMode = "prompt" And intNoLinksChanged <> 0 Then strMsg = "All Access databases were linked successfully." MsgBox strMsg, 0, strTitle End If If CheckMode <> "prompt" Then LinksOK = True End If 'Setup links changed flag. If intNoLinksChanged = 0 Then LinksChanged = False Else LinksChanged = True End If CheckTableLinksExit: DoCmd.Hourglass False varReturnVal = SysCmd(acSysCmdClearStatus) Exit Sub CheckTableLinksError: HandleError "CheckTableLinks", Error, Err Resume CheckTableLinksExit End Sub Public Function jstCheckTableLinks_Prompt() 'prompt for new database locations of linked tables jstCheckTableLinks CheckMode:="prompt", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Public Function jstCheckTableLinks_Full() 'check linked tables jstCheckTableLinks CheckMode:="full", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Public Function jstCheckTableLinks_Quick() 'check linked tables, only the first per database jstCheckTableLinks CheckMode:="quick", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Private Function ExistsInAppFolder(strPath As String) As Boolean On Error GoTo Err_ExistsInAppFolder Dim db As Database Dim i As Integer Dim lngPos As Long Dim strDBName As String Dim strAppPath As String Dim strCurrPath As String ExistsInAppFolder = False Set db = CurrentDb strDBName = FileOnly(strPath) strCurrPath = PathOnly(db.Name) If FileExists(strCurrPath & strDBName) Then ExistsInAppFolder = True End If Exit_ExistsInAppFolder: On Error Resume Next db.Close Set db = Nothing Exit Function Err_ExistsInAppFolder: ExistsInAppFolder = False Resume Exit_ExistsInAppFolder Resume End Function Private Function FileExists(Path As Variant) As Boolean On Error GoTo Err_FileExists Dim varRet As Variant If IsNull(Path) Then FileExists = False Exit Function End If varRet = Dir(Path) If Not IsNull(varRet) And varRet <> "" Then FileExists = True Else FileExists = False End If Exit_FileExists: Exit Function Err_FileExists: FileExists = False Resume Exit_FileExists End Function Private Function FileOnly(WholePath As Variant) As Variant On Error GoTo Err_FileOnly Dim FileOnlyPos If IsNull(WholePath) Then FileOnly = Null Exit Function End If FileOnlyPos = InStrRight(WholePath, "\") + 1 FileOnly = Mid(WholePath, FileOnlyPos) Exit_FileOnly: Exit Function Err_FileOnly: MsgBox Err.Number & ", " & Err.Description Resume Exit_FileOnly End Function Private Function PathOnly(WholePath As Variant) As Variant On Error GoTo Err_PathOnly Dim FileOnlyPos If IsNull(WholePath) Then PathOnly = Null Exit Function End If FileOnlyPos = InStrRight(WholePath, "\") + 1 PathOnly = Left(WholePath, FileOnlyPos - 1) Exit_PathOnly: Exit Function Err_PathOnly: MsgBox Err.Number & ", " & Err.Description Resume Exit_PathOnly End Function Private Function InStrRight(SearchString As Variant, soughtString As Variant) As Variant On Error GoTo Err_InStrRight Dim SoughtLen As Integer Dim Found As Integer Dim Pos As Integer If IsNull(SearchString) Or IsNull(soughtString) Then InStrRight = Null Exit Function End If If SearchString = "" Or soughtString = "" Then InStrRight = 0 Exit Function End If SoughtLen = Len(soughtString) Found = False Pos = Len(SearchString) - SoughtLen + 1 Do While Pos > 0 And Not Found If Mid(SearchString, Pos, SoughtLen) = soughtString Then Found = True Else Pos = Pos - 1 End If Loop InStrRight = Pos Exit_InStrRight: Exit Function Err_InStrRight: MsgBox Err.Number & ", " & Err.Description Resume Exit_InStrRight End Function Private Function GetDatabase( _ strDatabasePath As String, _ strPassword As String _ ) As DAO.Database Dim db As DAO.Database Dim lngTries As Long Do On Error GoTo NoPasswordErrHandler Set db = DBEngine.OpenDatabase(strDatabasePath, False, True, "MS Access;PWD=" & strPassword) On Error GoTo ErrHandler If db Is Nothing Then If Len(strPassword) Then MsgBox "Invalid password.", vbCritical, "Try again." End If strPassword = InputBoxDK("The database requires a password to open. Please provide a password.", "Password-protected database.") lngTries = lngTries + 1 If Len(strPassword) = 0 Then Exit Do End If End If Loop While db Is Nothing And lngTries < 3 Set GetDatabase = db ExitProc: On Error Resume Next Exit Function NoPasswordErrHandler: If Err.Number = 3031 Then Set db = Nothing Resume Next End If ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function Private Function ExtractPassword(strConnectionString As String) As String Dim lngleft As Long Dim lngRight As Long Const pwd As String = "PWD=" On Error GoTo ErrHandler lngleft = InStr(1, strConnectionString, pwd) If lngleft Then lngleft = lngleft + Len(pwd) lngRight = InStr(lngleft, strConnectionString, ";") If lngRight = 0 Then 'No ending semicolon was found; return the whole substring lngRight = Len(strConnectionString) End If ExtractPassword = Mid$(strConnectionString, lngleft, lngRight - lngleft) Else ExtractPassword = vbNullString End If ExitProc: On Error Resume Next Exit Function ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function #If VBA7 Then Private Function InputBoxPasswordMaskProc( _ ByVal lngCode As Long, _ ByVal wParam As LongPtr, _ ByVal lparam As LongPtr _ ) As LongPtr #Else Private Function InputBoxPasswordMaskProc( _ ByVal lngCode As Long, _ ByVal wParam As Long, _ ByVal lparam As Long _ ) As Long #End If 'DO NOT PUT IN VBA ERROR HANDLING 'This is a Windows procedure called by Message loop. On Error Resume Next 'Originally written by Daniel Klann 'Updated for 64-bit compatibility Dim RetVal Dim strClassName As String Dim lngBuffer As Long If lngCode < HC_ACTION Then InputBoxPasswordMaskProc = CallNextHookEx(hHook, lngCode, wParam, lparam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lparam End Function Private Function InputBoxDK( _ Prompt, _ Optional Title, _ Optional Default, _ Optional XPos, _ Optional YPos, _ Optional HelpFile, _ Optional Context _ ) As String 'Originally written by Daniel Klann 'Updated for 64-bit compatibility 'Replicate the functionality of Inputbox function 'while providing password masking. #If VBA7 Then Dim lngModHwnd As LongPtr #Else Dim lngModHwnd As Long #End If Dim lngThreadID As Long On Error GoTo ErrHandler lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf InputBoxPasswordMaskProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook ExitProc: On Error Resume Next Exit Function ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function 'Hope someone can use it! 2. اعمل Macro ، واحفظه باسم autoexec (هذا معناه بانه سيكون اول شئ يشتغل في قاعدة البيانات لما تفتح) ، في السطر الاول اختر: Runcode ثم ضع السطر التالي كاسم للكود: jstCheckTableLinks_Full() وبعدها تقدر ان تضع سطر آخر ليفتح اي نموذج. الكود سيفحص الجداول ، واذا لم يجد الرابط ، فسيفتح نافذة يسمح للمستخدم ان يختار برنامج الجداول ومساره ، وبسهولة جعفر

السلام عليكم بناء علي سؤال احد الاخوة للتنبيه الصوتي لخلية ما بشرط معين وددت الاجابة عليه في موضوع منفصل لسهولة استعراضه عند الحاجة اليه بالنسبة للتنبيه الصوتي ستكون هناك عدة خطوات لكي يتم العمل بها اولا سيتم استخدام خاصية speech المودجودة مع الاوفس و ساتكلم هنا عن الذي لم يثبت هذه الخاصية يجب بداية تشغيل برنامج الوورد و من Tools اختار speech وستاتيك رسالة اختار نعم لتثبيت ال speech و هنا سيطلب منك السي دي الخاص الذي قمت بتحميل الاوفس منه لاكمال التثبيت بعد ان تتم هذه العملية قم باغلاق الوورد و بهذا لن تحتاج للقيام بهذه الخطوة مرة اخري قم بتشغل الملف المرفق و فكرته هي النطق بكلمات معينة انت تختارها عند تحقق شرط معين و الشرط الموجود في هذا الملف هو ان كانت الخلية A3 (وهي مجموع الخلية A1,A2) و سيتم عمل الكود عند التغير في الخلية A1 او A2 و عندما تكون الخلية A3 اكبر من 100 سيتم قراءة ماقي الخلية G10 ارجو التجربة و اخباري النتيجة خالص تحياتي Speech.rar

اخي العزيز ابو احمد احنا كلنا ممتنين لسرعة استجابتك انت وكافة الخبراء في هذا الموقع الرائع بس المشكلة مثلا في موضوعنا هذا مثلا انكم بتحطوا الاجابة ماشي نجي نبص احنا كمبتدئين علي الكود مش عارفين نفهمه واحنا طبعا عايزين نفهم مش مجرد نلزق ورق حيط وخلاص ارجو منك شرح كود الترحيل هذا وجزاك الله خيرا Sub OFFICNA1() LR = Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row x = Range("F2").Value Range("A2:D" & LR).Select Selection.Copy Range("A2").Select Sheets(x).Select LR1 = Sheets(x).Range("a" & Rows.Count).End(xlUp).Row Range("A" & LR1 + 1).Select ActiveSheet.Paste Application.CutCopyMode = False Range("C1").Select MsgBox ("done") End Sub

السلام عليكم بعض التعديلات البسيطه مع اضافة تغير اسماء الصفحات تحياتي Last_Add_Remove_____________.rar

السلام عليكم و هذا هو الملف و لكن بعد عمل تعديلات بسيطه Add_Remove_____________.rar