Sub myEmlAndAttc()
  Rem 添付ファイル付き電子メール新規作成（半自動）処理
  Rem 記録者：Hitrock Camellia Shinopy
  Rem 言語：Outlook VBA
  Rem 機能...
  Rem   選択した連絡先（複数可）宛ての電子メールを新規作成。
  Rem   その際に添付ファイル（複数可）を指定する。
  Rem 注記：myEmlAndAttcを起動して使用｡
  Rem 第1版：2004/02/17：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定：Microsoft Excel 10.0 Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myOutlook As New Outlook.Application
  Dim myOlExp As Outlook.Explorer
  Dim myOlSel As Outlook.Selection
  Dim myAttc As Variant
  '
  Dim myExcel As Excel.Application
  Dim i As Integer
  Dim v As Variant
myEmlAndAttcEntry:
  If myOutlook.ActiveExplorer.CurrentFolder.Name <> "連絡先" Then
    MsgBox "連絡先を選択して下さい。"
    Exit Sub
  End If
  Set myOlExp = myOutlook.ActiveExplorer
  Set myOlSel = myOlExp.Selection
  Set myExcel = CreateObject("Excel.Application")
  '
  ChDrive "C:"
  ChDir "C:\Documents and Settings\User\My Documents"
myEmlAndAttcSubEntry:
  For i = 1 To myOlSel.Count
    myAttc = myExcel.Application.GetOpenFilename(filefilter:="テキスト,*.txt,文書,*.doc", _
      Title:=myOlSel.Item(i).Subject & " " & myOlSel.Item(i).Suffix & " 宛ての添付ファイルを選ぶ", _
      MultiSelect:=True)
    If TypeName(myAttc) = "Boolean" Then
      GoTo myEmlAndAttcSubExit
    End If
    '
    With CreateItem(olMailItem)
      On Error Resume Next
      .Subject = "御要望のファイルを送付します。"
      .To = myOlSel.Item(i).Email1Address
      .Body = myOlSel.Item(i).Subject & " " & myOlSel.Item(i).Suffix & vbCrLf _
        & "今後とも宜しくお願い致します。"
      For Each v In myAttc
        .Attachments.Add v
      Next v
      .Display
    End With
  Next i
myEmlAndAttcSubExit:
  myExcel.Quit
  Set myOlExp = Nothing
  Set myOlSel = Nothing
  Set myExcel = Nothing
myEmlAndAttcExit:
End Sub  '  myEmlAndAttc    *----*----*    *----*----*    *----*----*