jjafferr

السلام عليكم الحقول: 1. الكمية2 ، وتأخذ قيمتها من المتبقي السابق ، وعند ادخال قيمة للمنصرف او الرجيع ، سترى ان قيمة الكمية2 تظهر تلقائيا ، 2. المستهلك2: وستحتسب تلقائيا من ، المنصرف السابق - الرجيع ، والا ، فانها ستكون صفر: جعفر 285.حساب الرجيع.mdb.zip

وعليكم السلام أخي عبدالله البرنامج الذي ارفقته انا في مشاركتي السابقة يقوم بنفس الفكرة ، وكذلك فكرة أخوي ابوخليل وابو عبدالله هذه الخطوة سهلة ، ولكن الصعوبة كانت في رسائل msgbox ، لأنها من الكود ، والكود يقوم على اساس ANSI وليس UTF8 مثل بقية كائنات الاكسس ، وهناك طريقتين لحل هذه المشكلة: 1. إما عمل نموذج بمسمى frm_MsgBox مثلا ، ونجعله يقوم بعمل Msgbox ، 2. وإما بإستعمال كود بديل والموجود في المرفق(وبصراحة تعبت الى ان حصلت عليه) جرب المرفق واخبرنا النتيجة جعفر

بالصورة ، ربطت الاسمين

حيا الله السيد ، منور

وعليكم السلام أخي الرسالة معناها ان اعدادات اللغة في جهازك لا تناسب العربية ، لذا استطيع ان افكر في حلين: 1. الرابط التالي ، فيه مرفق "المفروض ان" يعمل على جميع اعدادات الوندوز ، وفيه وحدة نمطية خاصة للرسائل: http://www.officena.net/ib/topic/67205-هل-من-حل-شافى-لمشكلة-اختلاف-اعدادات-اللغة-بالويندز-على-الأجهزة-المختلفة/?do=findComment&comment=437551 2. تغيير اعدادات لغة الكمبيوتر: http://www.officena.net/ib/topic/64955-مشكلة-عند-فتح-البرنامج-على-ويندوز-8/ جعفر

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

السلام عليكم في الواقع صار لي كم يوم اشتغل على هذا البرنامج ، والمفروض يشتغل وبدون رسائل خطأ ، فلوسمحت أخي عبدالله ، جربه على جميع الاصدارات وجميع اللغات ، واعطنا النتيجة جعفر MultiLanguage3.zip

السلام عليكم co2002co ان شاء الله مفهومي لشرحك صحيح ، لأنه كان جدا صعب عليّ واخذ وقت طويل !! تفضل: المرفق فيه نموذجين فقط Form1 و Form2 ، وتقوم الوحدة النمطية بإنتاج نسخ من Form2 كلما ضغطت على احد سجلات مربع القائمة: . هاي الوحدة النمطية المسؤلة عن انتاج نسخ من النموذج: Option Compare Database Option Explicit 'Author: Allen J Browne, July 2004 'Email: allen@allenbrowne.com Public clnClient As New Collection 'Instances of frmClient. Function OpenAClient() 'Purpose: Open an independent instance of form frmClient. Dim frm As Form 'Open a new instance, show it, and set a caption. Set frm = New Form_Form2 frm.Visible = True frm.Caption = frm.Hwnd & ", opened " & Now() 'Append it to our collection. clnClient.Add Item:=frm, Key:=CStr(frm.Hwnd) Set frm = Nothing End Function Function CloseAllClients() 'Purpose: Close all instances in the clnClient collection. 'Note: Leaves the copy opened directly from database window. Dim lngKt As Long Dim lngI As Long lngKt = clnClient.Count For lngI = 1 To lngKt clnClient.Remove 1 Next End Function . وهاي كود النموذج Form1: Private Sub TopicList_AfterUpdate() Call OpenAClient End Sub . وهاي كود النموذج Form2: Private Sub Form_Load() Me.Text1 = Forms.Form1.TopicList.Column(0) Me.Text2 = Forms.Form1.TopicList.Column(1) Me.Text3 = Forms.Form1.TopicList.Column(2) Me.Text4 = Forms.Form1.TopicList.Column(3) Me.Text5 = Forms.Form1.TopicList.Column(4) End Sub جعفر 284.db.mdb.zip

