Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO? / Microsoft Access

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Microsoft Access [игнор отключен] [закрыт для гостей] / Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

25 сообщений из 25, страница 1 из 1

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987721

Loxinfo

Гость

Уважаемые гуру!
Подскажите пожалуйста как изменить существующий код, которы использовал vbSendMail, на код на отправку через CDO
Обычный код, который делает рассылку, я исправил, прилагаю его в ниде в "спойлере"
Но, есть еще код на форме, которая также отвечает за отправку писем, там все очень сложно, я не знаю VBA и MS Access настолько хорошо, а человек, который это делал, сейчас не доступен...

Помогите советом или примером

Код, которы нужно изменить
Option Compare Database
Option Explicit

' WIN32 API
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long

Private Const VK_RETURN = &HD

Private Const WM_CHAR = &H102

Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5

'--------------------------------------
Private Const SMTP_SERVER_HOST = "webhosting2037.is.cc" '"mail.talisman.co.th "
Private Const SMTP_SERVER_PORT = 587 '26 '465 '587 '25
'--------------------------------------

Private strFrom As String, strFromDisplayName As String
Private strTo As String, strToDisplayName As String
Private strReplyTo As String
Private strCC As String, strCCDisplayName As String
Private strBCC As String
Private bolAuthenticate As Boolean, strUsername As String, strPassword As String
Private strHTML As String, strSubject As String

Private WithEvents objSendMail As vbSendMail.clsSendMail

Private Sub cmdSend_Click()

On Error GoTo Errhandler
strHTML = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
strSubject = Me![txtSubject]

If Len(strHTML) = 0 Then
If MsgBox("ARE YOU SURE YOU WOULD LIKE TO SEND MESSAGE WITH AN EMPTY BODY?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then
Exit Sub
End If
End If

Set objSendMail = New vbSendMail.clsSendMail

'THE REAL ONE!!! Uncomment when ready
Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
strFrom, strFromDisplayName, _
strTo, strToDisplayName, _
strCC, strCCDisplayName, _
strBCC, _
strReplyTo, _
strSubject, strHTML, True, "", _
bolAuthenticate, strUsername, strPassword)

'EXAMPLE
'Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
' SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
' strFrom, strFromDisplayName, _
' "andrey@teleoss.com", "Talisman Travel", _
' "", "", _
' "andrey.kouprianov@gmail.com", _
' strReplyTo, _
' strSubject, strHTML, True, "", _
' bolAuthenticate, strUsername, strPassword)

objSendMail.Send

Set objSendMail = Nothing

Finalizer:
Exit Sub

Errhandler:
MsgBox Err.Description, vbExclamation, "Talisman Travel"
Resume Finalizer
End Sub

Private Sub objSendMail_SendFailed(Explanation As String)
MsgBox ("SENDING EMAIL FAILED FOR THE FOLLOWING REASON(S): " & vbCrLf & UCase(Explanation))
End Sub

Private Sub objSendMail_SendSuccesful()
MsgBox "YOUR EMAIL WAS SENT OUT SUCCESSFULLY"
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
On Error Resume Next
If KeyCode <> vbKeyReturn Then Exit Sub

If Screen.ActiveControl <> Me.WBrowser Then
Exit Sub
Else
' Eat this Key
KeyCode = 0
'Send CR to WebBrowser control
Call SendEnterKey(Me.hwnd)
End If
End Sub

Private Sub Form_Load()
Dim strArgs As Variant
Dim arrItems As Variant

On Error GoTo Errhandler

Me.WBrowser.Object.Navigate "about:blank"
Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
DoEvents
Loop

Me.WBrowser.Object.Document.designMode = "On"
Me.WBrowser.Object.Document.execCommand "AbsolutePosition", False, True
Me.WBrowser.Object.Document.execCommand "2D-Position", False, True

Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
DoEvents
Loop

strArgs = Me.OpenArgs & vbNullString
If Len(strArgs) = 0 Then
GoTo Finalizer
End If

arrItems = Split(strArgs, Chr(1))

strFrom = CStr(arrItems(0)) & vbNullString
strFromDisplayName = CStr(arrItems(1)) & vbNullString

strTo = CStr(arrItems(2)) & vbNullString
strToDisplayName = CStr(arrItems(3)) & vbNullString

strCC = CStr(arrItems(4)) & vbNullString
strCCDisplayName = CStr(arrItems(5)) & vbNullString

strBCC = CStr(arrItems(6)) & vbNullString

strReplyTo = CStr(arrItems(7)) & vbNullString

strSubject = CStr(arrItems(8)) & vbNullString
strHTML = CStr(arrItems(9)) & vbNullString

bolAuthenticate = CBool(arrItems(10)) & vbNullString
strUsername = CStr(arrItems(11)) & vbNullString
strPassword = CStr(arrItems(12)) & vbNullString

