EXCEL/FaceID - a羅針盤

１．FaceIdについて †

Excelが内部で持っているアイコンでExcelのメニューやボタンに使われています。前章のツールバーとコンテキストメニューで紹介しているように自作したこれらのボタンやメニューのアイコンとして使用することができます。ツールバー作成時によく利用するので一覧表を載せておきました。以下を参照して下さい。

EXCEL2010のFaceID一覧

EXCEL2002のFaceID一覧

Excel2010のFaceID一覧は以下のマクロで作成しました。できた一覧表を編集してイメージの無いところを省略しました。確認していませんがSheet_Formatの中の背景色の設定部分を修正すればExcel2002のバージョンでも動くと思います。
FaceIDのイメージは作成したボタンのFaceIDをCopyFaceメソッドでクリップボードにコピーできます。クリップボードのイメージをファイルに落としたり、クリップボードの内容を操作すると複雑になるので、ここではクリップボードにコピー後すぐに直接ワークシートに張り付けています。多量のイメージをワークシートに張り付けるので、計算中ScreenUpdating = Falseにしないと、イメージが増えるにつれて遅くなります。FaceIDは22715以上だとエラーになるので、そこまでで終わるようにしています。
クリップボードを表示して実行すると何回かsht.Pasteした後にsht.Pasteでエラーになるので、クリップボードは非表示の状態で動かしてください。

Option Explicit

Sub main()

    Sheet_Format
    FaceID_Draw
    
End Sub

Sub Sheet_Format()
    Dim sht     As Worksheet
    Dim block   As Integer
    Dim i       As Integer
    Dim j       As Integer
    Dim rowNo   As Integer
    
    Set sht = ActiveSheet
    
    sht.Columns("C:AA").Select
    Selection.ColumnWidth = 2.25
    sht.Rows("3:967").Select
    Selection.RowHeight = 17
    
    For block = 1 To 46
        rowNo = 21 * block - 18
        sht.Range(sht.Cells(rowNo, 3), sht.Cells(rowNo + 19, 27)).Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
        End With
        
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With

    Next block
    
    Set sht = Nothing

End Sub

Sub FaceID_Draw()
    Dim sht         As Worksheet
    Dim block       As Integer
    Dim i           As Integer
    Dim j           As Integer
    Dim rowNo       As Integer
    Dim clmNo       As Integer
    Dim FaceID      As Long
    Dim shpRange    As ShapeRange
    
    Const TempBar   As String = "TempBar"
    Dim TempCmdBar  As CommandBar
    Dim TempBtn     As CommandBarButton
    
    On Error Resume Next
    CommandBars(TempBar).Delete
    On Error GoTo 0
    Set TempCmdBar = Application.CommandBars.Add(Name:=TempBar, Temporary:=True)

    Set TempBtn = TempCmdBar.Controls.Add(Type:=msoControlButton)
    
    Set sht = ActiveSheet
    sht.Application.ScreenUpdating = False
    
    FaceID = 1
    For block = 1 To 46
        Application.StatusBar = block
        For rowNo = 1 To 20
            sht.Cells(rowNo + 21 * block - 19, 2) = FaceID
            For clmNo = 1 To 25
                With TempBtn
                    .FaceID = FaceID
                    .CopyFace
                End With
                
                sht.Cells(rowNo + 21 * block - 19, clmNo + 2).Select
                sht.Paste
                
                FaceID = FaceID + 1
                If FaceID = 22715 Then
                    Exit For
                End If
            Next clmNo
            If FaceID = 22715 Then
                Exit For
            End If

        Next rowNo
        If FaceID = 22715 Then
            Exit For
        End If
        
    Next block
        
    sht.Shapes.SelectAll
    Set shpRange = Selection.ShapeRange
    
    With shpRange
        .IncrementTop 2
        .IncrementLeft 3
    End With
    
    sht.Cells(2, 2).Select
    Application.StatusBar = False
    sht.Application.ScreenUpdating = True
    Set sht = Nothing

End Sub

次は貼り付けたワークシート上の全てのイメージを削除するプロシージャです。

Sub Face_Picture_Delete()
    Dim sht     As Worksheet
    Dim shp     As Shape

    Set sht = ActiveSheet
    For Each shp In sht.Shapes
        If shp.Type = msoPicture Then
            shp.Delete
        End If
    Next shp
    
    Set sht = Nothing

End Sub

前へ　 EXCEL Top　次へ

Last-modified: 2014-03-11 (火) 01:58:42 (3698d)