السلام عليكم أخي نبيل تفضل: . ولكن الكود لن يعمل اذا رقم اللغة لم يكن صحيحا في الكود وهذا هو الكود: Option Compare Database Private Declare Function ActivateKeyboardLayout Lib _ "user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long Private Const Ar = 5121 'Arabic United Arab Emirates keyboard language layout, Oman 8193 Private Const Fr = 1036 'Français(united states)keyboard language layout Private Const En = 1033 'US Private Sub cmd_Change_Language_Click() 'go back to the same field we were in, but to the end of it Dim ctl As Access.Control Set ctl = Screen.PreviousControl 'the last control we were on ctl.SetFocus 'set the focus back to it ctl.SelStart = Len(ctl.Text) 'go to the end of the field, so that we can continue writing If Me.cmd_Change_Language.Caption = "Arabic" Then Me.cmd_Change_Language.Caption = "French" Call ActivateKeyboardLayout(Ar, 0) ElseIf Me.cmd_Change_Language.Caption = "French" Then Me.cmd_Change_Language.Caption = "Arabic" Call ActivateKeyboardLayout(Fr, 0) End If End Sub Private Sub Form_Load() 'start with Arabic Call ActivateKeyboardLayout(Ar, 0) End Sub وهذا للقائمة المنسدلة Private Sub textlog_AfterUpdate() If Me.textlog.Value = "Arabic" Then Call ActivateKeyboardLayout(Ar, 0) ElseIf Me.textlog.Value = "French" Then Call ActivateKeyboardLayout(Fr, 0) End If End Sub . جعفر 283.Database changer.accdb.zip

تفضل الاستعلام qry_Sum_dorat يعمل المطلوب ، ونتائجه في اسفل النموذج: . جعفر 282.مشاركين في الدورات.accdb.zip

أخي عبدالرحمن ، وعلشان نكمل حيثما توقفت وبتعديل بسيط في الوحدة النمطية ، عملت لك التسلسل ، العليا والوسط والثالث . . وهذا هو الكود ، وبه التعديلات: Public Function fGetMaxNumber(ParamArray Values()) As Variant 'John Spencer UMBC CHPDM 'Last Update: April 5, 2000 'Returns the Maximum Number of a group of values passed to it. 'Sample call: myMax = GetMaxNumber("-21","TEST","2", "3",4,5,6,"7",0) 'returns 7 'Ignores values that cannot be treated as numbers. Dim I As Integer, vMax As Variant, tfFound As Boolean, dblCompare As Double '1 vMax = -1E+308 'very large negative number For I = LBound(Values) + 1 To UBound(Values) If IsNumeric(Values(I)) Then dblCompare = CDbl(Values(I)) If dblCompare > vMax Then vMax = dblCompare tfFound = True End If End If Next If tfFound Then A1 = vMax Else A1 = Null End If '2 vMax = -1E+308 'very large negative number For I = LBound(Values) + 1 To UBound(Values) If IsNumeric(Values(I)) And Val(Nz(Values(I), 0)) <> A1 Then dblCompare = CDbl(Values(I)) If dblCompare > vMax Then vMax = dblCompare tfFound = True End If End If Next If tfFound Then A2 = vMax Else A2 = Null End If '3 vMax = -1E+308 'very large negative number For I = LBound(Values) + 1 To UBound(Values) If IsNumeric(Values(I)) And Val(Nz(Values(I), 0)) <> A1 And Val(Nz(Values(I), 0)) <> A2 Then dblCompare = CDbl(Values(I)) If dblCompare > vMax Then vMax = dblCompare tfFound = True End If End If Next If tfFound Then A3 = vMax Else A3 = Null End If If Values(0) = 1 Then fGetMaxNumber = A1 ElseIf Values(0) = 2 Then fGetMaxNumber = A2 ElseIf Values(0) = 3 Then fGetMaxNumber = A3 End If End Function جعفر . أخي كرار حاولت النظر في برنامجك ، ولكن جدولك يختلف عن الجدول الاصل جعفر

حيا الله أخي مراد 1. ان شاء الله ، 2. انت تستطيع اختيار/اخفاء اي حقل ، من النموذج ، اضغط على مربع "اخفي" على يسار اسم الحقل ، 3. ايش رايك في هذه الطريقة لكل الحقول ، مع رأس وتذييل التقرير ، لون وحجم ونوع الخط ، وتنسيق يمين/يسار/وسط: http://www.officena.net/ib/topic/59818-اعمل-برنامجك-بعدة-لغات-وببساطة/?do=findComment&comment=383548 جعفر

