『ボタンのピクチャーの切替方法』（栗栄太）
ユーザーフォームにボタンを左右に２つ配置させます。
左のボタンには左向きのグレー色の矢印画像
右のボタンには右向きのグレー色の矢印画像
処理としては
押したボタンの画像を青色の矢印の画像に変更し、
もう一方はグレーに変更する。
ということをしたいのですが
どうやって画像を変更すればよいのでしょうか？
青とグレーのボタンを２つずつ４つ用意して
Visible を指定して表示させるしかないのでしょうか？
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
>青とグレーのボタンを２つずつ４つ用意して >Visible を指定して表示させるしかないのでしょうか？ それが一番簡単で早いと思います。
LoadPicture は個人的に結構面倒だったイメージがあります （´・ω・`） 2025/10/16(木) 14:57:47
画像でなくとも矢印文字はいかがでしょうか。
Private Sub CommandButton1_Click()
CommandButton1.ForeColor = RGB(0, 0, 255) ' 青
CommandButton2.ForeColor = RGB(128, 128, 128) ' 灰色
End Sub
Private Sub CommandButton2_Click()
CommandButton2.ForeColor = RGB(0, 0, 255) ' 青
CommandButton1.ForeColor = RGB(128, 128, 128) ' 灰色
End Sub
（にか） 2025/10/16(木) 17:44:03
（にか）さん説明不足ですみません。
もともと、矢印文字を使っていました。
この場合、Enabled を True,False で切り替えるだけで
グレーになるので、目的は達成していたのですが
矢印を見た目よくするために画像に変えました。
画像の場合も同じくグレーぽくなるのかなと思ったのですが、
実際にやってみると、 Enabled=false の場合、画像がつぶれてしまいます。
そこで、最終的に、（´・ω・`）さんと同じ考えに至ったのですが、
操作としては問題ないのですが、本来ボタンをクリックできない
グレーの時でもボタンが押せる状態になるのがしっくりこない
というわけです。
（栗栄太） 2025/10/17(金) 09:16:06
ボタンの画像を入れ換える方法について、 Imageコントロールに画像を設定しておいて、 Me.CommandButton1.Picture = Me.Image1.Picture とすることで、画像を入れ換えることができます。こちらの方が簡単ですね。 Imageコントロールは、UserFormの表示範囲外に配置するか、VisibleプロパティをFalseにしておけば見えません
ボタンをクリック出来なくするのは、Lockedプロパティを使ってはどうでしょう （´・ω・`） 2025/10/17(金) 10:17:36
参考です。
オートシェイプで矢印を作成し、それぞれに名前を付けてjpg 画像として保存してやってみた。
左矢印灰色 Left_1.jpg 左矢印青色 Left_2.jpg 右矢印灰色 Right_1.jpg 右矢印青色 Right_2.jpg
ユーザーフォームが開いた時矢印を表示させるためプロパティウィンドウで
CommandButton1 の Picture に Left_1.jpg を読み込む。 CommandButton2 の Picture に right_1.jpg を読み込む。
Private Sub CommandButton1_Click()
CommandButton1.Picture = LoadPicture("C:\Users\□□\Desktop\Left_2.jpg")
CommandButton2.Picture = LoadPicture("C:\Users\□□\Desktop\right_1.jpg")
End Sub
Private Sub CommandButton2_Click()
CommandButton2.Picture = LoadPicture("C:\Users\□□\Desktop\right_2.jpg")
CommandButton1.Picture = LoadPicture("C:\Users\□□\Desktop\Left_1.jpg")
End Sub
これで交互にきりかわりました。
＞青とグレーのボタンを２つずつ４つ用意して これは同じです。
（にか） 2025/10/17(金) 16:41:18
ユーザーフォームが開いた時、CommandButton に矢印を表示させるためプロパティウィンドウで
（にか） 2025/10/17(金) 20:02:30
ちょっと、手持ちのパーツを組み合わせて遊んでみました。 imageMsoでゲットしたアイコン画像をカラーマトリクス使ってグレー画像に変換しています。 (Lockedプロパティとかは何も考えてません) ここまで手間かけるのもなぁ...って感じになってしまいますね、やはり ^^;
元ネタは↓こちら(VBAの記事ではありませんが...)
画像をグレースケールに変換して表示する - .NET Tips (VB.NET,C#...)
https://dobon.net/vb/dotnet/graphics/grayscale.html
[ GDI+ サンプル ] [ G022_カラーマトリックスによる画像の色操作 ] - Mr.XRAY
http://mrxray.on.coocan.jp/Delphi/GDIPlusSamples/G022_GDIPlus_ColorMatrix.htm
Option Explicit
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 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 RGBQUAD
' rgbBlue As Byte
' rgbGreen As Byte
' rgbRed As Byte
' rgbReserved As Byte
'End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
' bmiColors As RGBQUAD
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 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 LongPtr
hPal As LongPtr
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 PICTYPE_BITMAP = 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 GDI+関係----------------------------------------------------------------------------------------------------
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = 1
ImageLockModeWrite = 2
ImageLockModeUserInputBuf = 4
End Enum
Private Type BITMAPDATA
Width As Long
Height As Long
stride As Long
PixelFormat As Long
scan0 As LongPtr
Reserved As LongPtr
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, ByRef scan0 As Any, ByRef nBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipBitmapSetResolution Lib "gdiplus" (ByVal pbitmap As LongPtr, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
Private Declare PtrSafe Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef RECT As Any, ByVal flags As Long, ByVal PixelFormat As Long, ByRef lockedBitmapData As Any) As Long
Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef lockedBitmapData As Any) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As LongPtr, ByRef Height As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As LongPtr, ByRef Width As Long) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
Private Enum PixelFormat
PixelFormat32bppRGB = &H22009
PixelFormat32bppARGB = &H26200A
End Enum
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As LongPtr, graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As LongPtr, ByVal lColor As Long) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
Private Enum ColorAdjustType
ColorAdjustTypeDefault = 0
ColorAdjustTypeBitmap = 1
ColorAdjustTypeBrush = 2
ColorAdjustTypePen = 3
ColorAdjustTypeText = 4
ColorAdjustTypeCount = 5
ColorAdjustTypeAny = 6
End Enum
Private Enum ColorMatrixFlags
ColorMatrixFlagsDefault = 0
ColorMatrixFlagsSkipGrays = 1
ColorMatrixFlagsAltGray = 2
End Enum
Private Type ColorMatrix
Item(0 To 4, 0 To 4) As Single
End Type
Private Declare PtrSafe Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As LongPtr) As Long
Private Declare PtrSafe Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal imageattr As LongPtr, ByVal caType As ColorAdjustType, ByVal enableFlag As Boolean, ColorMatrix As ColorMatrix, grayMatrix As ColorMatrix, ByVal flags As ColorMatrixFlags) As Long
Private Declare PtrSafe Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As LongPtr) As Long
Private Declare PtrSafe Function GdipCloneImage Lib "gdiplus" (ByVal Image As LongPtr, cloneImage As LongPtr) As Long
Private Declare PtrSafe Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As PixelFormat, ByVal srcBitmap As LongPtr, dstBitmap As LongPtr) As Long
Private Enum GpUnit
UnitWorld = 0
UnitDisplay = 1
UnitPixel = 2
UnitPoint = 3
UnitInch = 4
UnitDocument = 5
UnitMillimeter = 6
End Enum
Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal Image As LongPtr, _
ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, _
ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As GpUnit, _
Optional ByVal imageAttributes As LongPtr = 0, Optional ByVal callback As LongPtr = 0, Optional ByVal callbackData As LongPtr = 0) As Long
Rem 他----------------------------------------------------------------------------------------------------------
Private Type typeINT32
Value As Long
End Type
Private Type typeCOLORREF
Red As Byte
Green As Byte
Blue As Byte
NoData As Byte
End Type
Private Type typeARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private tkn As LongPtr
Private WithEvents ButtonPrev As MSForms.CommandButton
Private WithEvents ButtonNext As MSForms.CommandButton
Private Sub PrepareControls()
Set ButtonPrev = Me.Controls.Add("Forms.CommandButton.1", "ButtonPrev")
With ButtonPrev
.Top = 16: .Height = 21: .Left = 56: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = GetImagefromIdMso("MailMergeGoToPreviousRecord", 16, 16)
End With
Set ButtonNext = Me.Controls.Add("Forms.CommandButton.1", "ButtonNext")
With ButtonNext
.Top = 16: .Height = 21: .Left = 77: .Width = 21
.PicturePosition = fmPicturePositionCenter
.Picture = GetImagefromIdMso("MailMergeGoToNextRecord", 16, 16)
End With
End Sub
Private Function GetImagefromIdMso(idMso As String, Width As Long, Height As Long, Optional ByVal bkColor As OLE_COLOR = &H8000000F) As IPictureDisp
Dim hBmp As LongPtr, hGpBmp As LongPtr, pxARGB() As typeARGB
hBmp = CopyImage(CommandBars.GetImageMso(idMso, Width, Height).handle, IMAGE_BITMAP, 0&, 0&, LR_CREATEDIBSECTION)
pxARGB = GetBitsFromHBITMAP(hBmp)
hGpBmp = CreateFromBits(pxARGB, Not HasAlphaCannel(pxARGB))
If GdipCreateHBITMAPFromBitmap(hGpBmp, hBmp, SysColor2RGB(bkColor)) = 0 Then
Set GetImagefromIdMso = CreatePictureByhBmp(hBmp, 0)
End If
Call GdipDisposeImage(hGpBmp)
End Function
Private Function GetImagefromIdMso2(idMso As String, Width As Long, Height As Long, Optional ByVal bkColor As OLE_COLOR = &H8000000F) As IPictureDisp
Dim hBmp As LongPtr, hGpBmp As LongPtr, pxARGB() As typeARGB, hGpBmp2 As LongPtr
hBmp = CopyImage(CommandBars.GetImageMso(idMso, Width, Height).handle, IMAGE_BITMAP, 0&, 0&, LR_CREATEDIBSECTION)
pxARGB = GetBitsFromHBITMAP(hBmp)
hGpBmp = CreateFromBits(pxARGB, Not HasAlphaCannel(pxARGB))
hGpBmp2 = SetColorMatrix(hGpBmp, CreateGrayScaleMatrix)
Call GdipDisposeImage(hGpBmp)
If GdipCreateHBITMAPFromBitmap(hGpBmp2, hBmp, SysColor2RGB(bkColor)) = 0 Then
Set GetImagefromIdMso2 = CreatePictureByhBmp(hBmp, 0)
End If
Call GdipDisposeImage(hGpBmp2)
End Function
Private Function GetBitsFromHBITMAP(ByVal HBITMAP As LongPtr) As typeARGB()
Dim rtn As Long, pxWidth As Long, pxHeight As Long
Dim bi As BITMAPINFO
Dim hDC As LongPtr, hOld As LongPtr
Dim pxARGB() As typeARGB
hDC = CreateCompatibleDC(0&)
bi.bmiHeader.biSize = Len(bi.bmiHeader)
rtn = GetDIBits(hDC, HBITMAP, 0&, 0&, ByVal 0&, bi, DIB_RGB_COLORS)
If rtn Then
hOld = SelectObject(hDC, HBITMAP)
With bi.bmiHeader
pxWidth = .biWidth
pxHeight = Abs(.biHeight)
.biHeight = -pxHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = 0
.biSizeImage = 0
End With
ReDim pxARGB(1 To pxWidth, 1 To pxHeight)
rtn = GetDIBits(hDC, HBITMAP, 0&, pxHeight, pxARGB(1, 1), bi, DIB_RGB_COLORS)
Call SelectObject(hDC, hOld)
GetBitsFromHBITMAP = pxARGB
End If
Call DeleteDC(hDC)
End Function
Private Function CreateFromBits(Bits() As typeARGB, Optional ByVal NoAlpha As Boolean) As LongPtr
Dim pxWidth As Long, pxHeight As Long, hGpImg As LongPtr
pxWidth = UBound(Bits, 1) - LBound(Bits, 1) + 1
pxHeight = UBound(Bits, 2) - LBound(Bits, 2) + 1
If GdipCreateBitmapFromScan0(pxWidth, pxHeight, 0, PixelFormat32bppARGB, ByVal 0, hGpImg) = 0 Then
Dim BmpData As BITMAPDATA, pf As PixelFormat
With BmpData
.Width = pxWidth
.Height = pxHeight
.PixelFormat = PixelFormat32bppARGB
.scan0 = VarPtr(Bits(LBound(Bits, 1), LBound(Bits, 2)))
.stride = pxWidth * 4
End With
If NoAlpha Then pf = PixelFormat32bppRGB Else pf = PixelFormat32bppARGB
Call GdipBitmapLockBits(hGpImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeWrite, pf, BmpData)
Call GdipBitmapUnlockBits(hGpImg, BmpData)
Call GdipBitmapSetResolution(hGpImg, 96!, 96!)
CreateFromBits = hGpImg
End If
End Function
Private Function SysColor2RGB(argInt32 As OLE_COLOR) As OLE_COLOR
If (argInt32 And &HFF000000) = &H80000000 Then
SysColor2RGB = GetSysColor(argInt32 And &HFFFFFF)
Else
SysColor2RGB = argInt32
End If
End Function
Private Function HasAlphaCannel(pxARGB() As typeARGB) As Boolean
Dim r As Long, c As Long
For r = 1 To UBound(pxARGB, 1)
For c = 1 To UBound(pxARGB, 2)
If pxARGB(r, c).Alpha Then
HasAlphaCannel = True
Exit For
End If
Next
Next
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 = PICTYPE_BITMAP
.hBmp = hBmp
.hPal = hPal
End With
Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, CreatePictureByhBmp)
End Function
Private Sub SetMySize()
Dim maxW As Single, maxH As Single, c As MSForms.Control
Dim minTop As Single, minLeft As Single
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top + c.Height > maxH Then maxH = c.Top + c.Height
If c.Left + c.Width > maxW Then maxW = c.Left + c.Width
End If
Next
minTop = maxH
minLeft = maxW
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top >= 0 And c.Top < minTop Then minTop = c.Top
If c.Left >= 0 And c.Left < minLeft Then minLeft = c.Left
End If
Next
Me.Width = (maxW + minLeft) + (Me.Width - Me.InsideWidth)
Me.Height = (maxH + minTop) + (Me.Height - Me.InsideHeight)
End Sub
Private Sub ButtonNext_Click()
ButtonNext.Picture = GetImagefromIdMso("MailMergeGoToNextRecord", 16, 16)
ButtonPrev.Picture = GetImagefromIdMso2("MailMergeGoToPreviousRecord", 16, 16)
End Sub
Private Sub ButtonPrev_Click()
ButtonNext.Picture = GetImagefromIdMso2("MailMergeGoToNextRecord", 16, 16)
ButtonPrev.Picture = GetImagefromIdMso("MailMergeGoToPreviousRecord", 16, 16)
End Sub
Private Sub UserForm_Initialize()
#If Win64 Then
Debug.Print Now; "Running in 64-bit ver"
#Else
Debug.Print Now; "Running in 32-bit ver"
#End If
Call PrepareControls
Call SetMySize
Dim gi As GdiplusStartupInput
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
End Sub
Private Sub UserForm_Terminate()
If tkn Then Call GdiplusShutdown(tkn)
End Sub
Private Function SetColorMatrix(hImg As LongPtr, mx As ColorMatrix) As LongPtr
Dim mxg As ColorMatrix, hGrap As LongPtr, hAttr As LongPtr, hWork As LongPtr, rtn As Long
Dim pxWidth As Long, pxHeight As Long, hTmp As LongPtr
Call GdipGetImageWidth(hImg, pxWidth)
Call GdipGetImageHeight(hImg, pxHeight)
rtn = GdipDisposeImage(hTmp)
rtn = GdipCloneBitmapAreaI(0&, 0&, pxWidth, pxHeight, PixelFormat32bppARGB, hImg, hTmp)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hTmp, hGrap)
If rtn = 0 Then rtn = GdipCreateImageAttributes(hAttr)
If rtn = 0 Then rtn = GdipCloneImage(hTmp, hWork)
If rtn = 0 Then rtn = GdipSetImageAttributesColorMatrix(hAttr, ColorAdjustTypeBitmap, True, mx, mxg, ColorMatrixFlagsDefault)
If rtn = 0 Then rtn = GdipGraphicsClear(hGrap, 0&)
If rtn = 0 Then rtn = GdipDrawImageRectRectI(hGrap, hWork, 0&, 0&, pxWidth, pxHeight, 0&, 0&, pxWidth, pxHeight, UnitPixel, hAttr)
If rtn = 0 Then rtn = GdipDisposeImage(hWork)
SetColorMatrix = hTmp
rtn = GdipDisposeImageAttributes(hAttr)
rtn = GdipDeleteGraphics(hGrap)
End Function
Private Function CreateNewMatrix() As ColorMatrix
Dim i As Long
For i = 0 To 4
CreateNewMatrix.Item(i, i) = 1
Next
End Function
Private Function CreateGrayScaleMatrix() As ColorMatrix
Const wgtR = 0.298912!, wgtG = 0.586611!, wgtB = 0.114478!
CreateGrayScaleMatrix = CreateNewMatrix
Dim c As Long
With CreateGrayScaleMatrix
For c = 0 To 2
.Item(c, 0) = wgtR
Next
For c = 0 To 2
.Item(c, 1) = wgtG
Next
For c = 0 To 2
.Item(c, 2) = wgtB
Next
End With
End Function
（白茶） 2025/10/17(金) 20:24:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.