【対策】Gmailの定型文テンプレート使いづらい…消えた…【便利ツール】

Gmailにやっとテンプレート機能が付いた！ということで
返信用定型文に宛先含めて保存していたのだけれど、
3か月に1回くらい、定型文が消える消える。
保存しておいたテンプレートが勝手に消える。
Chromeのキャッシュクリアもしてないし、特におかしな作業もしていない。

なのに、消えている。どういうこと？
前も登録したのに、やり直し？面倒くさい！

ということで過去記事を見た。
mochi-ha.hatenablog.com
あっ、NAVER終わってたね。

ということで、過去のExcelマクロ(VBA)を引っ張り出してきた。
やっぱりデータの保存は大事だねぇ。

利用に必要な条件
・「元データ」というシートがあること
　A列：タイトル（なんでもいいけど、空白はNG）
　B列：TO　　複数ある場合はカンマ区切りで！
　C列：CC　　複数ある場合はカンマ区切りで！
　D列：BCC　　複数ある場合はカンマ区切りで！
　E列：件名
　F列：本文
　G列：結果
　L2：署名　←L2固定。

・合計3000文字以内に収まっていること（文字数多すぎると上手く反映しない）
・適当に作っているからバグがあるかもしれません
・上手く動作しなくても保証できません

VBAの追加の仕方
1.Alt+F11を押し、VBエディターを表示する
2.標準モジュールを追加する
3.標準モジュール（Module1)をダブルクリックで開き、ソースをコピペする
4.元データシートに、図形を描画する（Excel2007の場合は、挿入⇒図形⇒□とか）
5.描画した図形を右クリックし「マクロの登録」をクリック
6.「TEST」を選択

やっつけで作っているってのがよくわかりますね。困ったもんだ。

クリックで展開　ソースコード

Option Explicit

