-->
./
<!-- フラ&#65533;ュが見れな&#65533;のためにここに何か書&#65533; --> フラ&#65533;ュがインス&#65533;&#65533;ルされて&#65533;&#65533;たいで&#65533;&#65533;&#65533;

2009年12月24日

[Excel-VBA]メール送信の記録用のマクロ

このマクロの実行側のワークシートです。ログファイルは独立したファイルとして保存され、読み込まれます。

送信メール2009年12月24日
送信メール2009年12月24日 posted by (C)hirono-hideki

Sub createLog_Click()
    Dim cureentBook As Workbook, logBook As Workbook
    Dim strDir As String, strFileName As String, sfilename As String
    strDir = "D:\VMwareShare\Kokuhatu\Mail\Logs\" '作業ディレクトリ
    strFileName = strDir & "send-mail-log_" & Format(Now, "yyyymmdd") & ".xls" '絶対パスのファイル名
    Set cureentBook = ActiveWorkbook '現在のワークブックを保持

    'ディレクトリパスと拡張子を除いたファイル名を取得
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sfilename = FSO.GetBaseName(strFileName)
    MsgBox sfilename
        'ログ記録用のファイルを開く、存在しない場合は新規作成。

'ブックが開かれている場合はフラグを付ける。
    Dim chk As Boolean
    For Each wb In Application.Workbooks
        If wb.Name = sfilename & ".xls" Then
            chk = True
            Exit For
        Else
            chk = False
        End If
    Next

'ブックが開かれているか確認。開かれていない場合はファイルから読み込む。
If chk Then
    MsgBox "ブックは既に開かれています。"
Else
    'ログ記録用のファイルを開く、存在しない場合は新規作成。
    If Dir(strFileName) <> "" Then
        MsgBox "存在します。開きます。"
        Workbooks.Open strFileName
    Else
      MsgBox "存在しません。新規作成します。"
    ' フォルダに指定したファイルがないとき、ファイルを新規作成して名前を付ける
        Workbooks.Add
        ActiveWorkbook.SaveAs FILENAME:=strFileName
        ActiveWorkbook.Close
        Workbooks.Open strFileName
    End If
End If

    '元のブックをアクティブにし、データ範囲をコピー
    cureentBook.Activate
    Sheets("送信").Select
      
    Range("A11:C11").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Cells(24, 5).Select
   
    Application.DisplayAlerts = False      '確認ダイアログを表示させない
    Application.ScreenUpdating = False    '画面更新を中断する<
   
    'ログファイルのブックをアクティブにし、名前をつけてシートを新規に作成し、データを貼付け。
    Set logBook = Workbooks(sfilename & ".xls")
    logBook.Activate
    Dim NewWS As Worksheet
   
    '同一シート名の確認
    Dim chkSheetName As String
    chkSheetName = Format(Now, "yyyy年mm月dd日hh時nn分")
    For Each objWS In logBook.Worksheets
        If objWS.Name = chkSheetName Then
                MsgBox chkSheetName & "というシート名は既に存在します。1分時間をずらしてやり直して下さい。"
                Application.CutCopyMode = False
                Exit Sub
        End If
    Next

    Set NewWS = Worksheets.Add

    'NewWS.Range("A1:C1").Select
    NewWS.Paste
    NewWS.Columns("A:C").AutoFit
   
    NewWS.Name = Format(Now, "yyyy年mm月dd日hh時nn分")


    'Sheet1のシートを削除
    For Each objWS In logBook.Worksheets
        If objWS.Name = "Sheet1" Then
                Worksheets("Sheet1").Delete
        End If
    Next
   
   
    Application.DisplayAlerts = True      '確認ダイアログを表示する
    Application.ScreenUpdating = True    '画面更新を再開する

    Cells(24, 5).Select
    Application.CutCopyMode = False
   
    ActiveWorkbook.Save
    'ActiveWorkbook.Close
   
End Sub

 改良しました。作成されたログファイルはこんな感じです。実際に送信しておらず、一部手を加えたところもあります。
send-mail-log
send-mail-log posted by (C)hirono-hideki


 はじめからunionというのを使っていれば、ずっと完結できたと思います。改善の余地はまだまだありそうですが、過程というのも大事なので、そのままのコードを記載しておきます。文字修飾のあたりは、面倒なので、記録した自動マクロからコピペしました。