السلام عليكم أخي co2002co ، احد الاسباب اللي انا ما شاركت في سؤالك هو عدم وضوحه لي كلما كان شرحك بتفصيل اكثر ، وخصوصا بمثال او مثالين من بيانات برنامجك ، يدعمه صور لشكل النتيجة فكل جزء يوضح الجز الاخر حينها ستجد الكثير من الشباب يهب لمساعدتك ان شاء الله جعفر

السلام عليكم أخوي فهد ممكن توضح المطلوب بالتفصيل ، ومرة واحدة (يعني مو بالتقسيط المريح ) ، وتعطينا مثال على الاجابة اللي تريدها ، وهذا المثال وارقامه يجب ان يكونوا من المرفق ، حتى نستطيع تتبع الخطوات المطلوبة جعفر

السلام عليكم عملت إضافة لكود الوحدة النمطية ، وكود الحقل Text4 في المشاركة السابقة لإستفادة اكبر واعم جعفر

انا الغيت قسم راس وقسم ذيل التقرير ، والباقي قسم التفصيل Detail Section (كما تلاحظه في الصورة) ، بهذه الطريقة ، تصبح البطاقة عبارة عن سجل واحد ، والسجلات الاخرى (البطاقات الاخرى) ، تأتي تحتها تلقائيا الى ان تملئ الصفحة ، وبدل ان اخلي الحقول في صف افقي واحد ، جعلت الحقل وتسميتهم جنب بعض ، ثم وزعت الحقول فوق وتحت حسب المطلوب ، ولأني استخدم ورقة A4 ، فاعتقد اني كنت اطبع 5 او 6 بطاقات في الورقة الواحدة جعفر

المطلوب التسلسل/الفرز تنازليا ، ومن ثم اخذ الارقام الثلاث الاولى ، وليس اكبر قيمة واصغر قيمة جعفر السر في هذا الكود ، وهو تحويل الحقول ، من افقيا ، الى عموديا ، Set rst = CurrentDb.OpenRecordset("Select * From [درجات] Where [Auto_ID]=" & Me.Auto_ID) ReDim InputArray(rst.Fields.Count - 1) 'make the array For ii = 1 To rst.Fields.Count - 1 'MsgBox rst(ii).Name & vbCrLf & rst(ii) InputArray(ii) = rst(ii) Next ii فلما تكون الحقول افقيا ، يجب ان تتعامل مع كل حقل بإسمه ، ولكن عندما تحولهم الى طريقة عمودية ، فيصبح عندك حقل واحد تتعامل معه جعفر

عفوا اخي مافهمت شو اللي تريده المعلومات الموجودة في التقرير عبارة عن سجل شخص واحد ، موزعة ومرتبة ، كحقول وتسميات ، ومافي شئ خاص جعفر

وعليكم السلام استعمل استعلام اجمالي ، واحسب Count فيه عدد تكرار الحقول ، واجعل الفرز تنازلي ، فتحصل على طلبك جعفر

حياك الله أخوي عبدالرحمن بس السؤال ، اي الطريقتين صح ، لأن الوسط والاصغر يملكان نفس القيمة ، ولكن اسم الحقل مختلف ، وطبعا السؤال كان في فرز الارقام وليس فرز اسماء الحقول جعفر

