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

وعليكم السلام ورحمه الله وبركاته تفضل مقارنة.xlsb

السلام عليكم ورحمة الله وبركاته.. كنت اعمل على مشروع للقرآن الكريم، يكون ضمن تطبيق قوت القلوب، صورته في التوقيع 🥰 البرنامج من تصميمي وبرمجتي 100% فاحتجت للقرآن الكريم مرتل ومقسم لايات قمت بالعثور على ختمات كاملة وللعديد من القرآء في موقع Archive.org فقمت بتحويل الروابط الى قاعدة بيانات SQLite تتضمن ترتيل القرآن الكريم على شكل ايات كل آية على حدا وبرابط مباشر، أي ستقوم بتشغيل الصوت من الرابط مباشرة بدون تنزيلة طبعا يمكنكم تشغيل الصوت مباشرة من الويب باستخدام الكثير من المكتبات المجانية مثل NAudio.dll وغيرها... قبل كل شيء، هذا الكود لإنشاء الجدول sounds الذي ستكون فيه روابط الصوت لايات القرآن الكريم في قاعدة البيانات.. 1. تسلسل السورة 2. رقم الآية 3. رابط الملف الصوتي للآية 4. معرف القارئ CREATE TABLE "sounds" ( "surah_number" INTEGER, "ayah_number" INTEGER, "audio_url" TEXT, "reader_id" INTEGER ); 0. احمد نعينع 1. الطبلاوي 2. عبد الباسط 3. المنشاوي 4. الحصري السورس كود للفائدة، الذي يقوم بتوليد الايات حسب السور بلغة NET. Sub GenerateQuranAudioLinks(ByVal baseUrl As String, ByVal reader_id As String) ' عدد الآيات لكل سورة من القرآن الكريم Dim surahAyatCounts As Integer() = { 7, 286, 200, 176, 120, 165, 206, 75, 129, 109, 123, 111, 43, 52, 99, 128, 111, 110, 98, 135, 112, 78, 118, 64, 77, 227, 93, 88, 69, 60, 34, 30, 73, 54, 45, 83, 182, 88, 75, 85, 54, 53, 89, 59, 37, 35, 38, 29, 18, 45, 60, 49, 62, 55, 78, 96, 29, 22, 24, 13, 14, 11, 11, 18, 12, 12, 30, 52, 52, 44, 28, 28, 20, 56, 40, 31, 50, 40, 46, 42, 29, 19, 36, 25, 22, 17, 19, 26, 30, 20, 15, 21, 11, 8, 8, 19, 5, 8, 8, 11, 11, 8, 3, 9, 5, 4, 7, 3, 6, 3, 5, 4, 5, 6 } ' حلقة لتوليد جمل SQL لكل سورة وآياتها For surah As Integer = 1 To 114 Dim surahNumber As String = surah.ToString("D3") ' تحويل رقم السورة إلى 3 أرقام Dim ayatCount As Integer = surahAyatCounts(surah - 1) ' توليد جمل SQL بناءً على عدد الآيات لكل سورة For ayah As Integer = 0 To ayatCount Dim ayahNumber As String = ayah.ToString("D3") ' تحويل رقم الآية إلى 3 أرقام Dim fileUrl As String = baseUrl & surahNumber & ".zip" & "/" & surahNumber & ayahNumber & ".mp3" Dim sqlInsert As String = "INSERT INTO sounds (surah_number, ayah_number, audio_url, reader_id) VALUES (" & surah & "," & ayah & "," & "'" & fileUrl & "'" & "," & reader_id & ");" My.Computer.FileSystem.WriteAllText(Application.StartupPath & "\sql_" & reader_id & ".txt", sqlInsert & vbNewLine, True) Next Next '' تشغيل كل عملية في ثريد منفصل باستخدام Task 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb---a7mad--n3ena3---morattal------quran----6236---ayaat-----__verse--by---_189/", "1")) 'احمد نعينع 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb__---mp3------------quran----6236---ayaat-----__verse--by---verse----_-by-/", "2")) 'الطبلاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/192kb----morattal----quran----6236---ayaat-----__verse--by---verse----_-by--ab_525/", "3")) 'عبد الباسط 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb____--mp3-------full-----quran----6236---ayaat-----__verse--by---verse---/", "4")) 'المنشاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb___--mp3-----quran----6236---ayaat-----__verse--by---verse----_-by---alhos/", "5")) 'الحصري End Sub ارفقت لكم البيانات على شكل ملفات TXT لكي تعدلو عليها كيفما شئتم. لا تنسوني ووالدي من صالح دعائكم SQLite.zip

