MENU

ベルブログ

ベルブログ

Sample Page

メールをランダムに送信するプログラム

2025-09-27

' send_random.vbs ── 指定フォルダからランダムに選んだテキストファイルをメール送信（1行目=件名、添付:で添付指定）
Option Explicit
Randomize
On Error Resume Next

Dim ol, mi, fso, folder, files, fileList, fileCount, idx
Dim ts, allText, lines, subjectText, bodyText, i

' ===== 設定 =====
Const TARGET_FOLDER = "\\desktop-9eld0nc\kyoyubunsyo\program\2025.9.27_テキストをランダムに送信するプログラム\randam"   ' ←テキストファイルを入れるフォルダ
Const MAIL_TO   = "kyokench@gmail.com"
Const MAIL_CC   = ""
Const MAIL_BCC  = ""

' ===== Outlook 起動 =====
Set ol = CreateObject("Outlook.Application")
If Err.Number <> 0 Then
  MsgBox "Outlook を起動できませんでした。", 16, "送信エラー"
  WScript.Quit 1
End If
On Error GoTo 0

' ===== フォルダ内のテキストファイル一覧取得 =====
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(TARGET_FOLDER) Then
  MsgBox "指定フォルダが存在しません: " & TARGET_FOLDER, 16, "エラー"
  WScript.Quit 1
End If

Set folder = fso.GetFolder(TARGET_FOLDER)
Set files = folder.Files

fileCount = 0
ReDim fileList(0)
Dim f
For Each f In files
  If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
    If fileCount = 0 Then
      ReDim fileList(0)
    Else
      ReDim Preserve fileList(fileCount)
    End If
    fileList(fileCount) = f.Path
    fileCount = fileCount + 1
  End If
Next

If fileCount = 0 Then
  MsgBox "フォルダ内に .txt ファイルが見つかりません。", 16, "エラー"
  WScript.Quit 1
End If

' ===== ランダムに1つ選択 =====
idx = Int(Rnd * fileCount)

' --- ADODB.Stream で UTF-8 として読み込む ---
Dim stream
Set stream = CreateObject("ADODB.Stream")
stream.Type = 2  ' text
stream.Mode = 3  ' read/write
stream.Charset = "UTF-8"   ' ← ここを "UTF-8" に指定
stream.Open
stream.LoadFromFile fileList(idx)
allText = stream.ReadText
stream.Close
Set stream = Nothing

' ===== 件名と本文・添付を分離 =====
lines = Split(allText, vbCrLf)
subjectText = ""
bodyText = ""
Set mi = ol.CreateItem(0)

If UBound(lines) >= 0 Then
  subjectText = Trim(lines(0))
Else
  subjectText = "(件名なし)"
End If

For i = 1 To UBound(lines)
  If Left(Trim(lines(i)), 3) = "添付:" Then
    Dim attachPath
    attachPath = Trim(Mid(lines(i), 4))
    If fso.FileExists(attachPath) Then
      mi.Attachments.Add attachPath
    End If
  Else
    bodyText = bodyText & lines(i) & vbCrLf
  End If
Next

' ===== メール作成 =====
mi.To = MAIL_TO
mi.CC = MAIL_CC
mi.BCC = MAIL_BCC
mi.Subject = subjectText
' HTML本文として送信（日本語を含めてもエンコードが正しくなる）
mi.HTMLBody = "<html><body>" & Replace(bodyText, vbCrLf, "<br>") & "</body></html>"

' ===== 送信 =====
mi.Send
MsgBox "送信トレイに投入しました。" & vbCrLf & _
       "使用ファイル: " & fileList(idx), 64, "送信完了"

' ===== 配列スライス用の関数 =====
Function SliceArray(arr, startIndex)
  Dim result(), i, j
  ReDim result(UBound(arr) - startIndex)
  j = 0
  For i = startIndex To UBound(arr)
    result(j) = arr(i)
    j = j + 1
  Next
  SliceArray = result
End Function

