M.T.P
چهارشنبه 10 اسفند 1390, 15:06 عصر
دوستان عزیز:
همانطور که احتمالا مستحضر هستید ، تابع زیر برای ارسال کردن ایمیل است و بدون هیچ گونه مشکلی نامه ها رو ارسال میکنه ، اما سوالی که هست اینه که دستور Send در تابع زیر مشمول چند ثانیه زمان برای ارسال هست ( حدودا 5 تا 10 ثانیه ) اگه فایل ضمیمه هم باشه که قائدتا زمان بیشتری رو نیازمند خواهد بود و این طبیعیه اما برای ما vb6 کارها که با Multi Threading مشکل داریم مدت زمان فوق رو باید برنامه صبر کنه تا ایمیل ارسال شه و در برنامه های ما از دیدگاه کاربر برنامه هنگ کرده و ممکنه کاربر از این موضوع اطلاع نداشته باشه و برنامه رو End Process کنه و یا اصلا ممکنه دوست نداشته باشیم این مدت رو منتظر بمونیم و کل برنامه معطل این پروسیجر باشه و علی رغم اینکه تابع DoEvent نمی تونه چاره ساز این موضوع باشه لذا چنانچه راهکار و یا دستور مشابه دیگری در اختیار دارید که این مشکل رو رفع کنه از شما سپاسگزار خواهم بود.
Public Function SendMail(ByVal sMailReciever As String, _
ByVal sMailSender As String, _
ByVal sMailSenderPassword As String, _
ByVal sMailSubject As String, _
ByVal sMailText As String, _
ByVal sMailAttachFile As String) As Boolean
On Error GoTo EndLine
Dim ObMsg As Object
Dim ObConf As Object
Dim Flds As Object
Dim StrSchema As String
Dim blnRet As Boolean
blnRet = False
If sMailSender = vbNullString Or sMailSenderPassword = vbNullString Then
GoTo EndLine
End If
Set ObMsg = CreateObject("CDO.Message")
Set ObConf = CreateObject("CDO.Configuration")
Set Flds = ObConf.Fields
' send one copy with Google SMTP server (with autentication)
StrSchema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(StrSchema & "sendusing") = 2
Flds.Item(StrSchema & "smtpserver") = "smtp.gmail.com"
Flds.Item(StrSchema & "smtpserverport") = 465
Flds.Item(StrSchema & "smtpauthenticate") = 1
Flds.Item(StrSchema & "sendusername") = sMailSender
Flds.Item(StrSchema & "sendpassword") = sMailSenderPassword
Flds.Item(StrSchema & "smtpusessl") = 1
Flds.Update
With ObMsg
.To = sMailReciever
.From = sMailSender
.Subject = sMailSubject
.HTMLBody = sMailText
.Sender = sMailSender
.Organization = "S.M.B Productions"
.ReplyTo = sMailSender
If sMailAttachFile <> vbNullString Then
.AddAttachment (sMailAttachFile)
End If
Set .Configuration = ObConf
.Send
End With
blnRet = True
EndLine:
Set ObMsg = Nothing
Set ObConf = Nothing
Set Flds = Nothing
SendMail = blnRet
End Function
همانطور که احتمالا مستحضر هستید ، تابع زیر برای ارسال کردن ایمیل است و بدون هیچ گونه مشکلی نامه ها رو ارسال میکنه ، اما سوالی که هست اینه که دستور Send در تابع زیر مشمول چند ثانیه زمان برای ارسال هست ( حدودا 5 تا 10 ثانیه ) اگه فایل ضمیمه هم باشه که قائدتا زمان بیشتری رو نیازمند خواهد بود و این طبیعیه اما برای ما vb6 کارها که با Multi Threading مشکل داریم مدت زمان فوق رو باید برنامه صبر کنه تا ایمیل ارسال شه و در برنامه های ما از دیدگاه کاربر برنامه هنگ کرده و ممکنه کاربر از این موضوع اطلاع نداشته باشه و برنامه رو End Process کنه و یا اصلا ممکنه دوست نداشته باشیم این مدت رو منتظر بمونیم و کل برنامه معطل این پروسیجر باشه و علی رغم اینکه تابع DoEvent نمی تونه چاره ساز این موضوع باشه لذا چنانچه راهکار و یا دستور مشابه دیگری در اختیار دارید که این مشکل رو رفع کنه از شما سپاسگزار خواهم بود.
Public Function SendMail(ByVal sMailReciever As String, _
ByVal sMailSender As String, _
ByVal sMailSenderPassword As String, _
ByVal sMailSubject As String, _
ByVal sMailText As String, _
ByVal sMailAttachFile As String) As Boolean
On Error GoTo EndLine
Dim ObMsg As Object
Dim ObConf As Object
Dim Flds As Object
Dim StrSchema As String
Dim blnRet As Boolean
blnRet = False
If sMailSender = vbNullString Or sMailSenderPassword = vbNullString Then
GoTo EndLine
End If
Set ObMsg = CreateObject("CDO.Message")
Set ObConf = CreateObject("CDO.Configuration")
Set Flds = ObConf.Fields
' send one copy with Google SMTP server (with autentication)
StrSchema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(StrSchema & "sendusing") = 2
Flds.Item(StrSchema & "smtpserver") = "smtp.gmail.com"
Flds.Item(StrSchema & "smtpserverport") = 465
Flds.Item(StrSchema & "smtpauthenticate") = 1
Flds.Item(StrSchema & "sendusername") = sMailSender
Flds.Item(StrSchema & "sendpassword") = sMailSenderPassword
Flds.Item(StrSchema & "smtpusessl") = 1
Flds.Update
With ObMsg
.To = sMailReciever
.From = sMailSender
.Subject = sMailSubject
.HTMLBody = sMailText
.Sender = sMailSender
.Organization = "S.M.B Productions"
.ReplyTo = sMailSender
If sMailAttachFile <> vbNullString Then
.AddAttachment (sMailAttachFile)
End If
Set .Configuration = ObConf
.Send
End With
blnRet = True
EndLine:
Set ObMsg = Nothing
Set ObConf = Nothing
Set Flds = Nothing
SendMail = blnRet
End Function