|
 |
|
| | |
| |
Îòïðàâêà ïî÷òû (4 ñïîñîáà) + àðõèâàöèÿ
1. Ñòàíäàðòíûé ñïîñîá
DoCmd.SendObject ...
íå ïîçâîëÿåò îòïðàâèòü íåñêîëüêî âëîæåííûõ ôàéëîâ.
2. Ïðîñòîé ñïîñîá
Application.FollowHyperlink "mailto:kozin@mail.ru?subject=äëÿ ïðîâåðêè íå çàáóäü ñìåíèòü àäðåñàòà íà ñâîé &body=òåêñò ñîîáùåíèÿ ", , True
òîëüêî ïîäãîòîâêà ïèñüìà ê îòïðàâêå
3. Èñïîëüçîâàíèå MAPI
Ïîçâîëÿåò ïðèêðåïëÿòü íåñêîëüêî ôàéëîâ
Ðàáîòàåò ÷åðåç ïî÷òîâóþ ïðîãðàììó, íàçíà÷åííóþ ïî÷òîâûì êëèåíòîì ïî óìîë÷àíèþ:
(íàïðèìåð MSOutlookExpress èëè MSOutlook)
Public Sub testSengMultyattach()
Const SESSION_SIGNON = 1
Const MESSAGE_COMPOSE = 6
Const ATTACHTYPE_DATA = 0
Const RECIPTYPE_TO = 1
Const RECIPTYPE_CC = 2
Const MESSAGE_RESOLVENAME = 13
Const MESSAGE_SEND = 3
Const SESSION_SIGNOFF = 2
Dim MS 'MAPI Session
Dim Msgs
Set MS = CreateObject("MSMAPI.mapiSession.1")
Set Msgs = CreateObject("MSMAPI.mapiMessages.1")
MS.signon
Msgs.sessionid = MS.sessionid
Msgs.compose
Msgs.msgsubject = "I test you sample "
Msgs.msgnotetext = "This works"
Msgs.RecipIndex = 0 'First recipient
Msgs.RecipType = RECIPTYPE_TO
Msgs.RecipDisplayName = "kozin@mail.ru" 'Recipient in TO line. this my mail :))
Msgs.AttachmentType = 0
Msgs.AttachmentIndex = 0
Msgs.AttachmentPathName = "c:\CONFIG.SYS"
Msgs.AttachmentPosition = 0
Msgs.AttachmentIndex = 1 'next number !!!
Msgs.AttachmentPathName = "c:\autoexec.bat"
Msgs.AttachmentPosition = 1
'ask to commit
Msgs.send ("1")
'or send auto
'Msgs.Action = MESSAGE_SEND
'Close MAPI mail session:
MS.Action = SESSION_SIGNOFF
End Sub
4. Èñïîëüçîâàíèå CDO
Private Sub SendCDOmail()
Dim Msg 'As CDO.Message
Set Msg = CreateObject("CDO.Message")
Dim mailaddress As String
Dim Msghtml As String
mailaddress = "kozin@mail.ru"
Msghtml = "<HTML><h2>Ñì. âëîæåíèÿ</h2></HTML>"
With Msg
.HTMLBody = Msghtml
.AddAttachment ("c:\autoexec.bat")
.To = """Administratior"" <" & mailaddress & ">"
.FROM = """Ðîáîìýéë"" <mailservice@mailserver.ru>"
.Send
End With
Set Msg = Nothing
End Sub
Äëÿ èñïîëüçîâàíèÿ CDO äîëæíà áûòü óñòàíîâëåíà áèáëèîòåêà
"Microsoft CDO for Exchange 2000"
(c îïåðöèîííûìè ñèñòåìàìè íà÷èíàÿ ñ Windows 2000 óñòàíîâêà íå òðåáóåòñÿ ò.ê.
óñòàíàâëèâàåòñÿ ïðè óñòàíîâêè OS)
Ïðåèìóùåñòâî CDO ïåðåä âûøåóïîìÿíóòûìè ñïîñîáàìè - íå òðåáóåòñÿ íàëè÷èå óñòàíîâëåííîé è íàñòðîåííé äëÿ êîíêðåòíîãî ïîëüçîâàòåëÿ ïî÷òîâîé ïðîãðàììû.
Äîïîëíèòåëüíûå ìàòåðèàëû:
Îòïðàâêà ñî ñïåöèôè÷íûìè ïàðàìåòðàìè ñåðâåðà.
Private Function SendCDOmail(mailaddress As String, filename) As String
'Âîçâðàùàåò ïóñòóþ ñòðîêó åñëè îòïðàâêà óäàëàñü èíà÷å îïèñàíèå îøèáêè
On Error GoTo errh:
Dim Msg 'As CDO.Message
Set Msg = CreateObject("CDO.Message")
Dim Msghtml As String
Msghtml = "<HTML><h2>Ñì. âëîæåíèÿ</h2></HTML>"
Msg.HTMLBody = Msghtml
Msg.AddAttachment (filename)
'êîíôèãóðàöèÿ îòïðàâêè ïî SMTP, äëÿ èñïîëüçîâàíèÿ äåôîëòíûõ
'íàñòðîåê ñèñòåìû ìîæíî íå óêàçûâàòü
'Êîíñòàíòû íå ìåíÿòü!!!!
With Msg.Configuration.Fields
Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSendUsingPort = 2
.Item(cdoSendUsingMethod) = cdoSendUsingPort
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
.Item(cdoSMTPServer) = "192.168.2.3" 'IP àäðåñ âàøåãî SMTP ñåðâåðà
Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
.Item(cdoSMTPConnectionTimeout) = 360 'Ñåêóíäû
Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
'Const cdoBasic = 1
Const cdoAnonymous = 0
.Item(cdoSMTPAuthenticate) = cdoAnonymous
End With
Msg.Configuration.Fields.Update
With Msg
.To = """ Êîìó "" <" & mailaddress & ">"
.FROM = """Ðîáîìýéë"" <èìÿ@äîìåí.ru>"
.Send
End With
Exit Function
errh:
SendCDOmail = Err.Description
End Function
Àðõèâàöèÿ ôàéëà ïåðåä îòïðàâêîé
Private Function MoveFileToARC(filename As String)
'Äëÿ àðõèâàöèè èñïîëüçóåòñÿ êîíñîëüíîå ïðèëîæåíèå rar
'èñïîëüçóåòñÿ ïóòü óñòàíîâêè WinRaR ïî óìîë÷àíèþ
'Âîçâðàùàåò èìÿ ôàéëà - àðõèâà
Dim rarfile As String
rarfile = Environ("tmp") & "\" & Fix(Timer) & Replace(filename, ".xls", ".rar", , , vbTextCompare)
On Error Resume Next
Kill rarfile
On Error GoTo 0
If Trim(filename) = "" Then MsgBox "Íåîáõîäèìî èìÿ ôàéëà": Exit Function
' RAR <êîìàíäà> -<êëþ÷ 1> -<êëþ÷ N> <àðõèâ> <ôàéëû...>
Dim OShell
Set OShell = CreateObject("WScript.Shell")
Dim DosCommand
DosCommand = Chr(34) & Environ("programfiles") & "\winrar\rar.exe "" a -ep " & rarfile & " " & Environ("tmp") & "\" & filename
'Debug.Print DosCommand
DoEvents
Call OShell.Run(DosCommand, 2, True)
DoEvents
On Error Resume Next
Kill Environ("tmp") & "\" & filename
On Error GoTo 0
If Dir(rarfile) <> "" Then MoveFileToARC = rarfile
End Function
Ïðèìåð èñïîëüçîâàíèÿ:
Private Sub sendmail_Click()
If Nz(Me.mailaddress, "") = "" Then MsgBox "Íå óêàçàí ïî÷òîâûé àäðåñ": Exit Sub
Dim ARCfile, srcfile As String
DoCmd.Hourglass True
srcfile = "c:\autoexec.bat"
ARCfile = MoveFileToARC(srcfile)
If ARCfile = "" Then MsgBox "Îøèáêà àðõèâàöèè ôàéëà ": Exit Sub
Dim sendresult
sendresult = SendCDOmail(Me.mailaddress, ARCfile)
Kill ARCfile
DoCmd.Hourglass False
If sendresult <> "" Then
MsgBox "Îøèáêà îòïðàâêè ôàéëà ïî email:" & sendresult
Else
DoCmd.Close acForm, Me.name
MsgBox "Ôàéë " & srcfile & " Óñïåøíî îòïðàâëåí."
End If
End Sub
| |
| | |
