VBA メールの送り方について

Question

再度修正しました
VBAで専用かつINSの時にメールをsyunsukeに送りたいのですがこれだと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 t 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
Dim mailTo As String

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
t = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
'宛先
If InStr(s, "専用") > 0 And InStr(t, "INS") > 0 Then
f1 = True
mailTo = "syunsuke"
End If
If InStr(s, "フレッツ") Then
f1 = True
mailTo = "b230420"
End If
If InStr(s, "INS") Then
f1 = True
mailTo = "b230420"
End If
If InStr(s, "専用") Then
f1 = True
mailTo = "aquarius0319"
End If

If InStr(s, "秋田") And r < tb.Rows.Count Then
If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
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 ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(olMailItem)
mail.Display

mail.To = mailTo '宛先
mail.Subject = "件名"
mail.Body = "本文"

'添付ファイル
mail.Attachments.Add file

'添付ファイル
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "*.*"
.InitialFileName = "C:\"
.AllowMultiSelect = True
If .Show Then
Dim o As Integer
For o = 1 To .SelectedItems.Count
mail.Attachments.Add .SelectedItems(o)
Next
End If
End With

'メール送信
mail.Send '送信

ol.Quit

End Sub

Comments

[y_waiwai]

このままではコードが読みづらいので、質問を編集し、<code>ボタンを押し、出てくる’’’の枠の中にコードを貼り付けてください

[cx20]

(主に回答者向けの情報です)
VBA のコードを見やすく整形してくれるサイトがあるようです。構文の色付けもされるので多少読みやすくなります。
https://www.automateexcel.com/vba-code-indenter/

[shunsuke_0319]

ありがとうございます
修正させていただきました

[cx20]

