ابو جودي

هو تحدى صعب لان توصلت له ولكن لكل بلد لابد من كتابة الاكواد ولكن انا ابلور الافكار لاقدم كودا ذكيا ومرنا وطريقة فعالة بقدر الامكان ابشر

لو كلمة مرور فتح القاعدة نفسها انسى او كلمة مرور محرر الاكواد هات القاعدة وافتحها لك فى عشر ثانية بس

تدلل انشئ موديول واعطه مثلا الاسم basResizeControls وضع به الكود الاتى Option Compare Database Option Explicit ' Constants Const FONT_ZOOM_PERCENT_CHANGE As Double = 0.1 ' Percentage change for font zoom ' Variables Private fontZoom As Double ' Current font zoom level Private ctrlKeyIsPressed As Boolean ' Flag to indicate if the Ctrl key is pressed ' Enum to represent control tag indices Private Enum ControlTag FromLeft = 0 FromTop ControlWidth ControlHeight OriginalFontSize OriginalControlHeight End Enum ' Log error message to debug or a specified location Private Sub LogError(errMsg As String) ' Modify this part to log errors as needed, e.g., in a table or text file Debug.Print "Error: " & errMsg End Sub ' Save control positions to their Tag properties Public Sub SaveControlPositionsToTags(frm As Form) On Error GoTo ErrorHandler Dim ctl As Control Dim ctlLeft As String Dim ctlTop As String Dim ctlWidth As String Dim ctlHeight As String Dim ctlOriginalFontSize As String Dim ctlOriginalControlHeight As String For Each ctl In frm.Controls ctlLeft = CStr(Round(ctl.Left / frm.Width, 2)) ' Calculate relative left position ctlTop = CStr(Round(ctl.Top / frm.Section(ctl.Section).Height, 2)) ' Calculate relative top position ctlWidth = CStr(Round(ctl.Width / frm.Width, 2)) ' Calculate relative width ctlHeight = CStr(Round(ctl.Height / frm.Section(ctl.Section).Height, 2)) ' Calculate relative height ' Capture original font size and control height for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctlOriginalFontSize = ctl.FontSize ctlOriginalControlHeight = ctl.Height End Select ' Store the calculated values in the Tag property ctl.Tag = ctlLeft & ":" & ctlTop & ":" & ctlWidth & ":" & ctlHeight & ":" & ctlOriginalFontSize & ":" & ctlOriginalControlHeight Next ' Store proportional heights for header and footer sections frm.Section(acHeader).Tag = CStr(Round(frm.Section(acHeader).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) frm.Section(acFooter).Tag = CStr(Round(frm.Section(acFooter).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) Exit Sub ErrorHandler: LogError "SaveControlPositionsToTags: " & Err.Description Resume Next End Sub ' Reposition controls based on their stored Tag properties and current font zoom Public Sub RepositionControls(frm As Form, fontZoom As Double) On Error GoTo ErrorHandler Dim formDetailHeight As Long Dim tagArray() As String ' Calculate the detail section height formDetailHeight = frm.WindowHeight - frm.Section(acHeader).Height - frm.Section(acFooter).Height Dim ctl As Control For Each ctl In frm.Controls If ctl.Tag <> "" Then tagArray = Split(ctl.Tag, ":") ' Split the Tag property into an array If ctl.Section = acDetail Then ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ formDetailHeight * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ formDetailHeight * CDbl(tagArray(ControlTag.ControlHeight)) Else ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.ControlHeight)) End If ' Adjust font sizes for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctl.FontSize = Round(CDbl(tagArray(ControlTag.OriginalFontSize)) * (ctl.Height / CDbl(tagArray(ControlTag.OriginalControlHeight))) * fontZoom) End Select End If Next Exit Sub ErrorHandler: LogError "RepositionControls: " & Err.Description Resume Next End Sub ' Initialize the form by saving control positions Public Sub InitForm(frm As Form) On Error GoTo ErrorHandler fontZoom = 1 ' Set initial font zoom level SaveControlPositionsToTags frm Exit Sub ErrorHandler: LogError "InitForm: " & Err.Description Resume Next End Sub ' Handle the mouse wheel event to zoom in/out if Ctrl key is pressed Public Sub HandleMouseWheel(frm As Form, ByVal Page As Boolean, ByVal Count As Long) On Error GoTo ErrorHandler If ctrlKeyIsPressed Then If Count < 0 Then fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom ElseIf Count > 0 Then fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom End If End If Exit Sub ErrorHandler: LogError "HandleMouseWheel: " & Err.Description Resume Next End Sub ' Handle the form resize event Public Sub HandleResize(frm As Form) On Error GoTo ErrorHandler ' Adjust header and footer heights proportionally frm.Section(acHeader).Height = frm.WindowHeight * CDbl(frm.Section(acHeader).Tag) frm.Section(acFooter).Height = frm.WindowHeight * CDbl(frm.Section(acFooter).Tag) RepositionControls frm, fontZoom Exit Sub ErrorHandler: LogError "HandleResize: " & Err.Description Resume Next End Sub ' Handle key up event to reset Ctrl key flag Public Sub HandleKeyUp() ctrlKeyIsPressed = False End Sub ' Handle key down event to manage font zooming with + and - keys Public Sub HandleKeyDown(frm As Form, KeyCode As Integer, Shift As Integer) On Error GoTo ErrorHandler Dim shiftKeyPressed As Boolean shiftKeyPressed = (Shift And acShiftMask) > 0 If shiftKeyPressed Then Select Case KeyCode Case vbKeyAdd fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "+" symbol from showing up in text boxes Case vbKeySubtract fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "-" symbol from showing up in text boxes End Select End If ' Check if Ctrl key is pressed If (Shift And acCtrlMask) > 0 Then ctrlKeyIsPressed = True End If Exit Sub ErrorHandler: LogError "HandleKeyDown: " & Err.Description Resume Next End Sub وفى النموذج يتم الاستدعاء من خلال Private Sub Form_Load() Call InitForm(Me) End Sub Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long) Call HandleMouseWheel(Me, Page, Count) End Sub Private Sub Form_Resize() Call HandleResize(Me) End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) Call HandleKeyUp End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Call HandleKeyDown(Me, KeyCode, Shift) End Sub وان اردت اضافة DoCmd.Maximize فى الحدث Form_Load يمكنك ذلك