If Len(strFrom) = 0 Then
Call MsgBox("NO SENDER ADDRESS SPECIFIED! YOU WILL NOT BE ABLE TO SEND THIS EMAIL", vbYesNo + vbExclamation, Me.Caption)
cmdSend.Enabled = False
GoTo Finalizer
ElseIf Len(strTo) = 0 Then
cmdSend.Enabled = False
Call MsgBox("NO RECIPIENT ADDRESS SPECIFIED! YOU WILL NOT BE ABLE TO SEND THIS EMAIL", vbYesNo + vbExclamation, Me.Caption)
GoTo Finalizer
End If

'==========================================================
Me![txtFrom] = ""
If Len(strFromDisplayName) > 0 Then
Me![txtFrom] = """" & strFromDisplayName & """ "
End If
Me![txtFrom] = Me![txtFrom] & "<" & strFrom & ">"

Me![txtTo] = ""
If Len(strToDisplayName) > 0 Then
Me![txtTo] = """" & strToDisplayName & """ "
End If
Me![txtTo] = Me![txtTo] & "<" & strTo & ">"

If Len(strCC) > 0 Then
Me![txtCC] = ""
If Len(strCCDisplayName) > 0 Then
Me![txtCC] = """" & strCCDisplayName & """ "
End If
Me![txtCC] = Me![txtCC] & "<" & strCC & ">"
End If

Me![txtBCC] = ""
If Len(strBCC) > 0 Then
Me![txtBCC] = "<" & strBCC & ">"
End If

Me![txtReplyTo] = ""
If Len(strReplyTo) > 0 Then
Me![txtReplyTo] = strReplyTo
End If

Me![txtSubject] = strSubject

' Write the HTML to our Browser
Me.WBrowser.Object.Document.Body.innerHTML = strHTML

Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
DoEvents
Loop

Me.txtSubject.SetFocus
Finalizer:
Exit Sub

Errhandler:
MsgBox Err.Description, vbExclamation, "Talisman Travel"
Resume Finalizer
End Sub

Private Sub Form_Unload(Cancel As Integer)

End Sub

Public Sub SendEnterKey(hwndForm As Long)
Dim lngTemp1 As Long
Dim lngTemp2 As Long
Dim lngRet As Long

Dim hWndShell As Long
Dim hwnd As Long
Dim hWndDetail As Long

hWndDetail = 0
' Find Detail Window
hWndDetail = FindDetailWindow(hwndForm)

If hWndDetail = 0 Then Exit Sub
' Find "Shell Embedding" child window
hWndShell = FindWindowEx(hWndDetail, 0&, "Shell Embedding", "")
If hWndShell = 0 Then Exit Sub

' Find Doc window
hWndShell = FindWindowEx(hWndShell, 0&, "Shell DocObject View", "")
If hWndShell = 0 Then Exit Sub

' Find Explorer window
hwnd = FindWindowEx(hWndShell, 0&, "Internet Explorer_Server", "")
If hwnd = 0 Then Exit Sub

' Generate Enter key
lngTemp1 = MapVirtualKey(VK_RETURN, 0&)
lngTemp2 = MakeDWord(1, CInt(lngTemp1))

lngRet = PostMessage(hwnd, WM_CHAR, 13, lngTemp2)
'''lngTemp1 = MapVirtualKey(10, 0&)
'''lngTemp2 = MakeDWord(1, CInt(lngTemp1))
lngRet = PostMessage(hwnd, WM_CHAR, 10, lngTemp2)

DoEvents
End Sub

Private Function GetWindowClassName(hwnd As Long)
Const MAX_LEN = 256
Dim strBuffer As String
Dim lngLen As Long

strBuffer = Space$(MAX_LEN)
lngLen = GetClassName(hwnd, strBuffer, MAX_LEN)
If lngLen > 0 Then GetWindowClassName = Left$(strBuffer, lngLen)
End Function

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Function FindDetailWindow(ByVal frmhWnd As Long) As Long
' The Detail Window is always the second of three
' windows of class OFormSub.
' 1) Form Header
' 2) Detail
' 3) Footer

Dim hWnd_VSB As Long
Dim hwnd As Long
Dim ctr As Long

ctr = 0
hwnd = frmhWnd

' Let's get first Child Window of the FORM
hWnd_VSB = GetWindow(hwnd, GW_CHILD)

' Let's walk through every sibling window of the Form
Do
' Thanks to Terry Kreft for explaining
' why the apiGetParent acll is not required.
' Terry is in a Class by himself! :-)
'If apiGetParent(hWnd_VSB) <> hWnd Then Exit Do

If GetWindowClassName(hWnd_VSB) = "OFormSub" Then
ctr = ctr + 1
If ctr = 2 Then
FindDetailWindow = hWnd_VSB
Exit Function
End If

