استخراج ایمیل از textbox

[maxtools]

چگونه در یک textbox فقط ایمیل های رو جمع آوری کنیم در یک listbox ????

مثلا فقط اونایی که @yahoo هستن ؟

[Mr'Jamshidy]

خب شما یک نمونه از مقدار اون تکست باکس بزار ما ببینیم فرمت اون تکست باکس چیه تا بتونیم راهنماییت کنیم!

[maxtools]

98104
یک تکس باکس با کلی متن فقط ایمیل ها رو از این تکس باکس استخراج کنه بندازه ایمیل ها رو تو یه لیست باکس همین !!!

[SlowCode]

سلام
با تابع instr کلمه yahoo.com@ رو جستجو کن بعد با instrrev ازاون نقطه کاراکتر فاصله رو جستجو کن و حالا با mid می تونی ایمیل رو بدست بیاری.
اگه تعداد ایمیل ها زیاد باشه این رو توی یه حلقه بنویس.

[maxtools]

سلام
با تابع instr کلمه yahoo.com@ رو جستجو کن بعد با instrrev ازاون نقطه کاراکتر فاصله رو جستجو کن و حالا با mid می تونی ایمیل رو بدست بیاری.
اگه تعداد ایمیل ها زیاد باشه این رو توی یه حلقه بنویس.

میشه خودتون یه زحمت بکشید گیج شدم متاسفانه !!!!! :گیج:

[Mr'Jamshidy]

شما متن بزار من بهت میگم چی کار کنی

با عکس من گیج میشم

[niksalehi]

سلام!
داخل ماژول:


Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "@yahoo.com"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub


بک لیستباکس توی فرم بزار و یک کامند باتن...




Dim res As New Collection
Dim i
Call email(Text1, res )
For i= 1 To res .Count
List1.AddItem res(i)
Next

[maxtools]

سلام!
داخل ماژول:


Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "@yahoo.com"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub


بک لیستباکس توی فرم بزار و یک کامند باتن...




Dim res As New Collection
Dim i
Call email(Text1, res )
For i= 1 To res .Count
List1.AddItem res(i)
Next



98140

متاسفانه خطا میزنه ؟؟؟؟ :افسرده:

[maxtools]

کسی نبود جوابی به ما بده ؟؟؟؟

[Hashemvp]

دوست عزیز این چیزی ک شما میخوای باید یکسری چیزا رو دقیق بدونی ک بتونی ب صورت دقیق درش بیاری
کد هایی ک niksalehi (http://barnamenevis.org/member.php?161132-niksalehi) جان گذاشتن درست هستن البته با یکسری دستکاری درستش کردم ولی خوب مشکل اینجاست که فقط @yahoo.com رو جدا میکنه و ب لیست اضافه میکنه


Public Sub email(sContents$, CResult As Collection)
'On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "@yahoo.com"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& '+ Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, "")
hhh = Len(sContents$)
sHRef$ = Mid(sContents$, lLPos& , Len(sLINK$) )
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub

Private Sub Command1_Click()
Dim res As New Collection
Dim i As Integer
Call email(Text1.Text, res)
For i = 1 To res.Count
List1.AddItem res(i)
Next
End Sub

برای اینکه ایمیل رو ب صورت دقیق بتونی در بیاری باید یکسری نشونه ها داشته باشی یا اینکه بدونی اون ایمیل چند کاراکتر هست

تو الان ی دونه از نشونه ها رو داری ک اون @yahoo.com ک میشه فهمید این اخر ادرس ایمیل هست ولی برای اینکه بدونی اول ادرس ایمیل کجا هست باید یک نشونه اولش باشه
که تو اینو نداری

موفق باشی

[maxtools]

ممنون از لطفت ....

من گیج شدم یعنی چیزی وجود نداره که فقط ایمیل از تکس باکس استخراج کنه ؟؟؟

demo@yahoo.com
demo@gmail.com
demo@domain.ir

رو بندازه تو یه لیست باکس از یک تکس باکس ........ با کلی کد فقط ایمیل ها رو استخراج کنه !!!!

من کدی می خوام که بتونه بین این دستور کد را چاپ کنه



<a href="mailto:"

یعنی بعد از پیدا کردن کد بالا هر چی رو که بین دابل کوتیشن هست رو چاپ کنه . mailto:

[Hashemvp]

دوست عزیز همچنین امکانی میشه ولی در صورتی ک بدونی مثلا بعد از علامت ">" ادرس ایمیل حتما شروع میشه
ولی اینطوری ک هیچ نشونه ای نیست نمیشه فهمید ک ادرس ایمیل از کدوم کاراکتر شروع میشه
@yahoo.com
@gmail.com
@aol.com
و......... رو میشه براحتی پیدا کرد چون تعداد کاراکتر ها و نشونه شروع شدن اونا رو داریم همونطوری ک توی کد بالا ک تغییرش دادم و گذاشتم میتونی ببینی ک @yahoo.com رو پیدا میکنه
ولی نمیتونه تشخیص بده ک ادرس ایمیل از کجا شروع میشه

میشه همچنین کاری کرد و اگر ی نشونه مثل ی کاراکتر یا هر چیز دیگه ای قبل از شروع شدن ادرس ایمیل باشه راحت تر میشه اینکارو کرد ولی اگر هیچ نشونه ای نباشه
باید پروسه طولانی تری رو طی کنی تا بدش بیاری و ی طورایی هوشمند میشه

موفق باشی

[maxtools]

خب معلومه دیگه از mailto: ایمیل شروع میشه !!!!

من فقط اون دسته از ایمیل هایی رو می خوام که از لینک mailto استفاده کردن .

[Hashemvp]

خوب عالیه دوست عزیز با ی خورده دست کاری کد بالا میتونی براحتی ایمیل ها رو بدست بیاری

ی خورده روش کار کن هر جا گیر کردی کد رو بذار با ی نمونه متن ک داشتی روش کار میکردی کمکت میکنم

موفق باشی

[niksalehi]

Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "<a href=""mailto:""
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub

[maxtools]

Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "<a href=""mailto:""
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub




بازم نشد این مسئله خیلی مهم برام خواهشا اگر ممکنه تست کن بعد بزار ....

[niksalehi]

دوست عزیز شما سورس صفحه یا ادرسش رو بزار تا کمکت کنیم.

[maxtools]

من می خوام ایمیل های این پیج رو همه تو یه لیست باکس اد کنم ؟؟؟؟؟ !!!

http://net-boy.ir/test/

[حمید محمودی]

یک text روی فرم قرار بدید خصیصه Multilineش رو True کنید و سورس صفحه رو بریزید توی اون تکست؛
یک List روی فرم قرار داده و کد زیر رو اجرا کنید (تست شده و جواب میده)


Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "<a href=""mailto:"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub

Private Sub Form_Load()

Dim a As Collection
email Text1.Text, a

For i = 1 To a.Count - 1
List1.AddItem a.Item(i)
Next i

End Sub

[maxtools]

خیلی ازت ممنونم کمک بزرگی بهم کردی ...
حالا یه سوال دیگه اما ساده

من می خوام شماره ایرانسل 0936 رو فقط استخراج کنم .

09364813199

تعداد کاراکتر ها شماره همراه 11 تا هست .

که بیاد 0936 رو پیدا کنه با اینت بعد از 0936 تا 7 کاراکتر بعد رو چاپ کنه ؟

[حمید محمودی]

من می خوام شماره ایرانسل 0936 رو فقط استخراج کنم . همون کاری که در پست قبل گفتم رو انجام بدید، منتها اینبار، چند خط دلخواه اون متنی که در Text1 هست رو با عبارت زیر که شماره های دلخواه که پیش شمارهء دلخواه شما رو داشته باشه بدید مثلا :



<p>09361234567</p>


و کد رو بصورت زیر تغییر بدید و اجرا بگیرید (تست کردم، برای استخراج این فرمت از شماره تلفن به درستی کار میکنه و مشکلی نداره)



Public Sub Tel(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "<p>0936"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, "</p>")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub

Private Sub Form_Load()

Dim a As Collection
Tel Text1.Text, a

For i = 1 To a.Count
List1.AddItem "0936" & a.Item(i)
Next i

End Sub

[maxtools]

ممنون /
فقط یه مشکلی هست اگه طرف از تگ <p> استفاده نکنه دیگه پیداش نمی تونه بکنه ؟

[حمید محمودی]

اگه طرف از تگ <p> استفاده نکنه دیگه پیداش نمی تونه بکنه

خب باید مطابق با سورسی که دارید به دنبال اون متن بگردید؛ پس وقتی شما سورسی قرار ندادید ما هم نمیتونیم "حدس" بزنیم که اون شخصی که در ذهن شماست چطوری سایتش رو ساخته و از چه تگی استفاده کرده! و برای همین یک مثال برای شما اوردم که مثلا اگه تگ <p> بود، به اون صورت عمل کنید....

[maxtools]

خب با فرض این که به این شکل نوشته شده .


<font face="tahoma" size="2>matn ////////////////// 0936000000 sdfdsfsfsdfsfsdf</font>
ya be en shekl

<font face="tahoma" size="2>dfsdfsdfsf0936000000sdfsdfsdfsf</font>
ya en shekl

<font face="tahoma" size="2></img src="sdfdsfdsf.jpg">093600000000sdsdfsf</font>

اول باید 0936 رو پیدا کرد و آدرس این کاراکتر رو از تکس باکس گرفت و فقط 7 کاراکتر جلو رو چاپ کنه من فقط گیر اینم که چطور از 0936 به جلو فقط 7 کاراکتر رو چاپ کنه ؟

[محسن واژدی]

خب با فرض این که به این شکل نوشته شده .


<font face=&quot;tahoma&quot; size=&quot;2>matn ////////////////// 0936000000 sdfdsfsfsdfsfsdf</font>ya be en shekl

<font face=&quot;tahoma&quot; size=&quot;2>dfsdfsdfsf0936000000sdfsdfsdfsf</font>ya en shekl

<font face=&quot;tahoma&quot; size=&quot;2></img src=&quot;sdfdsfdsf.jpg&quot;>093600000000sdsdfsf</font>اول باید 0936 رو پیدا کرد و آدرس این کاراکتر رو از تکس باکس گرفت و فقط 7 کاراکتر جلو رو چاپ کنه من فقط گیر اینم که چطور از 0936 به جلو فقط 7 کاراکتر رو چاپ کنه ؟

سلام علیکم
کد زیر را بررسی کنید:
Private Sub Command1_Click()
Const sTarTxt$ = "0936"
Dim iFPos%, sRes$
iFPos% = InStr(1, Text1, sTarTxt$)
sRes$ = Mid(sConstTarTxt$, iFPos%, Len(sTarTxt$) + 6)
End Sub


بجای Text1 متن مورد نظر جایگزین کنید
موفق باشید

[maxtools]

خیلی آقایی ممنون ... :قلب:

[maxtools]

حلقه ایی که همه ی شماره ها رو سرچ کنه چی ؟

If InStr(1, Text1.Text, "0936") > 0 Then
Dim b, x As String
b = InStr(1, Text1.Text, "0936")
x = Mid(Text1.Text, b, Len("0936") + 7)

List1.AddItem (x)

Else
End If

[maxtools]

یک text روی فرم قرار بدید خصیصه Multilineش رو True کنید و سورس صفحه رو بریزید توی اون تکست؛
یک List روی فرم قرار داده و کد زیر رو اجرا کنید (تست شده و جواب میده)


Public Sub email(sContents$, CResult As Collection)
On Error Resume Next
Dim sHRef$, lQutePos&
Dim lLPos&
Const sLINK$ = "<a href=""mailto:"
Set CResult = New Collection

Do
lLPos& = InStr(lLPos& + 1, sContents$, sLINK$, vbTextCompare)

If lLPos& > 0 Then
lLPos& = lLPos& + Len(sLINK$)
lQutePos& = InStr(lLPos& + 1, sContents$, """")
sHRef$ = Mid(sContents$, lLPos&, lQutePos& - lLPos&)
If sHRef$ > "" Then
CResult.Add sHRef$
End If
End If
Loop Until lLPos& = 0
End Sub

Private Sub Form_Load()

Dim a As Collection
email Text1.Text, a

For i = 1 To a.Count - 1
List1.AddItem a.Item(i)
Next i

End Sub




نمی دونم چرا کار نمی کنه ..... ؟
98323

تو رو خدا دانلود کنید ببینم مشکل چیه هر چی نگاه کردم نتیجه ایی دربر نداشت !!!!

[Hashemvp]

دوست عزیز اگه ی خورده ب کد ها دقت کنی متوجه میشی
برات تغییرش دادم و اپلود کردم اینم لینکش
http://uplod.ir/t7qwqo86slsa/Search_Email.zip.htm

صد در صد تست شده:لبخند:
موفق باشی

[maxtools]

تنکیوووو :قلب:

[محسن واژدی]

حلقه ایی که همه ی شماره ها رو سرچ کنه چی ؟

If InStr(1, Text1.Text, "0936") > 0 Then
Dim b, x As String
b = InStr(1, Text1.Text, "0936")
x = Mid(Text1.Text, b, Len("0936") + 7)

List1.AddItem (x)

Else
End If

کد زیر بررسی کنین:
Private Sub Command1_Click()
Const sTarTxt$ = "0936"
Dim iFPos%, sRes$
sConstTarTxt$ = Text1
Do
iFPos% = InStr(iFPos% + 1, sConstTarTxt$, sTarTxt$)
If iFPos% > 0 Then
sRes$ = Mid(sConstTarTxt$, iFPos%, Len(sTarTxt$) + 7)
Debug.Print sRes$
End If
Loop While iFPos% > 0

End Sub

موفق باشید