Qiita Teams that are logged in
You are not logged in to any team

Log in to Qiita Team
OrganizationAdvent CalendarQiitadon (β)
Qiita JobsQiita ZineQiita Blog
Help us understand the problem. What is going on with this article?


More than 1 year has passed since last update.


Public Sub do_OutlookMailSend(Optional mode = 4)
Dim wb As Workbook
Set wb = ActiveWorkbook

' 最大行数の取得 その1
'ir_m = wb.Sheets("out").Range("a1").SpecialCells(xlLastCell).Row

' 最大行数の取得 その2
ir_m = 9999
For ir = 1 To 1000
    If Trim(wb.Sheets("out").Cells(ir, 1).Value) = "" Then
        ir_m = ir
        Exit For
    End If

' エクセルの表組みをコピー; 領域は適宜
wb.Sheets("out").Range("a1:f" & ir_m).Copy

Set myol = CreateObject("Outlook.Application")
Set myns = myol.Getnamespace("MAPI")
Set myfol = myns.getdefaultfolder(5)

Set mymail = myol.createItem(0)
Set ins = mymail.GetInspector

' WordEditorで、本文編集するのが、コツ
Set doc = ins.WordEditor

' ペイスト方式を選択
'mode is
'Const wdPasteHTML = 10
'Const wdPasteBitmap = 4
doc.Range.PasteSpecial DataType:=mode, Placement:=0

' オプション;画像での貼り付け時、拡縮と本文挿入
If mode = 4 Then
    doc.inlineShapes(1).ScaleWidth = 100
    doc.Range.InsertBefore "本文挿入" & vbCrLf & vbCrLf
End If

doc.Range.Font.Name = "MS Pゴシック"
doc.Range.Font.Size = 10.5

mymail.To = "abc@def.com"
mymail.Subject = "[" & Format(Now(), "YY MM DD") & "]" & " メール送信テスト"
'mymail.body = ""


Set mymail = Nothing
Set myfol = Nothing
Set myns = Nothing
Set myol = Nothing
Set wb = Nothing

End Sub

Private Sub CommandButton1_Click()
Call do_OutlookMailSend
End Sub

Private Sub CommandButton2_Click()
Call do_OutlookMailSend(10)
End Sub

Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away