残念ながら質問文のコード整形が解消していないようです。ソースコードの前後を「```」で囲む必要があります。
＜コードブロックの記入例＞
```VBA
ソースコード
```

[shunsuke_0319]

cx20様
ありがとうございます
修正させていただきました

[cx20]

修正ありがとうございます。インデントが付いていた状態でコード記載して頂けるとより見やすくなるかと思います。

[ken3memo]

素朴な疑問だけど、
ループを作り、パワーポイント内の表・テーブルのtb.Rows(r).Cells(c)でテキストを取り出し
VBAで
専用かつINSの時に
メールをsyunsukeに送りたい
仕様だと思いますが、

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
t = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
'宛先
If InStr(s, "専用") > 0 And InStr(t, "INS") > 0 Then

↑変数sとtが同じ場所を(同じ値なのでは？)
s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
t = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
で
専用かつINSの時って？
あっ、"INSxxxx専用"とか"xx専用xxINS"のデータをチェックしている場合もあるか。

sとtに変数を分けているので、別の場所(隣や下のセルなど)を参照したいのかと、深読みしてみた。
なんて、やりたいこと・仕様を勝手に想像すると、痛い目見るので、

※実データは無理だとおもいますが、
　例題の表があると(テストの表があると)
　ズバリの回答が得られやすいかも。。
※※過去質問に書いてあったらすみません。

長々、コメント書いたけど、
一言、
表の値・条件を書いてください
^^^^^^^^^^^^^^^^^^^^^^^^
と言えばヨカッタかも。

Answer 1

VBAで専用かつINSの時にメールをsyunsukeに送りたいのですがこれだとaquarius0319にしか行きません なぜでしょうか？

・elseif にしてないので情報が上書きされている
・InStrの戻り値は数値なのに、booleanとして判定に使用している。※0=false 0以外=Trueとして判断されているのを利用しているとは思いますが、あまり宜しくは無いと思います。

他にもあるでしょうけど、段下げなどしていない見辛いコードなので。
その点も改善された方が良いかと思います。

Answer 2

Option Explicit

Function openPresentation() As Presentation
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "ppt", "*.ppt?"
.InitialFileName = "C:\"
.AllowMultiSelect = False
If Not .Show Then Exit Function
Set openPresentation = Presentations.Open(.SelectedItems(1))
End With
End Function

Function getFiles() As Collection
Dim co As New Collection
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "*.*"
.InitialFileName = "C:\"
.AllowMultiSelect = True
If Not .Show Then Exit Function
Dim i As Integer
For i = 1 To .SelectedItems.Count
co.Add .SelectedItems(i)
Next
End With
Set getFiles = co
End Function


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 f0 As Boolean
Dim f1 As Boolean
Dim f2 As Boolean
Dim f3 As Boolean
Dim f4 As Boolean
Dim f5 As Boolean
Dim mailto As Object
Dim m As Variant
Dim att As Variant
Dim ol As Object
Dim mail As Object
Set mailto = CreateObject("Scripting.Dictionary")
Set pr = openPresentation
Do
For Each sl In pr.Slides
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.Cell(r, c).Shape.TextFrame2.TextRange.Text
If InStr(s, "秋田") > 0 Then
If r <> tb.Rows.Count Then
If IsNumeric(tb.Cell(r + 1, c).Shape.TextFrame2.TextRange.Text) Then f0 = True
End If
End If
If InStr(s, "専用") > 0 Then f1 = True
If InStr(s, "フレッツ") > 0 Then f2 = True
If InStr(s, "INS") > 0 Then f3 = True
If InStr(s, "BEW") > 0 Then f4 = True
If InStr(s, "メタル") > 0 Then f5 = True
'ifでいくらでも条件追加
'
If f0 And f1 Then
If f3 Then
mailto.Add "syunsuke", Null '秋田と専用とINS
Else
mailto.Add "aquarius0319", Null '秋田と専用(INS無し)
End If
End If
If f0 And f2 Then mailto.Add "b230420", Null '秋田とフレッツ
If mailto.Count > 0 Then Exit Do
Next
Next
End If
If f0 And f3 Then mailto.Add "suzuki", Null '秋田とINS
If mailto.Count > 0 Then Exit Do
Next
Next
If f0 And f4 Then mailto.Add "okumura", Null '秋田とBEW
If mailto.Count > 0 Then Exit Do
If f0 And f5 Then mailto.Add "kato", Null '秋田とメタル
If mailto.Count > 0 Then Exit Do
'If f0 And f5 Then mailto.Add "kato", Null '秋田とメタル
'If mailto.Count > 0 Then Exit Doでいくらでも条件追加
Loop Until True
pr.Close
If mailto.Count = 0 Then Exit Sub
'
MsgBox Join(mailto.keys, vbCrLf) & vbCrLf & vbCrLf & "にメールを送ります。"
For Each m In mailto.keys
MsgBox "送付先：" & m
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(olMailItem)
mail.Display
mail.To = m '宛先
mail.Subject = "件名"
mail.Body = "本文"
For Each att In getFiles
 '添付ファイル
mail.Attachments.Add att '添付ファイル
Next
With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "添付ファイル", "*.*"
        .InitialFileName = "C:\"
        .AllowMultiSelect = True
        If .Show Then
            Dim o As Integer
            For o = 1 To .SelectedItems.Count
                mail.Attachments.Add .SelectedItems(o)
            Next
        End If
    End With
mail.Send '送信
Next
End Sub

Answer 3

If InStr(s, "専用") > 0 And InStr(t, "INS") > 0 Then
    f1 = True
    mailTo = "syunsuke"
ElseIf InStr(s, "フレッツ") Then
    f1 = True
    mailTo = "b230420"
ElseIf InStr(s, "INS") Then
    f1 = True
    mailTo = "b230420"
ElseIf InStr(s, "専用") Then
    f1 = True
    mailTo = "aquarius0319"
End If

Answer 4

＞メールをsyunsukeに送りたいのですがこれだとaquarius0319にしか行きません なぜでしょうか？

'宛先
If InStr(s, "専用") > 0 And InStr(t, "INS") > 0 Then
f1 = True
mailTo = "syunsuke"
mailTo = "aquarius0319"
End If

↑宛先toに二件連続で変数に入れてますが、これだと最後のaquarius0319しか変数に残りません

; セミコロンで複数の宛先を指定すると良いのでは？

mailTo = "syunsuke"
mailTo = "aquarius0319"
を
mailTo = "syunsuke; aquarius0319"
にすると良いのでは？

'宛先
If InStr(s, "専用") > 0 And InStr(t, "INS") > 0 Then
    f1 = True
    mailTo = "syunsuke; aquarius0319"
End If

参考

https://support.microsoft.com/ja-jp/office/%E9%9B%BB%E5%AD%90%E3%83%A1%E3%83%BC%E3%83%AB-%E3%83%A1%E3%83%83%E3%82%BB%E3%83%BC%E3%82%B8%E3%82%92%E4%BD%9C%E6%88%90%E3%81%99%E3%82%8B-147208af-ca8e-4cdf-b71f-77ba81a54069

https://dekiru.net/article/20630/

Comments

[shunsuke_0319]

やってみたのですがそれでもaquarius0319にしかいきませんでした‥

[ken3memo]

shunsuke_0319 さん
mailTo = "syunsuke"
もしかして、スペルミスとかないですよね？
shunsuke
syunsuke
それは、さすがにないか。コードを見やすくUPすると、他の方が回答したくなるともいます