VBA メールを目的に応じてわける方法について

専用で秋田のときにaquarius0319
フレッツで秋田のときにb230420にメールを送れるようにしたいのですがこれだとaquarius0319にしかメールがいきません
なぜでしょうか？

Sub sample()
Const olMailItem = 0
Dim file As String
Dim pr As Presentation
Dim sl As Slide
Dim sh As Shape
Dim tb As Table
Dim r As Integer
Dim c As Integer
Dim s As String
Dim f1 As Boolean
Dim f2 As Boolean
Dim ol As Object
Dim mail As Object
Dim f As Object
Dim dic As Object
Dim k As Variant
Dim n As Variant

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "ppt", ".ppt?"
.InitialFileName = "C:"
.AllowMultiSelect = False
If Not .Show Then Exit Sub
file = .SelectedItems(1)
End With
Do
Set pr = Presentations.Open(file)
For Each sl In pr.Slides
f1 = False
f2 = False
For Each sh In sl.Shapes
If sh.HasTable Then
Set tb = sh.Table
For r = 1 To tb.Rows.Count
For c = 1 To tb.Rows(r).Cells.Count
s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
If InStr(s, "フレッツ") Then f1 = True
If InStr(s, "専用") Then f1 = True
If InStr(s, "秋田") Then
If r <> tb.Rows.Count Then
If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
End If
End If
If f1 And f2 Then Exit Do
Next
Next
End If
Next
Next
MsgBox "無かった"
Loop Until True
pr.Close
If Not (f1 And f2) Then Exit Sub
'
MsgBox "見つけた"
'添付ファイル
Set dic = CreateObject("Scripting.Dictionary")
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "."
.InitialFileName = "C:"
.AllowMultiSelect = True
If Not .Show Then Exit Sub
file = .SelectedItems(1)
Set dic = CreateObject("Scripting.Dictionary")
Dim i As Integer
For i = 1 To .SelectedItems.Count
dic.Add .SelectedItems(i), Null
Next
End With
'メール送信
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "ppt", ".ppt?"
.InitialFileName = "C:"
.AllowMultiSelect = False
If Not .Show Then Exit Sub
file = .SelectedItems(1)
End With
Do
Set pr = Presentations.Open(file)
For Each sl In pr.Slides
f1 = False
f2 = False
For Each sh In sl.Shapes
If sh.HasTable Then
Set tb = sh.Table
For r = 1 To tb.Rows.Count
For c = 1 To tb.Rows(r).Cells.Count
s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
If InStr(s, "専用") Then f1 = True
If InStr(s, "秋田") Then
If r <> tb.Rows.Count Then
If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
End If
End If
If f1 And f2 Then Exit Do
Next
Next
End If
Next
Next
Loop Until True
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(olMailItem)
mail.Display
mail.To = "aquarius0319" '宛先
mail.Subject = "件名"
mail.Body = "本文"
For Each k In dic.keys
mail.Attachments.Add k
Next
Set dic = CreateObject("Scripting.Dictionary")
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "."
.InitialFileName = "C:"
.AllowMultiSelect = True
If Not .Show Then Exit Sub
file = .SelectedItems(1)
Set dic = CreateObject("Scripting.Dictionary")
Dim l As Integer
For l = 1 To .SelectedItems.Count
dic.Add .SelectedItems(l), Null
Next
End With
mail.Attachments.Add file
mail.Send '送信
ol.Quit
Do
Set pr = Presentations.Open(file)
For Each sl In pr.Slides
f1 = False
f2 = False
For Each sh In sl.Shapes
If sh.HasTable Then
Set tb = sh.Table
For r = 1 To tb.Rows.Count
For c = 1 To tb.Rows(r).Cells.Count
s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
If InStr(s, "フレッツ") Then f1 = True
If InStr(s, "秋田") Then
If r <> tb.Rows.Count Then
If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
End If
End If
Next
Next
End If
Next
Next
Loop Until True
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(olMailItem)
mail.Display
mail.To = "b230420" '宛先
mail.Subject = "件名"
mail.Body = "本文"
For Each n In dic.keys
mail.Attachments.Add n
'ファイルを添付
Next
Set dic = CreateObject("Scripting.Dictionary")
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "."
.InitialFileName = "C:"
.AllowMultiSelect = True
If Not .Show Then Exit Sub
file = .SelectedItems(1)
Set dic = CreateObject("Scripting.Dictionary")
Dim o As Integer
For o = 1 To .SelectedItems.Count
dic.Add .SelectedItems(o), Null
Next
End With
mail.Attachments.Add file
mail.Send '送信
ol.Quit
End Sub

行動規範の内容に同意します

回答1件

ベストアンサー

VBA
1Sub sample()
2    Const olMailItem = 0
3    Dim file As String
4    Dim pr As Presentation
5    Dim sl As Slide
6    Dim sh As Shape
7    Dim tb As Table
8    Dim r As Integer
9    Dim c As Integer
10    Dim s As String
11    
12    Dim f1 As Boolean
13    Dim f2 As Boolean
14    Dim ol As Object
15    Dim mail As Object
16    Dim f As Object
17    Dim dic As Object
18    Dim k As Variant
19    Dim n As Variant
20    Dim mailTo As String
21    
22    With Application.FileDialog(msoFileDialogOpen)
23        .Filters.Clear
24        .Filters.Add "ppt", "*.ppt?"
25        .InitialFileName = "C:\"
26        .AllowMultiSelect = False
27        If Not .Show Then Exit Sub
28        file = .SelectedItems(1)
29    End With
30    
31    Do
32        Set pr = Presentations.Open(file)
33        For Each sl In pr.Slides
34            f1 = False
35            f2 = False
36            For Each sh In sl.Shapes
37                If sh.HasTable Then
38                    Set tb = sh.Table
39                    For r = 1 To tb.Rows.Count
40                    For c = 1 To tb.Rows(r).Cells.Count
41                            s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
42                            '宛先
43                            If InStr(s, "専用") Then
44                                f1 = True
45                                mailTo = "aquarius0319"
46                            End If
47                            If InStr(s, "フレッツ") Then
48                                f1 = True
49                                mailTo = "b230420"
50                            End If
51                            If InStr(s, "秋田") And r < tb.Rows.Count Then
52                                    If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
53                            End If
54                            If f1 And f2 Then Exit Do
55                    Next
56                    Next
57                End If
58            Next
59        Next
60        MsgBox "無かった"
61    Loop Until True
62    pr.Close
63    
64    If Not (f1 And f2) Then Exit Sub
65    '
66    MsgBox "見つけた"
67    
68    
69    Set ol = CreateObject("Outlook.Application")
70    Set mail = ol.CreateItem(olMailItem)
71    mail.Display
72    
73    mail.To = mailTo '宛先
74    mail.Subject = "件名"
75    mail.Body = "本文"
76    
77    '添付ファイル
78    mail.Attachments.Add file
79    
80    '添付ファイル
81    With Application.FileDialog(msoFileDialogOpen)
82        .Filters.Clear
83        .Filters.Add "添付ファイル", "*.*"
84        .InitialFileName = "C:\"
85        .AllowMultiSelect = True
86        If .Show Then
87            Dim o As Integer
88            For o = 1 To .SelectedItems.Count
89                mail.Attachments.Add .SelectedItems(o)
90            Next
91        End If
92    End With
93    
94    'メール送信
95    mail.Send '送信
96    
97    ol.Quit
98    
99End Sub
100
101
102