Results of 1 - 1 of about 37697 for IF (0.008 sec.)
- [[20220929150026]]
- #score: 1591
- @digest: b6e9f3ade6a8d6444414de7ce36539ec
- @id: 92417
- @mdate: 2022-10-04T08:30:28Z
- @size: 22361
- @type: text/plain
- #keywords: crect (77465), lmtleft (73130), xlppi (65095), myleft (64667), list1 (63975), mytop (59197), arect (58630), lmttop (56000), px2ptx (50649), px2pty (50649), limittoedge (46907), fheight (45473), apicursorpos (43324), apirect (36765), apixel (36765), fwidth (35180), apoint (34812), ydpi (28880), xdpi (28880), cpos (28421), bottom (28287), 左部 (27632), getdpi (27438), longptr (26311), insidewidth (25673), ptrsafe (22827), ル左 (21437), 面よ (19351), nindex (18427), getwindowlong (17700), setwindowlong (17422), single (16901)
- 『プルダウンリストの表示を大きくする方法』（jj）
Excelでプルダウンのリストを作成した時に、全体が大きいので70%で表示したいのですが、そうするとプルダウンのリストも一緒に小さくなって見づらくなってしまいます。 全体の表示は70%だけど、プルダウンリストの表示はそのままか大きく表示する方法はありますでしょうか。。。 ＜ 使用 Excel:Office365、使用 OS:Windows10 ＞ ---- 普通じゃできないと思う 参考までに https://excel.ff-design.net/222/ （るり） 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モジュールと標準モジュールというのがよくわからないのですが… よろしければ簡単にどうすればいいのか教えていただけないでしょうか。 （jj） 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202209/20220929150026.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97059 documents and 608315 words.
訪問者：