السلام عليكم ورحمة الله وبركاته.. اولاً: جلب الوقت والتاريخ من time.windows.com ثم ضبط وقت وتاريخ الكومبيوتر.. العملية كلها بطرفة عين البرنامج مكتوب 100% بلغة Visual Studio .NET يمكنك تشغيله بالاكسس بـ shell السورس كود للفائدة (شرحت فيه كل شيء): Imports System.Net Imports System.Net.Sockets Module Main 'c0ded by: SEMO.Pa3x 'date: 23-09-2024 - 06:36 PM 'enjoy (: Sub Main() Try Dim computerDate As String = GetNetworkTime.ToShortDateString Dim computerTime As String = GetNetworkTime.ToShortTimeString ' قم بتشغيل العملية لتعيين التاريخ والوقت معاً Dim processInfo As New ProcessStartInfo("cmd.exe") processInfo.UseShellExecute = True processInfo.Verb = "runas" ' طلب صلاحيات المسؤول processInfo.Arguments = "/C date " & computerDate & " && time " & computerTime.Replace("ص", "AM").Replace("م", "PM") Process.Start(processInfo) Catch ex As Exception Console.WriteLine(ex.Message) Console.ReadLine() End Try End Sub Public Function GetNetworkTime() As DateTime ' خادم الوقت الافتراضي Const ntpServer As String = "time.windows.com" ' حجم رسالة NTP - 16 بايت من بيانات الهضم (RFC 2030) Dim ntpData As Byte() = New Byte(47) {} ' إعداد القيم LI = 0 (بدون تحذير)، VN = 3 (IPv4 فقط)، Mode = 3 (وضع العميل) ntpData(0) = &H1B ' الحصول على عناوين IP الخاصة بالخادم Dim addresses As IPAddress() = Dns.GetHostEntry(ntpServer).AddressList ' منفذ UDP المستخدم من قبل NTP هو 123 Dim ipEndPoint As New IPEndPoint(addresses(0), 123) ' استخدام UDP Using socket As New Socket(AddressFamily.InterNetwork, SocketType.Dgram, ProtocolType.Udp) socket.Connect(ipEndPoint) ' إيقاف تعليق الكود إذا تم حظر NTP socket.ReceiveTimeout = 3000 ' إرسال الطلب واستقبال الرد socket.Send(ntpData) socket.Receive(ntpData) socket.Close() End Using ' إزاحة للحصول على حقل "Transmit Timestamp" Const serverReplyTime As Byte = 40 ' الحصول على الجزء الخاص بالثواني Dim intPart As ULong = BitConverter.ToUInt32(ntpData, serverReplyTime) ' الحصول على الكسر الخاص بالثواني Dim fractPart As ULong = BitConverter.ToUInt32(ntpData, serverReplyTime + 4) ' تحويل البيانات من big-endian إلى little-endian intPart = SwapEndianness(intPart) fractPart = SwapEndianness(fractPart) ' تحويل البيانات إلى ميلي ثانية Dim milliseconds As ULong = (intPart * 1000UL) + ((fractPart * 1000UL) / &H100000000UL) ' الوقت بناءً على التوقيت العالمي UTC Dim networkDateTime As DateTime = (New DateTime(1900, 1, 1, 0, 0, 0, DateTimeKind.Utc)).AddMilliseconds(CLng(milliseconds)) ' إعادة الوقت المحلي Return networkDateTime.ToLocalTime() End Function ' دالة لتحويل البيانات من big-endian إلى little-endian Private Function SwapEndianness(x As ULong) As UInteger Return CUInt(((x And &HFFUL) << 24) + ((x And &HFF00UL) << 8) + ((x And &HFF0000UL) >> 8) + ((x And &HFF000000UL) >> 24)) End Function End Module اهداء للمعلم جعفر @jjafferr لا تنسوني ووالدي من صالح دعائكم. SetDateTimeInternetSEMO.zip

حل رائع معلمنا حسونة حسين

اعتذر على التأخير اتفضل يا سيدى تم تحويل القاعدة للتنسيق 2000 بامتداد mdb الاكواد تعمل على النواتان 32 , 64 بيت Security(Enable-Disable Shift Key).zip

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

تفضل اخى مقارنة.xlsb

لقد تم حل مثل هذه المشكلات كثيرا يجب البحث اولا وهذه أحد نتائج البحث Showing results for 'القروش خليتين' in content posted in منتدى الاكسيل Excel . - أوفيسنا (officena.net) بالتوفيق

بميزان حسناتك يارب

