| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >> vba로 메일 일괄보내기인데
잘 안되네요.
검토 부탁드립니다.
==============[시커미소님 글에 대한 답변입니다]==============
Sub 지국메일보내기()
Dim 경로 As String
Dim 시작 As Integer, 끝 As Integer, I As Integer, 멜주소 As String, 제목 As String, 본문 As String, 첨부 As String
If MsgBox("메일을 발송합니다. 확인을 클릭해 주세요." & vbCr & vbCr & "중지하려면 취소버튼을 눌러주세요", _
vbQuestion + vbOKCancel) = vbCancel Then
Exit Sub
End If
경로 = Application.ThisWorkbook.Path & "\"
With Sheets("발송")
시작 = .Range("B1")
끝 = .Range("B2")
제목 = .Cells(4, 2) '메일 제목
For I = 5 To 24
본문 = 본문 & vbNewLine & .Cells(I, 2)
Next
Debug.Print 제목
Debug.Print 본문
For I = 시작 To 끝
If .Cells(I, 2) = "" Then
첨부 = ""
Else
첨부 = 경로 & .Cells(I, 2) '첨부파일명
If Len(Dir(첨부)) = 0 Then
MsgBox "[" & 첨부 & "] 해당파일이 없습니다." & vbCrLf & "첨부없이 계속진행 합니다."
첨부 = ""
End If
End If
멜주소 = .Cells(I, 3) '메일주소
If Len(멜주소) > 0 Then
Run "Mailto", 멜주소, 제목, 본문, 첨부
Else
MsgBox "메일주소가 없습니다."
End If
Next I
MsgBox "메일 보내기를 완료했습니다"
End With
End Sub
Function Mailto(멜주소 As String, 제목 As String, 본문 As String, 첨부 As String) As Boolean
Dim objOutlook As New Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim Atts As Integer
On Error GoTo ErrTrap
Set objOutlookMsg = objOutlook.CreateItem(olMailItem) '이프로그램을 사용하기 위해서는 먼저 PC에 아웃룩이 세팅되어 있어야 함.
With objOutlookMsg
.To = 멜주소
.Subject = 제목
.Body = 본문
.Importance = olImportanceHigh
If 첨부 <> "" Then .Attachments.Add 첨부
'.Send
.Display
End With
ErrTrap:
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
If Err = 0 Then
'MsgBox "메일이 성공적으로 발송되었습니다.", vbInformation, "메일 발송 성공"
ElseIf Err = 429 Then
MsgBox "Microsoft Outlook 개체를 작성할 수 없어 자동 메일 발송을 실패했습니다.", vbExclamation, "메일 발송 실패"
Else
MsgBox Err.Description, vbExclamation, "메일 발송 실패"
End If
End Function
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
