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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي قم بافراغ اليوزرفورم من جميع الاكواد واستبدالها بالاكواد التالية Private Sub TextBox1_Change() If Me.TextBox1.Text = "" Then Me.ListBox1.Visible = False For I = 2 To 5 Controls("textbox" & I).Text = "" Next I Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet1 lrw = W.Cells(Rows.Count, 1).End(xlUp).Row l = 0 For Each c In Range("A3:A" & lrw) If c Like TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 1).Value l = l + 1 End If Next c End If End Sub Private Sub ListBox1_Click() Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet1 lrw = sh1.Cells(Rows.Count, 1).End(xlUp).Row Set f = sh1.Range("A3:A" & lrw).Find(ListBox1.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("A" & f.Row).Value TextBox2.Value = sh1.Range("B" & f.Row).Value TextBox3.Value = sh1.Range("C" & f.Row).Value TextBox4.Value = sh1.Range("d" & f.Row).Value TextBox5.Value = sh1.Range("E" & f.Row).Value End If Me.ListBox1.Visible = False End Sub Private Sub UserForm_Initialize() Me.TextBox1.SetFocus End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" End If End Sub سؤال مهم فى البحث للبرمجة officena 2024_2.xlsm

وهذا حل اخر ولكن باستخدام VBA لعمل المطلوب كما تريده وبشكل افضل وتلوين كود الصنف الجديد فى العمود 2 واظهار الاصناف الجديدة فى العمود 3 معا بدون خلايا فارغة استخراج اكواد الاصناف الجديدة وتلوينها VBA .xlsm

السلام عليكم ورحمة الله وبركاته هذا الموضوع اُثير اكثر من مرة في الآونة الاخيرة ، ورأيت من الافضل ان اضع مثال ليقتدي به الجميع وقبل ان نبدأ ، اود ان اشير الى انني اعمل على اكسس 32 بت ، ولا املك نسخة من اكسس 64 بت احب ان اشير الى الرابط الذي شرحت فيه ان مايكروسوفت توصي بتنصيب الاوفيس / اكسس 32 بت ، بغض النظر عن نوع الوندوز المنصّب على الكمبيوتر ، سواء كان 32 بت او 64 بت: http://www.officena.net/ib/topic/64036-هل-استخدم-اوفيس-32-بت-او-64-بت/ ولكن ، ماذا نفعل اذا عملنا برنامجنا على اكسس 32 بت ، واتضح ان الزبون عنده جهاز فيه اكسس 64 بت المثال التالي يشتغل على 32 بت و 64 بت ، ونستطيع ان نستفيد منه لعمل برنامجنا البرنامج المرفق ، بعد فك الضغط ، سيحتوي على 3 برامج: . هذا برنامج No_Password_BE.accdb ، وبه جدول واحد ، ولا يحتاج الى كلمة سر لفتحه: . هذا برنامج Password_is_jj_BE.accdb ، وبه جدول واحد ، وكلمة السر لفتحه هي jj: . البرنامج: JStreetAccessRelinker2.accdb من الرابط http://www.jstreettech.com/downloads.aspx ، وبه ماكرو ووحدات نمطية تعمل على 32 بت و 64 بت (فالفضل في هذا المثال يعود للبرنامج وليس لي ) ، وقد قمت بإضافة نموذج لربطه مع احد برنامج الجداول اعلاه ، ومبدئيا فهو مرتبط مع البرنامج No_Password_BE.accdb ، . وعند فتح البرنامج لأول مرة ، سوف يفتح نافذة تطلب معرفة مكان برنامج الجداول No_Password_BE.accdb ، وتستطيع ان تنقر على الزر Link Another BE ، وستفتح لك نافذة تطلب منك معرفة مكان برنامج الجداول الجديد الذي تريد ان تربطه (بدل البرنامج No_Password_BE.accdb) : . وبما ان البرنامج هذا محمي بكلمة سر ، فسوف تظهر لك نافذة لإدخال كلمة السر (لاحظ ان الادخال مشفر) : . وعندما يتم الربط ، سترى رسالة التاكيد: . الرجاء من الشباب الذين لديهم نسخة من الاكسس 64 بت ، التاكد من ان البرنامج يشتغل على كمبيوترهم بدون اخطاء. عندما نريد ان نعمل برنامج يشتغل على النسختين 32 و 64 بت ، فكود النماذج هو نفسه بين نسختي 32 بت و 64 بت ، والشئ الوحيد الذي يتغير هو دوال الوحدات النمطية API ، والكود الذي ينادي هذه الوحدات (بغض النظر سواء كان في نموذج او في وحدة نمطية مستقلة) ، هنا سوف اعطي مثال واحد من الكود عن طريقة العمل للنسختين 32 و 64 بت: الكود التالي يستعمل دالة API فتح نافذة اختيار ملف ، والدالة هي 32 بت (لاحظ comdlg32.dll ) : Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long الان اذا اردنا ان نجعل هذه الداله API تعمل على 64 بت كذلك ، فالكود يجب ان يكون: #If VBA7 Then 'هذه لنسخة 64 بت Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean #Else 'وهذه لنسخة 32 بت Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long #End If ولاحظ في كود البرنامج ، انه تم جمع جميع الدوال مع بعض ، وجمعها في if# و else# و end if# واحدة. وهناك اصدار جديد لكود الربط ، ويمكن انزاله من هنا: http://www.jstreettech.com/files/JStreetAccessRelinker2.zip جعفر 238.Work_on_32Bits_and_64Bits.zip

في النموذج الرئيسي ...عند التحميل Private Sub Form_Load() If Now() - 10 > CDate("8/9/2023") Then MsgBox "انتهت الفترة التجريبية!" DoCmd.Close acForm, Me.Name, acSaveNo End If End Sub تستطيع تغيير ال 10 ايام الى اي مدة ...وتغيير التاريخ طبعا

طريقتين : 1- اخفاء شبكة الاستعلامات بالكود البرمجي .. موجودة في المنتدى ابحث عنها 2- تحويل الاستعلام الى جملة سكوال .. والتعامل معه على هذا الأساس

هل جربت حفظ المشروع بصيغة ACCDE ؟

وعليكم السلام جرب الملف سؤال مهم فى البحث 33.xlsm

هذه محاولة مني ضع هذه المعادلة في L5 =IFERROR(INDEX($I$5:$I$272,MATCH(0,IFERROR(MATCH($I$5:$I$272,$D$5:$D$1370,0),COUNTIF($L$4:$L4,$I$5:$I$272)),0)),"") واتسخ لأسفل 100 صف فقط حتى لا تبطئ الملف وإذا كان الأوفيس قديم نسبيا يجب الضغط على كنترول وشيفت وانتر بالتوفيق

تفضل اخى جرب الملف والمعادلة مع مراجعة النتائج للتأكد اما بالنسبة لتلوين الاكود الجديد فى العمود 2 يمكنك استخدام (Conditional Formatting) حذف متكرر ونلوينه.xlsx

ممكن تستعمل for ..... next لكن في كل مرة ستفتح نافذة جديدة في المتصفح

وعليكم السلام ورحمة الله وبركاته بعيدا عن التعقيد وتكرار البيانات عملت لك فلتر في ورقة البيانات وبعد تعديل البيانات تضغط زر حفظ التعديل فيلتغي الفلتر وبالتالي النتيجة واحدة أرجو أن يؤدي المطلوب هذي كل الأكواد Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B1")) Is Nothing Then Range("A2:APL2").AutoFilter Field:=21, Criteria1:=Range("B1") End If End Sub Sub e() Range("A2:APL2").AutoFilter Field:=21 End Sub نسخ البيانات - الى الرئيسية .xlsb

هذا هو المطلوب بارك الله فيك استاذى الكريم

جرب المرفق بعد اذنك اخي محمد البرناوي <><><><><><><><><> ForTest.accdb

نعم ممكن

السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb

3- استخلاص قيم من مكونات الجهاز تستخدم فى عملية الترخيص - رقم الـ UUID رقم ثابت لا يتغير بتغيير الهارد ديسك او ختى بعملية الفورمات أو إعادة التقسيم للهارد ديسك - Public Function GetUUID(Optional strHost As String = ".") As String On Error GoTo ErrorHandler Dim objComputerSystemProduct As Object Dim objWMIService As Object Dim objItems As Object Dim objDiskDriveSerial As Object Set objWMIService = GetObject("winmgmts:\\" & strHost & "\root\cimv2") Set objComputerSystemProduct = objWMIService.ExecQuery("Select * from Win32_ComputerSystemProduct", , 48) For Each objItems In objComputerSystemProduct GetUUID = objItems.UUID Next Set objItems = Nothing Set objWMIService = Nothing Set objComputerSystemProduct = Nothing ExitHandler: On Error Resume Next If Not objItems Is Nothing Then Set objItems = Nothing If Not objDiskDriveSerial Is Nothing Then Set objDiskDriveSerial = Nothing If Not objWMIService Is Nothing Then Set objWMIService = Nothing Exit Function ErrorHandler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: GetUUID" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occurred!" Resume ExitHandler End Function - ويتم استدعاءه فقط من خلال GetUUID() - رقم وموديل الهارد ديسك ثابت ولا يتغير Public Function GetDDSerialNumber(Optional strHost As String = ".", Optional strSymbol As String = ",") As String On Error GoTo ErrorHandler Dim objComputerSystemProduct As Object Dim objWMIService As Object Dim objItems As Object Dim objDiskDriveSerial As Object Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strHost & "\root\cimv2") Set objDiskDriveSerial = objWMIService.ExecQuery("SELECT DeviceID, SerialNumber FROM Win32_DiskDrive") For Each objItems In objDiskDriveSerial GetDDSerialNumber = Trim(GetDDSerialNumber) & Trim(objItems.SerialNumber & strSymbol) Next If Right(GetDDSerialNumber, 1) = strSymbol Then GetDDSerialNumber = Left(GetDDSerialNumber, Len(GetDDSerialNumber) - 1) Set objItems = Nothing Set objWMIService = Nothing Set objDiskDriveSerial = Nothing ExitHandler: On Error Resume Next If Not objItems Is Nothing Then Set objItems = Nothing If Not objDiskDriveSerial Is Nothing Then Set objDiskDriveSerial = Nothing If Not objWMIService Is Nothing Then Set objWMIService = Nothing Exit Function ErrorHandler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: GetDDSerialNumber" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occurred!" Resume ExitHandler End Function -ويتم فقط استدعاءه من خلال GetDDSerialNumber() التطبيق فى القاعدة المرفقة .. يتبع ... 3- ارقام القطع UUID - HDD.accdb

