4

平台：Windows XP 开发平台：VB6

当尝试通过 Make 选项卡上的 Project Properties 对话框设置应用程序标题时，它似乎会在设定的字符数处默默地切断标题。还通过 App.Title 属性尝试了这个，它似乎遇到了同样的问题。我不在乎这个，但 QA 部门坚持认为我们需要显示整个标题。

有没有人有解决方法或解决这个问题？

编辑：对于那些回答了 40 个字符限制的人，这就是我所怀疑的——因此我对可能的解决方法提出了问题 :-) 。

实际上，我发布这个问题是为了帮助一位开发人员，所以当我周一见到她时，我会向她指出你所有的优秀建议，看看是否有任何人能帮助她解决这个问题。我确实知道，出于某种原因，应用程序显示的某些对话框似乎从 App.Title 设置中提取了字符串，这就是为什么她问我关于字符串长度限制的原因。

我只是希望我能从微软那里找到一些明确的东西（比如某种 KB 注释），这样她就可以把它展示给我们的 QA 部门，这样他们就会意识到这只是 VB 的一个限制。

4

4 回答 4

4

MsgBox-Function 接受标题的参数。如果您不想更改对 MsgBox-Function 的每次调用，您可以“覆盖”默认行为：

Function MsgBox(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title, Optional HelpFile, Optional Context) As VbMsgBoxResult
    If IsMissing(Title) Then Title = String(40, "x") & "abc"
    MsgBox = Interaction.MsgBox(Prompt, Buttons, Title, HelpFile, Context)
End Function

编辑：正如 Mike Spross 所说：这只隐藏了正常的 MsgBox-Function。如果您想从另一个项目访问您的自定义 MsgBox，则必须对其进行限定。

于 2008-09-27T10:58:18.360 回答
3

我刚刚在 IDE 中创建了一个标准 EXE 项目，并在 Project Properties Make 选项卡下的应用程序标题字段中键入了文本，直到我填写了该字段。从这个快速测试中，App.Title 似乎被限制为 40 个字符。接下来，我通过将以下代码放入为项目创建的默认表单（Form1）中，在代码中进行了尝试：

Private Sub Form_Load()
    App.Title = String(41, "X")
    MsgBox Len(App.Title)
End Sub

此快速测试确认了 40 个字符的限制，因为 MsgBox 显示 40，即使代码尝试将 App.Title 设置为 41 个字符的字符串。

如果让完整的字符串显示在表单的标题栏中真的很重要，那么我能想到的确保显示整个标题的唯一方法就是获取标题栏文本的宽度并使用它来增加宽度您的表单，以便它可以容纳完整的标题字符串。如果我能找到正确的 API 咒语，我可能会回来并为此发布代码，但它在 Form_Load 事件中可能看起来像这样：

Dim nTitleBarTextWidth As Long
Dim nNewWidth As Long

Me.Caption = "My really really really really really long app title here"

' Get titlebar text width (somehow) '
nTitleBarTextWidth = GetTitleBarTextWidth()

' Compute the new width for the Form such that the title will fit within it '
' (May have to add a constant to this to make sure the title fits correctly) '
nNewWidth = Me.ScaleX(nTitleBarTextWidth, vbPixels, Me.ScaleMode)

' If the new width is bigger than the forms current size, use the new width '
If nNewWidth > Me.Width Then
    Form.Width = nNewWidth
End If
于 2008-09-26T21:53:47.030 回答
2

一种使用 Windows API 的解决方案


免责声明：恕我直言，这似乎只是为了满足问题中所述的要求，但本着对问题给出（希望）完整答案的精神，这里什么都没有......

这是我在 MSDN 中浏览了一段时间后想出的一个工作版本，直到我终于看到一篇关于 vbAccelerator 的文章让我的车轮转动起来。

  • 请参阅原始文章的vbAccelerator页面（与问题没有直接关系，但那里有足够的内容让我制定答案）

基本前提是先计算窗体标题文本的宽度，然后使用GetSystemMetrics获取窗口各个位的宽度，如边框和窗口框架宽度，Minimize、Maximize、Close按钮的宽度，等等（为了便于阅读/清晰，我将它们分成了它们自己的函数）。我们需要考虑窗口的这些部分，以便为表单计算准确的新宽度。

为了准确计算表单标题的宽度（“范围”），我们需要获取系统标题字体，因此SystemParametersInfo和CreateFontIndirect调用以及相关的好处。

所有这些努力的最终结果是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
于 2008-09-27T03:59:32.300 回答
1

看来 VB6 将 App.Title 属性限制为 40 个字符。不幸的是，我在 MSDN 上找不到任何详细说明此行为的文档。（不幸的是，我没有将文档加载到我的 VB6 副本仍然驻留的机器上。）

我用长标题进行了实验，这就是观察到的行为。如果您的标题超过 40 个字符，它将被截断。

于 2008-09-26T21:47:54.190 回答