تابعی که متن درون یک رشته را کشیده کندتا تمام رشته را بگیرد

[Doctor Sinohe]

با سلام

ایا تابعی است که متن درون یک رشته را کشیده کند تا انجاییکه تمام رشته را در بر گیرد؟؟

مثلا من یک متن دارم مثل Doctor Sinohe این 12 کاراکتر اگر ان را در یک String با ظرفیت 20 کاراکتر قرار دارم انرا به این مبدل کند D o c to r Si n o he یعنی به صورت خودکار متن را در تمام
طول String پراکنده کند


با تشکر از شما

[Doctor Sinohe]

:(

[المیرا]

با سلام
من فکر نمی کنم کاری که شما می خواهید انجام دهید کار روتینی باشد بنابراین تصور میکنم تابعش را باید خودتان بنویسید .ببخشید فضولی می کنم ولی چه فایده دارد؟
در حالت فارسی فکر میکنم کاربرد داشته باشد برای زیبایی که آنهم کاراکتر space نباید استفاده شود بلکه در جاهای مناسب کاراکتر کشیدن حروف قرار گیرد.
ببخشید که نه تنها کمک نکردم بلکه سوال هم کردم :oops:

[Doctor Sinohe]

سلام

ببخشید که نه تنها کمک نکردم بلکه سوال هم کردم

خواهش میکنم . باز هم مگر شما به من پاسخ دهید چون چند روز این موضوع اینجاست کسی به غیر از شما پاسخ نداده با این که عنوان موضوع بسیار گویاست

:oops: :oops:

ببخشید فضولی می کنم ولی چه فایده دارد؟

من منظورم کاراکتر Space نبود بلکه منظور من همان منظور شماست یعنی با کشیدن حروف ان را زیباتر کند اما چون این امکان در اینجا وجود نداشت مجبور شدم منظورم را انطور بیان کنم

عملیات مورد نظر من عملیات Justify روی متن است

و برای متن فارسی میخواهم ( شعر ) چون در شعر این خاصیت بسیار بسیار مهم است

باز هم از شما متشکرم :oops: :oops:

[المیرا]

دکتر جان . من فکر می کنم چون از فونتهای با عرض غیر ثابت استفاده می کنیم با آن روش عملی نباشد مثلا شعر زیر:
اسرار ازل را نه تو دانی ونه من
وین حرف معما نه تو خوانی ونه من
هست از پس پرده گفتگوی من وتو
چون پرده برافتد نه تو مانی ونه من
سطر 1: 30کاراکتر
سطر 2: 31کاراکتر
سطر 3: 28کاراکتر
سطر 4: 33 کاراکتر است. وبا مساوی کردن تعداد کاراکترها طول نوشته مساوی نمی شود .
حالا همه را 33 کاراکتر میکنم(با کشیدن بعضی حروف):
اســـرار ازل را نه تو دانی ونه من
ویــن حرف معما نه تو خوانی ونه من
هست از پـــــس پرده گفتگوی من وتو
چون پرده برافتد نه تو مانی ونه من
بدتر هم شد. تازه فکر میکنم با فونتهای مختلف وسایزهای مختلف حالتهای دیگری پیش بیاید
پس باید بغیر از تعداد کاراکتر های استرینگ به پارامتر دیگری فکر کنید . :?: مثلا طول آن . . :?:
البته این کار در اینجا هم تقریبا ممکن است:
اســرار ازل را نه تـو دانــی و نـه مـن
وین حرف معما نه تو خوانی و نه من
هست از پس پرده گفتگوی من و تو
چون پرده برافتد نه تو مانی و نه من
من چون از پارسا استفاده میکنم ممکن است کاراکتر کشیدن حروف را درست نبینید. در xp می توانید پیدایش کنید.
موفق باشید.

[Doctor Sinohe]

سلام
من هم به این پارامترها فکر کردم البته پارامتر میزان کردن مهمترین پارامتر این گروه است

منظور دقیقم را باز هم نتوانستم درست بیان کنم
منظور من به طور دقیق Justify در Word است
یعنی هر متنی را از جمله شعر زیبای ارسالی شما (شاعر خیام ) را مثلا در 50 کاراکتر میزان کند منظور من از تابع این بود
که فکربا عملیات Justify تمام عملیات پیش بینی شده توسط شما خود به خود انجام گیرد

با تشکر

[M-Gheibi]

با سلام.
این رو دانلود کن. همونیه که میخوای. البته به یه کمی مایه نیاز داره که شاید بشه با کمی تغییرات بدون مایه هم حل بشه. :oops: :wink:

[Doctor Sinohe]

سلام
بسیار از شما متشکرم :oops:

اما یک مشکلی پیش امد با بررسی این برنامه فهمیدم این برنامه فاصله های بین کلمات انگلیسی را حذف میکند و برای سیستم فارسی عمل نمیکند ولی خوب برای انگلیسی عالی عالی بود مرسی :oops: :oops: :oops:

من میخوام بدونم word Xp چگونه اینگونه کارا با متن فارسی میکند :?: :?:

[M-Gheibi]

خواهش میکنم قابلی نداشت :oops: :wink: موضوع جالبیه اگر چیزی پیدا کردم حتما اینجا مینویسم.

[(سیدشریفی)]

در مورد تعداد کاراکترها چون ما از جای خالی استفاده نمی کنیم و میخواهیم از کاراکتر خط کشیده استفاده کنیم پس این کاراکتر را در هر جای جمله نمیتوان قرار داد.
روش پیشنهادی من این است که شما میتوانید از اول جمله یکی یکی حرفهای جمله را چک کرده و جاهایی که حرف چسبیده به حرف دوم پیدا کردید وسط آنها یک کاراکتر خط کشیده قرار دهید و پس از این کار تعداد حرفهای جمله را چک نمایید اگر تعداد آن مورد نظر شما بود که هیچ وگرنه از کاراکتر بعدی ادامه داده و تا آخر جمله این کار را ادامه دهید و اگر باز هم تعداد به حد کافی نبود باز به اول جمله باز گشته و این کار را ادامه میدهیم.
البته این راه حل کمی پیچیده میباشد ولی با این روش حتما به خواسته تان میرسید.

[المیرا]

سلام
اولا عذر میخوام که در این بخش از اکسس حرف میزنم :oops:
ولی چون به این موضوع مربوط بود میگم.
در اکسس در فرم یا ریپورت وقتی یک لیبل یا تکست باکس می گذارید در properties آن می توانید text align را distribute انتخاب کنید . که در ظاهر (یعنی در design view) می بینید که کاراکتر ها کشیده میشوند تا تمام فضا را بگیرند ولی در نمایش فرم یا پرینت یا پرینت پریویو این اتفاق نمی افتد. آیا به نظر شما این باگ است؟ در ضمن در VB چنین امکانی وجود ندارد؟
(ببخشید من الان دسترسی به VB ندارم.)
در word هم من فکر می کنم justify کردن با اضافه کردن کاراکتر صورت نمی گیرد. کما اینکه در این حالت در یک متن هیچ کاراکتر کشیدگی قابل حذفی نمی بینید.

[Doctor Sinohe]

با سلام خدمت عزیزان
از توجه شما ممنونم
من خودم یک راه حل کشف کردم
با استفاده یک مراجعه(Refrence) به شی Microsoft word object library این موضوع تا حدی حل شد ولی خود نمیتوان با ورود در برنامه متن را تراز کنم بلکه ان را باید درون یک فایل ذخیره کنم اگر عزیزان با این شی کار کرده اند و میتوانند در برنامه از ان استفاده کنند راه حل را اینجا بنویسند
راه حل اقای شریفی مشکل است چون باید تک تک کاراکتر ها را تعریف کنم که ایا این دوتا وقتی به هم وصل میشن چسبیده اند یا نه ؟ من روی این روش کار میکنم نتیجه را اطلاع میدم
خانم المیرا
من زیاد با اکسس کار نکردم و متاسفانه پاسخ دقیقی برای شما ندارم :( :oops:
در مورد ورد هم ورد میتواند با اضافه کردن کاراکتر کشیدگی متن را کشیده کند برای مثال شما در ورد تایپ کنید دکتر سینوحه(آگهی بازرگانی :lol: ) و انقدر Space را استفاده کنید تا نشانگر تایپ از صفحه محو به به انتهای خط برود و همچنان ادامه دهد حالا یک حرف یا کاراکتر را تایپ کنید می بینید که دکتر سینوحه کشیده کامل توسط کاراکتر کشیدگی میشود

راستی اگر کسی بتوند فایلی که ورد با ان فایل عملیات کشیدگی را را انجام میدهد ( dll , Ocx , Cls , Bas , ...) پیدا کند خیلی خوب مشود :oops: :oops:

با تشکر از همه دوستان به خاطر توجه به این بحث :oops:

[روح اله معینی زاده]

:lol: با سلام خدمت دوستان گرامی
از بحثی که در اینجا صورت گرفته خوشم اومد. دیشب هم رفتم خونه و یک مقدار سعی کردم تا تونستم این برنامه کوچولو رو بنویسم. من اونو تو پارسا 99 آزمایش کردم و برای چند نمونه کوچک درست جواب داد، ولی از شما می خوام که اونو بیشتر آزمایش کنید.
برای اجرا، کافیه که روی فرم خودتون یک جعبه متن، یک برچسب و یک کلید قرار بدید. نیاز به تغییر نام اونا نیز ندارید. (TextBox, Lable, Command) بعد کدهای زیر رو با یک کپی به داخل قسمت کد فرم خودتون اضافه کنید.
این یک نمونه کوچکه که شما باید برای برنامه خودتون یک کم تغییرات در اون اعمال کنید. ولی اگه برنامه اشکال داشت حتما بگید، گرچه اگر خطایی هم داره باید خودتون سعی کنید و اون رو اصلاح نمایید. و اما کدهای برنامه:

Private Sub Command1_Click()
On Error Resume Next
Dim i As Integer
If Len(Trim(Text1.Text)) > 60 Then
Text1.Text = ""
Text1.SetFocus
Exit Sub
End If
If Len(Trim(Text1.Text)) < 2 Then
Text1.Text = ""
Text1.SetFocus
Exit Sub
End If
rework:
i = Val(Label1.Caption)
If i = 2 Then Exit Sub
Do While i > 1
If (Mid$(Text1.Text, i, 1) <> Chr(32)) Then
If (Mid$(Text1.Text, i - 1, 1) <> Chr(32)) Then
Checkruh Text1.Text, i - 1, Mid$(Text1.Text, i - 1, 1)
End If
End If
i = i - 1
Loop
If Len(Text1.Text) < 60 Then GoTo rework:
End Sub

Private Sub Text1_Change()
Label1.Caption = Str(Len(Text1.Text))
End Sub

Private Function Checkruh(strs As String, x As Integer, char As String) As String
Select Case char
Case "ب"
Checkruh = Mid$(strs, 1, x - 1) + "بـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "پ"
Checkruh = Mid$(strs, 1, x - 1) + "پـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ت"
Checkruh = Mid$(strs, 1, x - 1) + "تـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ث"
Checkruh = Mid$(strs, 1, x - 1) + "ثـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ج"
Checkruh = Mid$(strs, 1, x - 1) + "جـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "چ"
Checkruh = Mid$(strs, 1, x - 1) + "چـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ح"
Checkruh = Mid$(strs, 1, x - 1) + "حـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "خ"
Checkruh = Mid$(strs, 1, x - 1) + "خـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "س"
Checkruh = Mid$(strs, 1, x - 1) + "سـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ش"
Checkruh = Mid$(strs, 1, x - 1) + "شـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ص"
Checkruh = Mid$(strs, 1, x - 1) + "صـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ض"
Checkruh = Mid$(strs, 1, x - 1) + "ضـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ط"
Checkruh = Mid$(strs, 1, x - 1) + "طـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ظ"
Checkruh = Mid$(strs, 1, x - 1) + "ظـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ع"
Checkruh = Mid$(strs, 1, x - 1) + "عـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "غ"
Checkruh = Mid$(strs, 1, x - 1) + "غـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ف"
Checkruh = Mid$(strs, 1, x - 1) + "فـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ق"
Checkruh = Mid$(strs, 1, x - 1) + "قـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ک"
Checkruh = Mid$(strs, 1, x - 1) + "کـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "گ"
Checkruh = Mid$(strs, 1, x - 1) + "گـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ل"
Checkruh = Mid$(strs, 1, x - 1) + "لـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "م"
Checkruh = Mid$(strs, 1, x - 1) + "مـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ن"
Checkruh = Mid$(strs, 1, x - 1) + "نـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ه"
Checkruh = Mid$(strs, 1, x - 1) + "هـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
Case "ی"
Checkruh = Mid$(strs, 1, x - 1) + "یـ" + Mid$(strs, x + 1)
If Len(Checkruh) > 60 Then Exit Function
Text1.Text = Checkruh
End Select
End Function

با احترام- خدانگهدار.

[Doctor Sinohe]

با سلام
برنامه شما را بررسی کردم کمی دیر شد :( :oops: چون خودم داشتم روی یک برنامه کار میکردم پیرامون همین موضوع
برنامه شما بسیار خوب بود اما چند نقطه ضعف داشت یک اینکه قبل از حروف را هم کشیده میکرد مثلا ایران را بدین گونه تبدیل میکرد اــــــــیــــــــــــران دوم اینکه کد زیادی داشت و طولانی بود و از توابع زیاد و به طور تو در تو استفاده شده بود
اما بهر حال برنامه شما بسیار خوب بود و معلوم بود روی ان زحمت کشیده و وقت گذاشته اید از شما ممنونم
:oops: :oops: :oops: :oops: :lol:

[Doctor Sinohe]

اما در این گیر و دار خودم هم در حال نوشتن یک برنامه بودم که الان تمام شد این برنامه برای متن خوب است و با چندین متن تست شده البته کد هنوز کامل نیست من هم اکنون درصدد انم که ان را به یک DLL یا یک کلاس مبدل کنم اگر شد همین جا روی سایت میگزارم تا بقیه هم استفاده کنند
البته باید بگم جرقه نوشتن این برنامه اقای شریفی در ذهن من زد و برنامه زیبا و جالب اقای معینی زاده به من ایده داد با تشکر فراوان از هردو این عزیزان و دیگر دوستان که در این تاپیک مطالب مهم و جالبی را نوشته اند
:oops: :oops: :oops: :oops:
لطفا نظرات و پیشنهادات را راجع به این کد در همین جا اعلام کنید

و اما توضیحات
این کد نیاز به دو جعبه متن (textbox) ویک دکمه (commnadbutton) دارد بدون تغییر نام انها
Textbox اول برای درج متن مورد نظر و textbox دوم برای درج میزان کاراکتر برای کشیدگی که در صورت خالی گذاشتن به طور پیش فرض 50 است

Option Explicit

Option Base 1

Dim strText As String, Applylen As Integer

Dim mLen As Integer, I(25) As Integer

Dim Z As Byte, G As Integer

Dim S1 As String, S2 As String

Dim y As Integer, q As String

Private Sub Command1_Click()

mLen = 0: strText = ""

strText = Trim(Text1.Text)

mLen = Len(strText)

If mLen > Text2.Text Then Exit Sub

If Text2.Text = "" Then

Applylen = 50

Else

Applylen = Text2.Text

End If

G = Applylen - mLen

RE:

Call CheckChars(strText)

Z = Int(Rnd * 25) + 1

If I(Z) = 0 Or I(Z) = mLen Then GoTo RE

If Mid$(strText, I(Z) + 1, 1) = Chr$(32) Then GoTo RE

S1 = Left$(strText, I(Z))

S2 = Right$(strText, mLen - I(Z))

y = 0: q = ""

Do Until y = G

q = q + "ـ"

y = y + 1

Loop

strText = S1 & q & S2

Text1.Text = strText

End Sub

Private Sub CheckChars(Str As String)

I(1) = InStr(1, Str, "ب")

I(2) = InStr(1, Str, "پ")

I(3) = InStr(1, Str, "ت")

I(4) = InStr(1, Str, "ث")

I(5) = InStr(1, Str, "ج")

I(6) = InStr(1, Str, "چ")

I(7) = InStr(1, Str, "ح")

I(8) = InStr(1, Str, "خ")

I(9) = InStr(1, Str, "س")

I(10) = InStr(1, Str, "ش")

I(11) = InStr(1, Str, "ص")

I(12) = InStr(1, Str, "ض")

I(13) = InStr(1, Str, "ط")

I(14) = InStr(1, Str, "ظ")

I(15) = InStr(1, Str, "ع")

I(16) = InStr(1, Str, "غ")

I(17) = InStr(1, Str, "ف")

I(18) = InStr(1, Str, "ق")

I(19) = InStr(1, Str, "ک")

I(20) = InStr(1, Str, "گ")

I(21) = InStr(1, Str, "ل")

I(22) = InStr(1, Str, "م")

I(23) = InStr(1, Str, "ن")

I(24) = InStr(1, Str, "ه")

I(25) = InStr(1, Str, "ی")

End Sub

Private Sub Form_Load()

Call Randomize

End Sub

با تشکر از همه عزیزان به خاطر توجه به این بحث :oops: :oops: :oops:

کد شما رو اجرا کردم، جالب بود. ولی تنها یک مشکل داشت و اون هم این بود تنها یک حرف را کشیده می کرد. کد شما رو کمی تغییر دادم : ( در VB.Net )

 Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        Text3.Text = StretchWord(Text1.Text, Text2.Text)

    End Sub



    Private Function StretchWord(ByVal word As String, ByVal Length As Integer) As String

        Dim I As Integer

        While word.Length < Length

            I = CheckChars(word, Int(Rnd() * 25))

            If I <> 0 And I < word.Length Then

                If word.Substring(I, 1) <> " " Then

                    word = word.Substring(0, I) + "ـ" + word.Substring(I, word.Length - I)

                End If

            End If

        End While

        Return word

    End Function



    Private Function CheckChars(ByVal Str As String, ByVal Z As Integer) As Integer

        Dim I(25) As Integer

        I(1) = InStr(1, Str, "ت")

        I(2) = InStr(1, Str, "پ")

        I(3) = InStr(1, Str, "ت")

        I(4) = InStr(1, Str, "ث")

        I(5) = InStr(1, Str, "ج")

        I(6) = InStr(1, Str, "چ")

        I(7) = InStr(1, Str, "ح")

        I(8) = InStr(1, Str, "خ")

        I(9) = InStr(1, Str, "س")

        I(10) = InStr(1, Str, "ش")

        I(11) = InStr(1, Str, "ص")

        I(12) = InStr(1, Str, "ض")

        I(13) = InStr(1, Str, "ط")

        I(14) = InStr(1, Str, "ظ")

        I(15) = InStr(1, Str, "ع")

        I(16) = InStr(1, Str, "غ")

        I(17) = InStr(1, Str, "ف")

        I(18) = InStr(1, Str, "ق")

        I(19) = InStr(1, Str, "ک")

        I(20) = InStr(1, Str, "گ")

        I(21) = InStr(1, Str, "ل")

        I(22) = InStr(1, Str, "م")

        I(23) = InStr(1, Str, "ن")

        I(24) = InStr(1, Str, "ه")

        I(25) = InStr(1, Str, "ی")

        Return I(Z)

    End Function

[Doctor Sinohe]

سلام

مشکل حل شد
بعد از تذکر شیما خانم (که از برنامه خوبشان و تذکرشان بسیار متشکرم :oops: ) رفتم که مشکل را حل کنم
بعد از کلنجار رفتن با کد قبلی کد نهایی را آماده کردم و در یک کلاس جای دادم
این کد اشکال یابی شده است و ضمنا تنها یک حرف را کشیده نمیکند بلکه تمام حروف را کشیده خواهد کرد
این کد نهایی است و مشکل من که در ابتدا این تاپیک مطرح کردم حل شد
اگر اشکالی در این کد پیدا کرده اید در همین تاپیک ذکر کنید
باز هم از همه عزیزانی که به این تاپیک توجه نشان دادند با نوشتن کد ویا مطالب مهم مرا راهنمایی کردند کمـــال احترام و تشکر را دارم (خیلی ادبی شده . نه؟ :wink: )



دقت کنید این کد برای یک کلاس است

Option Explicit

Option Base 1

Dim strText As String, Rselect As Integer

Dim mLenmain As Integer, mlen As Integer

Dim G As Integer

Dim S1 As String, S2 As String

Dim y As Integer, q As String

Public Function Justify(strString As String, Optional ApplyLen As Integer = 50) As String

mLenmain = 0: strText = ""

strText = Trim(strString)

mLenmain = Len(strText)

If mLenmain > ApplyLen Then GoTo EWE

If ApplyLen = 0 Then

ApplyLen = 50

End If

G = ApplyLen - mlen

y = 0

DPO:

mlen = Len(strText)

Rselect = Selectchars(strText)

S1 = Left$(strText, Rselect)

S2 = Right$(strText, mlen - Rselect)

q = "ـ"

y = y + 1

strText = S1 & q & S2

If y < G Then

GoTo DPO

End If

EWE:

Justify = strText

End Function

Private Function Selectchars(Str As String) As Integer

Dim I(25) As Integer, Z As Byte

I(1) = InStr(1, Str, "ب") 

I(2) = InStr(1, Str, "پ") 

I(3) = InStr(1, Str, "ت") 

I(4) = InStr(1, Str, "ث") 

I(5) = InStr(1, Str, "ج") 

I(6) = InStr(1, Str, "چ") 

I(7) = InStr(1, Str, "ح") 

I(8) = InStr(1, Str, "خ") 

I(9) = InStr(1, Str, "س") 

I(10) = InStr(1, Str, "ش") 

I(11) = InStr(1, Str, "ص") 

I(12) = InStr(1, Str, "ض") 

I(13) = InStr(1, Str, "ط") 

I(14) = InStr(1, Str, "ظ") 

I(15) = InStr(1, Str, "ع") 

I(16) = InStr(1, Str, "غ") 

I(17) = InStr(1, Str, "ف") 

I(18) = InStr(1, Str, "ق") 

I(19) = InStr(1, Str, "ک") 

I(20) = InStr(1, Str, "گ") 

I(21) = InStr(1, Str, "ل") 

I(22) = InStr(1, Str, "م") 

I(23) = InStr(1, Str, "ن") 

I(24) = InStr(1, Str, "ه") 

I(25) = InStr(1, Str, "ی") 

RE:

Z = Int(Rnd * 25) + 1

If I(Z) = 0 Or I(Z) = mlen Then GoTo RE

If Mid$(strText, I(Z) + 1, 1) = "ا" Then GoTo RE

If Mid$(strText, I(Z) + 1, 1) = Chr$(32) Then GoTo RE

Selectchars = I(Z)

End Function

Private Sub Class_Initialize()

Call Randomize

End Sub

[روح اله معینی زاده]

:lol: با سلام خدمت جناب دکتر سینوحه و شیما خانم

خدمت جناب دکتر عرض کنم که من دوباره برنامه ای که نوشتم تست کردم و اون موردی که شما فرموده بودید رخ نداد، نمی دانم چرا شما به این مشکل برخورده اید.

کدهای شما (دکتر و شیما خانم که به اختصار «د. و ش.» خواهم نوشت) بسیار برام جالب بود، هم کم و هم کارا. البته من چون زیاد با توابع کار نکرده ام، زیاد از برنامه های شما (د. و ش.) سر در نیاوردم بنابراین سه سوال برام پیش آمد. :oops:

1- منظور از کد Z = Int(Rnd * 25) + 1 که دکتر نوشته و کد I = CheckChars(word, Int(Rnd() * 25)) که شیما خانم نوشته بود، چیه؟

2- کدهایی که شما (د. و ش.) نوشته اید متن رو از کجا شروع به کشیده شدن می کنه؟ کدی که بنده نوشته بودم از انتها شروع به این کار می کرد، شما (د. و ش.) چطور؟

3- نحوه استفاده از کلاس رو هم اصلا در وی بی یاد ندارم. این کد آخر رو که دکتر نوشته بود چطوری باید استفاده کنم؟

ببخشید ها. من وی بی رو با سیخونک کاری یاد گرفتم و یک کتاب مقدماتی رو هم خوندم، بنابراین ناراحت نشید (د. و ش.)

با احترام - خدانگهدار.

[Doctor Sinohe]

با سلام
از بررسی شما متشکرم
پرسش های شما را به ترتیب پاسخ میدهم
1. کد من که نوشته بودم یک عدد بین 1 تا 25 را به صورت تصادفی انتخاب میکرد
2. کدی که من نوشته بودم ابتدا کاراکتر های قابل کشیدن متن را پیدا کرده سپس یکی را به صورت تصادفی انتخاب کرده و یک کاراکتر کشیدگی( ـ ) بعد از ان اضافه میکند و تا جایی این کار را تکرار میکند تا به اندازه مورد نظر متن برسد کد شیما خانم هم فکر کنم همین کار را میکرد
3.شما باید ابتدا یک کلاس ایجاد کنید میتوانید از منوی project و انتخاب add class module (فکر کنم ها الان دقیق یادم نیست :( )این کار رابکنید
نام کلاس را تغییر ندهید و بگزارید همان Class1 بماند بعد کد من را در ان کلاس تایپ کنید ( کپی پیست کنید ) بعد در قسمت نوشتن کد فرم (ّForm1 ) کد زیر را تایپ کنید

dim m as class1

private sub Form_load()

set m = new class1

end sub

حال با متغیر m میتوانید مانند یک شی (مثلا textbox) کار کنید با دستور m.justify متد را فراخوانی کرده بعد از تعیین پارامترها کد را اجرا کنید

موفق باشید

آقای دکتر سینوحه یک زیر برنامه نوشته بودن (CheckChars) که محل شروع هر حروفی را که قابل کشیده شدن بود در آرایه I ذخیره می کرد و بعدا با مقدار رندم Z، یکی از این حروف را انتخاب می کردن ... من فقط این زیربرنامه را به یک تابع تبدیل کردم تا از متغییرهای سراسری کمتر استفاده کنم ... تابع CheckChars رشته را می گیرد و محل حرف Z ام آرایه را بر می گرداند.
I = CheckChars(word, Int(Rnd() * 25)) در این دستور دو پارامتر برای تابع فرستاده می شود و خروجی آن در I قرار می گیرد.
انتخاب حروف برای کشیده کردن هم با استفاده از تابع رندم هست.