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

جرب المرقق ده https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=229962&key=6be4aebe1bd6693b595feff8e00d6e1f

يمكنك دالك بدون الحاجة لاظافة اي اكواد جديدة فقط قم بتسمية عنصر Combobox2 طبقا لتسلسل عناصر textbox الموجودة مسبقا على الفورم اي (TEXTBOX62) وتعديل هدا السطر Const dict As Integer = 61 ليصبح بعدد العناصر الموجودة Const dict As Integer = 62 1 ترحيل مع كمبوبوكس.xlsm

السلام عليكم ورحمة الله تعالى وبركاته اليوم اقدم لكم هدية صغيرة ولكن النفع من ورائها عظيم جدا قد ينتج عن الكود اخطاء عند كتابة الكود قد نحتاج تتبع نتائج الكود قد محتاج معرفة القيم التى يعيدهها الكود قد نكتب استعلام مثلا زنقطع الاسطر ونضيف متغيرات نمرر منها قيما الى الاستعلام ونريد معرفة كبف سوف يراه الحاسوب فى النهاية وقد وقد و ........ الخ وهناك الكثير والكثير وما ذطرته هو فقط على سبيل المثال وليس الحصر اتتنى فكرة وهى كتابة كود فى موديول ليسهل الامور على مصممى قواعد البيانات فيضفى المرونة فى التعامل وكذا الاحترافية التامة مع هذا الامر وهو استخدام: Debug.Print وحتى لا اطيل عليكم اليكم الاكواد Option Compare Database Option Explicit '********************************************************************** ' Function: DebugPrint ' Purpose: Prints a message to the Immediate Window in the VBA editor and optionally logs it to a file. ' Inputs: ' Message - The message to be printed (String). ' Optional AddNewLine - A Boolean flag to add a new line after printing (default is True). ' Optional Prefix - A string to prefix the message (default is ""). ' Optional Suffix - A string to suffix the message (default is ""). ' Optional LogToFile - A Boolean flag to enable logging to a file (default is False). ' Optional FilePath - The path of the file where the log should be saved (default is ""). ' Returns: Nothing - The function performs a print and/or log operation. ' Notes: ' - The function sends the message to the Immediate Window. ' - If AddNewLine is True, a newline is added after the message. ' - Prefix and Suffix can be used to format the message. ' - LogToFile enables logging the message to a specified file. ' - Error handling is included to manage issues with file operations. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub DebugPrint(ByVal Message As String, Optional ByVal AddNewLine As Boolean = True, _ Optional ByVal Prefix As String = "", Optional ByVal Suffix As String = "", _ Optional ByVal LogToFile As Boolean = False, Optional ByVal FilePath As String = "") Dim fullMessage As String Dim fileNum As Integer ' Construct the full message with prefix and suffix fullMessage = Prefix & Message & Suffix ' Print the message to the Immediate Window Debug.Print fullMessage ' Optionally add a newline after printing If AddNewLine Then Debug.Print "" ' Adds an empty line for separation End If ' Log the message to a file if specified If LogToFile And FilePath <> "" Then On Error GoTo ErrorHandler fileNum = FreeFile Open FilePath For Append As #fileNum Print #fileNum, fullMessage Close #fileNum On Error GoTo 0 End If Exit Sub ErrorHandler: ' Handle any errors that occur during file operations Debug.Print "Error occurred while logging to file: " & Err.Description On Error GoTo 0 End Sub ' Example 1: Print a simple message Rem Call DebugPrint("This is a simple message") ' Example 2: Print a message with a prefix and suffix, without adding a new line Rem DebugPrint("Error encountered!", AddNewLine:=False, Prefix:="Error: ", Suffix:=" [Check details]") ' Example 3: Print a message and log it to a file Rem DebugPrint("Logging this message to a file.", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") ' Example 4: Print multiple messages with automatic new lines and logging Rem DebugPrint("Starting process...") Rem DebugPrint("Process in progress...") Rem DebugPrint("Process completed successfully!", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") '--------------------------------------------------------------------------------------------------------------------------------------- '********************************************************************** ' Subroutine: OpenImmediateWindow ' Purpose: Opens the Immediate Window in the VBA editor and prepares it for input. ' Inputs: None ' Returns: Nothing ' Notes: ' - The Immediate Window is activated and ready for input. ' - This subroutine uses the SendKeys method to send keystrokes. ' - Error handling is included to manage potential issues with SendKeys. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Sub OpenImmediateWindow() Dim shell As Object On Error GoTo ErrorHandler ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") With shell ' Send Ctrl+G to open the Immediate Window .SendKeys "^g ", True ' Send Tab to navigate if needed .SendKeys "{TAB}", True End With Application.VBE.MainWindow.Visible = True DoEvents 'this frees up the OS to repaint the screen Exit Sub ' Clean up Set shell = Nothing ErrorHandler: ' Handle any errors that occur during SendKeys operations Debug.Print "Error occurred while opening the Immediate Window: " & Err.Description On Error GoTo 0 End Sub '********************************************************************** ' Function: ClearImmediateWindowContent ' Purpose: Clears the content of the Immediate Window in the VBA Editor. ' Details: ' This function searches for an open Immediate Window within the VBE. ' If found, it sends keystrokes to clear the content using the WScript.Shell object. ' Inputs: None ' Returns: Void ' Error Handling: ' Includes basic error handling to inform the user in case of an issue. ' Notes: ' - This function assumes that there is only one Immediate Window open. ' - The function does not create a new Immediate Window if one is not found. '********************************************************************** Public Function ClearImmediateWindowContent() On Error GoTo ErrorHandler Dim totalVBEWindows As Long Dim currentWindowIndex As Long Const IMMEDIATE_WINDOW_TYPE As Long = 5 ' Type constant for Immediate Window Dim shell As Object ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") totalVBEWindows = Application.VBE.Windows.Count ' Get the number of open windows ' Iterate through all open windows For currentWindowIndex = 1 To totalVBEWindows ' Check if the current window is the Immediate Window If Application.VBE.Windows.Item(currentWindowIndex).Type = IMMEDIATE_WINDOW_TYPE Then Application.VBE.Windows.Item(currentWindowIndex).SetFocus ' Set focus to the Immediate Window ' Ensure the Immediate Window is active If Application.VBE.ActiveWindow.Type = IMMEDIATE_WINDOW_TYPE Then With shell ' Send Ctrl+G to activate the Immediate Window .SendKeys "^g", True ' Send Ctrl+A to select all content .SendKeys "^a", True ' Send Delete to clear selected content .SendKeys "{DEL}", True ' Send Backspace to ensure content is cleared .SendKeys "{BKSP}", True End With Exit Function ' Exit after clearing the content End If Exit For ' Exit the loop if Immediate Window is found and focused End If Next currentWindowIndex ' Clean up Set shell = Nothing Exit Function ErrorHandler: MsgBox "Error occurred while trying to clear the Immediate Window. Error: " & Err.Description, vbCritical ' Clean up Set shell = Nothing End Function '********************************************************************** ' Function: GetDesktopPath ' Purpose: Returns the path to the Desktop for the current user. ' Details: ' This function retrieves the path to the Desktop folder using Windows API functions. ' Inputs: None ' Returns: String - The full path to the Desktop folder. ' Notes: ' - This function uses Windows API to get the Desktop path. ' - Ensure you have error handling to manage unexpected issues. '********************************************************************** Public Function GetDesktopPath() As String Dim strDesktopPath As String Dim objShell As Object On Error GoTo ErrorHandler ' Create an instance of Shell object Set objShell = CreateObject("Shell.Application") ' Get the Desktop folder path strDesktopPath = objShell.NameSpace(&H10&).Self.Path ' Return the path GetDesktopPath = strDesktopPath Exit Function ErrorHandler: MsgBox "Error occurred while retrieving the Desktop path. Error: " & Err.Description, vbCritical GetDesktopPath = "" End Function بالمناسبة لا داعى للقلق من وجود واستخدام "SendKeys" داخل الاكود لانه تم التعامل معها بحرفية تامة كى لا تأثر على حالة الـ Num Lock ImmediateWindowHelper.accdb

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

