visual - 应用程序标题切断在VB6




visual basic用途 (4)

平台:Windows XP开发平台:VB6

当试图通过“制作”选项卡上的“项目属性”对话框设置应用程序标题时,它似乎以一定数量的字符静静地切断了标题。 也试过这个通过App.Title属性,它似乎遭受同样的问题。 我不在乎这个,但QA部门坚持要求显示整个标题。

有没有人有解决方法或解决这个?

编辑:对于那些谁回应约40个字符的限制,这就是我怀疑 - 因此我的问题可能的解决方法:-)。

其实我提出这个问题是为了帮助一个开发人员,所以当我在星期一看到她的时候,我会指出她所有的优秀建议,看看他们中的任何一个能否帮助她理顺。 我知道,出于某种原因,应用程序显示的一些对话框似乎从App.Title设置中获取字符串,这就是为什么她问我关于字符串长度的限制的原因。

我只是希望能从Microsoft找到一些明确的东西(比如某种类型的KB注释),这样她就可以把它展示给我们的QA部门,这样他们就会意识到这只是VB的限制。


看来VB6将App.Title属性限制为40个字符。 不幸的是,我找不到MSDN上的任何文档详细说明这种行为。 (不幸的是,我没有将文档加载到我的VB6副本所在的机器上。)

我用一个很长的标题进行了一个实验,那就是观察到的行为。 如果您的标题超过40个字符,它只会被截断。


+1 davidg。

你确定你的意思是标题? 标题是Windows任务栏中显示的内容。 使用标题设置窗体的标题栏中的文本。


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

编辑:正如迈克Spross笔记:这只隐藏正常的MsgBox函数。 如果您想从另一个项目访问您的自定义MsgBox,您将不得不限定它。


一个使用Windows API的解决方案


免责声明恕我直言,这似乎是矫枉过正,只是为了满足问题中所述的要求,但本着给予(希望)完整的问题的答案的精神,这里没有任何东西...

这是我在MSDN环顾了一段时间后想出来的一个工作版本,直到我终于找到一篇关于vbAccelerator的文章,让我的车轮转向。

  • 查看原文的vbAccelerator页面(与问题没有直接关系,但是那里有足够的空间给我一个答案)

基本前提是首先计算表单标题文本的宽度,然后使用GetSystemMetrics获取窗口各个位的宽度,例如边框和窗口框架宽度,最小化,最大化和关闭按钮的宽度等等(为了易读性和清晰度,我将这些功能分解为各自的功能)。 我们需要考虑窗口的这些部分,以便为窗体计算一个精确的新宽度。

为了准确地计算表单标题的宽度(“范围”),我们需要获得系统标题字体,因此SystemParametersInfoCreateFontIndirect调用和相关的好处。

最终的结果是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