تكسير الحروف

[MansurH]

سلام عليكم احبایی الکرام مرة اخری

في هذا النموذج نريد تکسیر الحروف علی اصول اتی نریدها

مثلا نرید:  ع  م  ا  ن

یصبح    :  ن ع  ا  م

الاصول:  حروفـ  (1  2  3  4)  تتحول الی (4  1  3  2)

وشکرا علی مساعدتکم

 

[Moosak]

  في 28‏/4‏/2022 at 13:39, سید منصور هاشمی said:

سلام عليكم احبایی الکرام مرة اخری

في هذا النموذج نريد تکسیر الحروف علی اصول اتی نریدها

مثلا نرید:  ع  م  ا  ن

یصبح    :  ن ع  ا  م

الاصول:  حروفـ  (1  2  3  4)  تتحول الی (4  1  3  2)

وشکرا علی مساعدتکم

 

Expand  

وعليكم السلام ورحمة الله وبركاته .. الأخ سيد

 

ماهي القاعدة التي تبني عليها ؟

لو أخذنا كلمة : س ي د ……مثلا

كيف ستكون النتيجة ؟

 

[MansurH]

س ی د       =>   د س ی

انا آسف لئن ما الی ای خبره بس ارید شی بهذا المثال

 

Private Sub Command8_Click()
Dim LString As String
Dim LArray() As String

LString = Me.txt
LArray = Split(LString)

Me.Text00 = LArray(7) & " " & LArray(0) & " " & LArray(6) & " " & LArray(1) & " " & LArray(5) & " " & LArray(2) & " " & LArray(4) & " " & LArray(3)


End Sub

 

[MansurH]

 

هذا النموذج یساعد کثیرا

taksir.zipFetching info...

تم تعديل أبريل 29, 2022 بواسطه سید منصور هاشمی

[Moosak]

  في 29‏/4‏/2022 at 05:10, سید منصور هاشمی said:

 

هذا النموذج یساعد کثیرا

taksir.zip 84.81 kB · 2 downloads

Expand  

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

[MansurH]

Dim OriginStr As String
Dim RevStr As String
Dim NextChar As String
Dim Length As Integer
Dim Pos As Integer

OriginStr = (Me.Text00)
 
Length = Len(OriginStr)
 
RevStr = ""
 
For Pos = Length To 1 Step -1
 
    NextChar = Mid(OriginStr, Pos, 1)
    RevStr = RevStr & NextChar
Next Pos
 
Me.Text01 = RevStr

 

[Moosak]

أهلا أخي سيد تم بحمد الله نجاح التجربة 🙂 

وهذه هي الأكواد المستخدمة والدالة المكسرة للكلام 

Public Function RandomizeTxt(TXT As String) As String

Dim x As Double
Dim y As String
Dim m As Double
Dim L As String
Dim R As String

y = Replace(TXT, " ", "")
m = Len(y) / 2

If InStr(1, m, ".") > 0 Then
    y = Replace(y, Mid(y, m + 0.5, 1), Mid(y, m + 0.5, 1) & " ")
End If

R = StrReverse(y)

For x = 1 To m + 0.5
    L = L & Mid(R, x, 1) & " " & Mid(y, x, 1) & " "
Next

RandomizeTxt = Trim(Replace(Replace(L, "  ", ""), "  ", " "))
End Function

المرفق :

 

تم تعديل أبريل 30, 2022 بواسطه Moosak
تم تعديل الكود ولكن حمل المرفق المعدل من المشاركة القادمة :)

[MansurH]

حقیقتا شی عجیب 😉

حضرتک خبیر بکل معناه بهذا العلم

احسنتم جزاک الله خیرا اخی العزیز🌺

تم تعديل أبريل 29, 2022 بواسطه سید منصور هاشمی

[MansurH]

شکراااااااااااااا

 

تم تعديل أبريل 29, 2022 بواسطه سید منصور هاشمی

[أبوبسمله]

السلام عليكم ورحمه الله وبركاته

اخى واستاذى موسى @Moosak جزاك الله خيرا 🌹

