HOME > エクセルVBA > サンプル > CopyFaceID

CopyFaceID


【ファイル名】CopyFaceID.xla
【バージョン】Ver 1.0.1
【作成日】2015年04月06日
【更新日】2017年01月05日
【動作確認】Microsoft Excel 2010
【必要なソフト】Microsoft Excel 2007 (97-2003アドインとして作成)
【ダウンロード】CopyFaceID.zip
【説明】アイコンのFaceIDのボタンのツールバーを作成します。(「アドイン」タブに表示)

FaceIDのボタンのツールバーを作成、クリックするとFaceIDをテキストとしてクリップボードにコピーします。
このサンプルではFaceIDの最後を3518としてますが本当はもっとあります。必要があれば変更してください。
このサンプルは以前に作成した「エクセレント顔」を修正して作成しました。
FaceIDの画像はExcelのバージョンにより異なる場合があります。
Excel 2007以降FaceIDはあまり使用されなくなりました。

ボタンの数が多いので1画面では表示できません。次の画面を表示するにはリボンの右端の矢印をクリックしてください。最後の画面は右向きの矢印がなくなります。戻るには左端の矢印をクリックしてください。


複数のアドインで同じ名前のプロシージャがあると、後からロードしたファイルのプロシージャは、既にロードしたプロシージャを実行する場合があります。
アドインのCommandBarControlオブジェクトのOnActionプロパティは、プロシージャの前にブック名と半角の感嘆符(!)を連結してください。
例.「FileA.xla」ファイルの「Sub2」プロシージャ
      .OnAction = "FileA.xla!Sub2"

CopyFaceIDModule
Option Explicit       ' 変数は明示的に宣言しなければいけない
Option Private Module ' プロジェクトの外部からモジュールの内容が参照できない
Option Compare Binary ' 文字列比較はバイナリ文字コード
Option Base 0         ' 配列の添字の既定値を 0 に設定

Const FaceIDCount As Long = 3518 ' FaceIDの最大数(本当はもっとあるが使用頻度はあまりない)
Const MaxCountInToolBar = 10 ' 1つのツールバーのボタン数
Const csToolBarName As String = "FaceIDToolBar" ' ツールバーの名前 + 数字

'テキストをクリップボードにコピーします。
Sub CopyText(buf As String)
' DataObjectを使うには、
' [ツール]の[参照設定]メニューを実行し、[Microsoft Forms 2.0 Object Library]にチェックを入れ[OK]ボタンをクリックします。
    Dim CB As New DataObject

    If Len(buf) < 1 Then Exit Sub
    With CB
      .SetText buf    ' 変数のデータをDataObjectに格納する
      .PutInClipboard ' DataObjectのデータをクリップボードに格納する
    End With
End Sub
' FaceIDをテキストとしてクリップボードにコピーします。
Sub CopyFaceId()
  CopyText (CStr(CommandBars.ActionControl.FaceID))
End Sub
'======================================================================================
' FaceIdツールバーの作成
'======================================================================================
Private Sub CreateFaceIDToolbar()
  Dim i As Long, j As Long, FaceID As Long, MaxToolBarCount As Long

  On Error Resume Next
  Application.Cursor = xlWait ' マウスカーソルを砂時計
  Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止(ステータスバーのメッセージは更新できます)
  MaxToolBarCount = FaceIDCount \ MaxCountInToolBar ' ツールバーの最大数
  For i = 0 To MaxToolBarCount
    With CommandBars.Add(Name:=csToolBarName & CStr(i))
      For j = 1 To MaxCountInToolBar ' 1つのツールバーのボタン数
        FaceID = i * MaxCountInToolBar + j
        With .Controls.Add(msoControlButton)
          .Caption = FaceID
          .FaceID = FaceID
          .TooltipText = CStr(FaceID)
          .OnAction = "CopyFaceID.xla!CopyFaceId"
        End With
        If FaceID >= FaceIDCount Then GoTo Exit_Proc ' 終了処理へ
        .Visible = True
      Next j
    End With
  Next i
Exit_Proc: ' 終了処理
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
  Application.ScreenUpdating = True '画面の更新をする
  On Error GoTo 0
End Sub
'======================================================================================
' FaceIdツールバーの削除
'======================================================================================
Private Sub DeleteFaceIDToolbar()
  Dim i As Long, MaxToolBarCount As Long

  On Error Resume Next
  MaxToolBarCount = FaceIDCount \ MaxCountInToolBar
  For i = 0 To MaxToolBarCount
    CommandBars(csToolBarName & CStr(i)).Delete
  Next i
  On Error GoTo 0
End Sub
'===========================================================
' 初期処理
'===========================================================
Sub Auto_Open()
  Call DeleteFaceIDToolbar ' ツールバーの削除
  Call CreateFaceIDToolbar ' ツールバーの追加
End Sub
'===========================================================
' 終了処理
'===========================================================
Sub Auto_Close()
  Call DeleteFaceIDToolbar ' ツールバーの削除
End Sub
'下記は使ってません!
'=================================================
' ツールバーのリセット
'===========================================================
Sub ResetToolBar()
  Dim CB As CommandBar

  On Error Resume Next
  For Each CB In Application.CommandBars
    If CommandBars(CB.Name).BuiltIn Then
      CommandBars(CB.Name).Reset
    Else
      CommandBars(CB.Name).Delete
    End If
  Next
  On Error GoTo 0
End Sub

このページの上