Aplicação Título Cut Off Em VB6

Question

Plataforma: Windows XP Plataforma de desenvolvimento: VB6

Ao tentar definir um título do aplicativo através do diálogo Propriedades do projeto na guia Marca, parece-cut silenciosamente fora do título em um determinado número de caracteres. Também tentou esta via a propriedade App.Title e parece sofrer do mesmo problema. Eu não me importo com isso, mas o QA Dept. insiste que nós necessitamos começar todo o título apresentado.

Alguém tem uma solução alternativa ou correção para esse?

---

Edit: Para aqueles que responderam sobre um limite de 40 caracteres, que é o que eu tipo de suspeita - daí a minha pergunta sobre uma possível solução alternativa :-).

Na verdade, eu postei esta pergunta para tentar ajudar um desenvolvedor companheiro então quando eu vê-la na segunda-feira, eu vou apontar-la a todos os seus excelentes sugestões e ver se algum deles ajudá-la a obter este endireitado. Eu sei que por algum motivo alguns dos diálogos exibida pelo aplicativo parece para pegar a corda da configuração App.Title é por isso que ela tinha me perguntado sobre a limitação do comprimento da corda.

Eu só desejo que eu poderia encontrar algo definitivo da Microsoft (como uma espécie de KB nota) para que ela pudesse mostrá-lo para o nosso departamento de QA para que eles percebem isso é simplesmente uma limitação do VB.

Answer 1

Uma solução usando a API do Windows

Aviso : IMHO isso parece um exagero apenas para satisfazer o requisito referido na pergunta, mas no espírito de dar um (espero) resposta completa para o problema, aqui vai nada ...

Aqui está uma versão de trabalho eu vim com depois que procuram no MSDN por algum tempo, até que finalmente veio em cima de um artigo sobre VBAccelerator que tenho minhas rodas girando.

• Veja a página VBAccelerator para o original artigo (não diretamente relacionado com a questão, mas não foi o suficiente para me para formular uma resposta)

A premissa básica é a primeira a calcular a largura do texto da legenda do formulário e, em seguida, para uso GetSystemMetrics para obter a largura de vários pedaços de janela, tais como a largura da borda e janela do quadro, o largura do minimizar, maximizar e fechar botões, e assim por diante (I dividir estes em suas próprias funções para readibility / clareza). Precisamos conta para estas partes da janela, a fim de calcular uma nova largura exata para o formulário.

A fim de calcular com precisão a largura ( "medida") de legenda do formulário, é preciso obter a fonte da legenda do sistema, daí o SystemParametersInfo e CreateFontIndirect chamadas e bem relacionado.

o resultado final de todo esse esforço é o GetRecommendedWidth função, que calcula todos esses valores e adiciona-los juntos, além de um pouco de cobertura extra para que haja algum espaço entre o último caractere do legenda e os botões de controle. Se esta nova largura é maior que a largura atual do formulário, GetRecommendedWidth retornará este (maior) de largura, caso contrário, ele retornará largura atual do formulário.

Eu só testei brevemente, mas parece funcionar bem. Uma vez que utiliza funções da API do Windows, no entanto, você pode querer ter cautela, especialmente porque ela está copiando memória ao redor. Eu não adicionar robusta de tratamento de erros, também.

A propósito, se alguém tem um limpador de forma, menos envolvidos de fazer isso, ou se eu perdi alguma coisa no meu próprio código, por favor me avise.

Para testá-lo, cole o seguinte código em um novo módulo

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

Em seguida, coloque o seguinte em seu evento Form_Load

Private Sub Form_Load()

    Me.Caption = String(100, "x") 'replace this with your caption'
    Me.Width = GetRecommendedWidth(Me)

End Sub

Answer 2

O MsgBox-Function tem um parâmetro para o título. Se você não quer mudar a cada chamada individual para o MsgBox-Function, você pode "substituir" o comportamento padrão:

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

Edit: notas Como Mike Spross: Isso só esconde o MsgBox-Function normal. Se você quiser acessar o seu MsgBox costume de outro projeto, você teria que qualificá-lo.

Answer 3

Acabei de criar um projecto EXE padrão no IDE e texto digitado no campo de título do aplicativo na guia Marca Propriedades do projeto até que encheu o campo. A partir deste teste rápido, parece que App.Title está limitado a 40 caracteres. Em seguida eu tentei-lo no código, colocando o seguinte código no formulário padrão (Form1) criado para o projeto:

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

Este rápidas confirma teste o limite de 40 characater, porque os MsgBox exibe 40, embora as tentativas de código para definir App.Title para uma cadeia de 41 caracteres.

Se é realmente importante para obter a seqüência completa para exibição na barra de título de um formulário, em seguida, única maneira que eu posso pensar para garantir que todo o título é exibido seria a de obter a largura do texto da barra de título e usar isso para aumentar a largura do seu Formulário de modo que possa acomodar a corda título completo. I pode voltar e código postal para isso, se eu posso encontrar os encantamentos API certas, mas pode ser algo como isto no evento 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

Answer 4

Parece que VB6 limita a propriedade App.Title a 40 caracteres. Infelizmente, não consigo localizar qualquer documentação no MSDN detalhando esse comportamento. (E, infelizmente, eu não tenho documentação carregados na máquina onde minha cópia do VB6 ainda reside.)

Eu corri uma experiência com títulos longos, e que foi o comportamento observado. Se o título é mais de 40 caracteres, ele simplesmente vai ficar truncado.

Answer 5

+1 davidg.

Você tem certeza que Título média? O título é o que aparece na barra de tarefas do Windows. Use Caption para definir o texto na barra de título de um formulário.