sideeq

السلام عليكم هناك موضوع قدمه احد الاخوة https://www.officena.net/ib/index.php?showtopic=54485 حول زرع ملف معين في الحاسوب يكون بمثابة حماية لملف الاكسس من السرقة هل يمكن تطبيقه على الاكسل

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

السلام عليكم كيف يمكن تطبيق هذا الكود على الاكسل

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

اخواني الاعزاء هذا الكود الذي اقصده اريد فقط اضافة كلمة درجة على العدد الصحيح وبعدها و على العشر جزء من الدرجة كود ابو حمود 1.xlsm

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

هذه الدالة يمكن تفيدك اذا اضفت اي بيانات في خلية مثلا a1 يتم تغيير التاريخ و الوقت الحالي في الخلية المطلوبة =IF(a1>0;TEXT(TODAY();"d/m/yyy")&" "&TEXT(NOW();"hh:mm:ss"))

رمضان مبارك عاى جميع الاعضاء هنا موضوع مهم ياريت حد من الاخوة يفيدنا الكل يعلم ان ملفات خلايا الاكسل المحمية فيها ثغرة وهي وجود برامج تكسر هذه الحماية للخلايا المؤمنة برقم سري وبالتالي تلغى الحماية وتضيع جهود الكثير ممن تعبوا في برمجة تطبيقات مختلفة في الاكسل فيا ترى هل هناك من طريقة للتغلب على هذه الثغرة او هل هناك كود vba يؤمن الخلايا بحماية اكثر جدوى مع فائق شكري وتقديري كم

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