حاضرة استاذي @ابو جودي❤️🌹😘 اجهز المرفق☕

نعم انا أرجع ذلك جدول على ان يبدأ بالبادئة"Usys" ليكون اسمه مثلا كالاتى : UsystblPassInfo وذلك ليكون مخفيا ضمن جداول النظام عن اعين المتطفلين نعم قرأت مقال ذات مرة أن الضغط والاصلاح بشكل متكرر و مستمر وبدون داع قد يضر بقاعدة البيانات والشئ بالشئ يذكر ان استاذى الجليل و معلمى القدير و والدى الاستاذ @jjafferr نسأل الله تعالى أن يرده ويعيده الينا ان شاء الله سالما هانئا ان شاء الله فى أقرب وقت قدم الينا كنز لا يقدر بقدر بثمن فى هذا الموضوع : ------------------------------------- وممكن بعد اذن حضرتك يا باش مهندسة فضلا وكرما وليس أمرا تشاركينا قاعدة البيانات التى تحدثتى عنها والتى تقوم بـ شكر جزبلا لحضرتك , جزاكم الله خيــــرا

جرب هدا في جزء تسجيل التغيير في ورقة العمل Log هناك خطأ حيث يتم إدخال quantity مرتين في العمود الثامن Sub TransferQuantities() On Error GoTo ErrHandler ' تعريف المتغيرات Dim lastRow As Long Dim itemData As Object Dim i As Long Dim itemCode As String Dim quantityToTransfer As Long Dim itemName As String Dim sourceKey As String Dim targetKey As String Dim currentDate As Date Dim answer As VbMsgBoxResult Dim fa As Worksheet ' تحديد الورقة واستخدام المتغير Set fa = Sheets("Inventaire") ' تحديد آخر صف في ورقة المخزون lastRow = fa.Cells(fa.Rows.Count, "A").End(xlUp).Row ' ملء قاموس ببيانات الأصناف Set itemData = CreateObject("Scripting.Dictionary") For i = 2 To lastRow Dim key As String key = fa.Cells(i, 3).Value & "_" & fa.Cells(i, 2).Value ' مفتاح فريد: كود الصنف + اسم المخزن itemData.Add key, i ' تخزين رقم الصف المقابل للمفتاح Next i ' تأكيد عملية النقل قبل بدء التنفيذ answer = MsgBox("هل أنت متأكد من تنفيذ عملية النقل؟", vbYesNo, "تأكيد") If answer <> vbYes Then Exit Sub ' الحصول على التاريخ الحالي currentDate = Date ' التكرار على عناصر ListBox1 For i = 0 To ListBox1.ListCount - 1 itemCode = ListBox1.List(i, 0) itemName = ListBox1.List(i, 1) quantityToTransfer = Val(ListBox1.List(i, 2)) sourceKey = itemCode & "_" & Me.ComboBox1.Value targetKey = itemCode & "_" & Me.ComboBox2.Value ' التحقق من وجود الصنف في قائمة التحويل If Not IsInList(itemCode, ListBox1) Then MsgBox "الصنف " & itemCode & " غير موجود في قائمة التحويل.", vbCritical Exit Sub End If ' التحقق من صحة البيانات If quantityToTransfer <= 0 Then MsgBox "الكمية يجب أن تكون موجبة.", vbCritical Exit Sub End If ' التحقق من وجود الصنف في المخازن المصدر والهدف If Not itemData.Exists(sourceKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن المصدر " & Me.ComboBox1.Value, vbCritical Exit Sub End If If Not itemData.Exists(targetKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن الهدف " & Me.ComboBox2.Value, vbCritical Exit Sub End If ' التحقق من الكمية المتاحة في المخزن المصدر If fa.Cells(itemData(sourceKey), 7).Value < quantityToTransfer Then MsgBox "الكمية المتاحة في المخزن المصدر غير كافية.", vbCritical Exit Sub End If ' تحديث الكميات On Error GoTo HandleError fa.Cells(itemData(sourceKey), 7).Value = fa.Cells(itemData(sourceKey), 7).Value - quantityToTransfer fa.Cells(itemData(targetKey), 7).Value = fa.Cells(itemData(targetKey), 7).Value + quantityToTransfer On Error GoTo 0 ' تسجيل التغيير With Sheets("Log") lastRowLog = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 .Cells(lastRowLog, 1).Value = TextBox2.Value ' رقم الفاتورة .Cells(lastRowLog, 2).Value = TextBox5.Value ' التاريخ .Cells(lastRowLog, 3).Value = "تم تحويل " & quantityToTransfer & " من مخزن " & Me.ComboBox1.Value & " إلى مخزن " & Me.ComboBox2.Value .Cells(lastRowLog, 4).Value = Me.ComboBox1.Value .Cells(lastRowLog, 5).Value = Me.ComboBox2.Value .Cells(lastRowLog, 6).Value = itemCode .Cells(lastRowLog, 7).Value = itemName .Cells(lastRowLog, 8).Value = quantityToTransfer .Cells(lastRowLog, 9).Value = Environ("Username") End With Next i MsgBox "تمت عملية التحويل بنجاح. تم تسجيل التغييرات.", vbInformation Exit Sub ErrHandler: Dim errorLog As String errorLog = "وقت الحدوث: " & Now & vbNewLine & _ "الخطأ: " & Err.Description & vbNewLine & _ "رقم السطر: " & Erl & vbNewLine & _ "الإجراء: " & Err.Source & vbNewLine & _ "القيم: itemCode=" & itemCode & ", quantity=" & quantityToTransfer & ", sourceKey=" & sourceKey & ", targetKey=" & targetKey Open "ErrorLog.txt" For Append As #1 Print #1, errorLog Close #1 MsgBox "حدث خطأ أثناء عملية التحويل. يرجى التحقق من البيانات والمحاولة مرة أخرى.", vbCritical End Sub Private Sub UserForm_Initialize() CancelOperation = False End Sub Private Sub cmdCancel_Click() CancelOperation = True Me.Hide End Sub Function IsInList(itemValue As Variant, myList As Object) As Boolean Dim i As Long For i = 0 To myList.ListCount - 1 If myList.List(i, 0) = itemValue Then IsInList = True Exit Function End If Next i IsInList = False End Function

السلا عليكم يمكنك الاطلاع على هذه المشاركة https://www.officena.net/ib/topic/44445-دالة-لإدراج-صورة/

شكرا استاذنا كبير المقام أ / محمد صالح والشكرموصول لاستاذ محمد هشام. للاضافة استفت منها جزاكما الله خيرا

ابشر .. قيد العمل ... عندما اقوم باعداد مثل هذه الأفكار احرص دائما على الشمولية بمعنى انني اعمل على ان يكون البرنامج صالح لكل زمان ومكان ... اي لكل بلد ولكل نظام شرائح .

المستخدمون يختلفون من مستخدم لآخر .. فقد يكون المستخدم هو مالك المشروع . اذا بتريح راسك وراس العميل كونهم موجودين في الجدول افضل ، على اعتبار ان المشروع برنامج حسابات ، على اعتبار ان هذه الاربع بنود رئيسية وثابتة لا يختلف فيها اثنان ويمكن ترك المستخدم ينشىء حساباته بنفسه ونعمل له نموذج ( يخصص للــ Admin) بضوابط خاصة لتسجيل الحسابات الرئيسية قبل العمل على الدليل انظر المرفق وضعت زر لفتحه من الدليل ،، وإلا فمكان استدعاء هذا النموذج يكون ضمن قائمة الأدوات التي تستخدم لمرة واحدة غالبا .. كإدخال اسم المؤسسة وبياناته ، وكرفع شعار المؤسسة و غيرها من الادوات ويمكن حمايته بشكل نهائي حيث لا يمكن فتحه الا لمن يحمل حساب الأـــ dmin حتى لو دخلت للتصميم عن طريق الشيفت dlookup8.rar

جرب هدا هل يناسبك wor2.xlsm

جرب هذا الكود في أحداث المصنف Private Sub Workbook_SheetActivate(ByVal Sh As Object) ShowScrollBar End Sub أو يمكنك وضع كود showscrollbars في هذا الحدث مباشرة بدون تسميته باسم خاص بالتوفيق

قد تحتاج إلى التأكد من أنك تستخدم أحدث إصدار من Microsoft 365، حيث أن هذه الدالة متاحة في Excel لـ Microsoft 3651. وإذا كنت مصريا ولك أبناء في التعليم فيمكنك استعمال البريد الموحد الخاص بهم في تفعيل أوفيس 365 بالتوفيق

او جرب هدا ربما هدا ما تقصده Private Sub CommandButton1_Click() Dim WS As Worksheet, NewWb As Workbook Dim Path As Variant Set WS = Worksheets("Sheet18") If WS.[E2] = 0 Then: Exit Sub 'Path = "D:\test\" في حالة كان المسار ثابت يمكنك تعديل السطر التالي بما يناسبك ' ' اختيار مسار الحفظ Path = Application.GetSaveAsFilename(InitialFileName:=WS.[E2], _ fileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="الرجاء اختيار مكان الحفظ") If Path <> False Then Application.DisplayAlerts = False Application.ScreenUpdating = Fals WS.Copy Set NewWb = ActiveWorkbook With NewWb.Sheets(1).UsedRange .Value = .Value End With NewWb.SaveAs Path, FileFormat:=51 '**************************************************************** ' هدا للمسار الثايت ' NewWb.SaveAs Filename:=Path & WS.[E2] & ".xlsx", FileFormat:=51 '********************************************************************* NewWb.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Saved successfully" Unload Me End If End Sub SAV 18 v2.xlsb

تفضل If ezr <> "الجزائر" Then e8.Visible = False g5.Visible = False m3.Visible = False ar.Visible = False Else e8.Visible = True g5.Visible = True m3.Visible = True ar.Visible = True End If الافواج4.rar

الشطر الأخير من الكود يكون هكذا "[idofacc]=" & [fatheraccc] وليس : "[fatheracc] =" & "[fatheraccc]" لأن قيمة مربع التحرير = [idofacc] ايضا عليك بعض الملاحظات في كتابتك للأكواد منها عمل اكثر من 6 احداث لحقل واحد .. هذا عجيب ومنها استخدامك للسطر On Error Resume Next بكثرة .. لحاجة ولغير حاجة وهذا خطأ هذا السطر لا يستخدم الا عند وجود اخطاء منطقية فقط

وعليكم السلام -تفضل كما طلبت أنك لم تقم بتصميم الملف بنفسك فلك هذا الفيديو به طلبك

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

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

جرب هذا الرابط https://answers.microsoft.com/en-us/msoffice/forum/all/how-to-enter-numbers-in-excel-spreadsheet-using/d8c92930-b468-410e-bc30-b0f527d02d6e ثم استخدم Windows Speech Recognition

وعليكم السلام ورحمة الله وبركاته يمكن أن يفيدك هذا الفيديو من استاذنا الخلوق أحمد فاروقhttps://www.youtube.com/watch?v=2cy2YfmFlzQ وهذا هو الكود الذي تم الشرح عليه Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value <> "" Then ActiveSheet.Unprotect Password:="111" Target.Locked = True ActiveSheet.Protect Password:="111" End If End Sub