End If

' Let's get the NEXT SIBLING Window
hWnd_VSB = GetWindow(hWnd_VSB, GW_HWNDNEXT)

' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_VSB <> 0

' SORRY - This is impossible but there is no Detail Window!
FindDetailWindow = 0
End Function

Исправленный, рабочий код
Private Sub SendCDOEmail_Click()
On Error GoTo ErrSend

Dim strFromDisplayName As String
Dim strTo As String, strToDisplayName As String
Dim strCCDisplayName As String
Dim strReplyTo As String
Dim strSubject As String
Dim strMsg As String
Dim strAttachment As String
Dim MsgHtml As String

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String

Dim msg As Object
Dim config As String

Set msg = CreateObject("CDO.Message")
config = " http://schemas.microsoft.com/cdo/configuration/"

With msg
Set dbs = CurrentDb()
strSQL = "SELECT GenMail FROM Hotels WHERE Hotel=""" & Me![Hotel] & """"
Set rst = dbs.OpenRecordset(strSQL)
.To = rst.Fields("GenMail") & vbNullString
rst.Close
Set rst = Nothing
strToDisplayName = ""

If Len(Trim(.To)) = 0 Then
.To = InputBox("THIS HOTEL HAS NO EMAIL ADDRESS. PLEASE, SPECIFY YOUR OWN", "EMAIL ADDRESS", "")

If Len(Trim(.To)) = 0 Then
MsgBox "THIS HOTEL HAS NO EMAIL ADDRESS. PLEASE, SPECIFY HOTEL'S EMAIL ADDRESS FIRST AND TRY AGAIN LATER", _
vbQuestion + vbOKOnly, "EMAIL"

Exit Sub
End If
End If

.From = "Talisman Travel <info@co.th>;"

.CC = "HotelContract <info@com>;"

.ReplyTo = "info@co.th"

.Subject = "Attn.: " & Me![Manager] & ", " & Me![First]

.HTMLBody = CreateHTMLReport
'.AddAttachment myAttachment

With .Configuration.Fields
.Item(config & "sendusing") = 2
.Item(config & "smtpserver") = "mail.com"
.Item(config & "smtpauthenticate") = 1
.Item(config & "smtpserverport") = 465
.Item(config & "sendusername") = "info@com"
.Item(config & "sendpassword") = "***************"
.Item(config & "smtpusessl") = True
.Item(config & "smtpconnectiontimeout") = 60
.Update
End With

.Send
End With

Set rst = Nothing
Set msg = Nothing

MsgBox "Birth Notice Email processing has been completed", vbOKOnly + vbInformation, "Email Complete"

ExitSend:
Exit Sub

ErrSend:

msg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext

'MsgBox "An Email processing error has occurred. Please retry sending Emails.", vbOKOnly + vbInformation, "Email Error"
Resume ExitSend
End Sub

...

Рейтинг:

0 / 0

08.08.2020, 10:37

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987725

ROI

Участник

Откуда: г. Тюмень

Сообщения: 2 326

Рейтинг: 0 / 0

Loxinfo,

так для примера:

Код: vbnet

'***************************************************************************
'               Дата последнего изменения 17.06.2019
'
'               Функция отправки сообщений по почте
'
'входные параметры:
'
'emailTo - адрес получателя
'emailFrom - адрес отправителя
'emailSubject - тема письма
'emailBody - текст письма
'emailServerName -
'
'***************************************************************************
Public Function roi_SendEmail(emailTo As String, emailFrom As String, emailSubject As String, _
                            emailBody As String, emailServerName As String, Optional VarDebug As Boolean) As String
    Dim oMSG As Object
    Dim oConfig As Object
    Dim CFields As Object
    Dim strBody As String
On Error GoTo HandleError

    'создаем объект Message это наше письмо
    Set oMSG = CreateObject("CDO.Message")
    'создаем объект Configuration это настройки соединения
    Set oConfig = CreateObject("CDO.Configuration")
    Set CFields = oConfig.Fields
    Set oMSG.Configuration = oConfig
    
    CFields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    'адрес SMTP сервера
    CFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = emailServerName
    
    CFields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    CFields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    CFields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Pupkin" 'Login
    CFields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "qwerty" 'password
    CFields("urn:schemas:mailheader:content-language") = "windows-1251"
    CFields.Update
    
    oMSG.To = emailTo                       'адрес получателя
    oMSG.FROM = emailFrom                   'адрес отправителя
    oMSG.Subject = emailSubject             ' тема письма
    oMSG.BodyPart.Charset = "windows-1251"  ' кодировака письма
    'oMSG.AddAttachment "c:\temp\Test0.rtf" 'путь к вложенному файлу
    'формируем HTML текст который будет телом письма
    'Примечание: HTMLBody может содержать любое HTML форматирование такое как "font" "table" "img" и т.п.
    oMSG.TextBody = emailBody
    oMSG.Send
    
    roi_SendEmail = "1"   'если писмо успешно оправлено

ExitProc:
    Set CFields = Nothing
    Set oConfig = Nothing
    Set oMSG = Nothing
    Exit Function
HandleError:
    roi_SendEmail = Err.Description  'если писмо не удалось оправить
    If Not IsNull(VarDebug) Then If VarDebug Then MsgBox (Err.Description)
    MsgBox Err.Number & _
            vbCrLf & Err.Description & _
            vbCrLf & vbCrLf & "Имя процедуры = roi_SendEmail", _
            vbCritical, "Ошибка отправки почты !!!"
    Resume ExitProc
End Function

...

Рейтинг:

0 / 0

08.08.2020, 11:32

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987739

Loxinfo

Гость

ROI, Спасибо..
Я видел аналогичный код и использовал его в программе по рассылке почты.
Но я не могу (не знаю как) внедрить его в код, который я указал выше, там слишком все сложно

...

Рейтинг:

0 / 0

08.08.2020, 13:21

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987745

ROI

Участник

Откуда: г. Тюмень

Сообщения: 2 326

Рейтинг: 0 / 0

Loxinfo

Я не могу понять про какой код вы говорите.
Вы вывалили две не форматированные портянки.
Выложите конкретный кусочек кода, который "готовит" данные, для отправки почтового сообщения.

...

Рейтинг:

0 / 0

08.08.2020, 13:29

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987748

Loxinfo

Гость

ROI, это первая часть кода, где есть данные по отправке почты, но как я вижу, в коде эти данные встречаются еще

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.

Option Compare Database
Option Explicit

' WIN32 API
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
    
Private Declare Function GetClassName Lib "user32" _
    Alias "GetClassNameA" _
    (ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) _
    As Long
    
Private Const VK_RETURN = &HD

Private Const WM_CHAR = &H102

Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5



'--------------------------------------
Private Const SMTP_SERVER_HOST = "webhosting2037.is.cc" '"mail.talisman.co.th "
Private Const SMTP_SERVER_PORT = 587 '26 '465 '587 '25
'--------------------------------------


Private strFrom As String, strFromDisplayName As String
Private strTo As String, strToDisplayName As String
Private strReplyTo As String
Private strCC As String, strCCDisplayName As String
Private strBCC As String
Private bolAuthenticate As Boolean, strUsername As String, strPassword As String
Private strHTML As String, strSubject As String

Private WithEvents objSendMail As vbSendMail.clsSendMail

Private Sub cmdSend_Click()

On Error GoTo Errhandler
    strHTML = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
    strSubject = Me![txtSubject]
    
    If Len(strHTML) = 0 Then
        If MsgBox("ARE YOU SURE YOU WOULD LIKE TO SEND MESSAGE WITH AN EMPTY BODY?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then
            Exit Sub
        End If
    End If

    Set objSendMail = New vbSendMail.clsSendMail
    
    'THE REAL ONE!!! Uncomment when ready
    Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
                                                SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
                                                strFrom, strFromDisplayName, _
                                                strTo, strToDisplayName, _
                                                strCC, strCCDisplayName, _
                                                strBCC, _
                                                strReplyTo, _
                                                strSubject, strHTML, True, "", _
                                                bolAuthenticate, strUsername, strPassword)
    
    'EXAMPLE
    'Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
    '                                            SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
    '                                            strFrom, strFromDisplayName, _
    '                                            "andrey@teleoss.com", "Talisman Travel", _
    '                                            "", "", _
    '                                            "andrey.kouprianov@gmail.com", _
    '                                            strReplyTo, _
    '                                            strSubject, strHTML, True, "", _
    '                                            bolAuthenticate, strUsername, strPassword)
    
    objSendMail.Send
    
    Set objSendMail = Nothing

Finalizer:
    Exit Sub

Errhandler:
    MsgBox Err.Description, vbExclamation, "Talisman Travel"
    Resume Finalizer
End Sub

Private Sub objSendMail_SendFailed(Explanation As String)
    MsgBox ("SENDING EMAIL FAILED FOR THE FOLLOWING REASON(S): " & vbCrLf & UCase(Explanation))
End Sub

Private Sub objSendMail_SendSuccesful()
    MsgBox "YOUR EMAIL WAS SENT OUT SUCCESSFULLY"
End Sub

...

Рейтинг:

0 / 0

08.08.2020, 13:33

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987749

Loxinfo

Гость

ROI, и тут есть данные по куда, от кого и т.д.

Код: vbnet

Private Sub Form_Load()
Dim strArgs As Variant
Dim arrItems As Variant
    
On Error GoTo Errhandler

    Me.WBrowser.Object.Navigate "about:blank"
    Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
        DoEvents
    Loop
    
    Me.WBrowser.Object.Document.designMode = "On"
    Me.WBrowser.Object.Document.execCommand "AbsolutePosition", False, True
    Me.WBrowser.Object.Document.execCommand "2D-Position", False, True
    
    Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
        DoEvents
    Loop
      
    strArgs = Me.OpenArgs & vbNullString
    If Len(strArgs) = 0 Then
        GoTo Finalizer
    End If

    arrItems = Split(strArgs, Chr(1))
    
    strFrom = CStr(arrItems(0)) & vbNullString
    strFromDisplayName = CStr(arrItems(1)) & vbNullString
    
    strTo = CStr(arrItems(2)) & vbNullString
    strToDisplayName = CStr(arrItems(3)) & vbNullString
    
    strCC = CStr(arrItems(4)) & vbNullString
    strCCDisplayName = CStr(arrItems(5)) & vbNullString
    
    strBCC = CStr(arrItems(6)) & vbNullString
    
    strReplyTo = CStr(arrItems(7)) & vbNullString
    
    strSubject = CStr(arrItems(8)) & vbNullString
    strHTML = CStr(arrItems(9)) & vbNullString
    
    bolAuthenticate = CBool(arrItems(10)) & vbNullString
    strUsername = CStr(arrItems(11)) & vbNullString
    strPassword = CStr(arrItems(12)) & vbNullString
    
    If Len(strFrom) = 0 Then
        Call MsgBox("NO SENDER ADDRESS SPECIFIED! YOU WILL NOT BE ABLE TO SEND THIS EMAIL", vbYesNo + vbExclamation, Me.Caption)
        cmdSend.Enabled = False
        GoTo Finalizer
    ElseIf Len(strTo) = 0 Then
        cmdSend.Enabled = False
        Call MsgBox("NO RECIPIENT ADDRESS SPECIFIED! YOU WILL NOT BE ABLE TO SEND THIS EMAIL", vbYesNo + vbExclamation, Me.Caption)
        GoTo Finalizer
    End If
    
    '==========================================================
    Me![txtFrom] = ""
    If Len(strFromDisplayName) > 0 Then
        Me![txtFrom] = """" & strFromDisplayName & """ "
    End If
    Me![txtFrom] = Me![txtFrom] & "<" & strFrom & ">"
    
    Me![txtTo] = ""
    If Len(strToDisplayName) > 0 Then
        Me![txtTo] = """" & strToDisplayName & """ "
    End If
    Me![txtTo] = Me![txtTo] & "<" & strTo & ">"
    
    If Len(strCC) > 0 Then
        Me![txtCC] = ""
        If Len(strCCDisplayName) > 0 Then
            Me![txtCC] = """" & strCCDisplayName & """ "
        End If
        Me![txtCC] = Me![txtCC] & "<" & strCC & ">"
    End If
    
    Me![txtBCC] = ""
    If Len(strBCC) > 0 Then
        Me![txtBCC] = "<" & strBCC & ">"
    End If
    
    Me![txtReplyTo] = ""
    If Len(strReplyTo) > 0 Then
        Me![txtReplyTo] = strReplyTo
    End If
    
    Me![txtSubject] = strSubject

    ' Write the HTML to our Browser
    Me.WBrowser.Object.Document.Body.innerHTML = strHTML

    Do While Me.WBrowser.Object.ReadyState <> READYSTATE_COMPLETE ' loaded
        DoEvents
    Loop
    
    Me.txtSubject.SetFocus
