есть макрос...отсылает письмо. хочу чтобы он высылал письмо на определенную дату (которая установлена в ячейке в определенное время) стырил часть кода получилось так, но не работает [vba]
Код
Sub Procedura_1() Application.OnTime Now + TimeValue("00:00:05"), "Send_Mail()" End Sub
Sub Send_Mail() Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/" Dim oCDOCnf As Object, oCDOMsg As Object Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String On Error Resume Next 'sFrom - êàê ïðàâèëî ñîâïàäàåò ñ sUsername SMTPserver = [B10] ' SMTPServer: äëÿ Mail.ru "smtp.mail.ru"; äëÿ ßíäåêñà "smtp.yandex.ru"; äëÿ Ðàìáëåðà "mail.rambler.ru" sUsername = [B11] ' Ó÷åòíàÿ çàïèñü íà ñåðâåðå sPass = [B12] ' Ïàðîëü ê ïî÷òîâîìó àêêàóíòó
If Len(SMTPserver) = 0 Then MsgBox "Íå óêàçàí SMTP ñåðâåð", vbInformation, "111": Exit Sub If Len(sUsername) = 0 Then MsgBox "Íå óêàçàíà ó÷åòíàÿ çàïèñü", vbInformation, "111": Exit Sub If Len(sPass) = 0 Then MsgBox "Íå óêàçàí ïàðîëü", vbInformation, "111": Exit Sub
sTo = [B2] 'Êîìó sFrom = [B3] 'Îò êîãî sSubject = [B4] 'Òåìà ïèñüìà sBody = [B5] 'Òåêñò ïèñüìà sAttachment = [B6] 'Âëîæåíèå(ïîëíûé ïóòü ê ôàéëó) 'Ïðîâåðêà íàëè÷èÿ ôàéëà ïî óêàçàííîìó ïóòè If Dir(sAttachment, vbDirectory) = "" Then sAttachment = "" 'Íàçíà÷àåì êîíôèãóðàöèþ CDO Set oCDOCnf = CreateObject("CDO.Configuration") With oCDOCnf.Fields .Item(CDO_Cnf & "sendusing") = 2 .Item(CDO_Cnf & "smtpauthenticate") = 1 .Item(CDO_Cnf & "smtpserver") = SMTPserver .Item(CDO_Cnf & "sendusername") = sUsername .Item(CDO_Cnf & "sendpassword") = sPass .Update End With 'Ñîçäàåì ñîîáùåíèå Set oCDOMsg = CreateObject("CDO.Message") With oCDOMsg Set .Configuration = oCDOCnf .BodyPart.Charset = "koi8-r" .From = sFrom .To = sTo .Subject = sSubject .TextBody = sBody If Len(sAttachment) > 0 Then .AddAttachment sAttachment .Send End With
Select Case Err.Number Case -2147220973: sMsg = "Íåò äîñòóïà ê Èíòåðíåò" Case -2147220975: sMsg = "Îòêàç ñåðâåðà SMTP" Case 0: sMsg = "Ïèñüìî îòïðàâëåíî" End Select MsgBox sMsg, vbInformation, "111" Set oCDOMsg = Nothing: Set oCDOCnf = Nothing End Sub
Sub Get_File_Path() Dim sPath sPath = Application.GetOpenFilename("All Files(*.*),*.*", , "Âûáðàòü ôàéëû", "Âûáðàòü", False) If sPath = False Then Exit Sub [B6] = sPath End Sub
[/vba]
доброй ночи,
есть макрос...отсылает письмо. хочу чтобы он высылал письмо на определенную дату (которая установлена в ячейке в определенное время) стырил часть кода получилось так, но не работает [vba]
Код
Sub Procedura_1() Application.OnTime Now + TimeValue("00:00:05"), "Send_Mail()" End Sub
Sub Send_Mail() Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/" Dim oCDOCnf As Object, oCDOMsg As Object Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String On Error Resume Next 'sFrom - êàê ïðàâèëî ñîâïàäàåò ñ sUsername SMTPserver = [B10] ' SMTPServer: äëÿ Mail.ru "smtp.mail.ru"; äëÿ ßíäåêñà "smtp.yandex.ru"; äëÿ Ðàìáëåðà "mail.rambler.ru" sUsername = [B11] ' Ó÷åòíàÿ çàïèñü íà ñåðâåðå sPass = [B12] ' Ïàðîëü ê ïî÷òîâîìó àêêàóíòó
If Len(SMTPserver) = 0 Then MsgBox "Íå óêàçàí SMTP ñåðâåð", vbInformation, "111": Exit Sub If Len(sUsername) = 0 Then MsgBox "Íå óêàçàíà ó÷åòíàÿ çàïèñü", vbInformation, "111": Exit Sub If Len(sPass) = 0 Then MsgBox "Íå óêàçàí ïàðîëü", vbInformation, "111": Exit Sub
sTo = [B2] 'Êîìó sFrom = [B3] 'Îò êîãî sSubject = [B4] 'Òåìà ïèñüìà sBody = [B5] 'Òåêñò ïèñüìà sAttachment = [B6] 'Âëîæåíèå(ïîëíûé ïóòü ê ôàéëó) 'Ïðîâåðêà íàëè÷èÿ ôàéëà ïî óêàçàííîìó ïóòè If Dir(sAttachment, vbDirectory) = "" Then sAttachment = "" 'Íàçíà÷àåì êîíôèãóðàöèþ CDO Set oCDOCnf = CreateObject("CDO.Configuration") With oCDOCnf.Fields .Item(CDO_Cnf & "sendusing") = 2 .Item(CDO_Cnf & "smtpauthenticate") = 1 .Item(CDO_Cnf & "smtpserver") = SMTPserver .Item(CDO_Cnf & "sendusername") = sUsername .Item(CDO_Cnf & "sendpassword") = sPass .Update End With 'Ñîçäàåì ñîîáùåíèå Set oCDOMsg = CreateObject("CDO.Message") With oCDOMsg Set .Configuration = oCDOCnf .BodyPart.Charset = "koi8-r" .From = sFrom .To = sTo .Subject = sSubject .TextBody = sBody If Len(sAttachment) > 0 Then .AddAttachment sAttachment .Send End With
Select Case Err.Number Case -2147220973: sMsg = "Íåò äîñòóïà ê Èíòåðíåò" Case -2147220975: sMsg = "Îòêàç ñåðâåðà SMTP" Case 0: sMsg = "Ïèñüìî îòïðàâëåíî" End Select MsgBox sMsg, vbInformation, "111" Set oCDOMsg = Nothing: Set oCDOCnf = Nothing End Sub
Sub Get_File_Path() Dim sPath sPath = Application.GetOpenFilename("All Files(*.*),*.*", , "Âûáðàòü ôàéëû", "Âûáðàòü", False) If sPath = False Then Exit Sub [B6] = sPath End Sub
Sub Procedura_1() Application.OnTime [b15] + TimeSerial(1, 16, 5), "Send_Mail" Application.OnTime [b15] + TimeSerial(1, 16, 45), "Send_Mail" End Sub
Sub Send_Mail() Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/" Dim oCDOCnf As Object, oCDOMsg As Object Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String On Error Resume Next SMTPserver = [B10] sUsername = [B11] sPass = [B12]
If Len(SMTPserver) = 0 Then MsgBox "Íå óêàçàí SMTP ñåðâåð", vbInformation, "111": Exit Sub If Len(sUsername) = 0 Then MsgBox "Íå óêàçàíà ó÷åòíàÿ çàïèñü", vbInformation, "111": Exit Sub If Len(sPass) = 0 Then MsgBox "Íå óêàçàí ïàðîëü", vbInformation, "111": Exit Sub
sTo = [B2] sFrom = [B3] sSubject = [B4] sBody = [B5] sAttachment = [B6] If Dir(sAttachment, vbDirectory) = "" Then sAttachment = "" Set oCDOCnf = CreateObject("CDO.Configuration") With oCDOCnf.Fields .Item(CDO_Cnf & "sendusing") = 2 .Item(CDO_Cnf & "smtpauthenticate") = 1 .Item(CDO_Cnf & "smtpserver") = SMTPserver .Item(CDO_Cnf & "sendusername") = sUsername .Item(CDO_Cnf & "sendpassword") = sPass .Update End With Set oCDOMsg = CreateObject("CDO.Message") With oCDOMsg Set .Configuration = oCDOCnf .BodyPart.Charset = "koi8-r" .From = sFrom .To = sTo .Subject = sSubject .TextBody = sBody If Len(sAttachment) > 0 Then .AddAttachment sAttachment .Send End With
Select Case Err.Number Case -2147220973: sMsg = "Íåò äîñòóïà ê Èíòåðíåò" Case -2147220975: sMsg = "Îòêàç ñåðâåðà SMTP" Case 0: sMsg = "Ïèñüìî îòïðàâëåíî" End Select MsgBox sMsg, vbInformation, "111" Set oCDOMsg = Nothing: Set oCDOCnf = Nothing End Sub
Sub Get_File_Path() Dim sPath sPath = Application.GetOpenFilename("All Files(*.*),*.*", , "Âûáðàòü ôàéëû", "Âûáðàòü", False) If sPath = False Then Exit Sub [B6] = sPath End Sub
[/vba]
задача решена вот код кому нужно
[vba]
Код
Sub Procedura_1() Application.OnTime [b15] + TimeSerial(1, 16, 5), "Send_Mail" Application.OnTime [b15] + TimeSerial(1, 16, 45), "Send_Mail" End Sub
Sub Send_Mail() Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/" Dim oCDOCnf As Object, oCDOMsg As Object Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String On Error Resume Next SMTPserver = [B10] sUsername = [B11] sPass = [B12]
If Len(SMTPserver) = 0 Then MsgBox "Íå óêàçàí SMTP ñåðâåð", vbInformation, "111": Exit Sub If Len(sUsername) = 0 Then MsgBox "Íå óêàçàíà ó÷åòíàÿ çàïèñü", vbInformation, "111": Exit Sub If Len(sPass) = 0 Then MsgBox "Íå óêàçàí ïàðîëü", vbInformation, "111": Exit Sub
sTo = [B2] sFrom = [B3] sSubject = [B4] sBody = [B5] sAttachment = [B6] If Dir(sAttachment, vbDirectory) = "" Then sAttachment = "" Set oCDOCnf = CreateObject("CDO.Configuration") With oCDOCnf.Fields .Item(CDO_Cnf & "sendusing") = 2 .Item(CDO_Cnf & "smtpauthenticate") = 1 .Item(CDO_Cnf & "smtpserver") = SMTPserver .Item(CDO_Cnf & "sendusername") = sUsername .Item(CDO_Cnf & "sendpassword") = sPass .Update End With Set oCDOMsg = CreateObject("CDO.Message") With oCDOMsg Set .Configuration = oCDOCnf .BodyPart.Charset = "koi8-r" .From = sFrom .To = sTo .Subject = sSubject .TextBody = sBody If Len(sAttachment) > 0 Then .AddAttachment sAttachment .Send End With
Select Case Err.Number Case -2147220973: sMsg = "Íåò äîñòóïà ê Èíòåðíåò" Case -2147220975: sMsg = "Îòêàç ñåðâåðà SMTP" Case 0: sMsg = "Ïèñüìî îòïðàâëåíî" End Select MsgBox sMsg, vbInformation, "111" Set oCDOMsg = Nothing: Set oCDOCnf = Nothing End Sub
Sub Get_File_Path() Dim sPath sPath = Application.GetOpenFilename("All Files(*.*),*.*", , "Âûáðàòü ôàéëû", "Âûáðàòü", False) If sPath = False Then Exit Sub [B6] = sPath End Sub