修正コード
Sub createLog_Click()
    Dim cureentBook As Workbook, logBook As Workbook
    Dim strDir As String, strFileName As String, sfilename As String
    strDir = "D:\VMwareShare\Kokuhatu\Mail\Logs\" '作業ディレクトリ
    strFileName = strDir & "send-mail-log_" & Format(Now, "yyyymmdd") & ".xls" '絶対パスのファイル名
    Set cureentBook = ActiveWorkbook '現在のワークブックを保持

    'ディレクトリパスと拡張子を除いたファイル名を取得
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sfilename = FSO.GetBaseName(strFileName)
    MsgBox sfilename
        'ログ記録用のファイルを開く、存在しない場合は新規作成。

'ブックが開かれている場合はフラグを付ける。
    Dim chk As Boolean
    For Each wb In Application.Workbooks
        If wb.Name = sfilename & ".xls" Then
            chk = True
            Exit For
        Else
            chk = False
        End If
    Next

'ブックが開かれているか確認。開かれていない場合はファイルから読み込む。
If chk Then
    MsgBox "ブックは既に開かれています。"
Else
    'ログ記録用のファイルを開く、存在しない場合は新規作成。
    If Dir(strFileName) <> "" Then
        MsgBox "存在します。開きます。"
        Workbooks.Open strFileName
    Else
      MsgBox "存在しません。新規作成します。"
    ' フォルダに指定したファイルがないとき、ファイルを新規作成して名前を付ける
        Workbooks.Add
        ActiveWorkbook.SaveAs FILENAME:=strFileName
        ActiveWorkbook.Close
        Workbooks.Open strFileName
    End If
End If

    '元のブックをアクティブにし、データ範囲をコピー
    cureentBook.Activate
    Sheets("送信").Select
      
    Range("A10:C10").Select
    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy
    Cells(24, 5).Select
   
    Application.DisplayAlerts = False      '確認ダイアログを表示させない
    Application.ScreenUpdating = False    '画面更新を中断する<
   
    'ログファイルのブックをアクティブにし、名前をつけてシートを新規に作成し、データを貼付け。
    Set logBook = Workbooks(sfilename & ".xls")
    logBook.Activate
    Dim NewWS As Worksheet
   
    '同一シート名の確認
    Dim chkSheetName As String
    chkSheetName = Format(Now, "yyyy年mm月dd日hh時nn分")
    For Each objWS In logBook.Worksheets
        If objWS.Name = chkSheetName Then
                MsgBox chkSheetName & "というシート名は既に存在します。1分時間をずらしてやり直して下さい。"
                Application.CutCopyMode = False
                Exit Sub
        End If
    Next

    Set NewWS = Worksheets.Add

    NewWS.Range("A7").Select
    NewWS.Paste
    NewWS.Columns("A:J").AutoFit
   
    NewWS.Name = Format(Now, "yyyy年mm月dd日hh時nn分")


    'Sheet1のシートを削除
    For Each objWS In logBook.Worksheets
        If objWS.Name = "Sheet1" Then
                Worksheets("Sheet1").Delete
        End If
    Next
   
   
    Application.DisplayAlerts = True      '確認ダイアログを表示する
    Application.ScreenUpdating = True    '画面更新を再開する

    Cells(24, 5).Select
    Application.CutCopyMode = False
   
  
    ActiveWorkbook.Save
    'ActiveWorkbook.Close
   
    cureentBook.Activate 'ログブックをアクティブ
     'Set r = Range(Cells(1, 1), Cells(8, 10))
     Set r = Union(Range(Cells(1, 1), Cells(4, 10)), Range(Cells(8, 1), Cells(8, 10)))

    r.Copy Destination:=logBook.Worksheets(NewWS.Name).Range("A1")
    NewWS.Columns("A:J").AutoFit

    logBook.Activate

    Range("D1").ColumnWidth = 10
   
    Range("A6").Value = "送信履歴"
    Range("A6").Select
    With Selection
        .HorizontalAlignment = xlDistributed
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 1
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "MS Pゴシック"
        .FontStyle = "太字"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
    End With
    With Selection.Interior
        .ColorIndex = 40
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

End Sub



posted by hirono at 05:24| Comment(1) | TrackBack(0) | プログラミング
この記事へのコメント
Extermely useful place the following. I appreciate an individual intended for discussing a person's knowledge by using myself. I’ll without doubt possibly be again. jordan shoes sale http://www.cheapretrojordanshoesonline.com/
Posted by jordan shoes sale at 2013年06月18日 23:51
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

この記事へのトラックバックURL
http://blog.sakura.ne.jp/tb/34361332

この記事へのトラックバック