نجوم المشاركات
Popular Content
Showing content with the highest reputation on 03/15/25 in مشاركات
-
غدا سارفع ملف توضيح للمطلوب قبل التنفيذ والنتيجة تقبل تحياتي1 point
-
نعم لان الاسماء لديك كلها تتضمن مسافة فارغة بين الاسماء كلية التربية كلية الاداره والاقتصاد قسم المحاسبة1 point
-
السلام عليكم ، واضافة الى ما تفضل به اخي خليفة غالبا مثل هذه المشكلة تحدث عند فقدان مكتبة راجع مكتبات البرنامج1 point
-
اذا لم ترغب في تغيير اعدادات لغة الجهاز افتح قاعدة جديدة واستورد بها محتويات القاعدة ولاتنسى المكتبات .1 point
-
اعتذر عن المتابعة أخي الكريم ، عل أحد الإخوة والأساتذة يفيدك في تحقيق مطالبك والتعامل مع المسميات باللغة العربية بشكل أفضل مني .1 point
-
وعليكم السلام ورحمة الله تعالى وبركاته.. اعتقد ان المشكلة كما أوضح الأساتذة في ردودهم التالية ، وأيضاً تفقد إعدادات الأمان . وللإحتياط تفقد اعدادات اللغة في الويندوز ، راجع هذا الموضوع هنا .1 point
-
وعليكم السلام اخي الكريم لا اخي الكريم ال sql مجانية1 point
-
وعليكم السلام ورحمة الله تعالى وبركاته اخي @أبو أحمد ، تفضل الكود التالي بعد تعديل المسميات في مثالك. Private Sub أمر26_Click() On Error GoTo ErrorHandler Dim db As dao.Database Dim rst1 As Recordset, rst2 As Recordset Dim fld As Field Dim sqlUpdate1 As String, sqlUpdate2 As String Dim recordID As Long If Me.searinumber = 0 Or IsNull(Me.searinumber) Or Me.searinumber = "" Then MsgBox "الرجاء إدخال رقم السجل", vbExclamation Me.searinumber.SetFocus Exit Sub End If recordID = Val(Me.searinumber) Set db = CurrentDb() If DCount("*", "جدول تسجيل الكتب", "searinumber = " & recordID) = 0 Then MsgBox "رقم السجل غير موجود", vbExclamation Me.searinumber.SetFocus GoTo ExitSub End If Set rst1 = db.OpenRecordset("جدول تسجيل الكتب") 'الجدول الرئيسي sqlUpdate1 = "UPDATE [جدول تسجيل الكتب] SET " For Each fld In rst1.Fields If fld.Name <> "searinumber" Then 'المفتاح الأساسي If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate1 = sqlUpdate1 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate1, 2) = ", " Then sqlUpdate1 = Left(sqlUpdate1, Len(sqlUpdate1) - 2) sqlUpdate1 = sqlUpdate1 & " WHERE searinumber = " & recordID End If Set rst2 = db.OpenRecordset("Marks") 'الجدول الفرعي sqlUpdate2 = "UPDATE Marks SET " For Each fld In rst2.Fields If fld.Name <> "NoMArks" Then 'الحقل المرتبط If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate2 = sqlUpdate2 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate2, 2) = ", " Then sqlUpdate2 = Left(sqlUpdate2, Len(sqlUpdate2) - 2) sqlUpdate2 = sqlUpdate2 & " WHERE NoMArks = " & recordID End If db.Execute sqlUpdate1 db.Execute sqlUpdate2 MsgBox "تمت تصفية بيانات السجل رقم " & recordID & " في الجدولين", vbInformation Me.Requery ExitSub: If Not rst1 Is Nothing Then rst1.Close If Not rst2 Is Nothing Then rst2.Close Set rst1 = Nothing Set rst2 = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ", vbCritical Resume ExitSub End Sub1 point
-
وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub SaveAsPDF() Dim CrWS As Worksheet: Set CrWS = Sheets("بيانات") Dim lastRow As Long: lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row Dim xPath As String: xPath = ThisWorkbook.Path & "\كشف_التلاميذ.pdf" CrWS.Range("A2:J" & lastRow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub1 point
-
السلام عليكم جرب التعديل في الملف Option Explicit Sub CircleLowGrades() Dim ws As Worksheet Dim gradeRanges As Variant Dim maxRanges As Variant Dim cell As Range Dim maxCell As Range Dim maxGrade As Double Dim shp As Shape Dim i As Integer, j As Integer Dim gradeRange As Range, maxRange As Range Set ws = ThisWorkbook.Sheets("شهادةنصف") gradeRanges = Array(ws.Range("D13:P13"), ws.Range("D30:P30"), ws.Range("D47:P47")) maxRanges = Array(ws.Range("D12:P12"), ws.Range("D29:P29"), ws.Range("D46:P46")) For Each shp In ws.Shapes If shp.Name Like "Circle*" Then shp.delete Next shp For i = LBound(gradeRanges) To UBound(gradeRanges) Set gradeRange = gradeRanges(i) Set maxRange = maxRanges(i) For j = 1 To gradeRange.Cells.Count Set cell = gradeRange.Cells(j) Set maxCell = maxRange.Cells(j) If IsNumeric(maxCell.Value) Then maxGrade = Val(maxCell.Value) Else maxGrade = 0 End If If IsNumeric(cell.Value) Then If Val(cell.Value) < maxGrade Then Call DrawCircle(ws, cell) End If ElseIf cell.Value = "غ" Or cell.Value = "غـ" Or cell.Value = "صفر" Then Call DrawCircle(ws, cell) End If Next j Next i End Sub Sub DrawCircle(ws As Worksheet, cell As Range) Dim shp As Shape Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left + 2, cell.Top + 2, cell.Width - 4, cell.Height - 4) shp.Name = "Circle" & cell.Address(False, False) shp.Line.ForeColor.RGB = RGB(255, 0, 0) shp.Fill.ForeColor.RGB = RGB(255, 255, 255) shp.Fill.Transparency = 1 End Sub test1.xlsb1 point
-
في موضوع لاخي الكريم // مؤمن جمعة (عمل لوحه UserForm بترحيل بيانات) علي الرابط التالي http://www.officena.net/ib/index.php?showtopic=49583&hl= وطلبه لتصميم برنامج لمتابعة حركة السيارات وتسجيل العمليات المتعلقة ونظرا لان عنوان الموضوع لا يدل علي محتواه وبعد اذن ادارة المنتدي طرحت الموضوع بشكل منفصل حتي يكون في متناول الجميع ولسهولة البحث بعد ذلك بالمنتدي الكريم ويمكن تعديل القاعدة لتتلائم مع شركات تاجير السيارات واضافة حساب كيلومترات السيارة وتكلفة الايجار علي حسب الحاجة وادعوا الله ان يكون الموضوع فيه الفائدة للسائل او الباحث شرح موجز لوظائف الفورم ولا تنسونا بدعوة بظاهر الغيب بصلاح الحال متابعة السيارات.rar1 point
-
السلام عليكم ورحمة الله تم التعديل حسب ما تريد على المعادلات مع تبسيطها لأبسط شكل ممكن... أرجو أن تفي التعديلات ما تريده بالضبط... بن علية حاجي عداد بقرب انتهاء فترة عقد.rar1 point
-
السلام عليكم ورحمة الله وبركاته تم إضافة المعادلات اللازمة لحساب ما تبقى من أيام لغاية تاريخ تجديد العقد الموالي للتاريخ الحالي (والعداد التنازلي يبدأ انطلاقا من 90 يوم كما طلبت)... أرجو أن تفي الغرض المطلوب... بن علية حاجي طلب عداد بقرب انتهاء عقد.rar1 point
-
أخي الكريم بسام أهلاً بك في المنتدى ونورت بين إخوانك ونتمنى لك قضاء أمتع الأوقات معنا إليك الملف المرفق الأخير الذي يحتوي على تعديلات الأخ الحبيب ضاحي .. قم بالنقر على اسم الملف سيظهر معك نافذة برنامج التحميل ..حدد المكان المراد حفظ الملف فيه ، وبعد التنزيل يمكنك فك الضغط عن الملف باستخدام برنامج الوينرار تقبل تحياتي متابعة السيارات.rar1 point
-
1 point
-
السلام عليكم تم حماية الشيتات من الحذف أو الإضافة تم منع خاصيتي النسخ واللصق شاهد المرفق ==== جاري العمل على حل مشكلة التاريخ salary finished.rar1 point
-
السلام عليكم في البداية جرب المرفق 1. لا يمكن حفظ الملف بأي صيغة اخرى 2. الملف لا يعمل اذا كان الامان منخفض 3. لا يمكن التعديل على الملف === بالنسبة للتاريخ يمكن التحكم فيه لو كان ما سبق يناسبك Abu_Ahmed.rar1 point
-
بسم الله الرحمن الرحيم و هذا مثال مايكروسوفت الذى تجده بHelp Example ". وقد قمت بالتعديل عليه لاظهار ايام الاسبوع عن طريق Array بالكود التالى Sub DOIT() Dim MyWeek, MyDay MyWeek = Array("Sat", "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun") For i = 0 To 6 MyDay = MyWeek(i) MsgBox (MyDay) Next i End Sub مع ملاحظه اننا قمن بمناداه ايام الاسبوع بعد تعريفها MyDay بوضعها بين قوسين مرفق ملف السلام عليكم Array.rar1 point
-
0 points