Windows API を使用した 1 つのソリューション
免責事項：IMHOこれは、質問に記載されている要件を満たすためだけにやり過ぎのように思えますが、問題に対して（うまくいけば）完全な答えを与えるという精神で、ここでは何もしません...
これは、MSDN をしばらく調べた後に思いついた実用的なバージョンです。最終的に vbAccelerator に関する記事を見つけて、私の車輪が回転しました。
基本的な前提は、最初にフォームのキャプション テキストの幅を計算し、次にGetSystemMetricsを使用して、ウィンドウのさまざまなビットの幅 (境界線やウィンドウ フレームの幅、最小化、最大化、閉じるボタンの幅など) を取得することです。など (読みやすさ/明確さのために、これらを独自の関数に分割します)。フォームの新しい幅を正確に計算するには、ウィンドウのこれらの部分を考慮する必要があります。
フォームのキャプションの幅 (「範囲」) を正確に計算するには、システム キャプション フォントを取得する必要があります。
このすべての努力の結果、GetRecommendedWidth関数が作成されます。この関数は、これらの値をすべて計算して加算し、キャプションの最後の文字とコントロール ボタンの間にスペースを空けるために少し余分なパディングを追加します。この新しい幅がフォームの現在の幅より大きい場合、GetRecommendedWidth はこの (大きい) 幅を返します。それ以外の場合は、フォームの現在の幅を返します。
簡単にテストしただけですが、問題なく動作しているようです。ただし、Windows API 関数を使用するため、特にメモリをコピーしているため、注意が必要な場合があります。堅牢なエラー処理も追加しませんでした。
ところで、誰かがこれを行うためのよりクリーンで関与の少ない方法を持っている場合、または自分のコードで何かを見逃している場合は、お知らせください。
試すには、次のコードを新しいモジュールに貼り付けます
Option Explicit
Private Type SIZE
cx As Long
cy As Long
End Type
Private Const LF_FACESIZE = 32
'NMLOGFONT: This declaration came from vbAccelerator (here is what he says about it):'
' '
' For some bizarre reason, maybe to do with byte '
' alignment, the LOGFONT structure we must apply '
' to NONCLIENTMETRICS seems to require an LF_FACESIZE '
' 4 bytes smaller than normal: '
Private Type NMLOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE - 4) As Byte
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As NMLOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As NMLOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As NMLOGFONT
lfStatusFont As NMLOGFONT
lfMessageFont As NMLOGFONT
End Type
Private Enum SystemMetrics
SM_CXBORDER = 5
SM_CXDLGFRAME = 7
SM_CXFRAME = 32
SM_CXSCREEN = 0
SM_CXICON = 11
SM_CXICONSPACING = 38
SM_CXSIZE = 30
SM_CXEDGE = 45
SM_CXSMICON = 49
SM_CXSMSIZE = 52
End Enum
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpszString As String, _
ByVal cbString As Long, _
lpSize As SIZE) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As SystemMetrics) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Function GetCaptionTextWidth(ByVal frm As Form) As Long
'-----------------------------------------------'
' This function does the following: '
' '
' 1. Get the font used for the forms caption '
' 2. Call GetTextExtent32 to get the width in '
' pixels of the forms caption '
' 3. Convert the width from pixels into '
' the scaling mode being used by the form '
' '
'-----------------------------------------------'
Dim sz As SIZE
Dim hOldFont As Long
Dim hCaptionFont As Long
Dim CaptionFont As LOGFONT
Dim ncm As NONCLIENTMETRICS
ncm.cbSize = LenB(ncm)
If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, ncm, 0) = 0 Then
' What should we do if we the call fails? Change as needed for your app,'
' but this call is unlikely to fail anyway'
Exit Function
End If
CopyMemory CaptionFont, ncm.lfCaptionFont, LenB(CaptionFont)
hCaptionFont = CreateFontIndirect(CaptionFont)
hOldFont = SelectObject(frm.hdc, hCaptionFont)
GetTextExtentPoint32 frm.hdc, frm.Caption, Len(frm.Caption), sz
GetCaptionTextWidth = frm.ScaleX(sz.cx, vbPixels, frm.ScaleMode)
'clean up, otherwise bad things will happen...'
DeleteObject (SelectObject(frm.hdc, hOldFont))
End Function
Private Function GetControlBoxWidth(ByVal frm As Form) As Long
Dim nButtonWidth As Long
Dim nButtonCount As Long
Dim nFinalWidth As Long
If frm.ControlBox Then
nButtonCount = 1 'close button is always present'
nButtonWidth = GetSystemMetrics(SM_CXSIZE) 'get width of a single button in the titlebar'
' account for min and max buttons if they are visible'
If frm.MinButton Then nButtonCount = nButtonCount + 1
If frm.MaxButton Then nButtonCount = nButtonCount + 1
nFinalWidth = nButtonWidth * nButtonCount
End If
'convert to whatever scale the form is using'
GetControlBoxWidth = frm.ScaleX(nFinalWidth, vbPixels, frm.ScaleMode)
End Function
Private Function GetIconWidth(ByVal frm As Form) As Long
Dim nFinalWidth As Long
If frm.ControlBox Then
Select Case frm.BorderStyle
Case vbFixedSingle, vbFixedDialog, vbSizable:
'we have an icon, gets its width'
nFinalWidth = GetSystemMetrics(SM_CXSMICON)
Case Else:
'no icon present, so report zero width'
nFinalWidth = 0
End Select
End If
'convert to whatever scale the form is using'
GetIconWidth = frm.ScaleX(nFinalWidth, vbPixels, frm.ScaleMode)
End Function
Private Function GetFrameWidth(ByVal frm As Form) As Long
Dim nFinalWidth As Long
If frm.ControlBox Then
Select Case frm.BorderStyle
Case vbFixedSingle, vbFixedDialog:
nFinalWidth = GetSystemMetrics(SM_CXDLGFRAME)
Case vbSizable:
nFinalWidth = GetSystemMetrics(SM_CXFRAME)
End Select
End If
'convert to whatever scale the form is using'
GetFrameWidth = frm.ScaleX(nFinalWidth, vbPixels, frm.ScaleMode)
End Function
Private Function GetBorderWidth(ByVal frm As Form) As Long
Dim nFinalWidth As Long
If frm.ControlBox Then
Select Case frm.Appearance
Case 0 'flat'
nFinalWidth = GetSystemMetrics(SM_CXBORDER)
Case 1 '3D'
nFinalWidth = GetSystemMetrics(SM_CXEDGE)
End Select
End If
'convert to whatever scale the form is using'
GetBorderWidth = frm.ScaleX(nFinalWidth, vbPixels, frm.ScaleMode)
End Function
Public Function GetRecommendedWidth(ByVal frm As Form) As Long
Dim nNewWidth As Long
' An abitrary amount of extra padding so that the caption text '
' is not scrunched up against the min/max/close buttons '
Const PADDING_TWIPS = 120
nNewWidth = _
GetCaptionTextWidth(frm) _
+ GetControlBoxWidth(frm) _
+ GetIconWidth(frm) _
+ GetFrameWidth(frm) * 2 _
+ GetBorderWidth(frm) * 2 _
+ PADDING_TWIPS
If nNewWidth > frm.Width Then
GetRecommendedWidth = nNewWidth
Else
GetRecommendedWidth = frm.Width
End If
End Function
次に、 Form_Load イベントに次を配置します
Private Sub Form_Load()
Me.Caption = String(100, "x") 'replace this with your caption'
Me.Width = GetRecommendedWidth(Me)
End Sub