ملحوظه بسيطه اخى على كودك الرائع وتسلم ايدك 💐

استبدل هذا الجزء من الكود

If InStr(1, m, ".") > 0 Then
    TXT = TXT & " "
End If

الى

If InStr(1, m, ".") > 0 Then
    TXT = TXT
End If

بالتوفيق

[Eng.Qassim]

فكرة جميلة جدا استاذ @Moosak ..لكن لم اجد فائدة من هذا الجزء

If InStr(1, m, ".") > 0 Then
    TXT = TXT & " "
End If

 

[Moosak]

  في 29‏/4‏/2022 at 19:41, سید منصور هاشمی said:

حقیقتا شی عجیب 😉

حضرتک خبیر بکل معناه بهذا العلم

احسنتم جزاک الله خیرا اخی العزیز🌺

Expand  

العفو أخي سيد ..

ذلك فضل الله .. 🙂

  في 29‏/4‏/2022 at 20:23, احمد الفلاحجي said:

السلام عليكم ورحمه الله وبركاته

اخى واستاذى موسى @Moosak جزاك الله خيرا 🌹

ملحوظه بسيطه اخى على كودك الرائع وتسلم ايدك 💐

استبدل هذا الجزء من الكود

Expand  

وعليكم السلام ورحمة الله وبركاته أخي الحبيب @احمد الفلاحجي 

العفو حبيبنا بارك الله فيك 🙂

في الحقيقة هذا الجزء حل لي مشكلة إذا كان عدد الحروف فردي وتمت قسمته على 2 بيطلع لنا كسور وسيتم تكرار الحرف الأوسط مرتين ، لذلك زودت المسافة علشان دايما يكون العدد زوجي وتشتغل الدالة صح 😉👌🏻

  في 29‏/4‏/2022 at 20:33, Eng.Qassim said:

فكرة جميلة جدا استاذ @Moosak ..لكن لم اجد فائدة من هذا الجزء

If InStr(1, m, ".") > 0 Then
    TXT = TXT & " "
End If

 

Expand  

ولذلك زودت هذا الجزء باش مهندس قاسم 😁✌️🏻

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

[Eng.Qassim]

  في 29‏/4‏/2022 at 20:34, Moosak said:

ولذلك زودت هذا الجزء

Expand  

😍الان توضحت الرؤيا ان كان العدد فردي

دائما مبدع استاذ موسى

[أبوبسمله]

  في 29‏/4‏/2022 at 20:34, Moosak said:

في الحقيقة هذا الجزء حل لي مشكلة إذا كان عدد الحروف فردي وتمت قسمته على 2 بيطلع لنا كسور وسيتم تكرار الحرف الأوسط مرتين ، لذلك زودت المسافة علشان دايما يكون العدد زوجي وتشتغل الدالة صح 😉👌🏻

Expand  

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

If InStr(1, m, ".") > 0 Then
    TXT = " " & TXT
End If

بالتوفيق

[Moosak]

كل الشكر لكما 😊🌷

[أبوبسمله]

بل الشكر لله ثم لك اخى موسى وفقك الله 💐

[MansurH]

ملحوظه هامه:

اذا کان النص ، حروف مزدوجه (4  6  8  10  12  14)  فلقاعده  ما فیها خطا وهی صحیحه و ممیزه

ولکن اذا کان النص ، حروفها مفرده (5  7   9   13  15) و هذا خطا

هل احد من الاساتید لدیه فکره؟؟

[Moosak]

  في 29‏/4‏/2022 at 20:48, سید منصور هاشمی said:

ملحوظه هامه:

اذا کان النص ، حروف مزدوجه (4  6  8  10  12  14)  فلقاعده  ما فیها خطا وهی صحیحه و ممیزه

ولکن اذا کان النص ، حروفها مفرده (5  7   9   13  15) و هذا خطا

هل احد من الاساتید لدیه فکره؟؟

Expand  

الحمدلله تم تصحيح هذا الخطأ 🙂 :

وتم تعديل الكود :

 

Public Function RandomizeTxt(TXT As String) As String