وعليكم السلام ورحمة الله تعالى وبركاته الخيار رقم 1 لاستخراج النتائج اظن انك بحاجة لفك الدمج على خلايا العمود A حيث أن الخلايا المدمجة تعتبر خلية واحدة في Excel مما يسبب تعارضا مع الدوال قم بإلغاء دمج الخلايا في العمود A (الصفوف 4 و 5) بحيث تصبح كل صف يحتوي على القيمة الصحيحة و بعد إلغاء الدمج استخدم المعادلة التالية =SUMPRODUCT(($A$4:$A$7=I14)*($B$4:$B$7=J14)*($C$4:$E$7)) إذا كنت تريد الاحتفاظ بالدمج يمكنك استخدام عمود مساعد (على سبيل المثال العمود O ) لتكرار القيم الموجودة في العمود A في الخلية O14 مثلا استخدم المعادلة التالية مع سحبها للاسفل =IF(A4<>"", A4, O13) استخدم المعادلة التالية في الخلية M14 لتستخدم العمود المساعد بدلًا من العمود المدمج A =SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*($C$4:$E$7)) Officena (1).xlsx

يمكنك اظافة الكود التالي في اخر الكود مع تعديل عناوين الخلايا بما يناسبك If MsgBox("تفريغ بيانات التسجيل ", vbYesNo + vbQuestion, "تأكيـــد") = vbYes Then ws.Range("G3:G7").ClearContents End If MsgBox "تم ترحيل البيانات بنجاح", vbInformatio

بارك الله فيك وجعلها الله في ميزان حسناتك

عمل جدا متقن جربت اغير الصوره png وحاولت اجعل الاكواد تخطأ لكنك مُدرك في كل كود كتبته شكرا لك وبعتمده بإذن الله في مشاريعي القادمه

ما شاءالله ،، تبارك الله مهندسنا @ابو جودي ,, عمل رائع ومتكامل جداً وخفيف ، وشغل نظيف ومجهود يستحق الإحترام

ما شاء الله عليك مجهود رائع وبارك الله فيك وزادك من العلم رفعة

ما شاء الله عليك يا أبا جودي ما شاء الله عليك 🙂 من يغوص في بحار الأكواد المكتوبة بماء الذهب يعلم يقينا حجم الجهد والعمل الذين تما على هذه القطعة الفنية الرااااائعة 🙂 لله درك أبا جودي ... عمرت مكتباتنا .. وإحنا قاعديييين 😅

يعطيك العافية يا مبدع يا فنان 😄 اشكرك على الهديه الرائعه من قبل ما اجربها 🌹🌹🌹🌹 جاري التجربه 🚴

ممكن لو تكرمت تعديل هذا المرفق ليعمل على أكسس 2003 "mdb" بجانب أى أكسس أعلى "accdb" .. وللنواتين 32 ، 64 بمعنى أن يكون تطبيق واحد شامل بمعنى الكلمة . مع الشكر مقدماً

