メルポン

ようやく掲載できました。

メルポンのソースコードです。

Option Explicit

'変数と置換データを格納する構造体(?)
Type local_define
  NKEY As String
  NVAL As String
End Type

Const IDX = "A1" 'テンプレシートのタイトル位置
Const PREROW = 19 'テンプレシートの設定最大行
Const TOROW = 20 'テンプレシートの宛先(TO)
Const CCROW = 21 'テンプレシートの宛先(CC)
Const BCCROW = 22 'テンプレシートの宛先(BCC)
Const SUBJROW = 23 'テンプレシートの宛先(タイトル)
Const BODYROW = 24 'テンプレシートの宛先(本文)

'選択するシート番号
Public SHEET_NUM As Long

Dim c_label(20) As local_define 'テンプレシート用の配列
Dim k_label(50) As local_define '共通シート用の配列
Dim c_num As Long 'customシート用の置換数
Dim k_num As Long '共通シート用の置換数

'メール作成
Sub MAIL_MAKE()

  Dim I As Long
  Dim J As Long
  Dim K As Long
  
  Dim m_col As Long   '選択肢行の最大列数
  Dim k_m_row As Long '共通シートの最大行
  
  Dim tmp_msg As String '一時変数(文字列)
  Dim tmp_int As Long '一時変数(数値)
  
  
  Dim ws1 As Worksheet '共通シート
  Dim ws2 As Worksheet 'テンプレシート
  
  Set ws1 = Worksheets("共通")
  For I = 1 To Worksheets.Count
    If Worksheets(I).Name <> "共通" Then
      UserForm1.ComboBox1.AddItem CStr(I) & "," & Worksheets(I).Range(IDX)
    End If
  Next I

  SHEET_NUM = 0 'ユーザフォームから正常に戻った場合に発生しない数字を設定
  UserForm1.Show 'ユーザフォーム開く

  '正常に選択されていなかったら、終了
  If SHEET_NUM = 0 Then
    Exit Sub
  Else
    '選択したテンプレシートをws2に設定
    Set ws2 = Worksheets(SHEET_NUM)
  End If

  'シート内の置換定義を取得 c_labelに全部格納
  J = 1
  For I = 2 To PREROW '2行目から19行目まで繰り返す
    '選択肢から選ばせる
    If InStr(ws2.Cells(I, 1), "SEL_LIST") > 0 Then
      m_col = ws2.Cells(I, 1).End(xlToRight).Column
      For K = 3 To m_col
        tmp_msg = tmp_msg & CStr(K - 2) & ":" & ws2.Cells(I, K) & ","
      Next K
      tmp_int = InputBox(Split(ws2.Cells(I, 1), ",")(1) & "を選択 " & tmp_msg)
      c_label(J).NKEY = ws2.Cells(I, 2)
      c_label(J).NVAL = ws2.Cells(I, tmp_int + 2)
      J = J + 1
    '任意に入力させる
    ElseIf InStr(ws2.Cells(I, 1), "IN_LIST") > 0 Then
      c_label(J).NKEY = ws2.Cells(I, 2)
      c_label(J).NVAL = InputBox(Split(ws2.Cells(I, 1), ",")(1) & " を入力してください")
      J = J + 1
    'それ以外の場合
    ElseIf ws2.Cells(I, 1) <> "" Then
      c_label(J).NKEY = ws2.Cells(I, 2)
      c_label(J).NVAL = ws2.Cells(I, 3)
      J = J + 1
    End If
  Next I
  c_num = J - 1

  '共通シートから情報を取得 k_labelに全部格納
  J = 1
  k_m_row = ws1.Range("A1").End(xlDown).Row
  For I = 2 To k_m_row
    k_label(J).NKEY = ws1.Cells(I, 2)
    k_label(J).NVAL = ws1.Cells(I, 3)
    J = J + 1
  Next I
  k_num = J - 1

  'メール情報取得して、全置換
  Dim to_val As String 'TO用の変数
  Dim cc_val As String 'CC用の変数
  Dim bcc_val As String 'BCC用の変数
  Dim subj_val As String 'SUBJECT用の変数
  Dim body_val As String 'BODY用の変数
  
  '置換処理
  to_val = AllReplace(ws2.Cells(TOROW, 2).Text)
  cc_val = AllReplace(ws2.Cells(CCROW, 2).Text)
  bcc_val = AllReplace(ws2.Cells(BCCROW, 2).Text)
  subj_val = AllReplace(ws2.Cells(SUBJROW, 2).Text)
  body_val = AllReplace(ws2.Cells(BODYROW, 2).Text)
  
  'メール作成
  If ws1.Range("C1") = "" Then
    'Outlookメール作成
    Call MakeOutlookMail(to_val, cc_val, bcc_val, subj_val, body_val)
  Else
    'Thunderbirdメール作成
    Call MakeThunderbirdMail(to_val, cc_val, bcc_val, subj_val, body_val, ws1.Range("C1").Text)
  End If
  
  
