OutlookスケジュールのTeams会議URLのQRコード化

OutLookにエントリーしているTeams会議URLをQRコード化します。
※必要になったので作りました。

■処理内容
・表示しているメール/スケジュールからTeamsURLを抽出します。
・抽出したURLをExcelを使用してQRコード化します。

■使い方
・QRコード化したいスケジュール/メールを表示してください。
・ALT+F8でマクロを起動してください。

■マクロ
以下をOutlookの標準モジュールに配置してください。

■その他
・Office365で稼働します。
・「microsoft Access BarCode Control 14.0」の参照設定は不要です。

Sub QRcodeCreate()

'--- 開いているメール、スケジュールを対象にする ---
Set a = Application.ActiveInspector
Set b = a.CurrentItem


'--- TemamsのURLを取得 ---
Set r = CreateObject("VBScript.RegExp")
r.Pattern = "Microsoft Teams 会議に参加[^<]+<([^>]+)>"
r.IgnoreCase = True
r.Global = True

Set x = r.Execute(b.Body) '--- URL取出し ---

For Each y In x
    c = y.SubMatches(0)  '--- サブマッチ ---
    Exit For
Next y


'--- Excel起動 ---
Set bk = CreateObject("Excel.Application")
bk.Application.Visible = True
bk.Application.Workbooks.Add


'--- 上部のメニュー非表示 ---
If bk.Application.CommandBars.GetPressedMso("MinimizeRibbon") = False Then
    bk.Application.CommandBars.ExecuteMso "MinimizeRibbon"
End If


'--- URL貼り付け ---
Set st = bk.WorkSheets.Item(1)
st.cells(15, 1) = c
With st.Range("A15:G25")
    .WrapText = True
    .MergeCells = True
End With


'--- QRコード貼り付け ---
'ClassType,FileName,Link,DisplayAsIcon,IconFileName,IconIndex,IconLabel,Left,Top,Width,Height
With st.OLEObjects.Add("BARCODE.BarCodeCtrl.1", , , , , , , 20, 20, 200, 200)
    .Object.Style = 110
    .LinkedCell = "A15"
End With


'--- 後処理 ---
Set st = Nothing
Set bk = Nothing
Set x = Nothing
Set r = Nothing

End Sub

おまけです。「VBS⇒EXCEL」で実行するVBS版です。(入力はOutllookでなくExcelです）

Set bk = CreateObject("Excel.Application")
bk.Application.Visible = true
bk.Application.Workbooks.Add()


If bk.Application.CommandBars.GetPressedMso("MinimizeRibbon") = False Then
  bk.Application.CommandBars.ExecuteMso "MinimizeRibbon"
End if


Set st = bk.WorkSheets.Item(1)
st.cells(15,1) = "http://ddff"  '☆☆←ココにURLをセットして。

'ClassType,FileName,Link,DisplayAsIcon,IconFileName,IconIndex,IconLabel,Left,Top,Width,Height
'ClassType:="BARCODE.BarCodeCtrl.1",,, Left:=20, Top:=20, Width:=150, Height:=150

Set bb = st.OLEObjects.Add("BARCODE.BarCodeCtrl.1",,,,,,,20,20,150,150)
bb.Object.Style = 110
bb.LinkedCell = "a15"

Set bb = nothing
Set st = nothing
Set bk = nothing


'microsoft Access BarCode Control 14.0は不要。

さらにおまけでExcel単独の場合です。「microsoft Access BarCode Control 14.0」の参照設定は不要です。

Sub aa() 
    Set bb = ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1", Left:=20, Top:=20, Width:=150, Height:=150)
    bb.Object.Style = 110
    bb.LinkedCell = "a15"  '☆☆←ここにURLがセットされているセルを指定
End Sub