2-تشفير البيانات نستخدم الأكواد الاتية فى وحدة نمطيه Function incode(A As String, b As String) As String Dim r, i As Integer, s, u As String 1: u = "" s = ctrs(A, 3) If Len(s) Mod 2 = 1 Then s = s + Trim(Str(Int(8 * Rnd(-Timer)))) i = 3 * Rnd(-Timer) + 1 For r = 1 To i u = Chr(100 * Rnd(-Timer) + 155) + u Next u = Trim(Str(i)) + u u = u + s u = getcode(u, b) If decode(u, b) = A Then incode = u Else GoTo 1: End If End Function Function decode(A, b As String) As String On Error Resume Next Dim r, i As Integer, s, u As String u = getcode(A, b) i = Val(Mid(u, 1, 1)) + 1 u = Mid(u, i + 1, Len(u) - i) If Len(u) Mod 3 <> 0 Then u = Mid(u, 1, Len(u) - 1) s = "" For r = 1 To Len(u) - 2 Step 3 s = s + Chr(Val(Mid(u, r, 3))) Next decode = s End Function Function getcode(A, b As String) As String On Error Resume Next Dim L, r As Integer, c As Long, q As String c = 0 For r = 1 To Len(b) c = c + Asc(Mid(b, r, 1)) * (10 ^ r) Next q = Str(c) c = 0 For r = 1 To Len(q) c = c + Val(Mid(q, r, 1)) Next q = "" For r = 1 To Len(A) L = 256 - Asc(Mid(A, r, 1)) - r - Len(A) If L + c > 255 Then q = q + Chr(L - c) Else q = q + Chr(L + c) End If Next getcode = q End Function Function ctrs(s As String, y As Byte) As String Dim r, i As Integer, u, T As String u = "" For r = 1 To Len(s) T = Trim(Str(Asc(Mid(s, r, 1)))) For i = 1 To y - Len(T) T = "0" + T Next i u = u + T Next ctrs = u End Function التطبيق فى القاعدة المرفقة .. يتبع ... 02-Encode Decode.accdb