' send_random.vbs ── 指定フォルダからランダムに選んだテキストファイルをメール送信（1行目=件名）
Option Explicit
Randomize
On Error Resume Next

Dim ol, mi, fso, folder, files, fileList, fileCount, idx
Dim ts, allText, lines, subjectText, bodyText

' ===== 設定 =====
Const TARGET_FOLDER = "\\desktop-9eld0nc\kyoyubunsyo\program\2025.9.27_テキストをランダムに送信するプログラム\randam"  ' ←テキストファイルを入れるフォルダ
Const MAIL_TO   = "kyokench@gmail.com"
Const MAIL_CC   = ""
Const MAIL_BCC   = ""

' ===== Outlook 起動 =====
Set ol = CreateObject("Outlook.Application")
If Err.Number <> 0 Then
  MsgBox "Outlook を起動できませんでした。", 16, "送信エラー"
  WScript.Quit 1
End If
On Error GoTo 0

' ===== フォルダ内のテキストファイル一覧取得 =====
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(TARGET_FOLDER) Then
  MsgBox "指定フォルダが存在しません: " & TARGET_FOLDER, 16, "エラー"
  WScript.Quit 1
End If

Set folder = fso.GetFolder(TARGET_FOLDER)
Set files = folder.Files

fileCount = 0
ReDim fileList(0)
Dim f
For Each f In files
  If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
    If fileCount = 0 Then
      ReDim fileList(0)
    Else
      ReDim Preserve fileList(fileCount)
    End If
    fileList(fileCount) = f.Path
    fileCount = fileCount + 1
  End If
Next

If fileCount = 0 Then
  MsgBox "フォルダ内に .txt ファイルが見つかりません。", 16, "エラー"
  WScript.Quit 1
End If

' ===== ランダムに1つ選択 =====
idx = Int(Rnd * fileCount)

' --- ADODB.Stream で UTF-8 として読み込む ---
Dim stream
Set stream = CreateObject("ADODB.Stream")
stream.Type = 2  ' text
stream.Mode = 3  ' read/write
stream.Charset = "UTF-8"   ' ← ここを "UTF-8" に指定
stream.Open
stream.LoadFromFile fileList(idx)
allText = stream.ReadText
stream.Close
Set stream = Nothing

' ===== 件名と本文を分離（1行目=件名） =====
lines = Split(allText, vbCrLf)
If UBound(lines) >= 0 Then
  subjectText = Trim(lines(0))
Else
  subjectText = "(件名なし)"
End If

If UBound(lines) > 0 Then
  bodyText = Join(SliceArray(lines, 1), vbCrLf)
Else
  bodyText = ""
End If

' ===== 件名と本文を分離（1行目=件名） =====
lines = Split(allText, vbCrLf)
If UBound(lines) >= 0 Then
  subjectText = Trim(lines(0))
Else
  subjectText = "(件名なし)"
End If

If UBound(lines) > 0 Then
  bodyText = Join(SliceArray(lines, 1), vbCrLf)
Else
  bodyText = ""
End If

' ===== メール作成 =====
Set mi = ol.CreateItem(0) ' MailItem
mi.To = MAIL_TO
mi.CC = MAIL_CC
mi.BCC = MAIL_BCC
mi.Subject = subjectText

' HTML本文として送信（日本語を含めてもエンコードが正しくなる）
mi.HTMLBody = "<html><body>" & Replace(bodyText, vbCrLf, "<br>") & "</body></html>"

' ===== 送信 =====
mi.Send
MsgBox "送信トレイに投入しました。" & vbCrLf & _
       "使用ファイル: " & fileList(idx), 64, "送信完了"

' ===== 配列スライス用の関数 =====
Function SliceArray(arr, startIndex)
  Dim result(), i, j
  ReDim result(UBound(arr) - startIndex)
  j = 0
  For i = startIndex To UBound(arr)
    result(j) = arr(i)
    j = j + 1
  Next
  SliceArray = result
End Function

よかったらシェアしてね！

URLをコピーしました！

この記事を書いた人

コメント

コメントするコメントをキャンセル