Finalizer:
    Exit Sub

Errhandler:
    MsgBox Err.Description, vbExclamation, "Talisman Travel"
    Resume Finalizer
End Sub

...

Рейтинг:

0 / 0

08.08.2020, 13:35

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987762

alecko

Участник

Откуда: Башкирия

Сообщения: 852

Рейтинг: 0 / 0

Loxinfo, этот код формирует html страницу с данными для отправки в браузере (вероятно active-x элемент)-
в вашей процедуре попробуйте заменить
.HTMLBody = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
.Subject = Me![txtSubject]

...

Рейтинг:

0 / 0

08.08.2020, 14:42

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987776

Loxinfo

Гость

alecko, извините, вы про первую часть кода или про вторую?
Мне нужно чтобы код отправлял HTML формы по CDO, т.к. vbSendMail уже не работает из за того что повышен уровень защиты на серверах

...

Рейтинг:

0 / 0

08.08.2020, 16:05

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987790

DarkMan

Участник

Сообщения: 1 041

Рейтинг: 0 / 0

Loxinfo

Я не смотрел эти обе портянки , так как нет ни времени ни желания разбираться. Посмотрите , может здесь есть то , что Вас интересует. 21876378

...

Рейтинг:

0 / 0

08.08.2020, 17:20

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987794

