[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『プルダウンリストの表示を大きくする方法』（ｊｊ）
Excelでプルダウンのリストを作成した時に、全体が大きいので70%で表示したいのですが、そうするとプルダウンのリストも一緒に小さくなって見づらくなってしまいます。
全体の表示は70%だけど、プルダウンリストの表示はそのままか大きく表示する方法はありますでしょうか。。。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
（るり） 2022/09/29(木) 15:37
大きくする方法が表示拡大なので無いです。
ただ、ウインドウを新しく表示する方法で片方だけ大きくするとか？
（ヘビー） 2022/09/29(木) 15:41
一時的に右クリックメニューにリストを追加するとかいう代替案を練ってみました。 (↓入力規則リストが単純な定数設定だった場合の例で)
'Sheetモジュール ----------------------------------------------------------------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim f As String
ContextMenu f
On Error Resume Next
f = ActiveCell.Validation.Formula1
On Error GoTo 0
If f = "" Then Exit Sub
ContextMenu f
End Sub
'標準モジュール -----------------------------------------------------------------------
Sub InputFromContextMenu(v)
ActiveCell.Value = v
ContextMenu False
End Sub
Sub ContextMenu(Sw As String)
On Error Resume Next
Dim Bar As CommandBar, c As CommandBarControl
For Each Bar In Application.CommandBars
If Bar.Name = "Cell" Then
For Each c In Bar.Controls
If c.Caption Like "□*" Then c.Delete
Next
End If
Next
If Len(Sw) = 0 Then Exit Sub
Dim v
For Each Bar In Application.CommandBars
If Bar.Name = "Cell" Then
With Bar.Controls
For Each v In Split(Sw, ",")
With .Add(temporary:=True)
.Caption = "□" & v
.OnAction = "'InputFromContextMenu""" & v & """'"
End With
Next
End With
End If
Next
End Sub
（白茶） 2022/09/29(木) 16:22
しかし自分で↑書いといて言うのもアレですが... ま−まず使わないだろなー ^^;
（白茶） 2022/09/29(木) 16:34
（白茶）さん
VBAは表面的な簡単な知識しかなく、 'Sheetモジュールと標準モジュールというのがよくわからないのですが…
よろしければ簡単にどうすればいいのか教えていただけないでしょうか。
（ｊｊ） 2022/09/30(金) 13:42
ごめんなさい。よくよく見てみたらこれ、ダメですね。 ^^; >> ContextMenu False とか、よく分かんない事書いてるし。
ちっちゃいUserFormを表示する等で対応した方がまだマシな気がしてきました... とりあえず忘れて下さいww。
（白茶） 2022/09/30(金) 14:16
>ちっちゃいUserFormを表示する の案を考えてきました。
'▼[UserForm1]=======================================================================================================================
Option Explicit
Private Type apiCursorPos
x As Long
y As Long
End Type
Private Type apiRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SPI_GETWORKAREA = 48
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Declare PtrSafe Function GetCaretPos Lib "user32.dll" (ByRef lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private WithEvents List1 As MSForms.ListBox
Rem =================================================================================================================================
Private Property Get xDPI() As Long '水平DPI
xDPI = GetDPI(LOGPIXELSX)
End Property
Private Property Get yDPI() As Long '垂直DPI
yDPI = GetDPI(LOGPIXELSY)
End Property
Private Property Get xlPPI() As Long 'エクセルPPI
xlPPI = Application.InchesToPoints(1)
End Property
Rem =================================================================================================================================
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As Long
hDC = GetDC(Application.hwnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
Rem =================================================================================================================================
Rem セル座標でフォーム表示する為のTopとLeftを得る(画面からのはみ出し補正付き)
Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える
Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示)
Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する)
Private Sub GetTopLeftFromCaretCellBR(ByRef fTop As Single, ByRef fLeft As Single, _
ByVal fHeight As Single, ByVal fWidth As Single, _
Optional ByVal LimitToEdge As Boolean = False _
)
Dim MyTop As Single, MyLeft As Single
Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single
Dim cRect As apiRECT, cPos As apiCursorPos
Rem ディスプレイサイズ(ピクセル単位)取得
Call SystemParametersInfo(SPI_GETWORKAREA, &H0, aRect, &H0)
Rem セルのピクセル座標取得
Call GetCaretPos(cPos)
Call ClientToScreen(GetFocus(), cPos)
With cRect
.Top = cPos.y
.Left = cPos.x
.Bottom = .Top + Pt2PxY(ActiveCell.Height) * ActiveWindow.Zoom / 100
.Right = .Left + Pt2PxX(ActiveCell.Width) * ActiveWindow.Zoom / 100
End With
Rem 垂直方向の開始位置補正計算
MyTop = Px2PtY(cRect.Bottom)
If MyTop < 0 Then MyTop = 0 'セル下部が画面より上だったら画面上端
If cRect.Bottom > aRect.Bottom Then MyTop = Px2PtY(cRect.Top) 'セル下部が画面より下だったらセル上部
If cRect.Top > aRect.Bottom Then MyTop = Px2PtY(aRect.Bottom) 'セル上部も画面より下だったら画面下端
LmtTop = Px2PtY(aRect.Bottom) - fHeight
If LmtTop < 0 Then LmtTop = 0
If MyTop > LmtTop Then
If MyTop > fHeight Then
MyTop = MyTop - fHeight
If LimitToEdge Then MyTop = LmtTop
Else
MyTop = LmtTop
End If
End If
Rem 水平方向の開始位置補正計算
MyLeft = Px2PtX(cRect.Right)
If MyLeft < 0 Then MyLeft = 0 'セル左部が画面より左だったら画面左端
If cRect.Right > aRect.Right Then MyLeft = Px2PtX(cRect.Left) 'セル右部が画面より右だったらセル左部
If cRect.Left > aRect.Right Then MyLeft = Px2PtX(aRect.Right) 'セル左部も画面より右だったら画面右端
LmtLeft = Px2PtX(aRect.Right) - fWidth
If LmtLeft < 0 Then LmtLeft = 0
If MyLeft > LmtLeft Then
If MyLeft > fWidth Then
MyLeft = MyLeft - fWidth
If LimitToEdge Then MyLeft = LmtLeft
Else
MyLeft = LmtLeft
End If
End If
Rem 計算結果を返して終わる
fTop = MyTop
fLeft = MyLeft
End Sub
Rem =================================================================================================================================
Private Function Px2PtX(aPixel As Long) As Single 'ピクセルを水平ポイントに変換
Px2PtX = Int((aPixel * xlPPI / xDPI) / (xlPPI / xDPI)) * (xlPPI / xDPI) 'Int((px * 0.75) / 0.75) * 0.75
End Function
Private Function Pt2PxX(aPoint As Single) As Long '水平ポイントをピクセルに変換
Pt2PxX = Int(aPoint * xDPI / xlPPI)
End Function
Private Function Px2PtY(aPixel As Long) As Single 'ピクセルを垂直ポイントに変換
Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI)
End Function
Private Function Pt2PxY(aPoint As Single) As Long '垂直ポイントをピクセルに変換
Pt2PxY = Int(aPoint * yDPI / xlPPI)
End Function
Rem =================================================================================================================================
Public Sub UpdateList1()
Dim f As String
On Error Resume Next
List1.RowSource = ""
List1.Clear
f = ActiveCell.Validation.Formula1
On Error GoTo 0
If Len(f) = 0 Then Exit Sub
If f Like "=*" Then
List1.RowSource = f
Else
List1.List = Split(f, ",")
End If
Dim MyTop As Single, MyLeft As Single
Me.StartupPosition = 0
Call GetTopLeftFromCaretCellBR(MyTop, MyLeft, Me.Height, Me.Width)
Me.Top = MyTop + (Me.Width - Me.InsideWidth)
Me.Left = MyLeft + (Me.Width - Me.InsideWidth)
Me.Show vbModeless
End Sub
Private Sub List1_Click()
If ActiveCell Is Nothing Then Exit Sub
ActiveCell.Value = List1.Value
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.Font.Size = 12
Set List1 = Me.Controls.Add("Forms.ListBox.1", "List1")
List1.Width = 120!
Me.Width = List1.Width + (Me.Width - Me.InsideWidth)
Me.Height = List1.Height + (Me.Height - Me.InsideHeight)
End Sub
'▼シートモジュールでの呼出し例======================================================================================================
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If ActiveCell.Validation.InCellDropdown Then
Cancel = True
UserForm1.UpdateList1
End If
End Sub
（白茶） 2022/09/30(金) 14:42
あかん。やっぱ横着しちゃダメですね ^^;
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim f As Boolean
On Error Resume Next
f = ActiveCell.Validation.InCellDropdown
On Error GoTo 0
If f Then
Cancel = True
UserForm1.UpdateList1
End If
End Sub
（白茶） 2022/09/30(金) 15:56
SendKeysで[元に戻す]機能を殺さずに入力する版 (その代りクリップボードが上書きされちゃいますけど ^^;)
Private Sub List1_Click()
If ActiveCell Is Nothing Then Exit Sub
' ActiveCell.Value = List1.Value
Dim d As New MSForms.DataObject
d.SetText List1.Value
d.PutInClipboard
Me.Hide
Application.SendKeys "{BS}^v^~" '← にこやか?
Unload Me
End Sub
（白茶） 2022/10/01(土) 20:49
UserForm側コード全体を再掲しておきます。 タイトルバー非表示、及びSelectionChangeによるUnload処理を追記しました。
Option Explicit
Private Type apiCursorPos
x As Long
y As Long
End Type
Private Type apiRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SPI_GETWORKAREA = 48
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const GWL_STYLE = (-16&)
Private Const GWL_EXSTYLE = (-20&)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_CAPTION = &HC00000
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetCaretPos Lib "user32.dll" (ByRef lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private WithEvents List1 As MSForms.ListBox, WithEvents Sh As Worksheet, addr As String
Rem =================================================================================================================================
Private Property Get xDPI() As Long '水平DPI
xDPI = GetDPI(LOGPIXELSX)
End Property
Private Property Get yDPI() As Long '垂直DPI
yDPI = GetDPI(LOGPIXELSY)
End Property
Private Property Get xlPPI() As Long 'エクセルPPI
xlPPI = Application.InchesToPoints(1)
End Property
Rem =================================================================================================================================
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As Long
hDC = GetDC(Application.hWnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
Rem =================================================================================================================================
Rem セル座標でフォーム表示する為のTopとLeftを得る(画面からのはみ出し補正付き)
Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える
Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示)
Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する)
Private Sub GetTopLeftFromCaretCellBR(ByRef fTop As Single, ByRef fLeft As Single, _
ByVal fHeight As Single, ByVal fWidth As Single, _
Optional ByVal LimitToEdge As Boolean = False _
)
Dim MyTop As Single, MyLeft As Single
Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single
Dim cRect As apiRECT, cPos As apiCursorPos
Rem ディスプレイサイズ(ピクセル単位)取得
Call SystemParametersInfo(SPI_GETWORKAREA, &H0, aRect, &H0)
Rem セルのピクセル座標取得
Call GetCaretPos(cPos)
Call ClientToScreen(GetFocus(), cPos)
With cRect
.Top = cPos.y
.Left = cPos.x
.Bottom = .Top + Pt2PxY(ActiveCell.Height) * ActiveWindow.Zoom / 100
.Right = .Left + Pt2PxX(ActiveCell.Width) * ActiveWindow.Zoom / 100
End With
Rem 垂直方向の開始位置補正計算
MyTop = Px2PtY(cRect.Bottom)
If MyTop < 0 Then MyTop = 0 'セル下部が画面より上だったら画面上端
If cRect.Bottom > aRect.Bottom Then MyTop = Px2PtY(cRect.Top) 'セル下部が画面より下だったらセル上部
If cRect.Top > aRect.Bottom Then MyTop = Px2PtY(aRect.Bottom) 'セル上部も画面より下だったら画面下端
LmtTop = Px2PtY(aRect.Bottom) - fHeight
If LmtTop < 0 Then LmtTop = 0
If MyTop > LmtTop Then
If MyTop > fHeight Then
MyTop = MyTop - fHeight
If LimitToEdge Then MyTop = LmtTop
Else
MyTop = LmtTop
End If
End If
Rem 水平方向の開始位置補正計算
MyLeft = Px2PtX(cRect.Right)
If MyLeft < 0 Then MyLeft = 0 'セル左部が画面より左だったら画面左端
If cRect.Right > aRect.Right Then MyLeft = Px2PtX(cRect.Left) 'セル右部が画面より右だったらセル左部
If cRect.Left > aRect.Right Then MyLeft = Px2PtX(aRect.Right) 'セル左部も画面より右だったら画面右端
LmtLeft = Px2PtX(aRect.Right) - fWidth
If LmtLeft < 0 Then LmtLeft = 0
If MyLeft > LmtLeft Then
If MyLeft > fWidth Then
MyLeft = MyLeft - fWidth
If LimitToEdge Then MyLeft = LmtLeft
Else
MyLeft = LmtLeft
End If
End If
Rem 計算結果を返して終わる
fTop = MyTop
fLeft = MyLeft
End Sub
Rem =================================================================================================================================
Private Function Px2PtX(aPixel As Long) As Single 'ピクセルを水平ポイントに変換
Px2PtX = Int((aPixel * xlPPI / xDPI) / (xlPPI / xDPI)) * (xlPPI / xDPI) 'Int((px * 0.75) / 0.75) * 0.75
End Function
Private Function Pt2PxX(aPoint As Single) As Long '水平ポイントをピクセルに変換
Pt2PxX = Int(aPoint * xDPI / xlPPI)
End Function
Private Function Px2PtY(aPixel As Long) As Single 'ピクセルを垂直ポイントに変換
Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI)
End Function
Private Function Pt2PxY(aPoint As Single) As Long '垂直ポイントをピクセルに変換
Pt2PxY = Int(aPoint * yDPI / xlPPI)
End Function
Rem =================================================================================================================================
Public Sub UpdateList1()
Dim f As String
On Error Resume Next
List1.RowSource = ""
List1.Clear
f = ActiveCell.Validation.Formula1
Set Sh = ActiveSheet
addr = ActiveCell.Address(external:=True)
On Error GoTo 0
If Len(f) = 0 Then Exit Sub
If f Like "=*" Then
List1.RowSource = f
Else
List1.List = Split(f, ",")
End If
Dim MyTop As Single, MyLeft As Single
Call GetTopLeftFromCaretCellBR(MyTop, MyLeft, Me.Height, Me.Width)
Me.Top = MyTop + (Me.Width - Me.InsideWidth)
Me.Left = MyLeft + (Me.Width - Me.InsideWidth)
Me.Show vbModeless
End Sub
Private Sub List1_Click()
If ActiveCell Is Nothing Then Exit Sub
' ActiveCell.Value = List1.Value
Dim d As New MSForms.DataObject
d.SetText List1.Value
d.PutInClipboard
Me.Hide
Application.SendKeys "{BS}^v^~" '← にこやか?
Unload Me
End Sub
Private Sub Sh_SelectionChange(ByVal Target As Range)
If ActiveCell.Address(external:=True) <> addr Then Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.Font.Size = 12
Dim hWnd As LongPtr
WindowFromAccessibleObject Me, hWnd
' SetWindowLong hWnd, GWL_EXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW 'タイトルバー(小)あり
SetWindowLong hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) And Not WS_CAPTION 'タイトルバーなし
DrawMenuBar hWnd
Me.StartupPosition = 0
Set List1 = Me.Controls.Add("Forms.ListBox.1", "List1")
List1.Width = 120!
Me.Width = List1.Width + (Me.Width - Me.InsideWidth)
Me.Height = List1.Height + (Me.Height - Me.InsideHeight)
End Sub
（白茶） 2022/10/01(土) 21:32
どうもUserFormのサイズ調整がしっくりこなかったので、ちょっとだけ足掻いてみました。
Private Sub UserForm_Initialize()
Me.Font.Size = 12
Dim hWnd As LongPtr
WindowFromAccessibleObject Me, hWnd
' SetWindowLong hWnd, GWL_EXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW 'タイトルバー(小)あり
SetWindowLong hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) And Not WS_CAPTION 'タイトルバーなし
DrawMenuBar hWnd
Me.StartupPosition = 0
Set List1 = Me.Controls.Add("Forms.ListBox.1", "List1")
List1.Width = 120!
List1.List = Array(1, 2, 3, 4, 5, 6, 7, 8) '■追記 ダミーでリスト設定して
List1.Clear '■追記 IntegralHeightに仕事をしてもらう
DoEvents '■追記
Me.Width = List1.Width + (Me.Width - Me.InsideWidth)
Me.Height = List1.Height + (Me.Height - Me.InsideHeight)
End Sub
（白茶） 2022/10/03(月) 11:42
こうしたら動作が更にそれっぽくなりそう。
Private Sub List1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value = vbKeyReturn Then
PutInCb2Ac
ElseIf KeyAscii.Value = vbKeyEscape Then
Unload Me
End If
End Sub
Private Sub List1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
PutInCb2Ac
End Sub
Private Sub PutInCb2Ac()
If ActiveCell Is Nothing Then Exit Sub
Dim d As New MSForms.DataObject
d.SetText List1.Value
d.PutInClipboard
Me.Hide
Application.SendKeys "{BS}^v^~"
Unload Me
End Sub
（白茶） 2022/10/04(火) 17:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.