平台： Windows XP 开发平台：VB6 尝试通过“制作”选项卡上的“项目属性”对话框设置应用程序标题时,它似乎以一定数量的字符静默切断标题.也尝试通过App.Title属性,它似乎遭受同样的问
开发平台：VB6
尝试通过“制作”选项卡上的“项目属性”对话框设置应用程序标题时,它似乎以一定数量的字符静默切断标题.也尝试通过App.Title属性,它似乎遭受同样的问题.我不关心这个,但QA部门坚持认为我们需要显示整个标题.
有没有人有解决方法或修复此问题？
编辑：对那些回复40个字符限制的人来说,这就是我怀疑的 – 因此我对可能的解决方法的问题:-).
实际上我发布了这个问题,试图帮助一位开发人员,所以当我周一看到她时,我会向她指出你所有的优秀建议,看看是否有任何一个能帮助她理顺这个问题.我知道由于某些原因,应用程序显示的某些对话框似乎从App.Title设置中获取字符串,这就是为什么她问我关于字符串长度的限制.
我只是希望能从微软找到一些明确的东西(比如某种KB注释),这样她就可以把它展示给我们的QA部门,这样他们就会意识到这只是VB的限制.
一种使用Windows API的解决方案免责声明：恕我直言,这似乎只是为了满足问题中所述的要求而过度杀戮,但本着给予(希望)完整答案的精神,这里什么都没有……
这是我在MSDN中查看一段时间之后想出的一个工作版本,直到我终于找到一篇关于vbAccelerator的文章让我的车轮转动.
>请参阅vbAccelerator页面了解原始文章(与问题没有直接关系,但有足够的空间让我来制定答案)
基本前提是首先计算表单标题文本的宽度,然后使用GetSystemMetrics获取窗口各个位的宽度,例如边框和窗口框架宽度,最小化,最大化和关闭按钮的宽度等等(为了便于阅读/清晰,我将它们分成了各自的功能).我们需要考虑窗口的这些部分,以便为表单计算准确的新宽度.
为了准确计算表单标题的宽度(“范围”),我们需要获取系统标题字体,因此需要SystemParametersInfo和CreateFontIndirect调用以及相关的优点.
所有这些努力的最终结果是GetRecommendedWidth函数,它计算所有这些值并将它们加在一起,加上一些额外的填充,以便在标题的最后一个字符和控制按钮之间留出一些空间.如果此新宽度大于表单的当前宽度,则GetRecommendedWidth将返回此(更大)宽度,否则,它将返回Form的当前宽度.
我只是简单测试了一下,但似乎工作正常.但是,由于它使用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