alecko

Участник

Откуда: Башкирия

Сообщения: 852

Рейтинг: 0 / 0

Loxinfo,
этот 22179535
присваиваются публичным и не только переменным различные данные, которые используются при отправке письма- куда, кому и пр., формируется html код и потом присваивается элемнту формы(браузер) (проконтролировать может надо)
- этот код трогать вообще не нужно.
здесь 22179534 - отправляется письмо, вместо этого кода (Private Sub cmdSend_Click()) вы и создали свой, но данные в своем коде вам нужно заменить на созданные ранее в 1-м модуле (они Private соответственно доступны в модуле).

примерно

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.

.From = strFrom 
.CC = strCC 
.ReplyTo =strReplyTo 
.Subject = Me![txtSubject]
.HTMLBody = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
With .Configuration.Fields
.Item(config & "sendusing") = 2
.Item(config & "smtpserver") = SMTP_SERVER_HOST ' здесь наверное один сервер нужно оставить
.Item(config & "smtpauthenticate") = bolAuthenticate 
.Item(config & "smtpserverport") = SMTP_SERVER_PORT
.Item(config & "sendusername") = strUsername 
.Item(config & "sendpassword") = strPassword 
.Item(config & "smtpusessl") = True
.Item(config & "smtpconnectiontimeout") = 60
.Update
End With

