Slackのカスタム絵文字を一括作成するVBAマクロ

ホーム
Office関連, Excel
Slackのカスタム絵文字を一括作成するVBAマクロ

Office関連

2020.04.29

Slackのカスタム絵文字を一括作成するVBAマクロ

在宅勤務で使うビジネスチャットサービスとして注目されている「Slack」、私の会社でも導入しています。

Slackにはカスタム絵文字機能があり、私の会社でも「絵文字ジェネレーター」で作成した、

や

といった絵文字を使用しています。

総務という立場上、社内Slackの管理も行っているのですが、先日ある社員から「自分の名前の絵文字が欲しいんだけどー」と、相談を受けました。

なるほど。
たしかに「田中」や「佐藤」といった絵文字があると便利かもしれません。

とはいえ、絵文字ジェネレーターで個人情報となる名前で絵文字を作成するわけにはいきませんし、そもそも全従業員分の絵文字を一つずつ手作業で作成するのも大変です。

そこで、Excelの従業員リストを元に、Slackのカスタム絵文字を一括で作成するマクロを書くことにしました。

処理内容

マクロの大まかな処理内容は下記の通りです。

カスタム絵文字の元となる画像(シェイプ)を作成
クリップボードにコピー
画像として保存

クリップボードにコピーされた画像をファイルとして保存する際に使うのが、前回の記事(下記)で紹介したツール(CB2IMG)です。

2020.04.27

クリップボードにある画像をファイルとして保存するC#コード

とある目的で、クリップボードにコピーされた画像をファイルとして保存する処理を書いてみました。下記のようなツールも見つけましたが、任意のタイミングで任意の場所にファイル保存したかったので、自分で書くことにしました。下記の通り簡単なコードで...

VBAですべての処理を書けないことはないのですが、コードが複雑になる上に、透過色や画質にまでこだわり出すと非常に面倒くさいことになるので、この部分は無理せず外に出すことにしました。

“すべての処理をVBAで片づけない”、実運用上ではそんな視点も大事だと思います。

絵文字用シェイプを作成するVBAコード

まずは核となる、絵文字用シェイプを作成するコードです。
枠線や文字配置等いろいろと指定していますが、ポイントはワードアートの「変形」にある「四角」です。
これを指定することで、枠いっぱいに文字が広がり、カスタム絵文字にしたときに見やすくなります。

Private Function InsertShape(ByVal sht As Excel.Worksheet, _
                             ByVal shpText As String, _
                             Optional ByVal shpFontName As String = "MS UI Gothic", _
                             Optional ByVal shpForeColor As Long = &H0&, _
                             Optional ByVal shpBackColor As Long = &HFFFFFF) As Excel.Shape
'カスタム絵文字の元となるイメージ作成
'
' sht:イメージ作成先のシート
' shpText:文字列
' shpFontName:フォント
' shpForeColor:文字色
' shpBackColor:背景色
'

  Dim shp As Excel.Shape
  
  Set shp = sht.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
  With shp
    .TextEffect.PresetShape = msoTextEffectShapePlainText
    .ScaleHeight 1, msoFalse, msoScaleFromTopLeft
    .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
    .Height = 94.5 '出力後のサイズが大体 128 x 128ピクセル となるように調整
    .Width = 94.8
    .Line.Visible = msoFalse
    With .Fill
      '.Visible = msoFalse
      .Visible = msoTrue
      .ForeColor.RGB = shpBackColor
      .Transparency = 0
      .Solid
    End With
    With .TextFrame2
      .VerticalAnchor = msoAnchorMiddle
      .HorizontalAnchor = msoAnchorCenter
      .WordArtformat = msoTextEffect1
      With .TextRange
        .ParagraphFormat.Alignment = msoAlignCenter
        .ParagraphFormat.LineRuleWithin = msoFalse
        .ParagraphFormat.SpaceWithin = 10 '段落の間隔10pt
        If Len(shpText) > 2 Then
          .Text = Mid(shpText, 1, 2) & vbNewLine & Mid(shpText, 3) '3文字目以降は改行
        Else
          .Text = shpText
        End If
      End With
      With .TextRange.Font
        '.Line.Visible = msoFalse
        .Line.Transparency = 1
        .Shadow.Visible = msoFalse
        .Bold = msoTrue
        .Fill.ForeColor.RGB = shpForeColor
        .Name = shpFontName
        .NameAscii = shpFontName
        .NameFarEast = shpFontName
        .NameOther = shpFontName
      End With
    End With
  End With
  Set InsertShape = shp
End Function

使い方は下記のようになります。

Public Sub Sample()
  Dim shp As Excel.Shape
  Const cb2img As String = "C:\wk\CB2IMG\CB2IMG.exe" 'CB2IMGのパス
  
  '元画像作成
  Set shp = InsertShape(ActiveSheet, _
                        "齋藤花子", _
                        "UD Digi Kyokasho N-B", _
                        &HFFFFFF, _
                        &H57972B)
  'クリップボードにコピー
  shp.Copy
  'CB2IMGを実行してクリップボードにコピーされた画像をファイルとして保存
  Shell """" & cb2img & """ " & """C:\wk\CB2IMG\img\TEST.png""", vbNormalFocus
End Sub

「InsertShape」で作成したシェイプをクリップボードにコピーし、その後「CB2IMG」を実行してファイルとして保存しています。

Slackのカスタム絵文字を一括作成するVBAコード

あとは従業員リストを用意して繰り返し実行するだけです。
テストには下図のような、「疑似個人情報データ生成サービス」で生成したダミーデータを使うことにしました。

Public Sub BatchCreateEmoji()
'Slackのカスタム絵文字一括作成
  Dim sht As Excel.Worksheet
  Dim shp As Excel.Shape
  Dim wsh As Object
  Dim i As Long
  Const cb2img As String = "C:\wk\CB2IMG\CB2IMG.exe" 'CB2IMGのパス
  Const savefolder As String = "C:\wk\CB2IMG\img\" '画像保存先
  
  Set wsh = CreateObject("Wscript.Shell")
  Set sht = ActiveSheet
  With sht
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
      Set shp = InsertShape(sht, .Cells(i, 4).Value, , &H1400E5)
      DoEvents
      shp.Copy
       wsh.Run """" & cb2img & """ " & """" & savefolder & "name-" & .Cells(i, 5).Value & .Cells(i, 6).Value & ".png""", 0, True 'コマンド実行＆処理待ち
      shp.Delete
    Next
  End With
  MsgBox "処理が終了しました。", vbSystemModal + vbInformation
End Sub

上記コードでは、CB2IMGの終了待ちを行うため、WshShell.Runメソッドを使用しています。
(処理中にSleepを挟んだ方が安定するかもしれません。)