End Sub

Private Sub MakeOutlookMail(to_val, cc_val, bcc_val, subj_val, body_val)

    'メール作成に必要なOutlookオブジェクトを生成する
    Dim outlookObj As Object
    Dim mailItemObj As Object
    Set outlookObj = CreateObject("Outlook.Application")
    Set mailItemObj = outlookObj.CreateItem(0)

    'メール情報の設定
    mailItemObj.To = Replace(to_val, ",", "; ")
    mailItemObj.CC = Replace(cc_val, ",", "; ")
    mailItemObj.BCC = Replace(bcc_val, ",", "; ")
    mailItemObj.Subject = subj_val
    mailItemObj.Body = body_val

    'メール表示
    mailItemObj.Display

    'オブジェクトの解放
    Set mailItemObj = Nothing
    Set outlookObj = Nothing

End Sub

Private Sub MakeThunderbirdMail(to_val As String, cc_val As String, bcc_val As String, subj_val As String, body_val As String, mailer As String)
  Dim sPath As String
  Dim encodedSubject As String
  Dim arg As String
  
  encodedSubject = urlEncode(subj_val)
  
  '-osint は送信画面が開かない
  
  Dim to_address As String
  Dim cc_address As String
  Dim bcc_address As String
  to_address = ""
  cc_address = ""
  bcc_address = ""
  If to_val <> "" Then
    to_address = "to=" & to_val
  End If
  If cc_val <> "" Then
    cc_address = "cc=" & cc_val
  End If
  If bcc_val <> "" Then
    bcc_address = "bcc=" & bcc_val
  End If
  sPath = mailer & " -foreground -compose "
  arg = to_address & "," & cc_address & "," & bcc_address & "," & _
        "subject=" & encodedSubject & "," & _
        "body=" & body_val
  Shell sPath & arg

End Sub

Private Function AllReplace(in_str As String) As String
  Dim I As Long
  Dim tmp As String
  
  tmp = in_str
    
  'カスタムシート上の置換処理
  For I = c_num To 1 Step -1
    tmp = Replace(tmp, c_label(I).NKEY, c_label(I).NVAL)
  Next I

  '共通シート上の置換処理
  For I = k_num To 1 Step -1
    tmp = Replace(tmp, k_label(I).NKEY, k_label(I).NVAL)
  Next I
    
  AllReplace = tmp

End Function

