VB6 How can I adjust maximum characters in a textbox depending on width of text entered so far?

Hello SteveQ2,

You could select the textbox font to be a fixed rather than proportional font?

Regards,
Chris

(haven't tried this yet)

Can you change the character limit at run-time with this API?

    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    Private Const EM_LIMITTEXT = &HC5

    ...
        SendMessage Text1.hwnd, EM_LIMITTEXT, 5, 0&

Chris_Bottomley,  
I need to keep a proportional font.  The current font setting is Arial 8.  

Idle_Mind,
That API method might be very helpful to reset the character limit but first I need to determine how many characters will fit in the textbox after the user start to type in the textbox.  The number of maxchars or limittext would be very different if the users enter characters like "WWW" or "iii".

You must set PictureboxHidden Font to the same Font as Textbox1, Otherwise PictureboxHidden.TextWidth result will not be accurate.

If you know how to call API functions, the API function GetTextExtentPoint32() can be used to determine the text width.  You should be able to pass the API function the hDC of your TextBox.  The only difficulty is that the return value is likely in pixels, while the dimensions of your TextBox are likely in twips.

Here is API function to return TextWidthA.
Note that TextBox hDc is not exposed so you need to call another API GetDc.
To return as Twips just multiply by Screen.TwipsPerPixelX.

Option Explicit
 
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As Size) As Long
Private Type Size
   cx As Long
   cy As Long
End Type
 
Private Sub Command1_Click()
   Debug.Print "TextWidthA(Text1)", TextWidthA(Text1)
End Sub
 
Private Function TextWidthA(tb As TextBox) As Long
    Dim sz As Size
    Call GetTextExtentPoint32(GetDC(tb.hwnd), tb.Text, Len(tb.Text), sz)
    TextWidthA = sz.cx * Screen.TwipsPerPixelX
End Function

Select allOpen in new window

Danaseaman,

The api calls you have supplied seem like they have alot of potential but they're still giving me very different results if the text I type in is "WWW" or "iiiii".  

I've attached the code I'm running.  It's very similar to the code you supplied but I've added some debugging info to see what it's doing.  Any ideas how I can get it to work as well if the user enters alot of narrow characters as it seems to work if they enter all wide upper case letters?

Option Explicit
' This code requires a new blank form, 1 textbox, and 1 label
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As Size) As Long
Private intWidthOfTextboxText As Integer
Private intWidthOfWidestPossibleChar As Integer
Private intWidthOfNarrowestPossibleChar As Integer
Private Type Size
   cx As Long
   cy As Long
End Type
Private Sub Form_Load()
   Label1.Width = 6000
   Text1.Text = "W"
   TextWidthA Text1
   intWidthOfWidestPossibleChar = intWidthOfTextboxText
   MsgBox "Widest possible character W: " & intWidthOfWidestPossibleChar
   Text1.Text = "i"
   TextWidthA Text1
   intWidthOfNarrowestPossibleChar = intWidthOfTextboxText
   MsgBox "Narrowest possible character i: " & intWidthOfNarrowestPossibleChar
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
  TextWidthA Text1
End Sub
Private Function TextWidthA(tb As TextBox) As Long
    Dim sz As Size
    Call GetTextExtentPoint32(GetDC(tb.hwnd), tb.Text, Len(tb.Text), sz)
    intWidthOfTextboxText = sz.cx * Screen.TwipsPerPixelX
    Label1.Caption = "Text width is in ok range: " & intWidthOfTextboxText
    If intWidthOfTextboxText >= Text1.Width Then
       Label1.Caption = "Text exceeds " & Text1.Width & ": " & intWidthOfTextboxText
    End If
 End Function