تفضل عملت لك طريقتين: الاولى باستخدام الجدول المؤقت tbl_Temp ، والطريقة الثانية عن طريق الكود ووحدة نمطية: . الجزء الاول من الكود لطريقة الجدول المؤقت ، والطريقة الثانية للكود: Function Sort_It() Dim rst As DAO.Recordset Dim rstT As DAO.Recordset 'clear tbl_Temp CurrentDb.Execute ("Delete * From tbl_Temp") 'DoCmd.RunSQL ("Delete * From tbl_Temp") Set rst = CurrentDb.OpenRecordset("Select * From [درجات] Where [Auto_ID]=" & Me.Auto_ID) Set rstT = CurrentDb.OpenRecordset("Select * From tbl_Temp") For ii = 1 To rst.Fields.Count - 1 'MsgBox rst(ii).Name & vbCrLf & rst(ii) rstT.AddNew rstT!iNumber = rst(ii) rstT!iField = rst(ii).Name rstT.Update Next ii 'DoCmd.OpenQuery "qry_Sort_it" Set rst = CurrentDb.OpenRecordset("Select * From tbl_Temp Order By iNumber Desc") rst.MoveLast: rst.MoveFirst Me.L1 = rst!iNumber & vbCrLf & rst!iField rst.MoveNext Me.L2 = rst!iNumber & vbCrLf & rst!iField rst.MoveNext Me.L3 = rst!iNumber & vbCrLf & rst!iField rst.Close: Set rst = Nothing rstT.Close: Set rstT = Nothing End Function Private Sub Form_Current() Call Sort_It Me.L11 = "" Me.L22 = "" Me.L33 = "" Call cmd_Sort_Click End Sub Private Sub cmd_Sort_Click() Dim rst As DAO.Recordset Dim InputArray() As Variant Set rst = CurrentDb.OpenRecordset("Select * From [درجات] Where [Auto_ID]=" & Me.Auto_ID) ReDim InputArray(rst.Fields.Count - 1) 'make the array For ii = 1 To rst.Fields.Count - 1 'MsgBox rst(ii).Name & vbCrLf & rst(ii) InputArray(ii) = rst(ii) Next ii 'call the sorting array Call QSortInPlace(InputArray, , , True) 'display the numbers For ii = 0 To rst.Fields.Count - 2 'then sorted numbers For jj = 0 To rst.Fields.Count - 2 'match the numbers, then display its field name If InputArray(ii) = rst(jj) Then 'MsgBox InputArray(ii) & vbCrLf & rst(jj).Name 'don't repeat the same field name If InStr(Me.L11, rst(jj).Name) > 0 Or InStr(Me.L22, rst(jj).Name) > 0 Then GoTo 2 If Len(Me.L11 & "") = 0 Then Me.L11 = InputArray(ii) & vbCrLf & rst(jj).Name ElseIf Len(Me.L22 & "") = 0 Then Me.L22 = InputArray(ii) & vbCrLf & rst(jj).Name ElseIf Len(Me.L33 & "") = 0 Then Me.L33 = InputArray(ii) & vbCrLf & rst(jj).Name End If End If 2: Next jj Next ii End Sub . واما الوحدة النمطية التي استخدمتها للفرز: Option Compare Database Public Function QSortInPlace( _ ByRef InputArray As Variant, _ Optional ByVal LB As Long = -1&, _ Optional ByVal UB As Long = -1&, _ Optional ByVal Descending As Boolean = False, _ Optional ByVal CompareMode As VbCompareMethod = vbTextCompare, _ Optional ByVal NoAlerts As Boolean = False) As Boolean ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' QSortInPlace ' ' This function sorts the array InputArray in place -- this is, the original array in the ' calling procedure is sorted. It will work with either string data or numeric data. ' It need not sort the entire array. You can sort only part of the array by setting the LB and ' UB parameters to the first (LB) and last (UB) element indexes that you want to sort. ' LB and UB are optional parameters. If omitted LB is set to the LBound of InputArray, and if ' omitted UB is set to the UBound of the InputArray. If you want to sort the entire array, ' omit the LB and UB parameters, or set both to -1, or set LB = LBound(InputArray) and set ' UB to UBound(InputArray). ' ' By default, the sort method is case INSENSTIVE (case doens't matter: "A", "b", "C", "d"). ' To make it case SENSITIVE (case matters: "A" "C" "b" "d"), set the CompareMode argument ' to vbBinaryCompare (=0). If Compare mode is omitted or is any value other than vbBinaryCompare, ' it is assumed to be vbTextCompare and the sorting is done case INSENSITIVE. ' ' The function returns TRUE if the array was successfully sorted or FALSE if an error ' occurred. If an error occurs (e.g., LB > UB), a message box indicating the error is ' displayed. To suppress message boxes, set the NoAlerts parameter to TRUE. ' '''''''''''''''''''''''''''''''''''''' ' MODIFYING THIS CODE: '''''''''''''''''''''''''''''''''''''' ' If you modify this code and you call "Exit Procedure", you MUST decrment the RecursionLevel ' variable. E.g., ' If SomethingThatCausesAnExit Then ' RecursionLevel = RecursionLevel - 1 ' Exit Function ' End If ''''''''''''''''''''''''''''''''''''''' ' ' Note: If you coerce InputArray to a ByVal argument, QSortInPlace will not be ' able to reference the InputArray in the calling procedure and the array will ' not be sorted. ' ' This function uses the following procedures. These are declared as Private procedures ' at the end of this module: ' IsArrayAllocated ' IsSimpleDataType ' IsSimpleNumericType ' QSortCompare ' NumberOfArrayDimensions ' ReverseArrayInPlace ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Temp As Variant Dim Buffer As Variant Dim CurLow As Long Dim CurHigh As Long Dim CurMidpoint As Long Dim Ndx As Long Dim pCompareMode As VbCompareMethod ''''''''''''''''''''''''' ' Set the default result. ''''''''''''''''''''''''' QSortInPlace = False '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' This variable is used to determine the level ' of recursion (the function calling itself). ' RecursionLevel is incremented when this procedure ' is called, either initially by a calling procedure ' or recursively by itself. The variable is decremented ' when the procedure exits. We do the input parameter ' validation only when RecursionLevel is 1 (when ' the function is called by another function, not ' when it is called recursively). '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Static RecursionLevel As Long '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Keep track of the recursion level -- that is, how many ' times the procedure has called itself. ' Carry out the validation routines only when this ' procedure is first called. Don't run the ' validations on a recursive call to the ' procedure. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' RecursionLevel = RecursionLevel + 1 If RecursionLevel = 1 Then '''''''''''''''''''''''''''''''''' ' Ensure InputArray is an array. '''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If ''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' InputArray is not an array. Exit with a False result. ''''''''''''''''''''''''''''''''''''''''''''''''''''''' RecursionLevel = RecursionLevel - 1 Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Test LB and UB. If < 0 then set to LBound and UBound ' of the InputArray. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If LB < 0 Then LB = LBound(InputArray) End If If UB < 0 Then UB = UBound(InputArray) End If Select Case NumberOfArrayDimensions(InputArray) Case 0 '''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. '''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The InputArray is an empty, unallocated array." End If RecursionLevel = RecursionLevel - 1 Exit Function Case 1 '''''''''''''''''''''''''''''''''''''''''' ' We sort ONLY single dimensional arrays. '''''''''''''''''''''''''''''''''''''''''' Case Else '''''''''''''''''''''''''''''''''''''''''' ' We sort ONLY single dimensional arrays. '''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The InputArray is multi-dimensional." & _ "QSortInPlace works only on single-dimensional arrays." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that InputArray is an array of simple data ' types, not other arrays or objects. This tests ' the data type of only the first element of ' InputArray. If InputArray is an array of Variants, ' subsequent data types may not be simple data types ' (e.g., they may be objects or other arrays), and ' this may cause QSortInPlace to fail on the StrComp ' operation. ''''''''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "InputArray is not an array of simple data types." RecursionLevel = RecursionLevel - 1 Exit Function End If End If '''''''''''''''''''''''''''''''''''''''''''''''''''' ' ensure that the LB parameter is valid. '''''''''''''''''''''''''''''''''''''''''''''''''''' Select Case LB Case Is < LBound(InputArray) If NoAlerts = False Then MsgBox "The LB lower bound parameter is less than the LBound of the InputArray" End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is > UBound(InputArray) If NoAlerts = False Then MsgBox "The LB lower bound parameter is greater than the UBound of the InputArray" End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is > UB If NoAlerts = False Then MsgBox "The LB lower bound parameter is greater than the UB upper bound parameter." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select '''''''''''''''''''''''''''''''''''''''''''''''''''' ' ensure the UB parameter is valid. '''''''''''''''''''''''''''''''''''''''''''''''''''' Select Case UB Case Is > UBound(InputArray) If NoAlerts = False Then MsgBox "The UB upper bound parameter is greater than the upper bound of the InputArray." End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is < LBound(InputArray) If NoAlerts = False Then MsgBox "The UB upper bound parameter is less than the lower bound of the InputArray." End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is < LB If NoAlerts = False Then MsgBox "the UB upper bound parameter is less than the LB lower bound parameter." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select '''''''''''''''''''''''''''''''''''''''''''''''''''''' ' if UB = LB, we have nothing to sort, so get out. '''''''''''''''''''''''''''''''''''''''''''''''''''''' If UB = LB Then QSortInPlace = True RecursionLevel = RecursionLevel - 1 Exit Function End If End If ' RecursionLevel = 1 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that CompareMode is either vbBinaryCompare or ' vbTextCompare. If it is neither, default to vbTextCompare. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If (CompareMode = vbBinaryCompare) Or (CompareMode = vbTextCompare) Then pCompareMode = CompareMode Else pCompareMode = vbTextCompare End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Begin the actual sorting process. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' CurLow = LB CurHigh = UB If LB = 0 Then CurMidpoint = ((LB + UB) \ 2) + 1 Else CurMidpoint = (LB + UB) \ 2 ' note integer division (\) here End If Temp = InputArray(CurMidpoint) Do While (CurLow <= CurHigh) Do While QSortCompare(V1:=InputArray(CurLow), V2:=Temp, CompareMode:=pCompareMode) < 0 CurLow = CurLow + 1 If CurLow = UB Then Exit Do End If Loop Do While QSortCompare(V1:=Temp, V2:=InputArray(CurHigh), CompareMode:=pCompareMode) < 0 CurHigh = CurHigh - 1 If CurHigh = LB Then Exit Do End If Loop If (CurLow <= CurHigh) Then Buffer = InputArray(CurLow) InputArray(CurLow) = InputArray(CurHigh) InputArray(CurHigh) = Buffer CurLow = CurLow + 1 CurHigh = CurHigh - 1 End If Loop If LB < CurHigh Then QSortInPlace InputArray:=InputArray, LB:=LB, UB:=CurHigh, _ Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True End If If CurLow < UB Then QSortInPlace InputArray:=InputArray, LB:=CurLow, UB:=UB, _ Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True End If ''''''''''''''''''''''''''''''''''''' ' If Descending is True, reverse the ' order of the array, but only if the ' recursion level is 1. ''''''''''''''''''''''''''''''''''''' If Descending = True Then If RecursionLevel = 1 Then ReverseArrayInPlace2 InputArray, LB, UB End If End If RecursionLevel = RecursionLevel - 1 QSortInPlace = True End Function Public Function QSortCompare(V1 As Variant, V2 As Variant, _ Optional CompareMode As VbCompareMethod = vbTextCompare) As Long ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' QSortCompare ' This function is used in QSortInPlace to compare two elements. If ' V1 AND V2 are both numeric data types (integer, long, single, double) ' they are converted to Doubles and compared. If V1 and V2 are BOTH strings ' that contain numeric data, they are converted to Doubles and compared. ' If either V1 or V2 is a string and does NOT contain numeric data, both ' V1 and V2 are converted to Strings and compared with StrComp. ' ' The result is -1 if V1 < V2, ' 0 if V1 = V2 ' 1 if V1 > V2 ' For text comparisons, case sensitivity is controlled by CompareMode. ' If this is vbBinaryCompare, the result is case SENSITIVE. If this ' is omitted or any other value, the result is case INSENSITIVE. ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim D1 As Double Dim D2 As Double Dim S1 As String Dim S2 As String Dim Compare As VbCompareMethod '''''''''''''''''''''''''''''''''''''''''''''''' ' Test CompareMode. Any value other than ' vbBinaryCompare will default to vbTextCompare. '''''''''''''''''''''''''''''''''''''''''''''''' If CompareMode = vbBinaryCompare Or CompareMode = vbTextCompare Then Compare = CompareMode Else Compare = vbTextCompare End If ''''''''''''''''''''''''''''''''''''''''''''''' ' If either V1 or V2 is either an array or ' an Object, raise a error 13 - Type Mismatch. ''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(V1) = True Or IsArray(V2) = True Then Err.Raise 13 Exit Function End If If IsObject(V1) = True Or IsObject(V2) = True Then Err.Raise 13 Exit Function End If If IsSimpleNumericType(V1) = True Then If IsSimpleNumericType(V2) = True Then ''''''''''''''''''''''''''''''''''''' ' If BOTH V1 and V2 are numeric data ' types, then convert to Doubles and ' do an arithmetic compare and ' return the result. ''''''''''''''''''''''''''''''''''''' D1 = CDbl(V1) D2 = CDbl(V2) If D1 = D2 Then QSortCompare = 0 Exit Function End If If D1 < D2 Then QSortCompare = -1 Exit Function End If If D1 > D2 Then QSortCompare = 1 Exit Function End If End If End If '''''''''''''''''''''''''''''''''''''''''''' ' Either V1 or V2 was not numeric data type. ' Test whether BOTH V1 AND V2 are numeric ' strings. If BOTH are numeric, convert to ' Doubles and do a arithmetic comparison. '''''''''''''''''''''''''''''''''''''''''''' If IsNumeric(V1) = True And IsNumeric(V2) = True Then D1 = CDbl(V1) D2 = CDbl(V2) If D1 = D2 Then QSortCompare = 0 Exit Function End If If D1 < D2 Then QSortCompare = -1 Exit Function End If If D1 > D2 Then QSortCompare = 1 Exit Function End If End If '''''''''''''''''''''''''''''''''''''''''''''' ' Either or both V1 and V2 was not numeric ' string. In this case, convert to Strings ' and use StrComp to compare. '''''''''''''''''''''''''''''''''''''''''''''' S1 = CStr(V1) S2 = CStr(V2) QSortCompare = StrComp(S1, S2, Compare) End Function Public Function NumberOfArrayDimensions(Arr As Variant) As Integer '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' NumberOfArrayDimensions ' This function returns the number of dimensions of an array. An unallocated dynamic array ' has 0 dimensions. This condition can also be tested with IsArrayEmpty. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Ndx As Integer Dim Res As Integer On Error Resume Next ' Loop, increasing the dimension index Ndx, until an error occurs. ' An error will occur when Ndx exceeds the number of dimension ' in the array. Return Ndx - 1. Do Ndx = Ndx + 1 Res = UBound(Arr, Ndx) Loop Until Err.Number <> 0 NumberOfArrayDimensions = Ndx - 1 End Function Public Function ReverseArrayInPlace(InputArray As Variant, _ Optional NoAlerts As Boolean = False) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ReverseArrayInPlace ' This procedure reverses the order of an array in place -- this is, the array variable ' in the calling procedure is sorted. An error will occur if InputArray is not an array, 'if it is an empty, unallocated array, or if the number of dimensions is not 1. ' ' NOTE: Before calling the ReverseArrayInPlace procedure, consider if your needs can ' be met by simply reading the existing array in reverse order (Step -1). If so, you can save ' the overhead added to your application by calling this function. ' ' The function returns TRUE if the array was successfully reversed, or FALSE if ' an error occurred. ' ' If an error occurred, a message box is displayed indicating the error. To suppress ' the message box and simply return FALSE, set the NoAlerts parameter to TRUE. ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Temp As Variant Dim Ndx As Long Dim Ndx2 As Long Dim OrigN As Long Dim NewN As Long Dim NewArr() As Variant '''''''''''''''''''''''''''''''' ' Set the default return value. '''''''''''''''''''''''''''''''' ReverseArrayInPlace = False ''''''''''''''''''''''''''''''''' ' Ensure we have an array ''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If Exit Function End If '''''''''''''''''''''''''''''''''''''' ' Test the number of dimensions of the ' InputArray. If 0, we have an empty, ' unallocated array. Get out with ' an error message. If greater than ' one, we have a multi-dimensional ' array, which is not allowed. Only ' an allocated 1-dimensional array is ' allowed. '''''''''''''''''''''''''''''''''''''' Select Case NumberOfArrayDimensions(InputArray) Case 0 ''''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array is an empty, unallocated array." End If Exit Function Case 1 ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' Case Else ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _ "on single-dimensional arrays." End If Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that we have only simple data types, ' not an array of objects or arrays. ''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _ "ReverseArrayInPlace can reverse only arrays of simple data types." Exit Function End If End If ReDim NewArr(LBound(InputArray) To UBound(InputArray)) NewN = UBound(NewArr) For OrigN = LBound(InputArray) To UBound(InputArray) NewArr(NewN) = InputArray(OrigN) NewN = NewN - 1 Next OrigN For NewN = LBound(NewArr) To UBound(NewArr) InputArray(NewN) = NewArr(NewN) Next NewN ReverseArrayInPlace = True End Function Public Function ReverseArrayInPlace2(InputArray As Variant, _ Optional LB As Long = -1, Optional UB As Long = -1, _ Optional NoAlerts As Boolean = False) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ReverseArrayInPlace2 ' This reverses the order of elements in InputArray. To reverse the entire array, omit or ' set to less than 0 the LB and UB parameters. To reverse only part of tbe array, set LB and/or ' UB to the LBound and UBound of the sub array to be reversed. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim N As Long Dim Temp As Variant Dim Ndx As Long Dim Ndx2 As Long Dim OrigN As Long Dim NewN As Long Dim NewArr() As Variant '''''''''''''''''''''''''''''''' ' Set the default return value. '''''''''''''''''''''''''''''''' ReverseArrayInPlace2 = False ''''''''''''''''''''''''''''''''' ' Ensure we have an array ''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If Exit Function End If '''''''''''''''''''''''''''''''''''''' ' Test the number of dimensions of the ' InputArray. If 0, we have an empty, ' unallocated array. Get out with ' an error message. If greater than ' one, we have a multi-dimensional ' array, which is not allowed. Only ' an allocated 1-dimensional array is ' allowed. '''''''''''''''''''''''''''''''''''''' Select Case NumberOfArrayDimensions(InputArray) Case 0 ''''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array is an empty, unallocated array." End If Exit Function Case 1 ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' Case Else ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _ "on single-dimensional arrays." End If Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that we have only simple data types, ' not an array of objects or arrays. ''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _ "ReverseArrayInPlace can reverse only arrays of simple data types." Exit Function End If End If If LB < 0 Then LB = LBound(InputArray) End If If UB < 0 Then UB = UBound(InputArray) End If For N = LB To (LB + ((UB - LB - 1) \ 2)) Temp = InputArray(N) InputArray(N) = InputArray(UB - (N - LB)) InputArray(UB - (N - LB)) = Temp Next N ReverseArrayInPlace2 = True End Function Public Function IsSimpleNumericType(V As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsSimpleNumericType ' This returns TRUE if V is one of the following data types: ' vbBoolean ' vbByte ' vbCurrency ' vbDate ' vbDecimal ' vbDouble ' vbInteger ' vbLong ' vbSingle ' vbVariant if it contains a numeric value ' It returns FALSE for any other data type, including any array ' or vbEmpty. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(V) = True Then Select Case VarType(V) Case vbBoolean, _ vbByte, _ vbCurrency, _ vbDate, _ vbDecimal, _ vbDouble, _ vbInteger, _ vbLong, _ vbSingle IsSimpleNumericType = True Case vbVariant If IsNumeric(V) = True Then IsSimpleNumericType = True Else IsSimpleNumericType = False End If Case Else IsSimpleNumericType = False End Select Else IsSimpleNumericType = False End If End Function Public Function IsSimpleDataType(V As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsSimpleDataType ' This function returns TRUE if V is one of the following ' variable types (as returned by the VarType function: ' vbBoolean ' vbByte ' vbCurrency ' vbDate ' vbDecimal ' vbDouble ' vbEmpty ' vbError ' vbInteger ' vbLong ' vbNull ' vbSingle ' vbString ' vbVariant ' ' It returns FALSE if V is any one of the following variable ' types: ' vbArray ' vbDataObject ' vbObject ' vbUserDefinedType ' or if it is an array of any type. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Test if V is an array. We can't just use VarType(V) = vbArray ' because the VarType of an array is vbArray + VarType(type ' of array element). E.g, the VarType of an Array of Longs is ' 8195 = vbArray + vbLong. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(V) = True Then IsSimpleDataType = False Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' We must also explicitly check whether V is an object, rather ' relying on VarType(V) to equal vbObject. The reason is that ' if V is an object and that object has a default proprety, VarType ' returns the data type of the default property. For example, if ' V is an Excel.Range object pointing to cell A1, and A1 contains ' 12345, VarType(V) would return vbDouble, the since Value is ' the default property of an Excel.Range object and the default ' numeric type of Value in Excel is Double. Thus, in order to ' prevent this type of behavior with default properties, we test ' IsObject(V) to see if V is an object. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsObject(V) = True Then IsSimpleDataType = False Exit Function End If ''''''''''''''''''''''''''''''''''''' ' Test the value returned by VarType. ''''''''''''''''''''''''''''''''''''' Select Case VarType(V) Case vbArray, vbDataObject, vbObject, vbUserDefinedType ''''''''''''''''''''''' ' not simple data types ''''''''''''''''''''''' IsSimpleDataType = False Case Else '''''''''''''''''''''''''''''''''''' ' otherwise it is a simple data type '''''''''''''''''''''''''''''''''''' IsSimpleDataType = True End Select End Function Public Function IsArrayAllocated(Arr As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsArrayAllocated ' Returns TRUE if the array is allocated (either a static array or a dynamic array that has been ' sized with Redim) or FALSE if the array has not been allocated (a dynamic that has not yet ' been sized with Redim, or a dynamic array that has been Erased). '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim N As Long ''''''''''''''''''''''''''''''''''''''''''''''''''' ' If Arr is not an array, return FALSE and get out. ''''''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(Arr) = False Then IsArrayAllocated = False Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Try to get the UBound of the array. If the array has not been allocated, ' an error will occur. Test Err.Number to see if an error occured. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next N = UBound(Arr, 1) If Err.Number = 0 Then ''''''''''''''''''''''''''''''''''''' ' No error. Array has been allocated. ''''''''''''''''''''''''''''''''''''' IsArrayAllocated = True Else ''''''''''''''''''''''''''''''''''''' ' Error. Unallocated array. ''''''''''''''''''''''''''''''''''''' IsArrayAllocated = False End If End Function جعفر 281.1جديد.mdb.zip