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

:: السلام عليكم ورحمة الله وبركاته :: 🙂 يطيب لي أن أهديكم هذه الهدية البسيطة 🎁 :: مرسال الواتسأب :: وهو برنامج بسيط جدا لإرسال الرسائل عن طريق الواتسأب .. مع إمكانية إرسال المرفقات كذلك ( صور أو مستندات ) 🙂 وله واجهتين رئيسيتين : 1 - الرسائل الفردية 2 - الرسائل الموجهة لعدة أشخاص :: وهذه صور لواجهات البرنامج :: طبعا من الضروري تنصيب برنامج الواتسأب للكمبيوتر وتشغيله قبل تشغيل البرنامج 🙂 وبملاحظاتكم ودعواتكم دوما نرتقي 🙂 :: وأخيرا :: التحميل :: ☺️👌🏼 مرسال الواتسأب.accdb

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

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub ضياء_test1() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(U2=""رئيسي"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(U2=""رئيسي"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End Sub او بهده الطريقة Sub ضياء_test2() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(RC[-5]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(RC[-6]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With End Sub وبهده الطريقة بالنسبة لحدث الشيت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect(Target, Range("x:y")) Is Nothing Then lr = ActiveSheet.Cells(Rows.Count, "u").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & lr) .Formula = "=IF(U2=""ورقة1"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & lr) .Formula = "=IF(U2=""ورقة1"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End If End Sub حساب.xlsm حساب _ حدث الشيت.xlsm

يسعدنى أن أكون اول من يقدم لك الشكر الجزيل اخى الكريم وجزاك الله خيرا يارب

السلام عليكم في الملف المرفق فيه طلبك ان شاء الله الملف الاصلي وهو من كنوز المنتدى فورم ادخال و تعديل مرن مع الطباعة 1.xls

السلام عليكم ورحمة الله وبركاته القلب يعتصر حزنا وانا اكتب لكم ... اغلاق منتدى شقيق ... منتديات الاكسس والوورد ....

جرب جساب الفرق بين تاريخين.xlsx

الموضوع فعلا سهلا هل هذا طلبك test.accdb

الكوود المرتبط بزر الطباعة Private Sub ButtonPrint_Click() If Me.Frame1.ScrollHeight > Me.Frame1.Height Then Print1 Else If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÓÌá Úáì ÇáÝæÑã ¿ ", vbYesNo + mBox, "ØÈÇÚÉ Úáì ÇáÝæÑã ") = vbYes Then Print2 Else Print1 End If End If End Sub Private Sub Print1() Dim ctl As Control Dim i As Integer Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("A1").Resize(LastColumn, 2) .ColumnWidth = 35 .Borders.LineStyle = 1 .PrintPreview End With .Close False End With '------------------------ Me.Show End Sub Private Sub Print2() Print_Visible False '''''''''''''''''''''''''' If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÝæÑã ÍÓÈ åÐå ÇáãÚÇíäÉ ¿ ", vbYesNo + mBox, "ãÚÇíäÉ ÞÈá ÇáØÈÇÚÉ") = vbYes Then On Error Resume Next Me.PrintForm On Error GoTo 0 End If '''''''''''''''''''''''''' Print_Visible True kh_Enabled True End Sub اما باقي اكواد الفورم فربمما الكود في الاعلى مرتبط بباقي الاكواد Option Explicit '====================================================== '====================================================== ' ÊäÓíÞ ÇáÊÇÑíÎ Private Const DtF As String = "yyyy/mm/dd" '====================================================== ' ÚõÑÖ ÊÇßÓÊ ÇáÇÏÎÇá Private Const iWgt1 As Single = 200 '====================================================== Private Const Frmtop As Single = 3 Private Const Frmlft As Single = 3 Private Const iHgt As Single = 21.55 Private Const iTop As Single = iHgt + 2 Private Const mBox As Long = vbMsgBoxRight + vbMsgBoxRtlReading '====================================================== '====================================================== Private Ar() As Integer Private MyRngSeri As Range Private MyRngdate As Range Private ContRow As Long Private iRow As Long Private LastColumn As Integer Private tSr As Boolean Private MyList As String Private tAc As Boolean Private iColor1, iColor2 Private Sub BoxFind_Click() Dim tm As Integer Me.ListFind.Clear tm = Me.BoxFind.Tag Me.Controls("Labeldt" & tm).ForeColor = vbBlack tm = Me.BoxFind.ListIndex + 1 Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor Me.BoxFind.Tag = tm End Sub Private Sub ButtonCalendar_Click() On Error GoTo 1 Dim MyVelue, t With Me.Frame1 If .ActiveControl Is Nothing Then .SetFocus If TypeOf .ActiveControl Is MSForms.TextBox Then .ActiveControl.BackColor = Me.ButtonCalendar.BackColor If .ActiveControl.Top > .Height Then .ScrollTop = .ActiveControl.Top - (.Height / 2) MyVelue = .ActiveControl t = .Controls(.ActiveControl.TabIndex + 1) If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then Else MyVelue = Date With FormDate .Caption = t .Tag = MyVelue .Show End With .ActiveControl.BackColor = &HFFFFFF Else MsgBox "áÇ íãßä ÇÖÇÝÉ ÇáÊÇÑíÎ Ýí ÞÇÆãÉ", mBox, "ÊäÈíå" End If End With 1 If Err Then Err.Clear End Sub Private Sub ButtonClear_Click() kh_ClearRecord End Sub Private Sub ButtonEnd_Click() Me.ScrollBar1.Value = ContRow End Sub Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False) Dim tm As Integer '''''''''''''''''''''''''''''''' For tm = 2 To LastColumn If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then Me.Controls("Textdt" & tm) = "" End If Next End Sub Private Sub kh_AddNewRecord() Dim C As Integer '''''''''''''''''' Me.Frame1.ScrollTop = 0 kh_ClearRecord True '''''''''''''''''' Me.LabelSerial = ContRow + 1 Me.LabelSerial2 = ContRow + 1 & " - " & ContRow + 1 kh_Enabled False '''''''''''''''''' With Me.Controls("Textdt1") If .Enabled Then .SetFocus .Text = "íÌÈ ÇáÇÏÎÇá Ýí åÐå ÇáÎáíÉ ÇÝÊÑÇÖíÇð" .SelStart = 0 .SelLength = .TextLength Else .Text = "........" End If End With End Sub Private Sub ButtonGo_Click() With MyRngdate .Worksheet.Activate .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select End With Unload Me End Sub Private Sub ButtonNew_Click() kh_AddNewRecord End Sub Private Sub ButtonNewCancel_Click() ScrollBar1_Change End Sub Private Sub ButtonNewSave_Click() If kh_TestBlank() Then Exit Sub Dim cRow As Long: cRow = ContRow + 1 Me.ScrollBar1.Max = cRow kh_SaveDate cRow, True Me.ScrollBar1.Value = cRow Call MsgBox(" Êã ÍÝÙ ÇáÓÌá ÇáÌÏíÏ ÈäÌÇÍ ", mBox, "ÇáÍãÏááå") End Sub Private Sub ButtonPrint_Click() If Me.Frame1.ScrollHeight > Me.Frame1.Height Then Print1 Else If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÓÌá Úáì ÇáÝæÑã ¿ ", vbYesNo + mBox, "ØÈÇÚÉ Úáì ÇáÝæÑã ") = vbYes Then Print2 Else Print1 End If End If End Sub Private Sub Print1() Dim ctl As Control Dim i As Integer Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("A1").Resize(LastColumn, 2) .ColumnWidth = 35 .Borders.LineStyle = 1 .PrintPreview End With .Close False End With '------------------------ Me.Show End Sub Private Sub Print2() Print_Visible False '''''''''''''''''''''''''' If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÝæÑã ÍÓÈ åÐå ÇáãÚÇíäÉ ¿ ", vbYesNo + mBox, "ãÚÇíäÉ ÞÈá ÇáØÈÇÚÉ") = vbYes Then On Error Resume Next Me.PrintForm On Error GoTo 0 End If '''''''''''''''''''''''''' Print_Visible True kh_Enabled True End Sub Private Sub Print_Visible(v As Boolean) Dim ctl As Control '''''''''''''''''''''''''' If v Then Me.BackColor = iColor1 With Me.Frame1 .BackColor = iColor2 .SpecialEffect = 3 End With Else Me.BackColor = vbWhite With Me.Frame1 .BackColor = vbWhite .SpecialEffect = 0 End With End If '''''''''''''''''''''''''' For Each ctl In Me.Controls If ctl.Parent.Name <> "Frame1" Then If ctl.Name <> "Frame1" Then ctl.Visible = v End If Next '''''''''''''''''''''''''' For Each ctl In Me.Frame1.Controls If TypeOf ctl Is MSForms.ComboBox Then ctl.ShowDropButtonWhen = IIf(v, 2, 0) End If Next End Sub Private Sub ButtonSaveDate_Click() If kh_TestBlank() Then Exit Sub kh_SaveDate iRow ScrollBar1_Change Call MsgBox(" Êã ÍÝÙ ÇáÊÛííÑÇÊ ÈäÌÇÍ ", mBox, "ÇáÍãÏááå") End Sub Private Function kh_TestBlank() As Boolean If Len(Trim(Me.Controls("Textdt1"))) = 0 Then kh_TestBlank = True Me.Controls("Textdt1").SetFocus Call MsgBox("ÇáÚãæÏ : " & Me.Controls("Labeldt1") & vbCr & vbCr & "íÌÈ ÇáÇÏÎÇá Ýí åÐå ÇáÎáíÉ ÇÝÊÑÇÖíÇð", mBox + vbCritical, "ÇÓÊÎÏÇã ÎÇØìÁ") End If End Function Private Sub kh_AutoFill() Dim CelFill As Range, CFil As Range Dim R As Integer '''''''''''''''''''''''''' If tSr Then Set CelFill = Union(MyRngSeri, MyRngdate) Else Set CelFill = MyRngdate End If '''''''''''''''''''''''''' For R = 1 To CelFill.Areas.Count Set CFil = CelFill.Areas(R).Rows(ContRow + 1) With CFil .AutoFill .Resize(2), xlFillDefault End With Next Set CelFill = Nothing Set CFil = Nothing End Sub Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False) Dim MyVelue, Msg Dim C As Integer, cc As Integer '''''''''''''''''''''''''' 'On Error GoTo 1 '''''''''''''''''''''''''' Application.Calculation = xlCalculationManual '''''''''''''''''''''''''' If nR > 1 And tFil Then kh_AutoFill If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR ''''''''''''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) If Me.Controls("Textdt" & cc).Enabled = True Then With MyRngdate MyVelue = Me.Controls("Textdt" & cc).Text If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Else If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then Msg = MsgBox("ÇáÎáíÉ Ýí ÇáÚãæÏ : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _ & "ãäÓÞÉ ßÊÇÑíÎ æÇáÇÏÎÇá ÇáÌÏíÏ ÑÞã" & vbCr & vbCr _ & "åá ÊÑíÏ ãÓÍ ÊäÓíÞÇÊ ÇáÇÑÞÇã ÇáÓÇÈÞÉ ¿¿", mBox + vbYesNo, "ÊÃßíÏ ãÓÍ ÊäÓíÞÇÊ ÇáÊÇÑíÎ ÇáÓÇÈÞÉ ¿¿ ") ''''''''''''''''''''''''' If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = "" End If End If .Cells(nR + 1, C).Value = MyVelue End With End If Next '''''''''''''''''''''''''' 1: Application.Calculation = xlCalculationAutomatic '''''''''''''''''''''''''' End Sub Private Sub ButtonExit_Click() Unload Me End Sub Private Sub ButtonDelete_Click() If MsgBox(" åá ÊÑíÏ ÍÐÝ ÇáÓÌá ÑÞã : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "ÊÇßíÏ ÇáÍÐÝ ") = vbNo Then Exit Sub If Me.ListFind.ListCount Then Me.ListFind.Clear MyRngdate.Rows(iRow + 1).EntireRow.Delete If Not tSr Then GoTo 1 If iRow = ContRow Then GoTo 1 With MyRngSeri .Cells(iRow + 1, 1).Value = iRow Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries End With 1: Me.ScrollBar1.Max = ContRow - 1 ScrollBar1_Change Call MsgBox(" Êã ÍÐÝ ÇáÓÌá ÈäÌÇÍ ", mBox, "ÇáÍãÏááå") End Sub Private Sub ButtonTop_Click() If ContRow Then Me.ScrollBar1.Value = 1 End Sub Private Sub CheckFind_Click() Me.ListFind.Clear Me.LblFindCount = 0 End Sub Private Sub CheckFindDate_Click() If Me.CheckFindDate.Value = True Then kh_SetDate Me.TextFind '''''''''''''''''''''''''''' End If End Sub Private Sub LabelH2_Click() Call MsgBox(" ÓíÊã ÊÍæíá Çí ÞíãÉ ÊÖÚåÇ Ýí ãÑÈÚ ÇáäÕ ááÈÍË " _ & vbCr & vbCr & "Çáì ÊÇÑíÎ ÈÇáÊäÓíÞ ÇáÇÝÊÑÇÖí ááÝæÑã ,,,,,,," _ & vbCr & String$(40, "=") _ & vbCr & vbCr & "ãÚ ÇãßÇäíÉ ÇÏÎÇá ÑÞã ÕÍíÍ Èíä 1 Çáì 31 áíÝåã Úáì Çäå " _ & vbCr & vbCr & "ÊÇÑíÎ Çáíæã ááÔåÑ ÇáÍÇáí æÇáÓäÉ ÇáÍÇáíÉ " _ , mBox + vbQuestion + vbApplicationModal, "ÊÚáíãÇÊ") ''''''''''''''''''''''''''' End Sub Private Sub ListFind_Click() Dim RR As Long RR = Me.ListFind.Column(1) Me.ScrollBar1.Value = RR End Sub Private Sub ScrollBar1_Change() Dim MyVelue Dim C As Integer, cc As Integer Me.Frame1.ScrollTop = 0 With Me.ScrollBar1 If ContRow = 0 Then .Min = 1 iRow = .Value: ContRow = .Max End With ''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) With MyRngdate If IsDate(.Cells(iRow + 1, C)) Then MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF) Else: MyVelue = .Cells(iRow + 1, C).Value2 End If End With On Error Resume Next Me.Controls("Textdt" & cc).Text = "" Me.Controls("Textdt" & cc).Text = MyVelue On Error GoTo 0 Next '------------------------------ Me.LabelSerial.Caption = iRow Me.LabelSerial2.Caption = iRow & " - " & ContRow kh_Enabled True End Sub Private Sub TextFind_Change() With Me.ListFind If .ListCount Then .Clear End With Me.LblFindCount = 0 Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False) End Sub Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) If Me.CheckFindDate.Value = False Then Exit Sub kh_SetDate Me.TextFind End Sub ' åÐÇ ÇáßæÏ íÑÛãß ÈÇÏÎÇá ÊÇÑíÎ Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control) Dim dtest, dt dtest = dCntrl If Not IsDate(dtest) Then If IsNumeric(dtest) Then On Error Resume Next dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF) If Err Then dt = Format(Date, DtF) On Error GoTo 0 Else dt = Format(Date, DtF) End If Else: dt = Format(CDate(dtest), DtF) End If dCntrl = dt End Sub Private Sub TextSerial_Change() Dim v v = Me.TextSerial.Text If Len(v) = 0 Then Exit Sub If Not IsNumeric(v) Then GoTo 1 If v = 0 Or v > ContRow Then GoTo 1 Exit Sub '======================= 1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1) End Sub Private Sub TextSerial_AfterUpdate() If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = "" End Sub Private Sub kh_Enabled(ByVal Ebl As Boolean) Me.ButtonNewSave.Visible = Not Ebl Me.ButtonNewCancel.Visible = Not Ebl Me.ButtonNew.Visible = Ebl Me.ButtonSaveDate.Visible = Ebl '''''''''''''''''''''''''''''''''''''''''''' Me.ButtonPrint.Enabled = Ebl Me.ButtonSaveDate.Enabled = Ebl Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False) '''''''''''''''''''''''''''''''' Me.ButtonEnd.Enabled = CBool(iRow <> ContRow) Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1) Me.ButtonNewCancel.Enabled = IIf(iRow, True, False) Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl) End Sub Private Sub ButtonSerach_Click() Dim tb1 As Boolean, ib As Boolean Dim R As Long, RR As Long Dim C As Integer Dim MyFind, MySrch, MyVelue '''''''''''''''''''''' Me.ListFind.Clear If Len(Trim(Me.TextFind)) = 0 Then Exit Sub ''''''''''''''''''''' C = Me.BoxFind.ListIndex + 1 tb1 = CBool(Me.CheckFindDate.Value = True) If tb1 Then If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind MyFind = CDbl(CDate(Me.TextFind)) Else MyFind = Me.TextFind.Value End If ''''''''''''''''''''''' With MyRngdate.Cells(2, Ar(C)) For R = 1 To ContRow If Len(Trim(.Cells(R, 1))) Then If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare)) If ib Then MyVelue = .Cells(R, 1).Value If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Me.ListFind.AddItem MyVelue Me.ListFind.List(RR, 1) = R RR = RR + 1 End If End If Next End With Me.LblFindCount = Me.ListFind.ListCount If RR = 0 Then MsgBox " áÇ ÊæÌÏ äÊÇÆÌ áÈÍËß åÐÇ ", mBox, "ÊäÈíå" ''''''''''''''''''''''''' End Sub Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "") tSr = TypeName(Evaluate(aSr)) = "Range" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With ThisWorkbook If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr) Set MyRngdate = .Worksheets(MySht).Range(MyAddrs) End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With MyRngdate ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row LastColumn = .Cells.Count End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Col As Range Dim ii As Integer ReDim Ar(1 To LastColumn) For Each Col In MyRngdate.Cells ii = ii + 1 Ar(ii) = Col.Column - MyRngdate.Column + 1 Next ''''''''''''''''''''''''''' End Sub Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean If Not Rng.Comment Is Nothing Then MyList = Trim(Replace(Rng.Comment.Text, Chr(10), "")) MyList = Replace(MyList, " ", "") If TypeName(Evaluate(MyList)) = "Range" Then kh_TestType = True End If End If End Function Private Sub UserForm_Activate() Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double Dim MyBox As Control, MyLabl As Control Dim t As Integer Dim tTp As Boolean Dim MyType As String ''''''''''''''''''''' If tAc Then Exit Sub Me.Caption = MyRngdate.Worksheet.Name MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2) With Frame1 If MyScrollHeight > .Height Then .ScrollBars = 2 .ScrollHeight = MyScrollHeight End If End With MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2)) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For t = 1 To LastColumn tTp = kh_TestType(MyRngdate.Cells(1, Ar(t))) MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1") Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True) With MyBox .Move Frmlft, MyTop, iWgt1, iHgt .TextAlign = 3 If tTp Then .BackColor = 16761024 .ControlTipText = "ÅÎÊÑ ãä ÇáÞÇÆãÉ" On Error Resume Next .List = Range(MyList).Value If Err Then .AddItem Range(MyList).Cells(1, 1).Value On Error GoTo 0 End If If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then .BackStyle = 0 .TextAlign = 2 .SpecialEffect = 3 .Enabled = False End If End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True) With MyLabl .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt .SpecialEffect = 3 .TextAlign = 2 .Caption = MyRngdate.Cells(1, Ar(t)) End With ''''''''''''''''''''''''''''''''''' Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2 MyTop = MyTop + iTop Next ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.BoxFind .Style = 2 .Tag = 1 .ListIndex = 0 End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.ScrollBar1 .Max = ContRow If ContRow Then .Min = 1 .Value = ContRow Else kh_AddNewRecord End If End With tAc = True ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' End Sub Private Sub UserForm_Initialize() Dim Zo% Dim ZH#, ZW#, AL#, AT#, AH#, AW# Dim FH!, FW! '=========================================== AH = Application.Height: AW = Application.Width AL = Application.Left: AT = Application.Top FH = Height: FW = Width ZH = AH - FH: ZW = AW - FW: Zo = Zoom If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW) '=========================================== Move AL, AT, AW, AH If Zo <> 100 Then Zoom = Zo '''''''''''''''''''''''' iColor1 = Me.BackColor iColor2 = Me.Frame1.BackColor End Sub Private Sub UserForm_Terminate() Set MyRngdate = Nothing Erase Ar Unload FormDate End Sub

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

السلام عليكم ورحمة الله وبركاته ارجو ان يوافق هذا التعديل مرادك جرب ووافنا بالنتائج مع تمنياتي بالتوفيق وكامل اسفي علي تأخري بالرد T3Q - Copy.rar

كما العنوان ومدى الدالتين: أم القـرى : بين 1317/08/29 و 1450/12/29 الميلادي : بين 1900/01/01 و 2029/05/13 طبعا لمن سيستخدمهما عليه أن يفصل أوامر فتح الإكسل وإغلاقه عن الدوال ووضعهم مع الفتح والخروج من مشروع الإكسل ، لتجنب البطء مع كل نداء للدالتين. Option Explicit Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Sub OpenxlApp() Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) End Sub Sub ClosexlApp() xlBook.Close SaveChanges:=False xlApp.Quit End Sub 'AbuuAhmed Function sysUmTest(ByVal UmAlqura As String) As String Dim Dash1 As Byte, Dash2 As Byte, Dash3 As Byte Dim Part1 As String, Part2 As String Dim Part3 As String, Part4 As String On Error Resume Next Part4 = Replace(UmAlqura, "/", "-") If Not IsNumeric(Replace(Part4, "-", "", 1)) Then Exit Function Dash1 = InStr(1, Part4, "-"): If Dash1 = 0 Then Exit Function Dash2 = InStr(Dash1 + 1, Part4, "-"): If Dash2 = 0 Then Exit Function Dash3 = InStr(Dash2 + 1, Part4, "-"): If Dash3 > 0 Then Exit Function Part1 = Left(Part4, Dash1 - 1) Part2 = Mid(Part4, Dash1 + 1, Dash2 - Dash1 - 1) Part3 = Mid(Part4, Dash2 + 1) If Len(Part1) < 4 And Len(Part3) < 4 Then Exit Function If Len(Part1) = 1 Then Part1 = Format(Part1, "00") If Len(Part2) = 1 Then Part2 = Format(Part2, "00") If Len(Part3) = 1 Then Part3 = Format(Part3, "00") If Len(Part1) = 2 Then Part4 = Part1 Part1 = Part3 Part3 = Part4 End If If Not (Val(Part1) >= 1300 And Val(Part1) <= 1600) Then Exit Function If Not (Val(Part2) >= 1 And Val(Part2) <= 12) Then Exit Function If Not (Val(Part3) >= 1 And Val(Part3) <= 30) Then Exit Function sysUmTest = Part1 & "-" & Part2 & "-" & Part3 End Function Function sysUm2Greg(ByVal UmAlqura As String) As Long Dim CurCal As VbCalendar Dim Greg As Long, Days As Long Dim Hdd As Byte On Error Resume Next UmAlqura = sysUmTest(UmAlqura) If UmAlqura = "" Or UmAlqura < "1317-08-29" Or UmAlqura > "1450-12-29" Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A2").Formula = "=LEFT(TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@""),2)" Hdd = Right(UmAlqura, 2) CurCal = Calendar Calendar = vbCalHijri Greg = DateSerial(Left(UmAlqura, 4), Mid(UmAlqura, 6, 2), Hdd) Calendar = CurCal .Range("A1") = Greg If Hdd = .Range("A2") Then sysUm2Greg = Greg Else For Days = Greg + 2 To Greg - 2 Step -1 .Range("A1") = Days If Hdd = .Range("A2") Then Exit For Next Days sysUm2Greg = IIf(Abs(Days - Greg) > 2, Greg, Days) End If End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Function sysGreg2Um(ByVal Greg As Long) As String On Error Resume Next If Greg < DateSerial(1900, 1, 1) Then Exit Function If Greg > DateSerial(2029, 5, 13) Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A1") = Greg .Range("A2").Formula = "=TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@"")" sysGreg2Um = .Range("A2") End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Sub sysUmTesting() Dim UmAlqura As String UmAlqura = "30-6-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) Debug.Print UmAlqura = "1-7-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) End Sub

وأخيرا بعد طوووووووووووال أنتظار وصل الذي تم طلبه من قبل نصف سنة شكرا أخي موسى @Moosak .. جاري تجربة الملف

يمكنك استخدام معادلة شرطية لتظهر رسالة خطأ فى حال كون تاريخ آخر قسط قبل تاريخ أول قسط استبدل المعادلة فى الخلية حمراء اللون بما يلي: =IF(G16>F16,"هناك خطأ تاريخ اخر قسط لا يجب ان يكون بعد تاريخ اول قسط",DATEDIF(G16,F16,"m"))

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

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

السلام عليكم ورحمة الله وبركاته اذا كنت تريد ان يعرض لك الاستعلام البيانات بدون تكرار القيم فمن شاشة تصميم الاستعلام - ومن خصائص الاستعلام حدد الخاصية قيم فريدة الي نعم (uniqe value = yes) كما هو واضح بالصور الثالية: ودمتم تمنياتي بالتوفيق

اعمل تجميع للحقل ..Group By

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

السلام عليكم أخي الكريم بالنسبة لحذف رد متعوب عليه و يمكن ان يفيد الاخرين ، فاتفق معك بان ذلك غير مناسب ، ولا اردي ما سبب حدوث ذلك، و باذن الله ساناقش الأمر مع الأحوة لتجنب حدوث ذلك مرة أخرى. و أعتذر على حدوث ذلك. بالنبسة للموضوع المغلق، تم فتحه الان لفترة اضافية، و السبب فى غلق المواضيع السابقة المكتملة هو تجنب رفعها عند الرد بالشكر مثلا بعد فترة طويلة مما يشتت متابعي الموضيع الجديدة بالقسم، سواء المتابعين بغرض القراءة او بعرض محاولة الرد. و السبب فى ذلك هو تكرار تعقيبات متتالية على مواضيع قديمة مغلق من قبل بعض الاخوة كانت تؤدي لرفع المواضيع القديمة بصورة قد تجعل الصفحة الاولي فى المنتدى كلها مواضيع من هذا النوع ، فتنتقل كافة المواضيع الجديدة للصفحة التالية و يصعب على المتابعين متابعة الجديد، حيث يتعين عليهم فتح كافة المواضيع الجديدة لمعرفة انها فقط قد تم رفعها بكلمة شكر. بينما يمكن استخدام الرموز التعبيرية للاعجاب او الشكر و التقييم دون اضافة رد و رفع الموضوع. و هذا الاجراء و غيره بالطبع قابل للتعديل وفق الظروف والمستجدات، و لكن هذا ما اجتمع الرأي عليه من فترة و لم يكن مطبقا من البداية، فقد وجد أنه الأفضل لعموم المستفيدين من الموقع باغلاق المواضيع المكتملة، و بالطبع لا يوجد رأي أو قرار ثابت ، بل يمكن تعديل أي شيء أو تعديله أو تضمين بعض الاستثناءات. مع ملاحظة أن غلق الموضوع لا يمنع التعقيب عليه وانما يمكن الاشارة له فى موضوع جديد لاستكمال الحوار و اذا لزم الامر و حينها يتم دمج الموضوعان. وهذه الحالة من حيث العدد هي الاقل مقارنة برفع المواضيع من خلال كلمات الشكر، و التي نفضل استبدالها بالعلامات التعبيرية كل لا يتم رفع المواضيع. و في حال وجود موضوع مميز يمكن الاقتراح على الاخوة المشرفين اضافته لقائمة المواضع المميزة المثبتة أو تثبيته لفترة كي تعم الفائدة بصورة اكبر ، و ايضا يمكن اضافته لمكتبة الموضع ليظهر ضمن عدد اقل من المواضيع المميزة ، فقسم الاكسيل بالمكتبة به اقل من 150 موضوع ، و اقترح عليك اضافة الموضوع المشار اليه الي مكتبة الموقع ليسهل الوصول اليه ، و عند الاضافة يتم فتح موضوع خاص بالحوار حول الموضوع بصورة آلية فى القسم المناظر و مواضيع الحوار حول ملفات المكتبة عادة لا يتم اغلافها حيث ترتبط بالملف المرفوع للمكتبة. و اقترح عمل مثال بسيط واضافته للمكتبة سواء بعمل مثال و ضمه لقسم الاكسيل بالمكتبة او رفعه ككود فى القسم المناظر. وفي حال اضافة مثال للمكتبة يمكن تعميمه على الاعضاء بالبريد ليصل للجميع . https://www.officena.net/ib/files/ و يسعدني استكمال الحوار معك اذا رايت هناك حاجة لذلك. و كما ذكرت لا توجد قواعد ثابتة ، و انما عندما نجد حاجة نناقش ما يلزم و نتفق على أي تعديل مطلوب للقواعد المتبعة.

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

اطلاقا لست بحاجة ان تصمم ورقة لكل فريم فقط تقوم بتعيين رقم الفورم من خلال اجراء معين من خلال حلقة تكرارية لكل الفريمات ثم تقوم باختيار الفريم الذي تريده عن طريق checkbox او optionbutton لورقة واحدة فقط يتم تخصيصها للطباعة ، ثم لماذا تستخدم كل هذه الفريمات ؟ قريم واحد فقط لاي عدد من الاوراق فقط تقوم بحلقة تكرارية لكل الاوراق من خلال فريم واحد يتم جلب الورقة المحددة داخل نفس الفريم بناء على الكومبوبوكس .تحياتي .

طيب اجعل الموشر في خانة البحث ثم اسحب الباركود بالماسح وانظر ....... Database1.accdb

وكما يمكننا التعامل مع الوحدة النمطية ModTableLink باستدعائها كما نشاء لربط وجلب أي جدول من أي BE نشاء ، ولطرح المثال و التوضيح ، يمكننا : Call CreateTableLink("H:\Manager\Operations09\Data09.mdb", "co", "") Call CreateTableLink("H:\Manager\Operations09\Data09.mdb", "Emp", "1256") Call CreateTableLink("\\Server\Manager\Operations2014\Data14.accdb ", " tblSeaLine ", "") من أي مسار و أي إمتداد ، ووفق المتغيرات المحددة ، فكل ما ضمن العلم متاح ... وللحديث بقية ...

ربط FE مع جدول أو جداول مختارة مسألة أتصورها في بعض الأحيان ، ولحاجات محددة ، فإفترضت تصوراً معيناً بأنني بحاجة لإجراء ارتباط مع BE بجدول محدد ، لاجراء تعديل أو تنفيذ استعلام أو تقرير ما ، فقمت بتحليل الامر وتثبيت المتغيرات وخرجت بوحدة نمطية دعونا نسميها ModTableLink ، نقوم من خلالها باجراء عملية ربط مع BE معينة و مع جدول معين محدد Co ، كما احتسبت بالبال مسألة كلمة السر للجدول ، و حاجتي لتغيير اسم الجدول لأنني أتعامل مع وضع استثنائي افترض به انني أنبه نفسي و أذكرها بانني أتعامل مع جدول مرتبط فاضفت لاسم الجدول المرتبط في FE عبارة link_to . وللتنفيذ ننشيئ الوحدة النمطية الجديدة ونسخ البها : Public Function CreateTableLink(strBEPath, strSourceTableName, strPassword) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef Dim strConnect As String Dim strLinkName As String strLinkName = "link_to_" & strSourceTableName strConnect = "MS Access;PWD=" & strPassword & _ ";DATABASE=" & strBEPath Debug.Print strConnect Set db = CurrentDb Set tdf = db.CreateTableDef tdf.Connect = strConnect tdf.SourceTableName = strSourceTableName tdf.Name = strLinkName db.TableDefs.Append tdf Set tdf = Nothing Set db = Nothing End Function حيث نتعامل عند الاستدعاء مع المتغيرات الثلاثة الرئيسية : مسار القاعدة كاملاً ، واسم الجدول ، وكلمة السر حال وجودها ، واذا لم تكن موجودة نترك فراغاً بين حاصرتين "" . ونتعرف على الجزء BE واسم الجدول وكلمة السر ونقوم بإجراء الربط . أما الاستدعاء فيتم كمقترح ، خلف زر أمر إسمه cmdTableLink ، وبعنوان Table Link ونضع خلفه الكود التالي : Call CreateTableLink("H:\Manager\Operations09\Data09.mdb", "co", "") حيث يتم التعامل مع مسار قاعدة البيانات Data09 ثم الجدول Co وبدون كلمة سر ، ويتم الربط حسب هذه الضوابط و المتغيرات . وللحديث بقية .....

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