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

FaceIDList


【ファイル名】FaceIDList.xlsm
【バージョン】Ver 1.0.1
【作成日】2015年04月20日
【更新日】2015年04月24日
【動作確認】Microsoft Excel 2010
【ダウンロード】FaceIDList.zip
【説明】FaceIDの画像と番号の一覧のワーク シートを作成します。

画像をクリックするか、選択したセルのテキストをクリップボードにコピーします。
このサンプルではFaceIDの最後を4000としてますが本当はもっとあります。必要があれば変更してください。
FaceIDの画像はExcelのバージョンにより異なる場合があります。
FaceIDはExcel 2003までのメニューやツールバーのボタンの画像として使用します。Excel 2007以降でFaceIDはあまり使用されなくなりました。



プロシージャのCreateFaceIDListを実行すると、FaceIDの画像と番号の一覧のワーク シートを作成します。
自分でシートを作成した場合はコピーするためにWorksheet_SelectionChangeイベントでCopyFaceIdプロシージャを実行してください。

FaceIDListModule
Option Explicit ' 変数は明示的に宣言しなければいけない

Const csMaxRowCount As Long = 10 ' 1行の最大数
Const csMaxFaceIDCount As Long = 4000 ' FaceIDの最大数(本当はもっとあるが使用頻度はあまりない)
Const csSheetName = "FaceIDList" ' シート名
Const csHeadFaceIDName = "FaceID" ' 画像の先頭の名前

'===========================================================
'テキストをクリップボードにコピーします。
'===========================================================
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 (Application.ActiveCell.Value)
End Sub
Sub CopyFaceIdAction(FaceId As String)
  CopyText (FaceId)
End Sub
'===========================================================
' アクティブワークブックに指定したワークシートがあるか?
'===========================================================
Function ExistsWorkSheet(WorkSheetName As String) As Boolean
  Dim sh As Worksheet

  ExistsWorkSheet = False
  If ActiveWorkbook Is Nothing Then Exit Function
  On Error Resume Next
  Set sh = ActiveWorkbook.Worksheets(WorkSheetName)
  ExistsWorkSheet = Not (sh Is Nothing)
  On Error GoTo 0
End Function
'======================================================================================
' FaceIdの一覧の作成
'======================================================================================
Sub CreateFaceIDList()
  Dim i As Long, x As Long, y As Long, FaceId As Long, MaxRowCount As Long
  Dim MyCtrl As CommandBarButton

  On Error Resume Next ' エラーを無視して実行します。
  Application.StatusBar = "FaceIDの一覧を作成してます。しばらくお待ちください..."
  Application.Cursor = xlWait ' マウスカーソルを砂時計
  Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止(ステータスバーのメッセージは更新できます)

  Set MyCtrl = Application.CommandBars("Picture").Controls.Add(msoControlButton)
  With Worksheets.Add
    .Name = csSheetName
    MaxRowCount = csMaxFaceIDCount \ csMaxRowCount '  行数
    If csMaxFaceIDCount > (MaxRowCount * csMaxRowCount) Then MaxRowCount = MaxRowCount + 1 ' 行数 + 1
    For y = 1 To MaxRowCount
      For x = 1 To csMaxRowCount ' 1行のボタン数
        FaceId = (y - 1) * csMaxRowCount + x
        With MyCtrl
          .FaceId = FaceId
          .CopyFace
        End With
        Cells(y, x).Select
        Cells(y, x).Value = FaceId
        ActiveSheet.Paste
        With Selection
          .ShapeRange.Name = csHeadFaceIDName & FaceId
          .ShapeRange.Left = .ShapeRange.Left + 3
          .OnAction = "'FaceIDListModule.CopyFaceIdAction """ & CStr(FaceId) & """'"
        End With
        If FaceId >= csMaxFaceIDCount Then GoTo Exit_Proc ' 終了処理へ
      Next x
    Next y
  End With
Exit_Proc: ' 終了処理
  MyCtrl.Delete
  Set MyCtrl = Nothing
  ActiveSheet.Cells(1, 1).Select
  Application.StatusBar = ""
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
  Application.ScreenUpdating = True '画面の更新をする
  On Error GoTo 0
End Sub

このページの上

Sheetのモジュール
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Call FaceIDListModule.CopyFaceId ' 選択したセルのテキストをクリップボードにコピーします。
End Sub

このページの上