ارجو ممن لديه خبرة من الاخوة خبراء الاكسل الاعزاء اضافة كلمة (درجة) بعد الرقم و (جزء من الدرجة) بعد الكسر العشري . الى كود التفقيط التالي . ونفسه مرفق في الملف باسم كود ابو حمود Public Ones(0 To 12) As String Public Twos(2 To 9) As String Public Threes(1 To 2) As String Public Fours(1 To 3) As String Public Sevens(1 To 3) As String Public Tens(1 To 2) As String Public Prepositions() As String Public Decimals(1 To 3) As String Public Function Main(الرقم_رقماً) Dim lRange As Long Dim lPosDecimal As Long Dim sWhole As String, sDecimal As String On Error Resume Next LoadArrays 'الرقم_رقماً = Forms![نموذج1]![نص84] lRange = Len(الرقم_رقماً) If lRange <> 0 Then lPosDecimal = InStr(1, الرقم_رقماً, ".", vbTextCompare) If lPosDecimal > 0 Then sWhole = Mid(الرقم_رقماً, 1, lPosDecimal - 1) sDecimal = Mid(الرقم_رقماً, lPosDecimal + 1) sWhole = sLeftRemove(sWhole, "0") sDecimal = sRightRemove(sDecimal, "0") If InStr(sDecimal, ".") Then sDecimal = sFindReplace(sDecimal, ".", "") If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "") If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "") If InStr(sDecimal, ",") Then sWhole = sFindReplace(sDecimal, ",", "") If InStr(sDecimal, "،") Then sWhole = sFindReplace(sDecimal, "،", "") If Len(sDecimal) > 9 And Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole and decimal portion of the number", vbOKOnly, "Number to Text" Exit Function End If If Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole portion of the number", vbOKOnly, "Number to Text" Exit Function End If If Len(sDecimal) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "decimal portion of the number", vbOKOnly, "Number to Text" Exit Function End If If sDecimal <> "" Then If CLng(sDecimal) <> 0 Then If sWhole <> "" Then If CLng(sWhole) <> 0 Then الرقم_كتابة = sNum2Text(CLng(sWhole)) & " " & Prepositions(1) & _ sDec2Text(sDecimal) Else الرقم_كتابة = sDec2Text(sDecimal) End If Else الرقم_كتابة = sDec2Text(sDecimal) End If Else الرقم_كتابة = sNum2Text(CLng(sWhole)) End If Else الرقم_كتابة = sNum2Text(CLng(sWhole)) End If Else 'Only whole number If InStr(sWhole, ",") Then sWhole = sFindReplace(sWhole, ",", "") If InStr(sWhole, "،") Then sWhole = sFindReplace(sWhole, "،", "") sWhole = الرقم_رقماً sWhole = sLeftRemove(sWhole, "0") If Len(sWhole) > 9 Then MsgBox "Sorry:This addin does not support more than 9 digits for " & _ "whole portion of the number", vbOKOnly, "Number to Text" Exit Function End If الرقم_كتابة = sNum2Text(CLng(sWhole)) End If End If ' MsgBox الرقم_كتابة Main = الرقم_كتابة End Function Public Function sNum2Text(lNum As Long) As String Dim sNum As String 'The number as string to pass as a vlaue name in the INI file Dim I As Integer 'Loop counter to loop through all of the digits Dim iUpperBound As Integer 'Represents # of digits in each group of 3 significant bits On Error Resume Next sNum = Trim$(CStr(lNum)) 'Get rid of the zeros to the left If (lNum >= 0) And (lNum <= 12) Then '0 through 12 sNum2Text = Ones(lNum) ElseIf lNum Mod 10 = 0 And Len(sNum) = 2 Then '20,30,40,...,90 sNum2Text = Twos(CLng(Left(sNum, 1))) ElseIf lNum > 12 And lNum < 20 Then '13 to 19 sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Ones(10) ElseIf lNum Mod 10 > 0 And Len(sNum) = 2 Then '21,22,...29,31,32,33,...,99 sNum2Text = Ones(CLng(Right(sNum, 1))) & " " & Prepositions(1) & _ Twos(CLng(Left(sNum, 1))) ElseIf (lNum = 100) Or (lNum = 200) Then '100,200 sNum2Text = Threes(CLng(Left(sNum, 1))) ElseIf (lNum Mod 100) = 0 And Len(sNum) = 3 Then '300,400,500,...,900 sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1) ElseIf lNum Mod 100 > 0 And Len(sNum) = 3 Then '101,102,103,...,199,201,...999 If Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = Ones(CLng(Left(sNum, 1))) & " " & Threes(1) Else sNum2Text = Threes(CLng(Left(sNum, 1))) End If If Right(sNum, 2) = "11" Or Right(sNum, 2) = "12" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 2))) ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) <> 0 Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _ " " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1))) ElseIf Mid(sNum, 2, 1) <> "0" And Mid(sNum, 2, 1) <> "1" And Right(sNum, 1) = 0 Then sNum2Text = sNum2Text & " " & Prepositions(1) & Twos(CLng(Mid(sNum, 2, 1))) ElseIf Mid(sNum, 2, 1) = "1" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) & _ " " & Ones(10) ElseIf Mid(sNum, 2, 1) = "0" Then sNum2Text = sNum2Text & " " & Prepositions(1) & Ones(CLng(Right(sNum, 1))) Else 'Right(sNum, 2) = "00" sNum2Text = sNum2Text End If ElseIf Len(sNum) / 3 > 1 Then Do Until Len(sNum) = 3 If Len(sNum) Mod 3 <> 0 Then iUpperBound = Len(sNum) Mod 3 Else iUpperBound = 3 End If If (Len(sNum) / 3 > 2) And (Len(sNum) / 3 < 4) Then 'In the millions If Mid(sNum, 1, iUpperBound) = "000" Then Exit Do ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then sNum2Text = sNum2Text & Sevens(CLng(Left(sNum, 1))) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(3) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(3) & " " & Prepositions(1) Else sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Sevens(1) & " " & Prepositions(1) End If ElseIf (Len(sNum) / 3 >= 1) And (Len(sNum) / 3 < 3) Then 'In the thousands If Mid(sNum, 1, iUpperBound) = "000" Then Exit Do ElseIf (Len(sNum) Mod 3 = 1) And (Left(sNum, 1) = "1" Or Left(sNum, 1) = "2") Then sNum2Text = sNum2Text & Fours(CLng(Left(sNum, 1))) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 1) And Left(sNum, 1) <> "1" And Left(sNum, 1) <> "2" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(3) & " " & Prepositions(1) ElseIf (Len(sNum) Mod 3 = 2) And Left(sNum, 2) = "10" Then sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(3) & " " & Prepositions(1) Else sNum2Text = sNum2Text & sNum2Text(CLng(Mid(sNum, 1, iUpperBound))) & _ " " & Fours(1) & " " & Prepositions(1) End If End If sNum = Mid(sNum, iUpperBound + 1) lNum = CLng(sNum) 'Make sure the least significant 6 digits are not zero If sNum = String(Len(sNum), "0") Then sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1) Exit Function End If Loop 'Make sure the least significant 3 digits are not zero If sNum <> String(Len(sNum), "0") Then sNum2Text = sNum2Text & sNum2Text(lNum) Else 'get ride of the AND sNum2Text = Left(sNum2Text, Len(sNum2Text) - 1) End If End If End Function Public Function sDec2Text(sNum As String) As String Dim lLen As Long On Error Resume Next Do While Right(sNum, 1) = "0" sNum = Left(sNum, Len(Trim(sNum)) - 1) Loop lLen = Len(Trim(sNum)) If lLen = 0 Then sDec2Text = "" Exit Function ElseIf lLen = 1 Then Select Case sNum Case "0" sDec2Text = "" Case "1" sDec2Text = Decimals(1) Case "2" sDec2Text = Decimals(2) Case Else sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Decimals(3) End Select ElseIf lLen = 2 Then sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(2) & _ sNum2Text("1" & String(lLen, "0")) ElseIf lLen = 9 Then sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _ Tens(1) Else sDec2Text = sNum2Text(CLng(Trim(sNum))) & " " & Prepositions(3) & _ sNum2Text("1" & String(lLen, "0")) End If End Function Public Sub LoadArrays() 'Load the arrays with values 'Ones Ones(0) = "صفر" Ones(1) = "واحد" Ones(2) = "اثنان" Ones(3) = "ثلاثة" Ones(4) = "أربعة" Ones(5) = "خمسة" Ones(6) = "ستة" Ones(7) = "سبعة" Ones(8) = "ثمانية" Ones(9) = "تسعة" Ones(10) = "عشرة" Ones(11) = "أحد عشرة" Ones(12) = "اثنا عشرة" 'Twos Twos(2) = "عشرون" Twos(3) = "ثلاثون" Twos(4) = "أربعون" Twos(5) = "خمسون" Twos(6) = "ستون" Twos(7) = "سبعون" Twos(8) = "ثمانون" Twos(9) = "تسعون" 'Threes Threes(1) = "مائة" Threes(2) = "مائتان" 'Fours Fours(1) = "ألف" Fours(2) = "ألفان" Fours(3) = "آلاف" 'Sevens Sevens(1) = "مليون" Sevens(2) = "مليونان" Sevens(3) = "ملايين" 'Tens Tens(1) = "بليون" Tens(2) = "بلايين" 'Prepositions ReDim Prepositions(1 To 3) Prepositions(1) = "و" Prepositions(2) = "بال" Prepositions(3) = "من ال" 'Decimals Decimals(1) = "عشر" Decimals(2) = "عشران" Decimals(3) = "أعشار" End Sub Public Function sFindReplace(sString As String, sOld As String, sNew As String) As String On Error GoTo sFindReplace_Hndlr Dim I As Integer sFindReplace = sString I = 1 'Loop through all the characters of a string For j = 1 To Len(sString) If InStr(sOld, Mid(sFindReplace, I, 1)) Then sFindReplace = Mid(sFindReplace, 1, I - 1) & sNew & Mid(sFindReplace, I + 1) I = I - 1 End If I = I + 1 Next j Exit Function sFindReplace_Hndlr: Debug.Print "RTE Desc: " & Err.Description Debug.Print "RTE Num: " & Err.Number sFindReplace = sString Exit Function End Function Public Function sLeftRemove(str1 As String, str2 As String) As String On Error Resume Next If str1 = "0" And str2 = "0" Then sLeftRemove = str1 Exit Function End If Do While Left(str1, 1) = str2 str1 = Mid(str1, 2) Loop If str1 = "" Then str1 = "0" sLeftRemove = str1 End Function Public Function sRightRemove(str1 As String, str2 As String) As String On Error Resume Next If str1 = "0" And str2 = "0" Then sRightRemove = str1 Exit Function End If Do While Right(str1, 1) = str2 str1 = Mid(str1, 1, Len(str1) - 1) Loop If str1 = "" Then str1 = "0" sRightRemove = str1 End Function 'وفي النموذج في حدث عند الخروج من حقل الرقم ضع : 'Private Sub حقل_الرقم_Exit(Cancel As Integer) 'If Not IsNull(Me!حقل_الرقم) Then 'الرقم_رقما 'ً = حقل_الرقم 'Call Main ' '[حقل'_الكتابة] = الرقم_كتابة 'End If 'End Sub كود ابو حمود.docx