###前提・実現したいこと
マクロでGmailを使ってメールを送りたいのですがうまくいきません。
###発生している問題・エラーメッセージ
実行時エラー'2147220973(80040213)':
転送においてサーバーに接続出来ませんでした。
と出ます。
Option Explicit '----- 参照設定 Microsoft CDO for Windows 2XXX Library Public myCDOMsg As New CDO.Message Public Const myADDRESS As String _ = "http://schemas.microsoft.com/cdo/configuration/" Dim gyo As Long Dim gyo2 As Long Dim filecount As Long Dim sheetcount As Long Dim unmatch As Long Dim erfilecount As Long 'ボタンを押したとき Sub FolderSelect() 'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents 'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents Dim folderpass As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then folderpass = .SelectedItems(1) Else ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。" Exit Sub End If End With filecount = 0 sheetcount = 0 unmatch = 0 erfilecount = 0 gyo = 6 gyo2 = 2 ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中" Call FileSearch(folderpass, "*.csv") Dim dateupdate As String dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新" 'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate 'ThisWorkbook.Worksheets(2).Name = dateupdate ' ThisWorkbook.Worksheets(1).Range("B2").Value = "完了" ThisWorkbook.Worksheets(2).Activate End Sub 'ファイル検索 Sub FileSearch(Path As String, Target As String) Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call FileSearch(Folder.Path, Target) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name Like Target Then filecount = filecount + 1 ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path Call ParCopy(File.Path) gyo = gyo + 1 End If ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。" Next File End Sub ''一覧出力 Sub ParCopy(Path As String) Dim openbook As Workbook Dim openbooksheet As Worksheet Dim lp As Long Dim el As Long Dim br As String 'オ Dim c As Range, Target As Range Dim LastRow As Long '縦軸(マクロ側シート数用) lp = 2 '横軸(データ側ループ管理用) el = 3 Application.ScreenUpdating = False On Error GoTo myError Set openbook = Application.Workbooks.Open(Path) 'シートを格納 Set openbooksheet = openbook.Worksheets(1) openbooksheet.Unprotect 'シート数でのループ Do Until lp = 28 '各シート毎のループ Do Until ThisWorkbook.Worksheets(lp).Cells(1, el) = "" br = ThisWorkbook.Worksheets(lp).Cells(2, el) 'オートフィルタ用のアクティブ化 openbooksheet.Activate Selection.AutoFilter openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br '最終行の指定 LastRow = 291826 'マクロ側へのコピペ openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el)) openbooksheet.Range("A1").AutoFilter el = el + 1 Loop 'シート側変数の初期化 el = 3 lp = lp + 1 Loop openbook.Close False Application.ScreenUpdating = True Call test02 Exit Sub myError: MsgBox Err.Description ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生" erfilecount = erfilecount + 1 Application.ScreenUpdating = True End Sub 'シート毎保存部分 Sub test02() Dim wb1 As Workbook Dim i As Long Dim s As Long Dim mo As String Set wb1 = ActiveWorkbook s = wb1.Sheets.Count s = s - 1 For i = 2 To s mo = ThisWorkbook.Worksheets(28).Cells(i, 2) Workbooks.Add.SaveAs Filename:="C:\Users\hogehoge\Desktop\集計\" & mo & ".xls" wb1.Worksheets(i).Copy before:=Workbooks(mo & ".xls").Worksheets(1) Workbooks(mo & ".xls").Worksheets(1).Name = mo Next i Call SendMail End Sub Sub SendMail() With myCDOMsg .To = "受信者 <hogehoge@docomo.ne.jp>" '----- 宛先 '表示名を設定しない場合は<>の中だけでよい。 '.To = "aaa@aaa.com;bbb@bbb.com" ' .CC = "ccc@ccc.com" '----- CC .From = "送信者 <test@gmail.com>" '----- 送信者 .Subject = "テストの件" '----- 件名 .TextBody = _ " テストです。" & vbCrLf & _ " テストです。" & vbCrLf & _ " テストです。" & vbCrLf & _ " テストです。" '----- 本文 With .Configuration.Fields .Item(myADDRESS & "sendusing") = 2 '----- SMTPサーバーを設定 .Item(myADDRESS & "smtpserver") = "smtp.gmail.com" .Item(myADDRESS & "smtpserverport") = 587 .Item(myADDRESS & "smtpauthenticate") = 1 .Item(myADDRESS & "smtpusessl") = True .Item(myADDRESS & "sendusername") = "ID" .Item(myADDRESS & "sendpassword") = "パスワード" .Update End With .Send End With End Sub
###試したこと
ポートを変えたり、ブラウザ側でセキュリティレベルを下げたりしてみたのですがうまくいきませんでした。
###補足情報(言語/FW/ツール等のバージョンなど)
WIN10/Excel2013でやっています
皆様のお力をお貸しください。
よろしくお願いします。
回答5件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。