Private Function urlEncode(ByVal sWord As String) As String
  Dim d As Object
  Dim elm As Object
  
  sWord = Replace(sWord, "\", "\\")
  sWord = Replace(sWord, "'", "\'")
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"
  urlEncode = elm.innerText
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

Option Explicit

'変数と置換データを格納する構造体(?)

Type local_define

NKEY As String

NVAL As String

End Type

Const IDX = "A1" 'テンプレシートのタイトル位置

Const PREROW = 19 'テンプレシートの設定最大行

Const TOROW = 20 'テンプレシートの宛先(TO)

Const CCROW = 21 'テンプレシートの宛先(CC)

Const BCCROW = 22 'テンプレシートの宛先(BCC)

Const SUBJROW = 23 'テンプレシートの宛先(タイトル)

Const BODYROW = 24 'テンプレシートの宛先(本文)

'選択するシート番号

Public SHEET_NUM As Long

Dim c_label(20) As local_define 'テンプレシート用の配列

Dim k_label(50) As local_define '共通シート用の配列

Dim c_num As Long 'customシート用の置換数

Dim k_num As Long '共通シート用の置換数

'メール作成

Sub MAIL_MAKE()

Dim I As Long

Dim J As Long

Dim K As Long

Dim m_col As Long '選択肢行の最大列数

Dim k_m_row As Long '共通シートの最大行

Dim tmp_msg As String '一時変数(文字列)

Dim tmp_int As Long '一時変数(数値)

Dim ws1 As Worksheet '共通シート

Dim ws2 As Worksheet 'テンプレシート

Set ws1 = Worksheets("共通")

For I = 1 To Worksheets.Count

If Worksheets(I).Name <> "共通" Then

UserForm1.ComboBox1.AddItem CStr(I) & "," & Worksheets(I).Range(IDX)

End If

Next I

SHEET_NUM = 0 'ユーザフォームから正常に戻った場合に発生しない数字を設定

UserForm1.Show 'ユーザフォーム開く

'正常に選択されていなかったら、終了

If SHEET_NUM = 0 Then

Exit Sub

Else

'選択したテンプレシートをws2に設定

Set ws2 = Worksheets(SHEET_NUM)

End If

'シート内の置換定義を取得 c_labelに全部格納

J = 1

For I = 2 To PREROW '2行目から19行目まで繰り返す

'選択肢から選ばせる

If InStr(ws2.Cells(I, 1), "SEL_LIST") > 0 Then

m_col = ws2.Cells(I, 1).End(xlToRight).Column

For K = 3 To m_col

tmp_msg = tmp_msg & CStr(K - 2) & ":" & ws2.Cells(I, K) & ","

Next K

tmp_int = InputBox(Split(ws2.Cells(I, 1), ",")(1) & "を選択 " & tmp_msg)

c_label(J).NKEY = ws2.Cells(I, 2)

c_label(J).NVAL = ws2.Cells(I, tmp_int + 2)

J = J + 1

'任意に入力させる

ElseIf InStr(ws2.Cells(I, 1), "IN_LIST") > 0 Then

c_label(J).NKEY = ws2.Cells(I, 2)

c_label(J).NVAL = InputBox(Split(ws2.Cells(I, 1), ",")(1) & " を入力してください")

J = J + 1

'それ以外の場合

ElseIf ws2.Cells(I, 1) <> "" Then

c_label(J).NKEY = ws2.Cells(I, 2)

c_label(J).NVAL = ws2.Cells(I, 3)

J = J + 1

End If

Next I

c_num = J - 1

'共通シートから情報を取得 k_labelに全部格納

J = 1

k_m_row = ws1.Range("A1").End(xlDown).Row

For I = 2 To k_m_row

k_label(J).NKEY = ws1.Cells(I, 2)

k_label(J).NVAL = ws1.Cells(I, 3)

J = J + 1

Next I

k_num = J - 1

'メール情報取得して、全置換

Dim to_val As String 'TO用の変数

Dim cc_val As String 'CC用の変数

Dim bcc_val As String 'BCC用の変数

Dim subj_val As String 'SUBJECT用の変数

Dim body_val As String 'BODY用の変数

'置換処理

to_val = AllReplace(ws2.Cells(TOROW, 2).Text)

cc_val = AllReplace(ws2.Cells(CCROW, 2).Text)

bcc_val = AllReplace(ws2.Cells(BCCROW, 2).Text)

subj_val = AllReplace(ws2.Cells(SUBJROW, 2).Text)

body_val = AllReplace(ws2.Cells(BODYROW, 2).Text)

'メール作成

If ws1.Range("C1") = "" Then

'Outlookメール作成

Call MakeOutlookMail(to_val, cc_val, bcc_val, subj_val, body_val)

Else

'Thunderbirdメール作成

Call MakeThunderbirdMail(to_val, cc_val, bcc_val, subj_val, body_val, ws1.Range("C1").Text)

End If

End Sub

Private Sub MakeOutlookMail(to_val, cc_val, bcc_val, subj_val, body_val)

'メール作成に必要なOutlookオブジェクトを生成する

Dim outlookObj As Object

Dim mailItemObj As Object

Set outlookObj = CreateObject("Outlook.Application")

Set mailItemObj = outlookObj.CreateItem(0)

'メール情報の設定

mailItemObj.To = Replace(to_val, ",", "; ")

mailItemObj.CC = Replace(cc_val, ",", "; ")

mailItemObj.BCC = Replace(bcc_val, ",", "; ")

mailItemObj.Subject = subj_val

mailItemObj.Body = body_val

'メール表示

mailItemObj.Display

'オブジェクトの解放

Set mailItemObj = Nothing

Set outlookObj = Nothing

End Sub

Private Sub MakeThunderbirdMail(to_val As String, cc_val As String, bcc_val As String, subj_val As String, body_val As String, mailer As String)

Dim sPath As String

Dim encodedSubject As String

Dim arg As String

encodedSubject = urlEncode(subj_val)

'-osint は送信画面が開かない

Dim to_address As String

Dim cc_address As String

Dim bcc_address As String

to_address = ""

cc_address = ""

bcc_address = ""

If to_val <> "" Then

to_address = "to=" & to_val

End If

If cc_val <> "" Then

cc_address = "cc=" & cc_val

End If

If bcc_val <> "" Then

bcc_address = "bcc=" & bcc_val

End If

sPath = mailer & " -foreground -compose "

arg = to_address & "," & cc_address & "," & bcc_address & "," & _

"subject=" & encodedSubject & "," & _

"body=" & body_val

Shell sPath & arg

End Sub

Private Function AllReplace(in_str As String) As String

Dim I As Long

Dim tmp As String

tmp = in_str

'カスタムシート上の置換処理

For I = c_num To 1 Step -1

tmp = Replace(tmp, c_label(I).NKEY, c_label(I).NVAL)

Next I

'共通シート上の置換処理

For I = k_num To 1 Step -1

tmp = Replace(tmp, k_label(I).NKEY, k_label(I).NVAL)

Next I

AllReplace = tmp

End Function

Private Function urlEncode(ByVal sWord As String) As String

Dim d As Object

Dim elm As Object

sWord = Replace(sWord, "\", "\\")

sWord = Replace(sWord, "'", "\'")

Set d = CreateObject("htmlfile")

Set elm = d.createElement("span")

elm.setAttribute "id", "result"

d.appendChild elm

d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"

urlEncode = elm.innerText

End Function

MENU

VBA関連

VBA関連