...

Рейтинг:

0 / 0

08.08.2020, 17:59

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987795

Loxinfo

Гость

DarkMan, спасибо
То что вы дали, это код, который я сам постнул в одной из "портянок"
Вопрос в том, как изменить код в первой "портянке" чтобы он использовал CDO
поверьте, я прошерстил кучу форумов на нескольких яыках, перед тем как сделать этот пост.

...

Рейтинг:

0 / 0

08.08.2020, 17:59

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987796

Loxinfo

Гость

alecko,
как мне это вставить сюда

Код: vbnet

Option Compare Database
Option Explicit

' WIN32 API
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
    
Private Declare Function GetClassName Lib "user32" _
    Alias "GetClassNameA" _
    (ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) _
    As Long
    
Private Const VK_RETURN = &HD

Private Const WM_CHAR = &H102

Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5



'--------------------------------------
Private Const SMTP_SERVER_HOST = "webhosting2037.is.cc" '"mail.talisman.co.th "
Private Const SMTP_SERVER_PORT = 587 '26 '465 '587 '25
'--------------------------------------


Private strFrom As String, strFromDisplayName As String
Private strTo As String, strToDisplayName As String
Private strReplyTo As String
Private strCC As String, strCCDisplayName As String
Private strBCC As String
Private bolAuthenticate As Boolean, strUsername As String, strPassword As String
Private strHTML As String, strSubject As String

Private WithEvents objSendMail As vbSendMail.clsSendMail

Private Sub cmdSend_Click()

On Error GoTo Errhandler
    strHTML = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
    strSubject = Me![txtSubject]
    
    If Len(strHTML) = 0 Then
        If MsgBox("ARE YOU SURE YOU WOULD LIKE TO SEND MESSAGE WITH AN EMPTY BODY?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then
            Exit Sub
        End If
    End If

    Set objSendMail = New vbSendMail.clsSendMail
    
    'THE REAL ONE!!! Uncomment when ready
    Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
                                                SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
                                                strFrom, strFromDisplayName, _
                                                strTo, strToDisplayName, _
                                                strCC, strCCDisplayName, _
                                                strBCC, _
                                                strReplyTo, _
                                                strSubject, strHTML, True, "", _
                                                bolAuthenticate, strUsername, strPassword)
    
    'EXAMPLE
    'Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
    '                                            SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
    '                                            strFrom, strFromDisplayName, _
    '                                            "andrey@teleoss.com", "Talisman Travel", _
    '                                            "", "", _
    '                                            "andrey.kouprianov@gmail.com", _
    '                                            strReplyTo, _
    '                                            strSubject, strHTML, True, "", _
    '                                            bolAuthenticate, strUsername, strPassword)
    
    objSendMail.Send
    
    Set objSendMail = Nothing

Finalizer:
    Exit Sub

Errhandler:
    MsgBox Err.Description, vbExclamation, "Talisman Travel"
    Resume Finalizer
End Sub

...

Рейтинг:

0 / 0

08.08.2020, 18:01

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987797

Loxinfo

Гость

alecko,
я пробовал менять все, мне знавомые, варианты, ничего, форма не грузится или не работае

...

Рейтинг:

0 / 0

08.08.2020, 18:03

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987798

Loxinfo

Гость

alecko, извините
можно подробнее, что и на что я должен поменять в

Код: vbnet

