Google Appsによるオンラインストレージ活用　自動メール送信VBA

Goolge Appsを利用して、作成したGmailアカウントに大量のデータファイルを添付送信して管理するためのツール。

ここでは、大量のファイルを一括で圧縮し、Outlookのメール添付で送信するための自動送信ツールの作成方法を残す。


■必要なもの。
excel、outlook、Gmailアカウント（Appsでも通常アカウントでもよい）
今回は、office2000で作成する。

1　GmailアカウントのIMAP接続を有効化
まずGmailアカウント側でIMAP接続を有効化する。デフォルトでOFFなので忘れずに変更する。
Gmailアカウントでログイン後に、設定でIMAPを有効にする。手順は以下ヘルプを参照
http://mail.google.com/support/bin/answer.py?hl=jp&answer=77695

2　OutlookでIMAP接続アカウントを作成する。
Outlook2000でIMAP接続設定は、以下のヘルプを参照。
http://mail.google.com/support/bin/answer.py?answer=77661
好みに応じて、メール送信のデフォルトアカウントに設定する。

3　エクセルでファイル一括圧縮マクロを作成する。
フォルダにあるファイルをそのままメール添付して格納すると、サイズが大きくなるのとたまにファイルが崩壊するため、個々のファイルを圧縮する。

エクセルで新たにファイルを作成。ツール→マクロ→VisualBasicEditorを実行
VisualBasicEditorにて、挿入→標準モジュールを実行
以下のコードを入れる。なお、エラーハンドリングとかはあんまりいれてない。

これで、
・フォルダパスを指定
・「圧縮済」というフォルダを作成
・指定したフォルダパスの中のファイルをすべて「圧縮済」フォルダにlzh形式で保存する。
というマクロができあがる。

'*****APIの宣言
Public Declare Function Unlha Lib "UNLHA32.DLL" _
(ByVal hWnd As Long, _
ByVal szCmdline As String, _
ByVal Lpstr As String, _
ByVal wsize As Long) As Integer


Sub Make_LZHFile()

Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows")

Set FS = CreateObject("Scripting.FileSystemObject")
Set Fol = FS.GetFolder(Target)
Set Fil = Fol.Files
ThisWorkbook.Sheets("Sheet1").UsedRange.Delete

'見出しを付ける
ThisWorkbook.Sheets(1).Range("A1") = "パス"
ThisWorkbook.Sheets(1).Range("B1") = "ファイル名"
ThisWorkbook.Sheets(1).Range("C1") = "ファイル種別"
ThisWorkbook.Sheets(1).Range("D1") = "最終更新日"
ThisWorkbook.Sheets(1).Range("E1") = "フルパス"
ThisWorkbook.Sheets(1).Range("A1:E1").Interior.Color = RGB(0, 0, 0)
ThisWorkbook.Sheets(1).Range("A1:E1").Font.Color = RGB(255, 255, 255)
ThisWorkbook.Sheets(1).Range("A1:Es1").HorizontalAlignment = xlCenter


MkDir Target & "\圧縮済"

i = 2

For Each Fx In Fil
'Path
ThisWorkbook.Sheets(1).Cells(i, 1) = Target
'ファイル名
sFile = Fx.Name
'ファイル名の書き出し
ThisWorkbook.Sheets(1).Cells(i, 2) = sFile
'ファイル種別
sFType = Fx.Type
'最終更新日時の書き出し
ThisWorkbook.Sheets(1).Cells(i, 3) = sFType
'最終更新日
sLMod = Fx.DateLastModified
ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod
'フォルダフルパス
SFull = Target & "\" & sFile
ThisWorkbook.Sheets(1).Cells(i, 5) = SFull

'*****LZH圧縮/解凍コマンド
Dim strLZH As String 'LHAファイル名
Dim strXLS As String '圧縮元のフルパスとファイル名
Dim strCmdTxt As String 'UNLHA32.dllへのコマンド文字列
Dim strResult As String * 5000 '結果情報の戻り文字列

On Error GoTo ErrHandler

'ファイル名の設定
strXLS = SFull
strLZH = Target & "\圧縮済\" & sFile & ".lzh"

'コマンド文字列の生成
'"a"はLZHの圧縮・解凍を選択するスイッチ　a:圧縮、e:解凍
strCmdTxt = "a " & """" & strLZH & """" & " " & """" & strXLS & """"

'書庫ファイルの生成
If Unlha(0, strCmdTxt, strResult, 5000) <> 0 Then
MsgBox "LZH圧縮に失敗しました。　", vbCritical
End If
i = i + 1
Next
Exit Sub

'エラー処理
ErrHandler:
MsgBox Err.Description

End Sub

4　エクセルでOutlookメールへのファイル添付送信マクロを作成する。
次に、上記で圧縮したファイルを、順番にメール添付して送信するマクロを作成する。
モジュール2つにわたる。