يمكنكم الاطلاع على هذا المرفق https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=129345

ولان تعليقى بعد تقديم حلول اساتذتى الكرام لك اعتقد انه كان صادما ولانه اذا عرف السبب بطل العجب اليك السبب انظر الى قاعدة البيانات الاتية بعد اغلاقك لمفتاح الشيفت فى قاعدتك يمكن تغيير الاعداد مرة اخرى لقاعدتك من خلال المرفق الاتى فيتم استعادة عمل زر الشيفت مرة أخرى Security(Enable-Disable Shift Key).accdb

اتفضل موضوع بالشرح اتمنى ان يفى بالغرض

السلام عليكم ورحمة الله تعالى وبركاته بعد مواجهتى لمشكلة فى هذه النقطة عند التعامل مع ملفات الاكسل بسبب اختلاف النسخ والتنسيق لملفات الاكسل تبعا لاختلاف الاصدارات كانت هذه نتيجة وخلاصة افكاارى لحل مشاكلى اليكم الخطوات 1- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basFileUtilityKit بها هذه الكود Option Compare Database Option Explicit ' Enumeration for the types of file dialogs Enum EnumFileDialogType msoFileDialogFilePicker = 1 msoFileDialogFolderPicker = 4 End Enum ' Enumeration for different file extensions Enum EnumFileExtensions AccessFiles ExcelFiles WordFiles PDFFiles TextFiles ImageFiles VideoFiles AudioFiles AllFiles ' You can add additional file extensions as needed here End Enum ' Enumeration for different options related to file paths Enum EnumOptionFile DirectoryWithoutFileName DirectoryWithFileName FileNameWithExtension FileNameWithoutExtension ExtensionOnly End Enum ' Function to open the folder dialog and return the selected folder path Function GetFolderDialog() As String On Error Resume Next Dim folderDialogObject As Object Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker) With folderDialogObject .Title = "Select Folder" .AllowMultiSelect = False .Show End With If folderDialogObject.SelectedItems.Count > 0 Then GetFolderDialog = folderDialogObject.SelectedItems(1) Else ' Handle the case where no folder is selected MsgBox "No folder selected.", vbExclamation GetFolderDialog = "" End If Set folderDialogObject = Nothing On Error GoTo 0 End Function ' Function to open the file dialog and return the selected file path Function GetFileDialog(ByVal EnumFileExtension As EnumFileExtensions) As String On Error Resume Next ' Check if the Microsoft Office Object Library is referenced ' Make sure to go to Tools > References and select the appropriate version ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016 Dim fileDialogObject As Object Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker) With fileDialogObject .Title = "Select File" .AllowMultiSelect = False .Filters.Clear ' Adding filters based on the selected file extension Select Case EnumFileExtension Case EnumFileExtensions.AllFiles .Filters.Add "All Files", "*.*" Case EnumFileExtensions.TextFiles .Filters.Add "Text Files", "*.txt" Case EnumFileExtensions.ExcelFiles .Filters.Add "Excel Files", "*.xlsx; *.xls" Case EnumFileExtensions.ImageFiles .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif" Case EnumFileExtensions.VideoFiles .Filters.Add "Video Files", "*.mp4; *.avi; *.mov" Case EnumFileExtensions.AudioFiles .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg" Case EnumFileExtensions.PDFFiles .Filters.Add "PDF Files", "*.pdf" Case EnumFileExtensions.WordFiles .Filters.Add "Word Files", "*.docx; *.doc" Case EnumFileExtensions.AccessFiles .Filters.Add "Word Files", "*.accda , *.accdb,*.accdc , *.accde,*.accdr , *.accdt,*.accdw , *.mda,*.mdb , *.mde,*.mdf , *.mdw" ' You can add additional file extensions as needed here End Select .Show End With If fileDialogObject.SelectedItems.Count > 0 Then GetFileDialog = fileDialogObject.SelectedItems(1) Else ' Handle the case where no file is selected MsgBox "No file selected.", vbExclamation GetFileDialog = "" End If Set fileDialogObject = Nothing Exit Function If Err.Number <> 0 Then Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select ' Clear the error Err.Clear End If End Function ' Function to get the desired option for a file path Function GetFileOption(ByRef strFilePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = DirectoryWithFileName) As String On Error Resume Next Select Case EnumOptionFile Case DirectoryWithoutFileName GetFileOption = Left(strFilePath, InStrRev(strFilePath, "\")) Case DirectoryWithFileName GetFileOption = strFilePath Case FileNameWithExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1) Case ExtensionOnly GetFileOption = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")) Case FileNameWithoutExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1, InStrRev(strFilePath, ".") - InStrRev(strFilePath, "\") - 1) End Select On Error GoTo 0 End Function ' Function to get additional information about a file Function GetFileInfo(filePath As String) As String On Error Resume Next Dim fileInfo As String fileInfo = "File Information:" & vbCrLf fileInfo = fileInfo & "Path: " & filePath & vbCrLf fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf GetFileInfo = fileInfo On Error GoTo 0 End Function شرح الوظائف فى هذه الوحدة النمطية Enumerations توفر طريقة لتعريف مجموعة من الثوابت التي يمكن استخدامها لتحديد أنواع معينة من القيم. EnumFileDialogType هذه الـ Enumeration تستخدم لتحديد نوع مربع الحوار الخاص بالملفات: msoFileDialogFilePicker: لفتح مربع حوار لاختيار الملفات. msoFileDialogFolderPicker: لفتح مربع حوار لاختيار المجلدات. EnumFileExtensions هذه الـ Enumeration تستخدم لتحديد نوع الامتدادات التي يمكن اختيارها من مربع حوار الملفات: AllFiles: جميع الملفات. TextFiles: ملفات النصوص. ExcelFiles: ملفات إكسل. ImageFiles: ملفات الصور. VideoFiles: ملفات الفيديو. AudioFiles: ملفات الصوت. PDFFiles: ملفات PDF. WordFiles: ملفات وورد. EnumOptionFile هذه الـ Enumeration تستخدم لتحديد الخيارات المختلفة المتعلقة بالمسارات: DirectoryWithoutFileName: المسار بدون اسم الملف. DirectoryWithFileName: المسار مع اسم الملف. FileNameWithExtension: اسم الملف مع الامتداد. FileNameWithoutExtension: اسم الملف بدون الامتداد. ExtensionOnly: الامتداد فقط. Functions GetFolderDialog هذه الدالة تفتح مربع حوار لاختيار المجلدات وتعيد المسار الكامل للمجلد الذي تم اختياره. إذا لم يتم اختيار أي مجلد، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileDialog هذه الدالة تفتح مربع حوار لاختيار الملفات وتعيد المسار الكامل للملف الذي تم اختياره. يمكنك تحديد نوع الملفات المسموح باختيارها عبر الـ EnumFileExtensions. إذا لم يتم اختيار أي ملف، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileOption هذه الدالة تستخدم لتحديد أجزاء معينة من مسار الملف بناءً على القيمة المحددة في الـ EnumOptionFile: DirectoryWithoutFileName: يعيد المسار بدون اسم الملف. DirectoryWithFileName: يعيد المسار مع اسم الملف. FileNameWithExtension: يعيد اسم الملف مع الامتداد. FileNameWithoutExtension: يعيد اسم الملف بدون الامتداد. ExtensionOnly: يعيد الامتداد فقط GetFileInfo هذه الدالة تعيد معلومات حول ملف محدد، بما في ذلك المسار، الحجم، وتاريخ الإنشاء. تعرض هذه المعلومات كجزء من نص مرتجع. ------------------------ 2- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basExcelDataImport بها هذه الكود Public Const strTableExcel As String = "tblImportExcel" Function ExcelDataImport(ByRef excelFilePath As String) On Error Resume Next ' Disable error handling temporarily Const xlOpenXMLWorkbook As Long = 51 ' Variables for Excel and Access Dim excelApp As Object Dim excelWorkbook As Object Dim excelOpened As Boolean Dim sourceFileName As String Dim mainDirectory As String Dim convertedExcelFilePath As String ' Check if the Excel file path is provided If Nz(excelFilePath, "") = "" Then Exit Function ' Check if the Excel file exists If Dir(excelFilePath) = "" Then Exit Function ' Extract file information sourceFileName = GetFileOption(excelFilePath, FileNameWithExtension) mainDirectory = GetFileOption(excelFilePath, DirectoryWithoutFileName) convertedExcelFilePath = excelFilePath ' Create Excel application object Set excelApp = CreateObject("Excel.Application") ' Check if Excel application is successfully created If Err.Number <> 0 Then Err.Clear Set excelApp = CreateObject("Excel.Application") excelOpened = False Else excelOpened = True End If ' Reset error handling On Error GoTo 0 ' Set Excel application visibility excelApp.Visible = False ' Open Excel workbook Set excelWorkbook = excelApp.Workbooks.Open(mainDirectory & sourceFileName) ' Save the workbook in xlsx format without displaying alerts excelApp.DisplayAlerts = False excelWorkbook.SaveAs Replace(mainDirectory & sourceFileName, ".xls", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False excelApp.DisplayAlerts = True ' Close the workbook without saving changes excelWorkbook.Close False ' Quit Excel application if it was opened by the function If excelOpened = True Then excelApp.Quit ' Update the source file name with the new extension sourceFileName = sourceFileName & "x" ' Reset file attributes SetAttr mainDirectory & sourceFileName, vbNormal ' Import Excel data into Access table DoCmd.SetWarnings False 'acSpreadsheetTypeExcel8 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTableExcel, mainDirectory & sourceFileName, True ExitFunction: ' Enable system alerts before exiting the function DoCmd.SetWarnings True Exit Function ErrorHandler: ' Handle errors Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select End Function ' Function to delete all records from the specified table Sub DeleteAllRecords(Optional ByRef strTable As String = "") On Error Resume Next If Nz(strTable, "") = "" Then strTable = strTableExcel CurrentDb.Execute "DELETE FROM " & strTable ' Handle errors Select Case Err.Number Case 3078 If strTable = strTableExcel Then Resume Next Else Case Else ' HandleAndLogError strProcessName End Select End Sub شرح الوظائف فى هذه الوحدة النمطية الدالة ExcelDataImport تستورد بيانات من ملف Excel إلى جدول في قاعدة بيانات Access. strTableExcel: ثابت يحدد اسم الجدول في قاعدة بيانات Access الذي سيتم استيراد بيانات Excel إليه. excelFilePath: مسار ملف Excel الذي سيتم استيراد البيانات منه. ------------------------ 3- انشاء نموذج وفى الحدث عند النقر على زر الامر استخدم الكود التالى Private Sub cmdSubmit_Click() ' Get the path of the Excel file Dim strFilePath As String strFilePath = GetFileDialog(EnumFileExtensions.ExcelFiles) ' Check if a file was selected If strFilePath <> "Cancelled" Then ' Show status label Me!lblStatus.Visible = True Me!lblStatus.Caption = "Please wait ... " ' Clear TableData DeleteAllRecords ' Import data from Excel ExcelDataImport strFilePath ' Add Or Update Yor Table ' Hide the status label or reset any visual indicator Me!lblStatus.Visible = False Else ' User canceled the file selection MsgBox "File selection canceled", vbExclamation End If End Sub الان يتبقى عمل الاستعلام اللازم لاضاقة او تحديث وتعديل بياناتك طبقا لجدول الاكسس حسب رغباتك وتطلعاتك واخيرا مرفق قاعدة البيانات ImportFromExel.accdb

الحمد لله رب العالمين سعيد لسماع ذلك يسعدني انه تم حل مشكلتك

لا توجد اى طريقة ريح نفسك طريقك مسدود مسدود يا ولدى

اتفضل جرب استيراد البيانات من خلال نموذج Form1 من خلال الضغط على الزر واستعراض المجلدات لاختيار ملف الاكسل المراد استيراد البيانات منه سوف يتم انشاء جدول مؤقت به البيانات انقلها بعد ذلك للجدول وقم بباقى العمليات التى تريد اجراءها كما بحلو لك test ExcelDataImport.rar

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

لابد من إعادة تثبيت Microsoft Access

اهاااااا والان حضر الوحش صاحب المكتبة العامرة الاستاذ @Moosak اراه الان بعد ان اضاف المرفق الى مكتبته العامرة يتفحص ويمحص ترى هل يجد الثغرة ويتغلب عليها ؟!

جملة SQL هذه تهدف إلى حذف سجل او سجلات محددة من جدول معين وتحديداحذف السجلات التي يكون فيها قيمة الحقل "id" مساوية للقيمة المخزنة في المتغير "x"

جرب الجملة التالية "DELETE FROM tblBounce WHERE (((tblBounce.id) = " & x & "));"

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

طيب مشاركة مع اخوانى الكرام واساتذتى الافاضل بعد التعديلات على الاكواد #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr #Else Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If #Else Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Private Const GW_CHILDREN As Long = 5 Private Const WM_COMMAND As Long = &H111 Private Sub Btn_Hide_Click() Dim toggleDesktopCommand As Long Dim hWnd As LongPtr toggleDesktopCommand = &H7402 hWnd = FindWindow("Progman", "Program Manager") If hWnd <> 0 Then hWnd = GetWindow(hWnd, GW_CHILDREN) If hWnd <> 0 Then SendMessage hWnd, WM_COMMAND, toggleDesktopCommand, ByVal 0& If Btn_Hide.Caption = "Hide Icon" Then Me.Btn_Hide.Caption = "Show Icon" Me.Caption = " Desktop Icon Hide" Else Me.Btn_Hide.Caption = "Hide Icon" Me.Caption = " Desktop Icon Show" End If Else MsgBox "Failed to find child window of Program.", vbExclamation End If Else MsgBox "Failed to find Program window.", vbExclamation End If End Sub Private Sub Form_Load() Me.Caption = "" End Sub Hide Icon Desktop.accdb

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

وفين دالة NZ ?!

السلام عليكم ورحمة الله تعالى وبركاته اخوانى الكرام اساتذتى الاعزاء الموضوع ده بصراحة كان تحدى بينى وبين نفسي تعبت جدا فكرة الموضوع التقليدية هى التعامل بالارقام واسماء العناصر وكتابة الكثير والكثير من الاكواد والزحمة والحسابات و و وبلا بلا بلا بلا... وفى النهاية يبقى التعديل على العمل بالاضافة او التعديل شئ صعب جدا جدا جدا الا انه بفضل الله اقدم اليكم الفكرة الاتية للتجربة اعتمدت فى المقام الاول على ان تكون الاكواد ثابته بحيث يسهل استخدام الفكرة والطريقة ونقلها لاى قاعدة ولكن عجزت عن تحقيق كل شئ برمجيا وتوقفت وعجزت امام نقطة واحدة ووحيدة ولكن تم التغلب بالفهلوة على المشكلة اترك لكم التجربة وباب النقاش مفتوح بعد ذلك ومن يدرى فد اجد حل للمشكلة التى عجزت امامها معكم وعندكم تعديل جديد بتاريخ 31/05/2024 تم تحديث الموضوع باضافة الاصدار الثانى الذى يعتمد كليا على الوحدات النمطية تم حل جميع المشاكل والعقبات برمجيا والتى واجهتنى بالاصدار الاول على الرغم من انه قد تم التغلب عليها وقتها ولكن بحلول غير برمجية الإصدار الأول : expand and collapse button .accdb الإصدار الثاني (المحسن) : expand and collapse button V2.zip

ممكن مرفق المشكلة لو تكرمت

السلام عليكم ورحمة الله تعالى وبركاته وانا فايت لاقيت استاذنا الجليل اخوانا @شايب قلت فى نفسى لا لابد من المرور والقاء السلام ومشاركة مع احبائى فى الله اليكم فكرة بدون دوال وهى الاحب الى قلبى الشرح 1- انشاء وحدة نمطية عامة وظيفتها الاعلان عن متغيرات عامة وهى كالاتى Public strPasswordPrompt As String Public boolPasswordPrompt As Boolean 2- ننشئ نموذج لكلمة السر على ان يكون اسمه frmPasswordPrompt وبه مربع النص لكتابة كلمة السر على ان يكون اسمه txtPassword زر امر التأكيد على ان يكون اسمه btnConfirmation ونضع الكود الاتى لزر الامر boolPasswordPrompt = True strPasswordPrompt = Nz(Me.txtPassword.Value) DoCmd.Close acForm, Me.Name وهنا نطلب منه انه يلحق القيمة True الى المتغير العام boolPasswordPrompt وان يلحق القيمة التى سوف يتم كتابتها فى مربع النص txtPassword الى المتغير العام strPasswordPrompt ثم يغلق النموذج زر امر الالغاء على ان يكون اسمه btnCancel ونضع الكود الاتى لزر الامر boolPasswordPrompt = False DoCmd.Close acForm, Me.Name وهنا نطلب منه انه يلحق القيمة False الى المتغير العام boolPasswordPrompt ثم يغلق النموذج الان يمكن استخدام كلمة سر فى اى مكان فى النموذج اما للحذف او للطباعة او لفتح نموذج حسب رغبة المصمم والان الية استدعاء هذا النموذج للعمل على زر الامر المراد قتح النموذج السرى من خلاله نضع الاكواد الاتية Const CORRECT_PASSWORD As String = "123" Const MSG_ENTER_PASSWORD As String = "Please enter a password to proceed." Const MSG_INCORRECT_PASSWORD As String = "Incorrect password. Operation canceled." Const MSG_PROCEED_SUCCESSFULLY As String = "proceed successfully!" Const MSG_OPERATION_CANCELED As String = "Operation canceled" Do DoCmd.OpenForm "frmPasswordPrompt", , , , , acDialog Select Case True Case boolPasswordPrompt Select Case True Case Nz(strPasswordPrompt, "") = "" MsgBox MSG_ENTER_PASSWORD, vbExclamation Case strPasswordPrompt <> CORRECT_PASSWORD MsgBox MSG_INCORRECT_PASSWORD, vbExclamation Case Else MsgBox MSG_PROCEED_SUCCESSFULLY DoCmd.OpenForm ChrW("1587") & ChrW("1585") & ChrW("1610") Exit Do End Select Case Else MsgBox MSG_OPERATION_CANCELED, vbExclamation Exit Do End Select Loop هذا شرح مبسط للفكرة العامة ولكن ان اردنا العمل اكثر احترافية ومرونة من خلال الاكواد فى وحدة نمطية انظر المرفق الاتى رقم سري.accdb

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله

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

لا شكر على واجب اهلا بك جزانا والله واياكم خير الجزاء وسعيد جدا والله الحمد انا فى حد بتعجبة شخابيطى وعلشان بتحب الشخبطة خد اخر شخابيطى توسيط واخفاء بطريقة جديدة HideAccess.accdb