ツールバーボタンにイメージを表示する時に使うFaceID一覧を表示するためのマクロです。
- 画像をキャプチャするために作ったもので、サイズは 690×500 になるようマクロで調整しました。
環境によっては微調整が必要になるかも知れません。
- 定義関数 KGetValue KFindStr 以外は同じモジュールにして下さい。
- マクロ KFaceID01 で ControlButton のプロパティを変更しても反映されない時は、Excel の再起動をして下さい。
特に ボタンの追加・削除 faceID などの変更は再起動しないとだめみたいです。
- ControlButton で終了すると枠線を表示します。
- このマクロは AddinBox を参考にしました。
- Excelファイルダウンロード FaceID.lzh (26KB)
Option Explicit
Const myBarname As String = "FaceID List" 'コマンドバーの名前
Const myIdPageMax As Integer = 500 'IDの一画面表示数 (500)
Const myIdColCount As Integer = 25 'IDの一列表示数 (25)
Dim myIdMin As Integer '表示されているIDの最小値（先頭）
Dim myIdMax As Integer '表示されているIDの最大値（最後）
Sub KFaceID01()
''FaceID一覧表示 2003/12/20
Dim MyCB As CommandBar
Dim MyCBCtrl As CommandBarControl
Dim myCount As Integer 'カウンタ変数
Dim myButtonCount As Integer 'ボタン数（FaceIDを除く）
myButtonCount = 4 '[戻る] [表示範囲] [進む] [消去]
''初回のゼロ防止
If myIdMin = 0 Then
myIdMin = 1
End If
On Error Resume Next
Set MyCB = Application.CommandBars(myBarname)
If (MyCB Is Nothing) Then
''初回表示
Set MyCB = Application.CommandBars.Add(Name:=myBarname, Temporary:=True)
''1つ目のボタンの作成 (Button)
Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton)
With MyCBCtrl
.FaceID = 1017 ' (←)
.TooltipText = "戻る"
.OnAction = "KFaceIDBack"
End With
Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton)
With MyCBCtrl
.Style = msoButtonCaption
.Caption = "1 〜 " & myIdPageMax
.TooltipText = "表示範囲"
End With
Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton)
With MyCBCtrl
.FaceID = 1018 ' (→)
.TooltipText = "進む"
.OnAction = "KFaceIDNext"
End With
''4つ目のボタンの作成
Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton)
With MyCBCtrl
.FaceID = 1019
.TooltipText = "消去"
.OnAction = "KFaceIDDel"
End With
''5〜504 のボタンの作成
For myCount = 1 To myIdPageMax
Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton)
With MyCBCtrl
If (myCount = 1) Then
.BeginGroup = True
End If
.FaceID = myCount
.TooltipText = myCount
End With
Next myCount
''ツールバー表示
With MyCB
.Width = MyCB.Controls(myButtonCount + 1).Width * (myIdColCount + 1) '(25個分+α)
.Top = 150
.Left = 300
.Visible = True
End With
''表示範囲の書き換え
Else
With MyCB.Controls(2) ' 表示範囲
.Caption = myIdMin & "〜" & myIdMin + myIdPageMax - 1
End With
For myCount = 1 To myIdPageMax
With MyCB.Controls(myCount + myButtonCount) '(5)〜(504)
myIdMax = myIdMin + myCount - 1
.FaceID = myIdMax
.TooltipText = myIdMax
End With
Next myCount
MyCB.Visible = True
End If
''FaceID一覧番号表示 2003/12/20
KFaceID10 myIdMin
Set MyCBCtrl = Nothing
Set MyCB = Nothing
myIdMin = 1
End Sub
Sub KFaceIDBack()
Dim MyCB As CommandBar
On Error Resume Next
Set MyCB = Application.CommandBars(myBarname)
myIdMin = Val(MyCB.Controls(2).Caption) '[〜]の前のみ
Set MyCB = Nothing
If (myIdMin > 1) Then
myIdMin = myIdMin - myIdPageMax
KFaceID01
End If
End Sub
Sub KFaceIDNext()
Dim MyCB As CommandBar
On Error Resume Next
Set MyCB = Application.CommandBars(myBarname)
myIdMin = Val(MyCB.Controls(2).Caption) '[〜]の前のみ
Set MyCB = Nothing
If (myIdMin < 4001) Then
myIdMin = myIdMin + myIdPageMax
KFaceID01
End If
End Sub
Sub KFaceIDDel()
On Error Resume Next
myIdMin = 1
Application.CommandBars(myBarname).Delete
''枠線表示する
ActiveWindow.DisplayGridlines = True
End Sub
Sub KFaceID10(myStartid As Integer)
''FaceID一覧番号表示 2003/12/20
Dim myAction As String
Dim myCol01 As Integer, myCol02 As Integer
Dim myRow01 As Integer, myRow02 As Integer
Dim myColWa As Integer, myColWb As Integer
Dim myColWc As Integer, myColWd As Integer
Dim myColWe As Integer, myColWm As Integer
Dim myZAdr1 As String, myZAdr2 As String
Dim myZRow1 As Integer, myZRow2 As Integer, myZRowh As Integer
Dim myZCol1 As Integer
myAction = "番号計算"
Range("A1").Select
''変数値取得 戻り値:変数値 2002/5/18
myAction = "【 " & myAction & " 】"
myZRow1 = KGetValue("", myAction, 1)
myZRow2 = KGetValue("", myAction, 2)
myZRowh = KGetValue("", myAction, 3)
myCol01 = KGetValue("", myAction, 4)
myCol02 = KGetValue("", myAction, 5)
myRow01 = KGetValue("", myAction, 6)
myRow02 = KGetValue("", myAction, 7)
myColWa = KGetValue("", myAction, 8)
myColWb = KGetValue("", myAction, 9)
myColWc = KGetValue("", myAction, 10)
myColWd = KGetValue("", myAction, 11)
myColWe = KGetValue("", myAction, 12)
myColWm = KGetValue("", myAction, 13)
''行高
myZAdr1 = Range(Cells(myZRow1, 1), Cells(myZRow2, 1)).Address
Range(myZAdr1).RowHeight = myZRowh
''ID番号計算
Cells(myRow01, myCol01).Value = myStartid
''左側
Cells(myRow01 + 1, myCol01).FormulaR1C1 = "=R[-1]C+" & myIdColCount
myZAdr1 = Range(Cells(myRow01 + 1, myCol01), Cells(myRow02, myCol01)).Address
Cells(myRow01 + 1, myCol01).Select
Selection.AutoFill Destination:=Range(myZAdr1), Type:=xlFillDefault
''右側
myZCol1 = myCol01 - myCol02
myZAdr2 = Cells(myRow01, myCol02).Address
Range(myZAdr2).FormulaR1C1 = "=RC[" & myZCol1 & "]+" & myIdColCount & "-1"
Cells(myRow01 + 1, myCol02).FormulaR1C1 = "=R[-1]C+" & myIdColCount
myZAdr2 = Range(Cells(myRow01 + 1, myCol02), Cells(myRow02, myCol02)).Address
Cells(myRow01 + 1, myCol02).Select
Selection.AutoFill Destination:=Range(myZAdr2), Type:=xlFillDefault
''列幅調整
myZAdr1 = Cells(1, 1).Address
Range(myZAdr1).ColumnWidth = myColWa
myZAdr1 = Cells(1, 2).Address
Range(myZAdr1).ColumnWidth = myColWb
myZAdr1 = Cells(1, 3).Address
Range(myZAdr1).ColumnWidth = myColWc
myZAdr1 = Cells(1, myCol01).Address
Range(myZAdr1).ColumnWidth = myColWd
myZAdr1 = Range(Cells(1, myCol01 + 1), Cells(1, myCol02 - 1)).Address
Range(myZAdr1).ColumnWidth = myColWe
myZAdr1 = Cells(1, myCol02).Address
Range(myZAdr1).ColumnWidth = myColWm
''枠線表示しない
ActiveWindow.DisplayGridlines = False
Cells(myRow01, myCol01 - 1).Select
End Sub
Function KGetValue(mypZSht As String, mypAction As String, mypVno As Integer)
''値取得 戻り値:値 2002/9/13
' myaa = KGetValue( mypZSht,Action,Vno)
Dim mypZAction As String '実行処理名
Dim mypActionRow As Integer 'アクション名行
Dim mypZC As Integer '変数値取得列
Dim mypValue As Variant
If mypZSht = "" Then
mypZSht = ActiveWorkbook.ActiveSheet.Name
End If
mypZC = 2 'B列
mypZAction = mypAction
mypActionRow = KFindStr(1, 1, mypZSht, mypZAction) 'fJ 1:行方向 fR 1:行番号
mypValue = Sheets(mypZSht).Cells(mypActionRow + mypVno, mypZC).Value
KGetValue = mypValue
End Function
Function KFindStr(mypJSearch As Integer, mypRC As Integer, mypZSht As String, _
mypText As Variant)
''文字列を検索(方向指定)して、行・列番号を返す 2002/5/19
' myaa=KFindStr (fJ ,fR,ZSht,"Code") 'fJ 1:行方向 2:列方向 fR 1:行番号 2:列番号
''mypJ 1:行方向(列基準) 2:列方向(行基準) mypR 1:行番号 2:列番号
' myaa=KFindStr (1 ,1,ZSht,"Code") 'fJ 1:行方向 fR 1:行番号
' myab=KFindStr (2 ,2,ZSht,"Code") 'fJ 2:列方向 fR 2:列番号
Dim mypFindJ As String '検索方向
Dim mypTitle As String
Dim mypMsg1 As String
Dim mypMsg2 As String
mypTitle = "文字列検索"
mypMsg1 = "文字列 [ "
mypMsg2 = " ] が見つかりません。？"
If mypZSht = "" Then
mypZSht = ActiveSheet.Name
End If
If mypJSearch = 1 Then '行方向(列基準)
mypFindJ = xlByColumns
ElseIf mypJSearch = 2 Then '列方向(行基準)
mypFindJ = xlByRows
Else
MsgBox "パラメータが違います。 1 or 2", vbCritical, mypTitle
End
End If
On Error GoTo FindErr
If mypRC = 1 Then
KFindStr = Sheets(mypZSht).Cells.Find(What:=mypText, After:=Range("A1"), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=mypFindJ, SearchDirection:=xlNext, _
MatchCase:=False).Row
ElseIf mypRC = 2 Then
KFindStr = Sheets(mypZSht).Cells.Find(What:=mypText, After:=Range("A1"), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=mypFindJ, SearchDirection:=xlNext, _
MatchCase:=False).Column
End If
Exit Function
FindErr:
mypMsg1 = mypMsg1 & mypText & mypMsg2
MsgBox mypMsg1, vbCritical, mypTitle
End
End Function