Sub TEST()
    Dim MaxRow
    Dim i
    Dim MotoSheets
    Dim NextSheets
    Dim タイトル
    Dim ToData
    Dim CcData
    Dim BccData
    Dim 件名
    Dim 本文
    
    Set MotoSheets = ThisWorkbook.Worksheets("元データ")
    
    MaxRow = Range("A" & Rows.Count).End(xlUp).Row
    
    If MaxRow = 1 Then
    MsgBox "2行目から定形文データを入力して下さい"
    End
    End If
    
    For i = 2 To MaxRow
    ToData = MotoSheets.Range("B" & i)
    ToData = Replace(ToData, "<", "%3C")
    ToData = Replace(ToData, ">", "%3E")
    ToData = Replace(ToData, "＜", "%3C")
    ToData = Replace(ToData, "＞", "%3E")
    ToData = Replace(ToData, "&", "%26")
    ToData = Replace(ToData, vbCrLf, "%0A") '改行
    ToData = Replace(ToData, vbLf, "%0A") '改行
    ToData = Replace(ToData, vbCr, "%0A") '改行
    
    CcData = MotoSheets.Range("C" & i)
    CcData = Replace(CcData, "<", "%3C")
    CcData = Replace(CcData, ">", "%3E")
    CcData = Replace(CcData, "&", "%26")
    CcData = Replace(CcData, "＜", "%3C")
    CcData = Replace(CcData, "＞", "%3E")
    CcData = Replace(CcData, vbCrLf, "%0A") '改行
    CcData = Replace(CcData, vbLf, "%0A") '改行
    CcData = Replace(CcData, vbCr, "%0A") '改行
    
    BccData = MotoSheets.Range("D" & i)
    BccData = Replace(BccData, "<", "%3C")
    BccData = Replace(BccData, ">", "%3E")
    BccData = Replace(BccData, "&", "%26")
    BccData = Replace(BccData, "＜", "%3C")
    BccData = Replace(BccData, "＞", "%3E")
    BccData = Replace(BccData, vbCrLf, "%0A") '改行
    BccData = Replace(BccData, vbLf, "%0A") '改行
    BccData = Replace(BccData, vbCr, "%0A") '改行
    
    件名 = MotoSheets.Range("E" & i)
    本文 = MotoSheets.Range("F" & i) & vbCrLf & MotoSheets.Range("L2")
    
    件名 = Replace(件名, "%", "%25")
    件名 = Replace(件名, vbCrLf, "%0A") '改行
    件名 = Replace(件名, vbLf, "%0A") '改行
    件名 = Replace(件名, vbCr, "%0A") '改行
    件名 = Replace(件名, "|", "%7C")
    件名 = Replace(件名, "`", "%60")
    件名 = Replace(件名, "^", "%5E")
    件名 = Replace(件名, "<", "%3C")
    件名 = Replace(件名, ">", "%3E")
    件名 = Replace(件名, ")", "%29")
    件名 = Replace(件名, "(", "%28")
    件名 = Replace(件名, "}", "%7D")
    件名 = Replace(件名, "{", "%7B")
    件名 = Replace(件名, "]", "%5D")
    件名 = Replace(件名, "[", "%5B")
    件名 = Replace(件名, ";", "%3B")
    件名 = Replace(件名, "?", "%3F")
    件名 = Replace(件名, "@", "%40")
    件名 = Replace(件名, "&", "%26")
    件名 = Replace(件名, "=", "%3D")
    件名 = Replace(件名, "+", "%2B")
    件名 = Replace(件名, "$", "%24")
    件名 = Replace(件名, ",", "%2C")
    件名 = Replace(件名, "#", "%23")
    件名 = Replace(件名, "-", "%2D")
    件名 = Replace(件名, "_", "%5F")
    件名 = Replace(件名, ".", "%2E")
    件名 = Replace(件名, "!", "%21")
    件名 = Replace(件名, "*", "%2A")
    件名 = Replace(件名, "'", "%27")
    件名 = Replace(件名, ":", "%3A")
    件名 = Replace(件名, "･", "%A5")
    件名 = Replace(件名, "/", "%2F")
    件名 = Replace(件名, """", "%22") 'ダブルコーテーション
    件名 = Replace(件名, "\", "%5C")


    本文 = Replace(本文, "%", "%25")
    本文 = Replace(本文, vbCrLf, "%0A") '改行
    本文 = Replace(本文, vbLf, "%0A") '改行
    本文 = Replace(本文, vbCr, "%0A") '改行
    本文 = Replace(本文, "|", "%7C")
    本文 = Replace(本文, "`", "%60")
    本文 = Replace(本文, "^", "%5E")
    本文 = Replace(本文, "<", "%3C")
    本文 = Replace(本文, ">", "%3E")
    本文 = Replace(本文, ")", "%29")
    本文 = Replace(本文, "(", "%28")
    本文 = Replace(本文, "}", "%7D")
    本文 = Replace(本文, "{", "%7B")
    本文 = Replace(本文, "]", "%5D")
    本文 = Replace(本文, "[", "%5B")
    本文 = Replace(本文, ";", "%3B")
    本文 = Replace(本文, "?", "%3F")
    本文 = Replace(本文, ":", "%3A")
    本文 = Replace(本文, "@", "%40")
    本文 = Replace(本文, "&", "%26")
    本文 = Replace(本文, "=", "%3D")
    本文 = Replace(本文, "+", "%2B")
    本文 = Replace(本文, "$", "%24")
    本文 = Replace(本文, ",", "%2C")
    本文 = Replace(本文, "#", "%23")
    本文 = Replace(本文, "-", "%2D")
    本文 = Replace(本文, "_", "%5F")
    本文 = Replace(本文, ".", "%2E")
    本文 = Replace(本文, "!", "%21")
    本文 = Replace(本文, "*", "%2A")
    本文 = Replace(本文, "'", "%27")
    本文 = Replace(本文, "･", "%A5")
    本文 = Replace(本文, "/", "%2F")
    本文 = Replace(本文, """", "%22") 'ダブルコーテーション
    本文 = Replace(本文, "\", "%5C")

    
    If (Len(ToData) + Len(CcData) + Len(BccData) + Len(件名) + Len(本文)) > 3000 Then
        MsgBox "トータルが3000文字を超えました。減らしてください" & (Len(ToData) + Len(CcData) + Len(BccData) + Len(件名) + Len(本文))
        End
    End If
    

    MotoSheets.Range("G" & i).Value = "https://mail.google.com/mail/u/0/?view=cm&fs=1&tf=1&source=mailto&to=" & _
        ToData & "&cc=" & CcData & "&bcc=" & BccData & "&su=" & 件名 & "&body=" & 本文
            
    Next
    
    MsgBox "変換が完了しました。" & vbCrLf & "G列にあるアドレスを" & vbCrLf & _
    "Chromeのアドレス欄に貼り付けて更新してください。" & vbCrLf & vbCrLf & _
    "そのリンクをお気に入り登録すると定形文になります。"
    
End Sub


Public Function UrlEncodeUtf8(ByRef strSource As String) As String
Dim objSC As Object
Set objSC = CreateObject("ScriptControl")
objSC.Language = "Jscript"
UrlEncodeUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
Set objSC = Nothing
End Function

誰かの参考になれば幸いです。