4-1　メールアイテム生成
エクセルで新たにファイルを作成。ツール→マクロ→VisualBasicEditorを実行
VisualBasicEditorにて、挿入→標準モジュールを実行
以下のコードを入れる。なお、エラーハンドリングとかはあんまりいれてない。

これで、
・フォルダパスを指定
・その中のファイルを順番にメール添付して送信ボックスに入れる。
というマクロができあがる。
タイトルと本文に、ファイルのフルパスが入るため、Gmail検索時に有効。

Sub CreateMailItem( _
strToMbr As String, _
strCCMbr As String, _
strBCCMbr As String, _
strSbj As String, _
strBdy As String, _
strAdd As String, _
blnRRcpt As Boolean)

Dim objOLApp As Object
Dim objOLItem As Object

Set objOLApp = CreateObject("Outlook.Application")
'※2 宣言したObject変数をOutlookのアプリケーションに設定
Set objOLItem = objOLApp.CreateItem(0)
'※3 宣言したObject変数をOutlookのメールオブジェクトに設定

With objOLItem
.To = strToMbr 'To配信者アドレス
.Cc = strCCMbr 'CC配信者アドレス
.Bcc = strBCCMbr 'BCC配信者アドレス
.Subject = strSbj 'タイトル
.Body = strBdy '本文
.Attachments.Add strAdd '添付
.ReadReceiptRequested = blnRRcpt '開封確認要求
End With

objOLItem.send 'メールの表示(送信箱に移す場合は.send)
End Sub

4-2　メール自動送信
エクセルで新たにファイルを作成。ツール→マクロ→VisualBasicEditorを実行
VisualBasicEditorにて、挿入→標準モジュールを実行
以下のコードを入れる。なお、エラーハンドリングとかはあんまりいれてない。

Sub Make_SendMail()

Target = InputBox("ディレクトリ名を入力", "ディレクトリの指定", "C:\Windows")

Set FS = CreateObject("Scripting.FileSystemObject")
Set Fol = FS.GetFolder(Target)
Set Fil = Fol.Files
ThisWorkbook.Sheets("Sheet1").UsedRange.Delete

'見出しを付ける
ThisWorkbook.Sheets(1).Range("A1") = "パス"
ThisWorkbook.Sheets(1).Range("B1") = "ファイル名"
ThisWorkbook.Sheets(1).Range("C1") = "ファイル種別"
ThisWorkbook.Sheets(1).Range("D1") = "最終更新日"
ThisWorkbook.Sheets(1).Range("E1") = "フルパス"
ThisWorkbook.Sheets(1).Range("A1:E1").Interior.Color = RGB(0, 0, 0)
ThisWorkbook.Sheets(1).Range("A1:E1").Font.Color = RGB(255, 255, 255)
ThisWorkbook.Sheets(1).Range("A1:Es1").HorizontalAlignment = xlCenter

i = 2
For Each Fx In Fil
'Path
ThisWorkbook.Sheets(1).Cells(i, 1) = Target
'ファイル名
sFile = Fx.Name
'ファイル名の書き出し
ThisWorkbook.Sheets(1).Cells(i, 2) = sFile
'ファイル種別
sFType = Fx.Type
'最終更新日時の書き出し
ThisWorkbook.Sheets(1).Cells(i, 3) = sFType
'最終更新日
sLMod = Fx.DateLastModified
ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod
'フォルダフルパス
SFull = Target & "\" & sFile
ThisWorkbook.Sheets(1).Cells(i, 5) = SFull

Dim strToLst As String 'To配信者List
Dim strCCLst As String 'CC配信者List
Dim strBCCLst As String 'BCC配信者List
Dim strMailSbj As String 'タイトル
Dim strMailBdy As String '本文
Dim strMailAdd As String '添付
Dim blnMailRRcpt As Boolean 'ReadReceiptRequested(開封確認要求)

strToLst = "xxxxxx@xxxxxx←ここに送信先のGmailアドレスを入れる"
' strCCLst = "cc1@xxx.yy.zz" & "; " & "cc2@xxx.yy.zz" & "; " & "cc3@xxx.yy.zz"
' strBCCLst = "bcc@xxx.yy.zz" & "; " & "bcc2@xxx.yy.zz" & "; " & "bcc3@xxx.yy.zz"
strMailSbj = ThisWorkbook.Sheets(1).Cells(i, 5)
strMailBdy = ThisWorkbook.Sheets(1).Cells(i, 5)
strMailAdd = ThisWorkbook.Sheets(1).Cells(i, 5)
blnMailRRcpt = False

Module3←ここに4-1で作成した標準モジュール番号を入れる.CreateMailItem strToLst, strCCLst, strBCCLst, strMailSbj, strMailBdy, strMailAdd, blnMailRRcpt

i = i + 1
Next
End Sub

以上。