Dim x As Double
Dim y As String
Dim m As Double
Dim L As String
Dim R As String

y = Replace(TXT, " ", "")
m = Len(y) / 2

If InStr(1, m, ".") > 0 Then
    y = Replace(y, Mid(y, m + 0.5, 1), Mid(y, m + 0.5, 1) & " ")
End If

R = StrReverse(y)

For x = 1 To m + 0.5
    L = L & Mid(R, x, 1) & " " & Mid(y, x, 1) & " "
Next

RandomizeTxt = Trim(Replace(Replace(L, "  ", ""), "  ", " "))
End Function

 

 

تجربة تكسير الكلام (1).accdb 544 kB · 65 downloads

تم تعديل أبريل 30, 2022 بواسطه Moosak
تم تعديل الكود من جديد بسبب ظهور أخطاء في الجمل الفردية :)

[MansurH]

ماااااااااااشاااااااااااااااااا الله علیک ک ک ک ک ک ک ک 😊😉😌

میمیز جدا جدا....

تسلم حیاتک و انا اشکرک اخی و استاذی Moosak و اشکر الجمیع 

[Moosak]

أخي سید منصور هاشمی  قمت بتعديلات جديدة على الكود ..

فقد ظهرت لي أخطاء جديدة فجعلته هذه المرة يتجاهل المسافات ثم يضيفها من جديد لتجنب وقوع الأخطاء 🙂  

حمل نفس الملف الأخير 

 

[Moosak]

  في 29‏/4‏/2022 at 18:06, Moosak said:

Expand  

هذي الدالة تعطينا فكرة لعمل تشفير للجمل والكلمات 

[MansurH]

شکرا اخی

جزاک الله خیر

[MansurH]

استاذ موسی : شاهدت خطا فی تکسیر الحروف ما بین الحقیقیه و الماخوذه من الملف

تکسیر الحروف الحقیقیه لـ { بسم الله الرحمن الرحیم } = م ب ی س ح م ر ا ل ل ا ل ن ه م ا ح ل ر

تکسیر الحروف الملف نفس الجمله                           = م ب ی س ح م ا ر ل ل ل ا ه ن ا م ل ح ر

کما تشاهد ، الی 6 حروف الاولی ، هیه صحیحه و من بعدها تتحول الی خطا .....

 

تم تعديل أبريل 30, 2022 بواسطه سید منصور هاشمی

[Moosak]

  في 30‏/4‏/2022 at 12:40, MansurH said:

استاذ موسی : شاهدت خطا فی تکسیر الحروف ما بین الحقیقیه و الماخوذه من الملف

تکسیر الحروف الحقیقیه لـ { بسم الله الرحمن الرحیم } = م ب ی س ح م ر ا ل ل ا ل ن ه م ا ح ل ر

تکسیر الحروف الملف نفس الجمله                           = م ب ی س ح م ا ر ل ل ل ا ه ن ا م ل ح ر

کما تشاهد ، الی 6 حروف الاولی ، هیه صحیحه و من بعدها تتحول الی خطا .....

 

Expand  

السلام عليكم ورحمة الله وبركاته أخي سيد ..

تم تعديل الكود ليتلافى هذا الخطأ 🙂 

Public Function RandomizeTxt(TXT As String) As String

Dim x As Double
Dim y As String
Dim m As Double
Dim L As String
Dim R As String

y = Replace(TXT, " ", "")
m = Len(y) / 2

R = StrReverse(y)

For x = 1 To m + 0.5
    L = L & Mid(R, x, 1) & " " & Mid(y, x, 1) & " "
Next

If InStr(1, m, ".") > 0 Then
    L = Left(Trim(L), Len(L) - 2)
End If
RandomizeTxt = Trim(Replace(Replace(L, "  ", ""), "  ", " "))

End Function

تجربة تكسير الكلام (1).accdbFetching info...

تم تعديل مايو 4, 2022 بواسطه Moosak

[MansurH]

اخی موسی 

سلام علیکم ورحمة الله. عید سعید انشاله و انتم من العوادین. قبل الله اعمالکم

شکرا جزیلا لاسمترار مساعدتک