[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ツールバーに自作のアイコンを追加したい』（しのみや）
ツールバーに自作のアイコンを追加しようとしていて、 以下の記述をxlaで保存し、アドイン化しました。
Private Sub Workbook_AddinInstall()
On Error Resume Next
Application.CommandBars("パレット").Delete
Dim myBar As CommandBar, myButton As CommandBarButton
Set myBar = Application.CommandBars.Add(Position:=msoBarTop)
myBar.Name = "パレット"
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
myButton.OnAction = "RGB"
myButton.Caption = "RGB"
myButton.FaceId = 59
myBar.Visible = True
On Error GoTo 0
End Sub
ここでmyButton.FaceId = 59の部分を自分が作成したアイコンに変更しようとしています。 アイコンは、ビットマップで保存したものです。
どのようにしたらよいでしょうか。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
ただ、このアドインを人と共有しようと考えておりまして、
cに置いておけないのです。
どのようにしたら対応できますでしょうか。
（しのみや） 2020/12/16(水) 13:15
myButton.Picture = UserForm1.Image1.Picture
とかが簡単でしょうか。
（チオチモリン ） 2020/12/16(水) 14:07
ありがとうございます 必要な結果が得られました ユーザーフォームに置いてそれを読み込みに行く方法があるのですね （しのみや） 2020/12/16(水) 15:19
もうひとつ教えていただきたいことが出てきましたのでよろしくお願いします。
ツールバーにオプションボタンを置きたくて、
UserFormにFrameを置いて、オプションボタンを３つ置きました。
myButton.Picture = UserForm1.Frame1
このような感じでできるのかな…と試してみているのですが どうやら違うようです。
どのようにしたらよいでしょうか。 （しのみや） 2020/12/18(金) 09:55
見た目だけの話じゃなくって、 ちゃんとオプションボタンとして機能するオプションボタンですよね? RibbonUIの方でもcheckBoxならありますけど、Optionはどうなんだろ? 出来るのかな・・・? 私は見たことありません。
CommandBarのControlは ・Button ・ComboBox ・Popup の3種類なので機能としてはComboBoxがいちばん近いと思いますけどね
Sub Test_Add()
On Error Resume Next
Application.CommandBars("パレット").Delete
On Error GoTo 0
Dim myBar As CommandBar, myCombo As CommandBarComboBox
Set myBar = Application.CommandBars.Add(Position:=msoBarTop)
myBar.Name = "パレット"
Set myCombo = myBar.Controls.Add(Type:=msoControlComboBox)
myCombo.Caption = "Combo1"
myCombo.AddItem "Option1"
myCombo.AddItem "Option2"
myCombo.AddItem "Option3"
myCombo.OnAction = "Combo1_Click"
myBar.Visible = True
End Sub
Sub Combo1_Click()
MsgBox Application.CommandBars("パレット").Controls("Combo1").ListIndex
End Sub
（白茶） 2020/12/18(金) 11:40
（MK） 2020/12/18(金) 12:06
無理矢理ですがFaceIdの切替で「ソレっぽく」見せてみましたので追記しときます
Sub Test_Add()
On Error Resume Next
Application.CommandBars("パレット").Delete
On Error GoTo 0
Dim myBar As CommandBar, myCombo As CommandBarComboBox
Dim myButton As CommandBarButton
Set myBar = Application.CommandBars.Add(Position:=msoBarTop)
myBar.Name = "パレット"
Set myCombo = myBar.Controls.Add(Type:=msoControlComboBox)
myCombo.Caption = "Combo1"
myCombo.AddItem "Option1"
myCombo.AddItem "Option2"
myCombo.AddItem "Option3"
myCombo.OnAction = "Combo1_Click"
Dim i As Long
For i = 1 To 3
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
myButton.Caption = "Button" & i
myButton.OnAction = "'Button_Click " & i & "'"
myButton.Style = msoButtonIconAndCaption
myButton.FaceId = 6083
If i = 1 Then
myButton.State = msoButtonDown
myButton.FaceId = 6082
End If
Next
myBar.Visible = True
End Sub
Sub Combo1_Click()
MsgBox Application.CommandBars("パレット").Controls("Combo1").ListIndex
End Sub
Sub Button_Click(id As String)
With Application.CommandBars("パレット")
If .Controls("Button" & id).State = msoButtonDown Then Exit Sub
Dim myButton As CommandBarControl
For Each myButton In .Controls
If myButton.Caption Like "Button#" Then
myButton.State = msoButtonUp
myButton.FaceId = 6083
End If
Next
.Controls("Button" & id).State = msoButtonDown
.Controls("Button" & id).FaceId = 6082
End With
End Sub
（白茶） 2020/12/18(金) 13:14
ComboBoxを使わさせてもらおうかなと考えていたところ、 無理やりでも再現されるとは… 今から動きを勉強させてもらいます! （しのみや） 2020/12/18(金) 14:57
FaceIdの切替の頂いた記述をAddinsFileColor0.xlaのThisWorkbookに貼り付けて実行してみたところ、 ツールバーにコンボボックスとボタンの表示はできました。
しかし、Button1をクリックするとエラーメッセージが出ます。
マクロ"\\○○○\Microsoft\Addins\AddinsFileColor0.xla'!'Button_Click 1”を実行できません。 このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。
なにか私の貼り付け方が悪いのでしょうか…？ （しのみや） 2020/12/18(金) 15:48
すみませんちょっと進めることができました （しのみや） 2020/12/18(金) 15:55
頂いた記述のままですと、 ボタンの表示が ◎Button1 ○Button2 ○Button3となっておりますが、 ↓ ◎あああ ○いいい ○ううう としたいので、
myButton.Caption = "Button" & i ここを myButton.Caption = "あああ" に変えれば良いと思うのですが 変えてしまうと
Sub Button_Click(id As String) がうまく動かないのです。
どのようにしたらよいでしょうか。 （しのみや） 2020/12/18(金) 16:43
まぁ、いろいろやり様はあると思いますけど 例えば・・・
Sub Test_Add()
On Error Resume Next
Application.CommandBars("パレット").Delete
On Error GoTo 0
Dim myBar As CommandBar
Dim myButton As CommandBarButton
Set myBar = Application.CommandBars.Add(Position:=msoBarTop)
myBar.Name = "パレット"
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
myButton.Caption = "あああ"
myButton.OnAction = "'Button_Click """ & myButton.Caption & """'"
myButton.Style = msoButtonIconAndCaption
myButton.FaceId = 6082
myButton.Tag = "Group1"
myButton.State = msoButtonDown
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
myButton.Caption = "いいい"
myButton.OnAction = "'Button_Click """ & myButton.Caption & """'"
myButton.Style = msoButtonIconAndCaption
myButton.FaceId = 6083
myButton.Tag = "Group1"
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
myButton.Caption = "ううう"
myButton.OnAction = "'Button_Click """ & myButton.Caption & """'"
myButton.Style = msoButtonIconAndCaption
myButton.FaceId = 6083
myButton.Tag = "Group1"
myBar.Visible = True
End Sub
Sub Button_Click(id As String)
With Application.CommandBars("パレット")
If .Controls(id).State = msoButtonDown Then Exit Sub
Dim myButton As CommandBarControl
For Each myButton In .Controls
If myButton.Tag = "Group1" Then
myButton.State = msoButtonUp
myButton.FaceId = 6083
End If
Next
.Controls(id).State = msoButtonDown
.Controls(id).FaceId = 6082
End With
End Sub
（白茶） 2020/12/18(金) 17:02
参考出品 6083 あるんですね。446,1852,3940あたりで諦めてました。 白茶さん 感謝。 で、私も作ってみました。
Sub Test_Bar_Ctrl_Add()
Dim CB As Office.CommandBar
Dim i As Long
On Error Resume Next
Application.CommandBars(CB_Name).Delete '再作成時
Set CB = Application.CommandBars(CB_Name)
On Error GoTo 0
If CB Is Nothing Then
Set CB = Application.CommandBars.Add(CB_Name, , , True)
End If
'---
CB.Controls.Add(msoControlButton, 59).OnAction = "TestBtn1"
Call OP_作成(CB_Name, "Grp1", "○○,◇◇,■■", 1)
'---
CB.Controls.Add(msoControlButton, 59).OnAction = "TestBtn2"
Call OP_作成(CB_Name, "Grp2", "あああ,いいい,ううう", 2)
CB.Visible = True
End Sub
Sub TestBtn1()
MsgBox OP_Selected(CB_Name, "Grp1")
End Sub
Sub TestBtn2()
MsgBox OP_Selected(CB_Name, "Grp2")
End Sub
Sub OP_作成(BarName As String, グループ名 As String, 選択肢 As Variant, Optional 初期値 As Long = 1)
Dim i As Long
Dim CB As Office.CommandBar
Set CB = Application.CommandBars(BarName)
選択肢 = Split(選択肢, ",")
For i = 0 To UBound(選択肢)
With CB.Controls.Add(msoControlButton, 59)
.Tag = グループ名
.FaceId = IIf(初期値 = i + 1, 6082, 6083)
.Caption = 選択肢(i)
.OnAction = "OP_Click"
.Style = msoButtonIconAndCaption
End With
Next
CB.Visible = True
End Sub
Sub OP_Click()
Dim CBB As Office.CommandBarButton
Dim ClickCBB As Office.CommandBarButton
Set ClickCBB = Application.CommandBars.ActionControl
For Each CBB In ClickCBB.Parent.Controls
If CBB.Tag = ClickCBB.Tag Then CBB.FaceId = 6083
Next
ClickCBB.FaceId = 6082
End Sub
Function OP_Selected(BarName As String, グループ名 As String) As String
Dim CBB As Office.CommandBarButton
For Each CBB In Application.CommandBars(BarName).Controls
If CBB.Tag = グループ名 And CBB.FaceId = 6082 Then OP_Selected = CBB.Caption: Exit For
Next
End Function
（チオチモリン ） 2020/12/19(土) 10:17
忘れてました。 モジュールの先頭に Const CB_Name As String = "TestBar"’任意 を追加してください。 （チオチモリン ） 2020/12/19(土) 10:33
ちなみに9631と9632でCheckBoxのオン/オフも表現出来そうですよ。
手持ちの道具で22714まで並べて眺めてみたんですけど、 オフ時のイメージは1個ずつしか無さそうでした。
（白茶） 2020/12/21(月) 08:48
すぐ回答頂いているのに、返信遅くてすみません。 白茶さんのFaceIdの記述でオプションボタンの必要な動きが得られました。
こんな風にできるのかな？というのがもう一つ出て来ましたので、よろしくお願いします。
アドインを２つ追加したとします。
AddinsFileColor0.xla
◎あああ ○いいい ○ううう ←Application.CommandBars("パレット0")
AddinsFileColor1.xla
■□●○▲△ ←Application.CommandBars("パレット1")
◎あああが選択されていて、パレット1の■をクリックしたときに、Ａという動作 ◎あああが選択されていて、パレット1の□をクリックしたときに、Ｂという動作 ◎あああが選択されていて、パレット1の●をクリックしたときに、Ｃという動作 （省略） ◎いいいが選択されていて、パレット1の■をクリックしたときに、Ｇという動作 （省略）
このように、動作を分けたいのです。
AddinsFileをまたいで？選択されているもののIDを渡すことはできるのだろうか…と考えております…
もしできなければ、ひとつのAddinsFileする方法にしようかなと考えています。
AddinsFileColor0.xla
◎あああ ○いいい ○ううう ■□●○▲△ ←Application.CommandBars("パレット0")
しかし、 AddinsFileColor1.xlaが９まであるので分けておいたほうが管理もしやすいかなと思っています。
チオチモリン さん 白茶さんの記述を理解するので今のところ頭の中がいっぱいで… また時間を見つけて勉強をさせて頂きたいと思います。 ありがとうございます。 （しのみや） 2020/12/21(月) 11:56
白茶さん
CheckBoxのFaceID情報ありがとうございます。
ついでにチェックボックス版も作ろうかと思いますが、
チェック状態の戻り値を配列にするかカンマ区切りの文字列にするか 悩みますね。
（チオチモリン ） 2020/12/21(月) 14:50
実行トリガーはパレット1の各ボタンなので、 パレット1各ボタンのOnActionに指定したプロシージャの中で、 パレット0の有無を確認した上で、各オプションボタンのFaceIdを調べて分岐させれば良いのではないでしょうか? 今回の場合、アドインが分かれているかどうかは、あまり関係ない様に思いますけど・・・。
>もしできなければ、ひとつのAddinsFileする うーん、どうでしょう・・・ 提示頂いているのはあくまで「例」なのでしょうし、 私も実物を見て言ってる訳じゃないので、あんまり無責任な事は言えないですが、 今回の場合、パレット1は「パレット0ありき」の様ですから、あえて分ける意味があまり感じられません。
通常、アドインは「組織」であったり「業務」であったり、ある程度「大きな括り」でひとつにするのが自然ではないかと思います。 バージョン管理や、配布の問題等、後々の事を考えてなるべく一元的に扱える状態が望ましいのではないかと。
アドイン1が提供する機能とアドイン2が提供する機能に依存関係があるならば、 最低でも一方向の依存関係(アドイン2はアドイン1のアペンドである等)しか許容出来ませんしね。 で、 もしそこに設計上の意図があるが故の分割なのであれば、 「もしできなければ」を判断基準にするのは、ちょっと危なっかしくないでしょうか?
それに関連して、冒頭で気になってはいた事なのですが(すんごい「細かい事」で)、 Workbook_AddinInstallイベントでパレット作るのも、ちょっと気になります。
アドイン固有の設定値(例えば各パレットのオプションボタンの初期値等)を指定したい場合、 アドインファイル自体に保存する事も可能ではありますが、 Program Files配下にアドインを置くならUACの制限を考慮しないといけないので、 UserProfile配下にiniファイルを作ったり、レジストリを使って設定値を覚えさせたりします。
AddinInstallイベントって、そういったアドインの機能「そのもの」ではなく 機能を構築する為の「下準備」に関する動作に使う為のものだと思うんですよね(文脈的な意味では) 例えば↓こんな感じの流れです
Workbook_AddinInstall iniファイルの作成、レジストリの登録 ↓ ---------------------------------------------------------------------------- Workbook_Open ini・レジストリの読み込み → パレットの作成 ↓ ここが日常的に動かす範囲 Workbook_BeforeClose ini・レジストリの保存 → パレットの削除 ↓ ---------------------------------------------------------------------------- Workbook_AddinUninstall iniファイル、レジストリの削除
話が逸れてしまいましたが、 アドインの分割・統合については、その辺を踏まえてご判断された方が良いと思います。
※ あくまでご提示頂いている例を見た限りでの「私見」ですので、あまり真に受けないで下さいね。
（白茶） 2020/12/21(月) 15:19
白茶さん 頂いたお話の全部の理解はとてもついていけていない状態ではありますが…
自分で書きながらもAddinを分けておきたい理由が、 これといって根拠があるものではないと感じております…
とても勉強になるお話、ありがとうございます。
チオチモリン さん ただいま頂いた記述を勉強中です。
また行き詰ると思いますので教えて頂けると助かります。 ひとまずひとつのAddinで作ってみて違和感がないか…チャレンジしてみます。
（しのみや） 2020/12/21(月) 15:55
（花村） 2020/12/23(水) 01:51
手持ちの道具ですか。 100個ずつ順番に表示させるUserFormです。 たぶんご想像されてる様な便利なものではありませんよ? (検索機能とか無いです。ただ単に並べるだけ)
一応コード貼っときますね。(しのみやさん、場所お借りします) 作ったのもかなり前ですし、Excel2010でしか使った事ありませんので、動かなかったら諦めて下さい。
ShowModalをFalseにしたUserFormに以下のコードを貼って、適当に呼出して下さい。
Option Explicit
Rem API宣言=====================================================================================================
Rem クリップボード関係------------------------------------------------------------------------------------------
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Rem デバイスコンテキスト関係------------------------------------------------------------------------------------
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Const CF_BITMAP = 2&
Rem DIBit関係---------------------------------------------------------------------------------------------------
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private Declare PtrSafe Function GetDIBits Lib "gdi32" ( _
ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0&
Private Declare PtrSafe Function SetDIBits Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" ( _
ByVal hDC As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As LongPtr, _
ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Rem IPicture作成------------------------------------------------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
Private Const vbPicTypeBitmap = 1&
Rem CopyImage---------------------------------------------------------------------------------------------------
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Const IMAGE_BITMAP = 0&
Private Const LR_CREATEDIBSECTION = &H2000&
Rem その他変数・定数============================================================================================
Rem ------------------------------------------------------------------------------------------------------------
Private Const FM_WIDTH As Long = 324
Private Const FM_HEIGHT As Long = 225
Rem ------------------------------------------------------------------------------------------------------------
Private LabelHeader As MSForms.Label
Private WithEvents ChkCopyFace As MSForms.CheckBox
Private WithEvents FaceCover As MSForms.Label
Private LabelIdNum As MSForms.Label
Private WithEvents PixelCover As MSForms.Label
Private WithEvents ButtonPrev As MSForms.CommandButton
Private WithEvents ButtonNext As MSForms.CommandButton
Private WithEvents ButtonGoto As MSForms.CommandButton
Private WithEvents ButtonZoom As MSForms.CommandButton
Private WithEvents ButtonCopy As MSForms.CommandButton
Private WithEvents ButtonPaint As MSForms.CommandButton
Private WithEvents ButtonList As MSForms.CommandButton
Private LabelCap As MSForms.Label
Private LabelCap2 As MSForms.Label
Private LabelPx As MSForms.Label
Rem ------------------------------------------------------------------------------------------------------------
Private IdZero As Long, IdNow As Long, PicNow As IPictureDisp
Rem 内部イベント================================================================================================
Private Sub PrepareControls()
Dim i As Long
Me.Width = FM_WIDTH
Me.Height = FM_HEIGHT
Set LabelHeader = Me.Controls.Add("Forms.Label.1", "LabelHeader")
With LabelHeader
.Top = 2: .Height = 9: .Left = 6: .Width = 180
.TextAlign = fmTextAlignCenter
End With
For i = 0 To 99
With Me.Controls.Add("Forms.Image.1", "Face" & Format$(i, "000"))
.Top = 12 + 18 * Int(i / 10): .Height = 18: .Left = 6 + 18 * (i Mod 10): .Width = 18
.SpecialEffect = fmSpecialEffectRaised
.BackStyle = fmBackStyleTransparent
End With
Next
Set LabelCap = Me.Controls.Add("Forms.Label.1", "LabelCap")
With LabelCap
.Top = 12 + 180 + 1.5: .Height = 9: .Left = 6: .Width = 306
End With
Set FaceCover = Me.Controls.Add("Forms.Label.1", "FaceCover")
With FaceCover
.Top = 12: .Height = 180: .Left = 6: .Width = 180
.BackStyle = fmBackStyleTransparent
.ControlTipText = "拡大画像の描画/右クリックで画像をファイルに保存"
End With
Set ButtonPrev = Me.Controls.Add("Forms.CommandButton.1", "ButtonPrev")
With ButtonPrev
.Top = 6: .Height = 21: .Left = 190: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("MailMergeGoToPreviousRecord", 16, 16)
.Accelerator = ","
.ControlTipText = "前のページ(&<)"
End With
Set ButtonNext = Me.Controls.Add("Forms.CommandButton.1", "ButtonNext")
With ButtonNext
.Top = 6: .Height = 21: .Left = 211: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("MailMergeGoToNextRecord", 16, 16)
.Accelerator = "."
.ControlTipText = "次のページ(&>)"
End With
Set ChkCopyFace = Me.Controls.Add("Forms.CheckBox.1", "ChkCopyFace")
With ChkCopyFace
.Top = 6: .Height = 21: .Left = 234: .Width = 72
.Accelerator = "T"
.Caption = "旧画像(T)"
.ControlTipText = "CopyFaceを使った古い画像を表示(ちょっと重い)"
End With
Set ButtonGoto = Me.Controls.Add("Forms.CommandButton.1", "ButtonGoto")
With ButtonGoto
.Top = 6: .Height = 21: .Left = 237 + 54: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("FindDialog", 16, 16)
.Accelerator = "G"
.ControlTipText = "指定したIdへジャンプ(&G)"
End With
Set ButtonZoom = Me.Controls.Add("Forms.CommandButton.1", "ButtonZoom")
Set LabelIdNum = Me.Controls.Add("Forms.Label.1", "LabelIdNum")
With LabelIdNum
.Top = 30: .Height = 9: .Left = 190: .Width = 7.5 * 16 + 3
End With
With Me.Controls.Add("Forms.Frame.1", "Frame2")
.Top = 39: .Height = 7.5 * 16 + 3: .Left = 190: .Width = 7.5 * 16 + 3
.SpecialEffect = fmSpecialEffectSunken
.PictureTiling = True
Set .Picture = CreateCheckeredPattern(&HE5E5E5, &HFFFFFF, 5)
For i = 0 To 255
With .Controls.Add("Forms.Label.1", "Pixel" & Format$(i, "000"))
.Top = 7.5 * Int(i / 16): .Height = 7.5: .Left = 7.5 * (i Mod 16): .Width = 7.5
.BackStyle = fmBackStyleTransparent
End With
Next
Set PixelCover = .Controls.Add("Forms.Label.1", "PixelCover")
With PixelCover
.Height = 7.5 * 16: .Width = 7.5 * 16
.BackStyle = fmBackStyleTransparent
.ControlTipText = "透過色の設定/解除"
End With
End With
Set LabelCap2 = Me.Controls.Add("Forms.Label.1", "LabelCap2")
With LabelCap2
.Top = 39 + 7.5 * 16 + 3: .Height = 9: .Left = 190: .Width = 7.5 * 16 + 3
End With
With ButtonZoom
.Top = 39 + 7.5 * 16 + 12: .Height = 21: .Left = 190: .Width = 21 '42
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("ZoomIn", 16, 16)
.Accelerator = "Z"
.ControlTipText = "このフォーム自身を拡大/縮小(&Z)"
End With
Set ButtonPaint = Me.Controls.Add("Forms.CommandButton.1", "ButtonPaint")
With ButtonPaint
.Top = 39 + 7.5 * 16 + 12: .Height = 21: .Left = 190 + 21.75: .Width = 39
.Accelerator = "P"
.Caption = "塗絵(P)"
.ControlTipText = "選択中の画像でセル塗り絵を作成"
End With
Set ButtonList = Me.Controls.Add("Forms.CommandButton.1", "ButtonList")
With ButtonList
.Top = 39 + 7.5 * 16 + 12: .Height = 21: .Left = 190 + 21.75 + 39.75: .Width = 39
.Accelerator = "L"
.Caption = "書出(L)"
.ControlTipText = "現在の画像一覧(100個分)を新規シートに書き出し"
End With
Set ButtonCopy = Me.Controls.Add("Forms.CommandButton.1", "ButtonCopy")
With ButtonCopy
.Top = 39 + 7.5 * 16 + 12: .Height = 21: .Left = 291: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("Copy", 16, 16)
.Accelerator = "C"
.ControlTipText = "選択中の画像をクリップボードにコピー(&C)"
End With
End Sub
Private Sub UserForm_Initialize()
Call PrepareControls
Call UpdateImageLabels(IdZero)
End Sub
Private Sub UserForm_Terminate()
Set PicNow = Nothing
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Not LabelCap Is Nothing Then LabelCap.Caption = Empty
If Not LabelCap2 Is Nothing Then LabelCap2.Caption = Empty
If Not LabelPx Is Nothing Then LabelPx.BorderStyle = fmBorderStyleNone
End Sub
Private Sub ButtonPrev_Click()
StartId = StartId - 100
End Sub
Private Sub ButtonNext_Click()
StartId = StartId + 100
End Sub
Private Sub ButtonGoto_Click()
Dim i As Variant
i = InputBox("番号を入力")
If IsNumeric(i) Then CurrentId = CLng(i)
End Sub
Private Sub ChkCopyFace_Change()
Call UpdateImageLabels(IdZero, ChkCopyFace.Value)
Set PicNow = GetImagefromFaceId(IdNow, ChkCopyFace.Value)
Call UpdatePixelLabels(PicNow.handle)
End Sub
Private Sub FaceCover_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If x < 0 Or y < 0 Then Exit Sub
If x > FaceCover.Width Or y > FaceCover.Height Then Exit Sub
CurrentId = IdZero + Int(y / 18) * 10 + Int(x / 18)
If PicNow Is Nothing Then Exit Sub
If Button = 2 Then
Dim aPath As String, fExist As Boolean
aPath = Format$(IdNow, "00000") & ".bmp"
With CreateObject("Scripting.FileSystemObject")
Do
aPath = Application.GetSaveAsFilename(aPath, "ビットマップ,*.bmp,All file,*.*")
If aPath = "False" Then Exit Sub
fExist = .FileExists(aPath)
If fExist Then
If MsgBox(.GetFileName(aPath) & " は既に存在します。" & vbCrLf & "上書きしますか?", _
vbYesNo + vbExclamation, "上書き保存の確認") = vbYes Then Exit Do
End If
Loop While fExist
End With
SavePicture PicNow, aPath
End If
End Sub
Private Sub FaceCover_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If x < 0 Or y < 0 Then Exit Sub
If x > FaceCover.Width Or y > FaceCover.Height Then Exit Sub
Dim i As Long
i = Int(y / 18) * 10 + Int(x / 18)
If i > 99 Then Exit Sub
LabelCap.Caption = Me.Controls("Face" & Format$(i, "000")).ControlTipText
End Sub
Private Sub PixelCover_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If x < 0 Or y < 0 Then Exit Sub
If x > PixelCover.Width Or y > PixelCover.Height Then Exit Sub
Dim i As Long, bk As fmBackStyle, cl As Long
With Me.Controls("Pixel" & Format$(Int(y / 7.5) * 16 + Int(x / 7.5), "000"))
bk = .BackStyle
bk = IIf(bk = fmBackStyleOpaque, fmBackStyleTransparent, fmBackStyleOpaque)
cl = .BackColor
End With
For i = 0 To 255
With Me.Controls("Pixel" & Format$(i, "000"))
.BackStyle = fmBackStyleOpaque
If .BackColor = cl Then .BackStyle = bk
End With
Next
End Sub
Private Sub PixelCover_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Not LabelPx Is Nothing Then LabelPx.BorderStyle = fmBorderStyleNone
If x < 0 Or y < 0 Then Exit Sub
If x > PixelCover.Width Or y > PixelCover.Height Then Exit Sub
Dim i As Long
i = Int(y / 7.5) * 16 + Int(x / 7.5)
If i > 255 Then Exit Sub
Set LabelPx = Me.Controls("Pixel" & Format$(i, "000"))
With LabelPx
LabelCap2.Caption = .ControlTipText
.BorderStyle = fmBorderStyleSingle
.BorderColor = IIf(GetYfromRGB(SysColor2RGB(.BackColor)) < 0.5!, &HFFFFFF, &H0&)
End With
End Sub
Private Sub ButtonCopy_Click()
If Not PicNow Is Nothing Then
Dim Pic As IPictureDisp, hBmp As LongPtr
Set Pic = Me.Controls("Face" & Format$(IdNow - IdZero, "000")).Picture
Rem Pic.handleをそのままクリップボードに持っていくと、
Rem IPictureの破棄、あるいは別のビットマップオブジェクトが設定された時点で
Rem 現ビットマップオブジェクトも破棄されるのでコピーをクリップボードに持っていく
Rem あとDIBセクションとしてコピーすると貼り付け時に絵が認識できないのでフラグなしでコピー
hBmp = CopyImage(Pic.handle, IMAGE_BITMAP, 0&, 0&, 0&)
Call CopyBmptoClipboard(hBmp)
Call DeleteObject(hBmp)
End If
End Sub
Private Sub ButtonZoom_Click()
Dim tBarHeight As Single
tBarHeight = Me.Height - Me.InsideHeight
If Me.Zoom = 100 Then
Me.Zoom = 200
Me.Width = FM_WIDTH * 2
Me.Height = FM_HEIGHT * 2 - tBarHeight
ButtonZoom.Picture = CommandBars.GetImageMso("ZoomOut", 16, 16)
Else
Me.Zoom = 100
Me.Width = FM_WIDTH
Me.Height = FM_HEIGHT
ButtonZoom.Picture = CommandBars.GetImageMso("ZoomIn", 16, 16)
End If
End Sub
Private Sub ButtonPaint_Click()
If PicNow Is Nothing Then Exit Sub
Dim w As Single, c As Range, i As Long
If ActiveWorkbook Is Nothing Then Workbooks.Add
If ActiveWorkbook.Path <> "" Or Not ActiveWorkbook.Saved Then Workbooks.Add
With Cells(1, 1)
For w = Cells(1, 1).ColumnWidth To 0 Step -0.75
Cells(1, 1).ColumnWidth = w
If Cells(1, 1).Width <= Cells(1, 1).Height Then Exit For
Next
End With
Cells(1, 1).Resize(, 17).Columns.ColumnWidth = w
With Cells(2, 2).Resize(16, 16)
For Each c In .Cells
With Me.Controls("Pixel" & Format$(i, "000"))
If .BackStyle = fmBackStyleOpaque Then c.Interior.Color = .BackColor
End With
i = i + 1
Next
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Item(xlInsideHorizontal).LineStyle = xlNone
.Item(xlInsideVertical).LineStyle = xlNone
End With
End With
End Sub
Private Sub ButtonList_Click()
If MsgBox(IdZero & " ～ " & IdZero + 99 & " までのイメージを出力します", vbInformation + vbOKCancel) = vbCancel Then Exit Sub
Call CreateFaceImageList(IdZero, IdZero + 99)
End Sub
Rem プロパティ==================================================================================================
Private Property Get CurrentId() As Long
CurrentId = IdNow
End Property
Private Property Let CurrentId(ByVal newId As Long)
If newId < 0 Then newId = 0
If IdNow = newId Then Exit Property
Dim i As Long
IdNow = newId
Set PicNow = GetImagefromFaceId(IdNow, ChkCopyFace.Value)
LabelIdNum.Caption = Format$(IdNow, "00000") & " " & GetControlNamesFromId(IdNow)
StartId = IdNow
If PicNow Is Nothing Then
For i = 0 To 255
With Me.Controls("Pixel" & Format$(i, "000"))
.BackColor = &H80000005
End With
Next
Else
Call UpdatePixelLabels(PicNow.handle)
End If
End Property
Private Property Get StartId() As Long
StartId = IdZero
End Property
Private Property Let StartId(ByVal newId As Long)
If newId < 0 Then newId = 0
newId = Int(newId / 100) * 100
If IdZero = newId Then Exit Property
IdZero = newId
Call UpdateImageLabels(IdZero, ChkCopyFace.Value)
End Property
Private Sub UpdateImageLabels(ByVal StartNum As Long, Optional UseCopyFace As Boolean)
Dim i As Long, Cap As String
i = StartNum
For i = 0 To 99
With Me.Controls("Face" & Format$(i, "000"))
Set .Picture = GetImagefromFaceId(StartNum + i, UseCopyFace)
.ControlTipText = "ID:" & Format$(StartNum + i, "00000")
.SpecialEffect = fmSpecialEffectRaised
If .Picture Is Nothing Then .SpecialEffect = fmSpecialEffectEtched
Cap = GetControlNamesFromId(StartNum + i)
If Len(Cap) > 0 Then
.ControlTipText = .ControlTipText & ": " & Cap
.SpecialEffect = fmSpecialEffectSunken
End If
End With
Next
LabelHeader.Caption = StartNum & " to " & StartNum + 99
End Sub
Private Sub UpdatePixelLabels(hBmp As LongPtr)
Dim v() As Variant, i As Long, r As Long, c As Long
Dim vRGB() As Variant
v = GetRGBsofBmp(hBmp, 16, 16)
For r = 1 To 16
For c = 1 To 16
With Me.Controls("Pixel" & Format$(i, "000"))
.BackColor = v(r, c)
vRGB = SplitRGB(CLng(v(r, c)))
.ControlTipText = "x=" & c & " y=" & r & " RGB:" & Join(vRGB, ",")
.BackStyle = fmBackStyleOpaque
End With
i = i + 1
Next
Next
End Sub
Rem メソッド============================================================================================================
Public Sub CreateFaceImageList(idFrom As Long, idTo As Long)
Dim Btn As CommandBarButton, Pic As IPictureDisp, i As Long, r As Long
Dim hBmp As LongPtr
Dim ErrNum As Long
If ActiveWorkbook Is Nothing Then Workbooks.Add
If ActiveWorkbook.Path <> "" Or Not ActiveWorkbook.Saved Then Workbooks.Add
[A1:F1] = [{"FaceId",".CopyFace",".Picture",".Mask","MaskedImage",".Caption"}]
With CommandBars.Add(Name:="test", temporary:=True)
Set Btn = .Controls.Add(Type:=msoControlButton, temporary:=True)
r = 2
For i = idFrom To idTo
Cells(r, 1) = i
On Error Resume Next
Btn.FaceId = i
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
Rem CopyFace画像
Btn.CopyFace
Cells(r, 2).Select
ActiveSheet.Paste
Rem 素のPicture画像
Set Pic = Btn.Picture
Call CopyBmptoClipboard(Pic.handle)
Cells(r, 3).Select
ActiveSheet.Paste
Rem Mask画像
Set Pic = Btn.Mask
Call CopyBmptoClipboard(Pic.handle)
Cells(r, 4).Select
ActiveSheet.Paste
Rem マスク適用後のPicture画像
hBmp = CopyImage(Btn.Picture.handle, IMAGE_BITMAP, 0&, 0&, 0&)
Call SetMask(hBmp, Btn.Mask.handle, 16, 16)
Call CopyBmptoClipboard(hBmp)
Call DeleteObject(hBmp)
Cells(r, 5).Select
ActiveSheet.Paste
Else
Cells(r, 2).Value = "(No Image)"
End If
Rem コントロールキャプション
Cells(r, 6).Value = GetControlNamesFromId(i)
r = r + 1
DoEvents '画面描画維持
Next
Btn.Delete
.Delete
End With
End Sub
Rem サブルーチン================================================================================================
Private Function GetControlNamesFromId(ID As Long) As String
Dim Str As String
On Error Resume Next
Str = Application.CommandBars.FindControl(ID:=ID).Caption
On Error GoTo 0
GetControlNamesFromId = Str
End Function
Private Function GetImagefromFaceId(FaceIdNumber As Long, Optional UseCopyFace As Boolean) As IPictureDisp
Const BarName As String = "TMP_GetImagefromFaceId"
On Error Resume Next
CommandBars(BarName).Delete
On Error GoTo 0
Dim Cb As CommandBarButton, hBmp As LongPtr, bkColor As Long, ErrNum As Long
bkColor = Me.BackColor
With CommandBars.Add(Name:=BarName, temporary:=True)
Set Cb = .Controls.Add(Type:=msoControlButton, temporary:=True)
With Cb
On Error Resume Next
.FaceId = FaceIdNumber
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
If UseCopyFace Then
.CopyFace
hBmp = CopyImage(GetBmpfromClipboard, IMAGE_BITMAP, 0&, 0&, LR_CREATEDIBSECTION)
Else
hBmp = CopyImage(.Picture.handle, IMAGE_BITMAP, 0&, 0&, LR_CREATEDIBSECTION)
Call SetMask(hBmp, .Mask.handle, 16, 16, bkColor)
End If
If hBmp Then Set GetImagefromFaceId = CreatePictureByhBmp(hBmp)
End If
.Delete
End With
Set Cb = Nothing
.Delete
End With
End Function
Private Function CopyBmptoClipboard(hBmp As LongPtr) As Boolean
Call OpenClipboard(0&)
Call EmptyClipboard
CopyBmptoClipboard = CBool(SetClipboardData(CF_BITMAP, hBmp))
Call CloseClipboard
End Function
Private Function GetBmpfromClipboard() As LongPtr
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
If OpenClipboard(0&) <> 0 Then
GetBmpfromClipboard = GetClipboardData(CF_BITMAP)
Call CloseClipboard
End If
End Function
Private Function CreatePictureByhBmp(ByVal hBmp As LongPtr, Optional hPal As LongPtr) As IPictureDisp
Dim IID_IDispatch As GUID, Bmp As PicBmp
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0&
.Data4(7) = &H46&
End With
With Bmp
.Size = Len(Bmp)
.Type = vbPicTypeBitmap
.hBmp = hBmp
.hPal = hPal
End With
Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, CreatePictureByhBmp)
End Function
Private Function GetRGBsofBmp(ByVal hBmp As LongPtr, pxWidth As Long, pxHeight As Long) As Variant
Dim Rtn As LongPtr
Dim bi As BITMAPINFO
Dim hDC As LongPtr, hOld As LongPtr
Dim RGBBuff() As Byte, r As Long, c As Long, vRGB() As Variant
hDC = CreateCompatibleDC(0&)
hOld = SelectObject(hDC, hBmp)
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = pxWidth
.biHeight = -pxHeight 'トップダウン走査
.biPlanes = 1
.biBitCount = 32
.biSizeImage = pxWidth * 4 * pxHeight
End With
ReDim RGBBuff(1 To pxWidth * 4, 1 To pxHeight)
Rtn = GetDIBits(hDC, hBmp, 0&, pxHeight, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
Call SelectObject(hDC, hOld)
Call DeleteDC(hDC)
If Rtn = 0 Then Exit Function
ReDim vRGB(1 To pxHeight, 1 To pxWidth)
For r = 1 To pxHeight
For c = 1 To pxWidth
vRGB(r, c) = RGBBuff(c * 4 - 1, r) + RGBBuff(c * 4 - 2, r) * &H100& + RGBBuff(c * 4 - 3, r) * &H100& ^ 2
Next
Next
GetRGBsofBmp = vRGB
End Function
Private Function SplitRGB(aRGB As Long, Optional Percentage As Boolean) As Variant
Dim i As Long, Ary(0 To 2) As Variant
For i = 0 To 2
Ary(i) = (aRGB \ &H100& ^ i) Mod &H100&
If Percentage Then Ary(i) = CSng(Ary(i) / &HFF&)
Next
SplitRGB = Ary
End Function
Private Function SetMask(ByVal hBmp As LongPtr, ByVal hMask As LongPtr, pxWidth As Long, pxHeight As Long, _
Optional ByVal bkColor As Long = &H8000000F) As Boolean
Dim Rtn As LongPtr
Dim bi As BITMAPINFO
Dim hDC As LongPtr, hOld As LongPtr
Dim RGBBuff() As Byte, r As Long, c As Long
Dim MaskBuff() As Byte, bkRGB() As Variant, Alpha(0 To 2) As Single
hDC = CreateCompatibleDC(0&)
hOld = SelectObject(hDC, hBmp)
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = pxWidth
.biHeight = -pxHeight 'トップダウン走査
.biPlanes = 1
.biBitCount = 32
.biSizeImage = pxWidth * 4 * pxHeight
End With
ReDim RGBBuff(1 To pxWidth * 4, 1 To pxHeight)
ReDim MaskBuff(1 To pxWidth * 4, 1 To pxHeight)
Rtn = GetDIBits(hDC, hBmp, 0&, pxHeight, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
Rtn = GetDIBits(hDC, hMask, 0&, pxHeight, MaskBuff(1, 1), bi, DIB_RGB_COLORS)
bkRGB = SplitRGB(SysColor2RGB(bkColor))
For r = 1 To pxHeight
For c = 1 To pxWidth
Alpha(0) = MaskBuff(c * 4 - 1, r) / &HFF&
Alpha(1) = MaskBuff(c * 4 - 2, r) / &HFF&
Alpha(2) = MaskBuff(c * 4 - 3, r) / &HFF&
RGBBuff(c * 4 - 1, r) = CLng(bkRGB(0) * Alpha(0) + RGBBuff(c * 4 - 1, r) * (1 - Alpha(0))) 'R
RGBBuff(c * 4 - 2, r) = CLng(bkRGB(1) * Alpha(1) + RGBBuff(c * 4 - 2, r) * (1 - Alpha(1))) 'G
RGBBuff(c * 4 - 3, r) = CLng(bkRGB(2) * Alpha(2) + RGBBuff(c * 4 - 3, r) * (1 - Alpha(2))) 'B
Next
Next
Rtn = SetDIBits(hDC, hBmp, 0&, pxHeight, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
Call SelectObject(hDC, hOld)
Call DeleteDC(hDC)
If Rtn Then SetMask = True
End Function
Private Function SysColor2RGB(SysCol As Long) As Long
If (SysCol And &HFF000000) = &H80000000 Then
SysColor2RGB = GetSysColor(SysCol And &HFFFFFF)
Else
SysColor2RGB = SysCol
End If
End Function
Function GetYfromRGB(aRGB As Long) As Single
Const prmR = 0.298912!, prmG = 0.586611!, prmB = 0.114478!
Dim vRGB() As Variant
vRGB = SplitRGB(aRGB)
GetYfromRGB = vRGB(0) * prmR + vRGB(1) * prmG + vRGB(2) * prmB
GetYfromRGB = GetYfromRGB / &HFF&
If GetYfromRGB > 1! Then GetYfromRGB = 1!
If GetYfromRGB < 0! Then GetYfromRGB = 0!
End Function
Private Function CreateCheckeredPattern(color1 As Long, color2 As Long, pxSize As Long) As IPictureDisp
Dim Rtn As LongPtr
Dim bi As BITMAPINFO
Dim hDC As LongPtr, hOld As LongPtr, hBmp As LongPtr
Dim RGBBuff() As Byte, r As Long, c As Long
Dim RGB1() As Variant, RGB2() As Variant
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = pxSize * 2
.biHeight = -pxSize * 2 'トップダウン走査
.biPlanes = 1
.biBitCount = 32
.biSizeImage = (pxSize * 2) * 4 * (pxSize * 2)
End With
ReDim RGBBuff(1 To (pxSize * 2) * 4, 1 To (pxSize * 2))
For r = 1 To (pxSize * 2)
If r <= pxSize Then
RGB1 = SplitRGB(color1)
RGB2 = SplitRGB(color2)
Else
RGB1 = SplitRGB(color2)
RGB2 = SplitRGB(color1)
End If
For c = 1 To (pxSize * 2)
RGBBuff(c * 4 - 1, r) = IIf(c <= pxSize, RGB1(0), RGB2(0)) 'R
RGBBuff(c * 4 - 2, r) = IIf(c <= pxSize, RGB1(1), RGB2(1)) 'G
RGBBuff(c * 4 - 3, r) = IIf(c <= pxSize, RGB1(2), RGB2(2)) 'B
Next
Next
hDC = CreateCompatibleDC(0&)
hBmp = CreateDIBSection(hDC, bi, DIB_RGB_COLORS, 0&, 0&, 0&)
hOld = SelectObject(hDC, hBmp)
Rtn = SetDIBits(hDC, hBmp, 0&, pxSize * 2, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
Call SelectObject(hDC, hOld)
Call DeleteDC(hDC)
If Rtn Then Set CreateCheckeredPattern = CreatePictureByhBmp(hBmp)
End Function
（白茶） 2020/12/23(水) 15:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.