'--------------------------------------
Private Const SMTP_SERVER_HOST = "webhosting2037.is.cc" '"mail.talisman.co.th "
Private Const SMTP_SERVER_PORT = 587 '26 '465 '587 '25
'--------------------------------------


Private strFrom As String, strFromDisplayName As String
Private strTo As String, strToDisplayName As String
Private strReplyTo As String
Private strCC As String, strCCDisplayName As String
Private strBCC As String
Private bolAuthenticate As Boolean, strUsername As String, strPassword As String
Private strHTML As String, strSubject As String

Private WithEvents objSendMail As vbSendMail.clsSendMail

Private Sub cmdSend_Click()

On Error GoTo Errhandler
    strHTML = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
    strSubject = Me![txtSubject]
    
    If Len(strHTML) = 0 Then
        If MsgBox("ARE YOU SURE YOU WOULD LIKE TO SEND MESSAGE WITH AN EMPTY BODY?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then
            Exit Sub
        End If
    End If

    Set objSendMail = New vbSendMail.clsSendMail
    
    'THE REAL ONE!!! Uncomment when ready
    Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
                                                SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
                                                strFrom, strFromDisplayName, _
                                                strTo, strToDisplayName, _
                                                strCC, strCCDisplayName, _
                                                strBCC, _
                                                strReplyTo, _
                                                strSubject, strHTML, True, "", _
                                                bolAuthenticate, strUsername, strPassword)
    
    'EXAMPLE
    'Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
    '                                            SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
    '                                            strFrom, strFromDisplayName, _
    '                                            "andrey@teleoss.com", "Talisman Travel", _
    '                                            "", "", _
    '                                            "andrey.kouprianov@gmail.com", _
    '                                            strReplyTo, _
    '                                            strSubject, strHTML, True, "", _
    '                                            bolAuthenticate, strUsername, strPassword)
    
    objSendMail.Send
    
    Set objSendMail = Nothing

Finalizer:
    Exit Sub

Errhandler:
    MsgBox Err.Description, vbExclamation, "Talisman Travel"
    Resume Finalizer
End Sub

Private Sub objSendMail_SendFailed(Explanation As String)
    MsgBox ("SENDING EMAIL FAILED FOR THE FOLLOWING REASON(S): " & vbCrLf & UCase(Explanation))
End Sub

Private Sub objSendMail_SendSuccesful()
    MsgBox "YOUR EMAIL WAS SENT OUT SUCCESSFULLY"
End Sub

и главное где?
я пробовал много вариантов, акс ругается

...

Рейтинг:

0 / 0

08.08.2020, 18:07

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987799

alecko

Участник

Откуда: Башкирия

Сообщения: 852

Рейтинг: 0 / 0

Loxinfo,

выкидываете(можно заремить) эту процедуру

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.

Private Sub cmdSend_Click()

On Error GoTo Errhandler
    strHTML = Me.WBrowser.Object.Document.Body.innerHTML & vbNullString
    strSubject = Me![txtSubject]
    
    If Len(strHTML) = 0 Then
        If MsgBox("ARE YOU SURE YOU WOULD LIKE TO SEND MESSAGE WITH AN EMPTY BODY?", vbYesNo + vbQuestion, Me.Caption) = vbNo Then
            Exit Sub
        End If
    End If

    Set objSendMail = New vbSendMail.clsSendMail
    
    'THE REAL ONE!!! Uncomment when ready
    Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
                                                SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
                                                strFrom, strFromDisplayName, _
                                                strTo, strToDisplayName, _
                                                strCC, strCCDisplayName, _
                                                strBCC, _
                                                strReplyTo, _
                                                strSubject, strHTML, True, "", _
                                                bolAuthenticate, strUsername, strPassword)
    
    'EXAMPLE
    'Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
    '                                            SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
    '                                            strFrom, strFromDisplayName, _
    '                                            "andrey@teleoss.com", "Talisman Travel", _
    '                                            "", "", _
    '                                            "andrey.kouprianov@gmail.com", _
    '                                            strReplyTo, _
    '                                            strSubject, strHTML, True, "", _
    '                                            bolAuthenticate, strUsername, strPassword)
    
    objSendMail.Send
    
    Set objSendMail = Nothing

Finalizer:
    Exit Sub

Errhandler:
    MsgBox Err.Description, vbExclamation, "Talisman Travel"
    Resume Finalizer
End Sub

вместо неё будет работать ваш код (обзываете свою процедуру Private Sub cmdSend_Click()).

Код: vbnet

Private WithEvents objSendMail As vbSendMail.clsSendMail

тоже заремить

...

Рейтинг:

0 / 0

08.08.2020, 18:09

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987800

DarkMan

Участник

Сообщения: 1 041

Рейтинг: 0 / 0

Loxinfo

