I want Help For Compress Text in Text Box

[shekaraluwala]

Dear All


I want Help For Compress Text in Text Box
When I tying in Text Box that text is compress
Example : My Text Box Width is 1000 now i am Typing Like 'abcdefghijklmnopq'
now i want see Complete Text in The Text Box Width

That is Text Compress


Thanks in Advance of All

Please Reply Anybody

[WizBang]

If you need more characters to fit in a given width, can you use a smaller font size, or a different font, such as "Small Fonts"?

[dglienna]

Here you go:

You need a CLASS MODULE:

Option Explicit

Private Const LF_FACESIZE = 32

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 Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1

Private Declare Function CreateFontIndirect _
 Lib "gdi32" Alias "CreateFontIndirectA" ( _
 lpLogFont As LOGFONT) As Long

Private Declare Function GetDC _
 Lib "user32.dll" ( _
 ByVal hwnd As Long) As Long

Private Declare Function MulDiv _
 Lib "kernel32" ( _
 ByVal nNumber As Long, _
 ByVal nNumerator As Long, _
 ByVal nDenominator As Long) As Long

Private Declare Function DeleteObject _
 Lib "gdi32" ( _
 ByVal hObject As Long) As Long

Private Declare Function ReleaseDC _
 Lib "user32.dll" ( _
 ByVal hwnd As Long, _
 ByVal hdc As Long) As Long

Private Declare Function GetDeviceCaps _
 Lib "gdi32" ( _
 ByVal hdc As Long, _
 ByVal nIndex As Long) As Long

Private Const LOGPIXELSY = 90

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function DrawText _
 Lib "user32" Alias "DrawTextA" ( _
 ByVal hdc As Long, _
 ByVal lpStr As String, _
 ByVal nCount As Long, _
 lpRect As RECT, _
 ByVal wFormat As Long) As Long

Private Const DT_CALCRECT = &H400

Private Declare Function SelectObject _
 Lib "gdi32" ( _
 ByVal hdc As Long, _
 ByVal hObject As Long) As Long

Private m_Font As StdFont

Public Property Get Font() As StdFont
    Set Font = m_Font
End Property

Public Function TextWidth(ByVal sText As String) As Long
    Dim r As RECT
    r = GetFontSize(sText)
    TextWidth = r.Right
End Function

Public Function TextHeight(ByVal sText As String) As Long
    Dim r As RECT
    r = GetFontSize(sText)
    TextHeight = r.Bottom
End Function

Private Sub OLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)
    Dim sFont As String
    Dim iChar As Integer
    Dim b() As Byte
    
    ' Convert an OLE StdFont to a LOGFONT structure:
    With tLF
        sFont = fntThis.Name
        b = StrConv(sFont, vbFromUnicode)
        For iChar = 1 To Len(sFont)
            .lfFaceName(iChar - 1) = b(iChar - 1)
        Next iChar
        ' Based on the Win32SDK documentation:
        .lfHeight = -MulDiv((fntThis.size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
        .lfItalic = fntThis.Italic
        If (fntThis.Bold) Then
            .lfWeight = FW_BOLD
        Else
            .lfWeight = FW_NORMAL
        End If
        .lfUnderline = fntThis.Underline
        .lfStrikeOut = fntThis.Strikethrough
        .lfCharSet = fntThis.Charset
    End With
End Sub

Private Sub Class_Initialize()
    'set a standard font
    Set m_Font = New StdFont
    m_Font.Name = "MS Sans Serif"
    m_Font.size = 8
End Sub

Private Function GetFontSize(ByVal sText As String) As RECT
    Dim hdc As Long
    Dim tLF As LOGFONT
    Dim hFnt As Long, hFntOld As Long
    Dim tR As RECT
    
    hdc = GetDC(0)
    OLEFontToLogFont m_Font, hdc, tLF
    hFnt = CreateFontIndirect(tLF)
    hFntOld = SelectObject(hdc, hFnt)
    DrawText hdc, sText, -1, tR, DT_CALCRECT
    SelectObject hdc, hFntOld
    DeleteObject hFnt
    Call ReleaseDC(0, hdc)
    GetFontSize = tR
End Function

Private Sub Class_Terminate()
    Set m_Font = Nothing
End Sub

Then, you need only a few lines of code...

Option Explicit

Private Sub Text1_Change()
    Dim size As CTextSize
    Set size = New CTextSize
    'add 6 pixels for the border and to avoid wordwrapping
    Text1.Width = (size.TextWidth(Text1.Text) + 6) * Screen.TwipsPerPixelX
    Text1.Height = (size.TextHeight(Text1.Text) + 6) * Screen.TwipsPerPixelY
End Sub

You might want to check if it exceeds the form size...

[javajawa]

A simpler solution that dglienna's, but not tested (I don't have VB6 on this machine):

Note: this assumes FORM.scalemode = vbTwips.

  Private Const MaxFontSize = 12

  Private Sub Text1_Change()
    Dim Size as Integer, MaxWidth as Integer

    Size = MaxFontSize
    MaxWidth = Me.ScaleWidth - 300
    Me.Font.Size = MaxFontSize
    
    Do While Me.TextWidth(Text1.Text) > MaxWidth
      Size = Size - 1
      Me.Font.Size = Size
    Loop

    Set Text1.Font = Me.Font
    Text1.Width = Me.TextWidth(Text1.Text)

  End Sub