First, let me make sure I understand what you are trying to do.  
You want to limit the number of characters a user can type into a TextBox.  Your limit is basically the visual size of the TextBox (i.e. you don't want charaters to start strolling).  So basically, if the user types lots of narrow characters, they are allowed to enter more characters into the TextBox than if they use lots of wide characters.  To accomplish this, you are using a Key event to determine if the new character Keyed plus the existing text will fit within the viewable area of the Text Box.

But you are running into a problem, because what you've programmed might work for all WWW but doesn't work for iii, and if you make adjustments for iii, then WWW doesn't work.

First of all, I'd like to suggest that you simply use the KeyPress Event rather than the KeyUp event.  That way, you are only looking at characters that are going to be entered into the textbox rather than looking at every single time a key (like arrow keys) are pressed.  In the new character won't fit, you simply change the character to zero.

As for WWW v. iii, you have to keep in mind that you are only interested in the printable section of the TextBox, not the full size of the TextBox, because the full size of the TextBox includes things like the border of the textbox that is printed.

Listed below is some pseudo-code to demonstrate the idea...

Private Sub Text1_KeyUp( KeyAscii As Integer )
Dim TextBoxWidth as Integer
Dim NewTextWidth as Long
 
  TextBoxWidth = GetClientWidth( Text1.hwnd ) 
  NewTextWidth = GetTextWidth( Text1.hwnd, Text1.Text & Chr( KeyAscii )
  if NewTextWdith > TextBoxWidth then
    KeyAscii = 0
  end if
end sub
 
GetClientWidth( hwnd as long ) as long
  Dim R as RECT
  GetClientRect( hwnd, R )
  GetClientWidth = R.right - R.left
end function
  
GetTextWidth( hwnd as long, Text as String ) as long
  Dim sz as Size
  Call GetTextExtentPoint32( GetDC( hwnd), Text, Len( Text ), sz)
  GetTextWidth = sz.cx * Screen.TwipsPerPixelX
endf function 
 
'Here's the additional API declares needed that you might not already have
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Declare Function GetClientRect Lib "user32" Alias "GetClientRect" (ByVal hwnd As Long, lpRect As RECT) As Long

Select allOpen in new window

I can see you understand what I'm trying to accomplish but it doesn't look like GetTextExtentPoint32 is doing it yet.  I can type "WWWWWW" or "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" before any characters scroll out of sight in a textbox with a width of 1215.  According to GetTextExtentPoint32, the wide letters have a width of 1260 before any characters scroll out of sight.  But GetTextExtentPoint32 says the narrow letters have a width of 2280 before the any characters scroll out of the viewing area of the same textbox.    I really expected to get back a fairly similar number from GetTextExtentPoint32 for WWWWWW" and "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii".  Instead,  what appears to be the same width with more narrow characters is returning nearly double the width measurement from GetTextExtentPoint32 that the fewer wide characters returned. It still looks like it has potential.  Any ideas?

I broke down and did some test code, and danaseman seems to be correct.

What did work is when I loaded the DC with a font that matches the font in the TextBox.  The following snippet is UGLY, but it works if you create a new VB6 project, and drop a TextBox and Label on the Form.

From here, you might be able to clean things up and get things working, especially if there is an easier way to load the appropriate font into the DC than to go and create a new font object as the snippet shows.

Private Type Size
        cx As Long
        cy As Long
End Type
 
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 ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
 
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As Size) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
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(1 To LF_FACESIZE) As Byte
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
 
Private Function TextWidthA() As Long
    Dim sz As Size
    Dim hDC As Long
    Dim F As Font
    Dim lf As LOGFONT
    Dim I As Long
    Dim hFont As Long
    Dim hOldFont As Long
    
    Set F = Text1.Font
    lf.lfWeight = IIf(F.Bold, FW_BOLD, FW_NORMAL)
    lf.lfCharSet = F.Charset
    lf.lfItalic = F.Italic
    For I = 1 To Len(F.Name)
        lf.lfFaceName(I) = Asc(Mid$(F.Name, I, 1))
    Next I
    lf.lfFaceName(I) = 0
    lf.lfHeight = F.Size
    lf.lfStrikeOut = F.Strikethrough
    lf.lfUnderline = F.Underline
    lf.lfWeight = F.Weight
    
    hFont = CreateFontIndirect(lf)
    
    hDC = GetDC(Text1.hwnd)
    hOldFont = SelectObject(hDC, hFont)
    
    Call GetTextExtentPoint32(hDC, Text1.Text, Len(Text1.Text), sz)
    TextWidthA = sz.cx * Screen.TwipsPerPixelX
 
    Call SelectObject(hDC, hOldFont)
    Call DeleteObject(hFont)
    Call ReleaseDC(Text1.hwnd, hDC)
 
End Function
 
Private Sub Text1_Change()
    Label1.Caption = CStr(TextWidthA)
End Sub

Select allOpen in new window

Danaseaman(Guru), thank you!  I am so impressed!  I had tried and tried but could not get this problem solved.  It was beginning to seem like it might be impossible.  Thank you!