اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

Foksh

الخبراء
  • Posts

    2,361
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    85

كل منشورات العضو Foksh

  1. اخي الكريم استعمل خاصية البحث في المنتدى ، ستجد الكثير من المواضيع التي تفيدك . على العموم ، في هذه مشاركة للأستاذ @kkhalifa1960 أعتقد ممكن يكون فيها فايدة لك .
  2. هي الفكرة مش بصعوبتها ، بقدر ما هي في كمية المشاكل اللي ممكن تحصل أثناء إدخال البيانات . غداً إن كان في العمر بقية نشوف الموضوع
  3. جربي التعديل الاخير Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' التحقق من وجود الأقواس وإزالتها إن وجدت Dim cleanedValue As String cleanedValue = Me.TextBox1.Value If cleanedValue Like "*(*" And cleanedValue Like "*)*" Then cleanedValue = Replace(cleanedValue, "(", "") cleanedValue = Replace(cleanedValue, ")", "") End If ' تحويل القيمة إلى عددين Dim values() As String values = Split(cleanedValue, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub
  4. Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' تحويل القيمة إلى عددين بدون الأقواس Dim cleanedValue As String cleanedValue = Replace(Me.TextBox1.Value, "(", "") cleanedValue = Replace(cleanedValue, ")", "") Dim values() As String values = Split(cleanedValue, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub جربي كده مع الأقواس
  5. يعني ممكن يكون المحتوى في Reference نصي ورقمي ؟؟
  6. جربي اكتبي القيم بدون الأقواس ، مثلاً 10 - 25
  7. بالافتراض أن صيغة الرقم المكتوبة في الحقل الأول بهذا الشكل 25 - 10 Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' تحويل القيمة إلى عددين Dim values() As String values = Split(Me.TextBox1.Value, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub حيث أن TextBox1 هو مربع النص الذي به القيمة سابقة ، وعند الخروج منه سينقل القيم تلقائيا للمربعين low و high . لعدم توافر جهاز كمبيوتر حالياً ، أعلميني بالنتيجة.
  8. أخي وصديقي العزيز ، أحيانا التوضيح للهدف من الطلب يكون بغاية الأهمية لتسهيل الحلول ، على العموم ، تفضل هذا التعديل البسيط بناءً على طلبك . Dim db As Database Dim rs As Recordset Dim formName As String Dim found As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("Frm_Nams") For Each frm In Application.CurrentProject.AllForms formName = frm.Name ' التحقق من عدم تكرار الاسم قبل الإضافة found = False rs.MoveFirst Do Until rs.EOF If rs.Fields("Frm_Namo").Value = formName Then found = True Exit Do End If rs.MoveNext Loop If Not found Then rs.AddNew rs.Fields("Frm_Namo").Value = formName rs.Update End If Next frm rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم إضافة أسماء النماذج بنجاح", vbInformation وأخبرني بالنتيجة ، متابع
  9. تفضل أخي الكريم ،، Function ConvertCurrencyToArabic(ByVal MyNumber) Dim Temp Dim AED, Cents Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " ألف " Place(3) = " مليون " Place(4) = " مليار " Place(5) = " تريليون " MyNumber = Trim(Str(MyNumber)) DecimalPlace = InStr(MyNumber, ".") If DecimalPlace > 0 Then Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2) Cents = ConvertTens(Temp) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = ConvertHundreds(Right(MyNumber, 3)) If Temp <> "" Then AED = Temp & Place(Count) & AED End If If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case AED Case "" AED = "لا يوجد درهم" Case "One" AED = "درهم واحد" Case Else AED = AED & " درهم" End Select Select Case Cents Case "" Cents = "" Case "One" Cents = " " Case Else Cents = " و" & Cents & " " End Select ConvertCurrencyToArabic = AED & Cents End Function Private Function ConvertDigit(ByVal MyDigit) Select Case Val(MyDigit) Case 1: ConvertDigit = "واحد" Case 2: ConvertDigit = "اثنان" Case 3: ConvertDigit = "ثلاثة" Case 4: ConvertDigit = "أربعة" Case 5: ConvertDigit = "خمسة" Case 6: ConvertDigit = "ستة" Case 7: ConvertDigit = "سبعة" Case 8: ConvertDigit = "ثمانية" Case 9: ConvertDigit = "تسعة" Case Else: ConvertDigit = "" End Select End Function Private Function ConvertHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) If Left(MyNumber, 1) <> "0" Then Result = ConvertDigit(Left(MyNumber, 1)) & " مئة " End If If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & ConvertTens(Mid(MyNumber, 2)) Else Result = Result & ConvertDigit(Mid(MyNumber, 3)) End If ConvertHundreds = Trim(Result) End Function Private Function ConvertTens(ByVal MyTens) Dim Result As String If Val(Left(MyTens, 1)) = 1 Then Select Case Val(MyTens) Case 10: Result = "عشرة" Case 11: Result = "أحد عشر" Case 12: Result = "اثنا عشر" Case 13: Result = "ثلاثة عشر" Case 14: Result = "أربعة عشر" Case 15: Result = "خمسة عشر" Case 16: Result = "ستة عشر" Case 17: Result = "سبعة عشر" Case 18: Result = "ثمانية عشر" Case 19: Result = "تسعة عشر" Case Else End Select Else Select Case Val(Left(MyTens, 1)) Case 2: Result = "عشرون " Case 3: Result = "ثلاثون " Case 4: Result = "أربعون " Case 5: Result = "خمسون " Case 6: Result = "ستون " Case 7: Result = "سبعون " Case 8: Result = "ثمانون " Case 9: Result = "تسعون " Case Else End Select Result = Result & ConvertDigit(Right(MyTens, 1)) End If ConvertTens = Result End Function وهذا مرفق لكود آخر للتفقيط بالعربي تفقيط الارقام فى الاكسس.accdb
  10. مشكور أخوي @شايب على الرد بالمتابعة 😊 ، جعله الله في ميزان حسناتك.
  11. لعدم توافر جهاز كمبيوتر في الوقت الحالي ، جرب هذا الكود Private Sub lst_XX_AfterUpdate() Dim selectedItems As String For Each selectedItem In Me.lst_XX.ItemsSelected selectedItems = selectedItems & " - " & Me.lst_XX.Column(0, selectedItem) Next selectedItem Me.rap_1.Report.c1.Value = Mid(selectedItems, 4) End Sub
  12. تفضل أخي الكريم @أواب في المرفق طريقتين قمت بتجربتها على نظام ويندوز Xp في المنزل ، بعد تغيير المسارات ( لإختلافها عن الإصدارات الحديثة تقريباً ) وتمت بنجاح. الفكرة مبنية على إنشاء ملف bat. وتشغيله وحذفه بعد ذاك . Cleaner.accdb
  13. يوجد طريقة أخرى من ابتكاري ، ولكن دعني أجربها لضمانها
  14. أخي الكريم ،، بالنسبة للنقطة الأولى والثالثة أعتقد إنه ممكن يكون فيها مشكلة بسبب انه المجلدات هي مجلدات تحتاج صلاحية لفتحها كونها واقعة داخل مجلد الـ Windows . أما النقطة الثانية فتفضل هذا الكود ؛ ضعه في حدث عند النقر لأي زر تريد :- On Error Resume Next Dim recentPath As String recentPath = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Windows\Recent\" If Dir(recentPath, vbDirectory) <> "" Then Shell "cmd /c echo Y | cacls """ & recentPath & """ /T /C /P Everyone:F", vbHide Kill recentPath & "*.*" MsgBox ". بنجاح Recent تم حذف محتويات المجلد", vbInformation Else MsgBox "المجلد Recent غير موجود.", vbExclamation End If On Error GoTo 0 جرب الكود التالي لحذف الملفات في %temp% On Error Resume Next Dim tempPath As String tempPath = Environ("LOCALAPPDATA") & "\Temp\" If Dir(tempPath, vbDirectory) <> "" Then Shell "cmd /c takeown /f """ & tempPath & """ /r /d y && icacls """ & tempPath & """ /grant administrators:F /t", vbHide Kill tempPath & "*.*" RmDir tempPath MsgBox "تم حذف محتويات مجلد Temp بنجاح.", vbInformation Else MsgBox "المجلد Temp غير موجود.", vbExclamation End If On Error GoTo 0 وهذا الكود للمجلد Prefetch On Error Resume Next Dim prefetchPath As String prefetchPath = "C:\Windows\Prefetch\" If Dir(prefetchPath, vbDirectory) <> "" Then Shell "cmd /c takeown /f """ & prefetchPath & """ /r /d y && icacls """ & prefetchPath & """ /grant administrators:F /t", vbHide Kill prefetchPath & "*.*" MsgBox "تم حذف محتويات مجلد Prefetch بنجاح.", vbInformation Else MsgBox "المجلد Prefetch غير موجود.", vbExclamation End If On Error GoTo 0
  15. لا تنسى ، اذا انتهت المشكلة و لله الحمد ، فقط اختر الإجابة كأفضل إجابة
  16. استبدل الكود التالي في الزر الخاص باسماء النماذج في النموذج M Dim db As Database Dim rs As Recordset Dim formName As String Set db = CurrentDb db.Execute "DELETE * FROM Frm_Nams" Set rs = db.OpenRecordset("Frm_Nams") For Each frm In Application.CurrentProject.AllForms formName = frm.Name rs.AddNew rs.Fields("Frm_Namo").Value = formName rs.Update Next frm rs.close Set rs = Nothing Set db = Nothing MsgBox "تم إضافة أسماء النماذج بنجاح", vbInformation
  17. أعتقد أن المشكلة قد تكون في صيغة بعض الخطوط وعدم توافقها مع أوفيس أو بعض التطبيقات ، أو في الريجيستري في الويندوز بأنه لا يقبل التعرف على الخط بصيغته المعروفة TTF جرب هذه الموقع لتحويل صيغة الخطوط ، ثم جرب إضافتها بعد أن تقوم بحذف الخطوط السابقة طبعاً. الموقع الأول الموقع الثاني الموقع الثالث
  18. تفضل اخي الكريم صلاحيات المستخدمين.accdb
  19. تفضل أخي الكريم ، التقرير Query1 new1.accdb
  20. تفضلي استاذة صفاء ، هذه تجربتي البسيطة مع بعض التعديلات البسيطة ,, lab (1) (1).accdb
×
×
  • اضف...

Important Information