Вы написали , что хотите отправить HTML страницу через CDO . В указанном примере все конкретно описано , и даже приведен небольшой пример базы данных .
И портянка минимум в 2 раза меньше .
Я не понимаю чего именно Вы хотите ? Доработать свою портянку или все же отправлять e-mail???
P.S Посмотрел сообщения alecko , он же все обьяснил . Вы хоть немного просмотрите код и разберитесь , что и где делается.

...

Рейтинг:

0 / 0

08.08.2020, 18:10

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987801

Loxinfo

Гость

DarkMan, ф написал
Подскажите пожалуйста как изменить существующий код, которы использовал vbSendMail, на код на отправку через CDO
в заглавии к портянкам написано
Код, которы нужно изменить!!!!

...

Рейтинг:

0 / 0

08.08.2020, 18:13

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987803

Loxinfo

Гость

alecko, огромное, очень огромное вам спасибо, буду тестить, я уже неделю пытаюсть использовать разные варианты

...

Рейтинг:

0 / 0

08.08.2020, 18:20

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987808

DarkMan

Участник

Сообщения: 1 041

Рейтинг: 0 / 0

Loxinfo

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.

      Call modVBSendMail.VBSMCreateEmailWithBCC(objSendMail, _
                                                SMTP_SERVER_HOST, SMTP_SERVER_PORT, _
                                                strFrom, strFromDisplayName, _
                                                strTo, strToDisplayName, _
                                                strCC, strCCDisplayName, _
                                                strBCC, _
                                                strReplyTo, _
                                                strSubject, strHTML, True, "", _
                                                bolAuthenticate, strUsername, strPassword)

Это непосредственно отправка письма , вызывается функция и в нее передаются аргументы. Создайте свою на примере CDO и передавайте туда аргументы .
А ваще , код лучше не комуниздить , а писать самому , тогда Вы будете иметь хоть какое то представление о том , что Вы делаете. :))

...

Рейтинг:

0 / 0

08.08.2020, 18:25

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987812

DarkMan

Участник

Сообщения: 1 041

Рейтинг: 0 / 0

Loxinfo

alecko, огромное, очень огромное вам спасибо, буду тестить, я уже неделю пытаюсть использовать разные варианты

Кстати посмотрите пример ROI там тоже отправка через CDO . И портянка короткая.

...

Рейтинг:

0 / 0

08.08.2020, 18:29

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987878

Loxinfo

Гость

DarkMan, авторА ваще , код лучше не комуниздить , а писать самому
Я его не комуниздил, я заплатил человеку и он написал этот код лет 15 назад, сейчас контакта с ним нет

...

Рейтинг:

0 / 0

09.08.2020, 07:16

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987882

DarkMan

Участник

Сообщения: 1 041

Рейтинг: 0 / 0

Loxinfo

Я его не комуниздил, я заплатил человеку и он написал этот код лет 15 назад, сейчас контакта с ним нет

Фразу "комуниздил" я написал абстрактно . Все мы где то находим какие то примеры в инете или книжках , делаем копи/пасте и используем у себя. Я к тому , что попробуйте разобраться с тем кодом. К тому же Вам практически дали готовые примеры . И даже есть база где отправляются e-mail. Я не пойму в чем проблема то.

...

Рейтинг:

0 / 0

09.08.2020, 08:15

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987883

ROI

Участник

Откуда: г. Тюмень

Сообщения: 2 326

Рейтинг: 0 / 0

Loxinfo,
Ни кто в вашем коде разбираться не будет.
Так что придеться самому.
1 Скопируйте мою функцию(вообще то она не моя) в отдельный модуль.
2 в вашей процедуре клик кнопки

Код: vbnet

Private Sub cmdSend_Click()

Вызываете "мою" функцию
3 Заполняете её значениями из полей формы (если правильно я понял)
все

...

Рейтинг:

0 / 0

09.08.2020, 08:30

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987886

Loxinfo

Гость

alecko, спасибо, ваши советы и примеры очень помогли, я все поменял, все работает

...

Рейтинг:

0 / 0

09.08.2020, 09:10

| Ответить | Цитировать | Написать

Подскажите п-та, как изменить код отправки через vbSendMail на отправку через CDO?

#39987887

Loxinfo

Гость

ROI, спасибо вам за то что отозвались и дали пример.
Я уже все сделал, спасибо alecko , за его пример и поясниние

...

Рейтинг:

0 / 0

09.08.2020, 09:14

| Ответить | Цитировать | Написать

25 сообщений из 25, страница 1 из 1

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?fid=45&msg=39987878&tid=1609985]:	0ms
get settings:	10ms
get forum list:	13ms
check forum access:	4ms
check topic access:	4ms
track hit:	146ms
get topic data:	11ms
get forum data:	2ms
get page messages:	65ms
get tp. blocked users:	2ms
others:	283ms

total:	540ms