نسخة تجريبية للعميل _ تشفير لوقت محدد السلام عليكم اخوتي الكرام : احببت ان افرد العمل بعنوان مستقل ليكون قريبا للباحث وكنت وعدت بطرح مثالي المفتوح في موضوع سابق هنا وعندما راجعت مثالي بعد انقضاء الفترة تبين لي وجود ثغرات ، فقمت باصلاح الخلل وتجربة المثال اكثر من مرة للتأكد من عمل الأكواد على اكمل وجه . الفكرة : تحديد تاريخين من قبل المبرمج يتم تشفيرهما ، ولن يعمل البرنامج الا بين هذين التاريخين فقط بهذه الطريقة اغلقنا الطريق على من يحاول تغيير تاريخ الجهاز بعد انقضاء فترة التجربة والاتفاق على شراء البرنامج يتم ارسال نسخة دائمة الى العميل . يجب تقسيم قاعدة البيانات الى واجهات وجداول من اجل الحفاظ على بيانات العميل التي تم ادخالها خلال التجربة . ختاما ؛ اليكم الاكواد الخاصة مع المرفق دعواتكم ،،، Function EncryptDecrypt(strIn As String, strPass As String) As String Dim intLen As Integer Dim intCounter As Integer Dim varTmp As Variant Dim strTmp As String intLen = Len(strPass) strTmp = strIn For intCounter = 1 To Len(strIn) varTmp = Asc(Mid$(strPass, (intCounter Mod intLen) - intLen * ((intCounter Mod intLen) = 0), 1)) Mid$(strTmp, intCounter, 1) = Chr$(Asc(Mid$(strIn, intCounter, 1)) Xor varTmp) Next EncryptDecrypt = strTmp End Function Private Sub cmd1_Click() 'لإدراج التاريخ في الحقلين ثم تعديل الحقول يدويا حسب الفترة المطلوبة ' يستخدم مرة واحدة قبل التشفير Me.regEnd = Now() Me.regStart = Now() Me.Requery End Sub Private Sub cmd2_Click() ' تشفير الحقلين ولاحظ ان الزر يشفر ويفك التشفير في نفس الوقت Dim strPassword As String strPassword = "EnDecryptAccessOfficna" Me.regStart = EncryptDecrypt(Me.regStart, strPassword) Me.regEnd = EncryptDecrypt(Me.regEnd, strPassword) End Sub Private Sub Form_Current() On Error Resume Next Dim strRegStart, strRegEnd, vNowv As Date Dim strPassword As String vNowv = Now() strPassword = "EnDecryptAccessOfficna" strRegStart = EncryptDecrypt(Me.regStart, strPassword) strRegEnd = EncryptDecrypt(Me.regEnd, strPassword) 'عند العبث بالشفرة في اي من الحقلين If Not IsDate(strRegEnd) Or Not IsDate(strRegStart) Then MsgBox "تم التلاعب بالشفرة .. سيتم اغلاق البرنامج" DoCmd.Quit End If ' عند نهاية الفترة If vNowv > strRegEnd Then MsgBox "انتهت الفترة التجريبية .. تواصل مع المبرمج " DoCmd.Quit End If ' عند تغيير تاريخ الكمبيوتر لان النسخة المؤقتة ستعمل فقط بين التاريخين المرصودين If vNowv <= strRegStart Then MsgBox "تم تغيير تاريخ الجهاز .. سيتم غلق البرنامج " DoCmd.Quit End If End Sub تشفير.rar

خيركم من تعلم القران وعلمه ارجو الانتباه

ما اروع الأشخاص الذين يعتقدون أن كل شيء ممكن هم القادرون على الاكتشاف والابداع

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

بعد اذن استاذنا الفاضل والقدير الاستاذ ضاحى ورغبة استاذى gamalin وطلبه للملف استاذن من الاستاذ ضاحى غريب ان اعطيه الملف بعد ما اصبح يعمل معى ZAD IPTV Subscription.xlsm

حياكم الله ، على الرحب والسعة 🙂 مباشرة وبالطريقة العادية ، لا ، ولكن يمكن هكذا : جعفر

السلام عليكم 🙂 هذه جميع مكتبات مايكروسوفت ، بصيغة نواة 32bit ومقابلها نواة 64bit ، في ملف Win32API_PtrSafe.TXT https://www.microsoft.com/en-us/download/details.aspx?id=9970 وقد ارفقت الملف لسهولة الوصل اليه 🙂 جعفر Win32API_PtrSafe.zip