بعد إذن جميع الأخوة المشاركين هذا جهدي المتواضع لإثراء الموضوع يمكن اختصار الإجراء لهذا الكود Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Texte1 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row Texte1 = Ar_WriteDownNumber(Cells(LR, "Q") + (Cells(LR, "p") / 100), "جنيها", "قرشا", 100) Sh.Cells(LR + 2, "C").Value = "فقط " & Texte1 ''' هنا حدد اين تريد يظهرالتفقيط ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sh.Range(Sh.Cells(LR + 1, "A"), Sh.Cells(LR + 12, "C")).ClearContents Next Sh End Sub

السلام عليكم ورحمة الله الحاقا بالمشاركة السابقة ( بعد ان وقع سهوا) فى كود دالة التفقيط استبدل هذه الفقرة MyNumber = Abs(Number_Value) MyNumber = Int(MyNumber) بتلك الفقرة If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) حتى يعمل معك الكود بشكل سليم .... فيصبح الكود كاملاً Public Function Ar_WriteDownNumber(Number_Value As String, Optional Main_Currency As String, Optional Small_Currency As String, Optional Main_To_Small_Factor As Integer) Dim MyNumber Dim MyFractions Dim WordFraction Dim Pr Dim Hu Dim Th Dim PrTh Dim HuTh Dim PrMi Dim HuMi Dim Hu1 Dim Pr2 Dim l Dim Thu_Text As String Dim Mil_Text As String If Val(Main_To_Small_Factor) = 0 Then Main_To_Small_Factor = 100 If Small_Currency = "" Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If End If If Number_Value = Empty Then Number_Value = 0 Else MyNumber = Abs(Number_Value) End If MyNumber = Int(MyNumber) If InStr(Number_Value, ".") > 0 Then MyFractions = Mid(Number_Value, InStr(Number_Value, ".") + 1, 3) End If l = Len(MyNumber) Pr = Right(MyNumber, 2) Ar_WriteDownNumber = MyPrimary(Pr) If l > 2 Then Hu = Right(Left(MyNumber, l - 2), 1) If Val(Hu) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(Hu) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(Hu) End If End If Else GoTo 1 End If If l > 3 Then Th = Right(Left(MyNumber, l - 3), 2) If Val(Th) <> 0 Then Thu_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyThousand(Th) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyThousand(Th) End If Else Thu_Text = " ألف" End If Else GoTo 1 End If If l > 5 Then HuTh = Right(Left(MyNumber, l - 5), 1) If Val(HuTh) <> 0 Then If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuTh) & Thu_Text End If End If Else GoTo 1 End If If l > 6 Then PrTh = Right(Left(MyNumber, l - 6), 2) If Val(PrTh) <> 0 Then Mil_Text = "" If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MillionPrimary(PrTh) & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MillionPrimary(PrTh) & Mil_Text End If Else Mil_Text = " مليون" End If Else GoTo 1 End If If l > 8 Then HuMi = Right(Left(MyNumber, l - 8), 1) If Ar_WriteDownNumber <> 0 Then Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text & " و " & Ar_WriteDownNumber Else Ar_WriteDownNumber = MyHundreds(HuMi) & Mil_Text End If End If If l > 9 Then Ar_WriteDownNumber = MyNumber 1: If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " " & Main_Currency Else Ar_WriteDownNumber = "" End If If Len(MyFractions) < 2 Then MyFractions = MyFractions + "0" If Len(MyFractions) < 3 Then MyFractions = MyFractions + "0" If Val(MyFractions) = 0 Then Exit Function If Main_To_Small_Factor = 100 Then Pr2 = Left(MyFractions, 2) Else Pr2 = Mid(MyFractions, 2, 2) End If WordFraction = MyPrimary(Pr2) If Main_To_Small_Factor > 100 Then Hu1 = Left(MyFractions, 1) If Val(Hu1) <> 0 Then If WordFraction <> 0 Then WordFraction = MyHundreds(Hu1) & " و " & WordFraction Else WordFraction = MyHundreds(Hu1) End If End If Else GoTo 2 End If 2 If Main_Currency <> "" Then If Len(Trim(Ar_WriteDownNumber)) > 0 Then Ar_WriteDownNumber = Ar_WriteDownNumber & " و " & WordFraction & " " & Small_Currency Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If Else If Len(Trim(Ar_WriteDownNumber)) > 0 Then If Main_To_Small_Factor = 100 Then Small_Currency = " جزء من مائة" Else Small_Currency = " جزء من ألف" End If Ar_WriteDownNumber = Ar_WriteDownNumber & " فاصل " & WordFraction Else Ar_WriteDownNumber = WordFraction & " " & Small_Currency End If End If End Function Private Function MyPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyPrimary = Choose(J, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") Else myText1 = Choose(Val(K), "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyPrimary = myText1 & " و " & myText2 Else MyPrimary = myText2 End If End If End Function Private Function MyHundreds(J) J = Val(J) MyHundreds = Choose(J, "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") End Function Private Function MyThousand(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MyThousand = Choose(J, "ألف", "ألفان", "ثلاثة آلاف", "أربعة آلاف", "خمسة آلاف", "ستة آلاف", "سبعة آلاف", "ثمانية آلاف", "تسعة آلاف", "عشرة آلاف", "إحدى عشر ألفاً", "اثنا عشر ألفاً", "ثلاثة عشر ألفاً", "أربعة عشر ألفاً", "خمسة عشر ألفاً", "ستة عشر ألفاً", "سبعة عشر ألفاً", "ثمانية عشر ألفاً", "تسعة عشر ألفاً") Else myText1 = Choose(K, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose((J - K) / 10 - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") If Not IsNull(myText1) Then MyThousand = myText1 & " و" & myText2 & " الف" Else MyThousand = myText2 & " الف" End If End If End Function Private Function MillionPrimary(J) Dim myText1 Dim myText2 Dim K K = Right(J, 1) J = Val(J) If J < 20 Then MillionPrimary = Choose(J, "مليون", "مليونان", "ثلاثة ملايين", "أربعة ملايين", "خمسة ملايين", "ستة ملايين", "سبعة ملايين", "ثمانية ملايين", "تسعة ملايين", "عشرة ملايين", "إحدى عشر مليوناً", "اثنا عشر مليوناً", "ثلاثة عشر مليوناً", "أربعة عشر مليوناً", "خمسة عشر مليوناً", "ستة عشر مليوناً", "سبعة عشر مليوناً", "ثمانية عشر مليوناً", "تسعة عشر مليوناً") Else myText1 = Choose(Val(K), "واحد", "أثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") myText2 = Choose(Int((J - K) / 10) - 1, "عشرون مليون", "ثلاثون مليون", "أربعون مليون", "خمسون مليون", "ستون مليون", "سبعون مليون", "ثمانون مليون", "تسعون مليون") If Not IsNull(myText1) Then MillionPrimary = myText1 & " و " & myText2 Else MillionPrimary = myText2 End If End If End Function التفقيط المعدل2.xlsm