Solved

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

Posted on 2009-04-12
12
1,071 Views
Last Modified: 2013-12-20
I need to optimize the maxchars allowed in a VB6 textbox.  It makes a big difference in the maximum number of characters that will fit if the users enter wide letters like "WWW" or narrow letters like "iii".  Since textbox.maxchars can't be changed at runtime, I'm using code in the keypress event to limit the number of characters.  

I found there may be a potential solution using a hidden picturebox to determine the width of text entered so far to determine if more characters should be allowed in the textbox.  But I have not been able to get this work very accurately yet.

intWidthRemaining = Textbox1.Width - PictureboxHidden.TextWidth(Textbox1.text)
intMaxWidthOfPossibleNextChar = PictureboxHidden.TextWidth("W")
If intWidthRemaining > intMaxWidthOfPossibleNextChar Then blnAllowAnotherCharToBeTyped

Can a picturebox be used to determine the width of the text entered so far?  Or, is there an api call that could tell me if a textbox has room for more characters?  
0
Comment
Question by:SteveQ2
  • 4
  • 3
  • 3
  • +2
12 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24125844
Hello SteveQ2,

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

Regards,
Chris
0
 
LVL 85

Expert Comment

by:Mike Tomlinson
ID: 24125875
(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&
0
 

Author Comment

by:SteveQ2
ID: 24126025
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".
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 24126050
You must set PictureboxHidden Font to the same Font as Textbox1, Otherwise PictureboxHidden.TextWidth result will not be accurate.
0
 
LVL 16

Expert Comment

by:HooKooDooKu
ID: 24131951
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.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 24134453
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

Open in new window

0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:SteveQ2
ID: 24138181
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
0
 
LVL 16

Expert Comment

by:HooKooDooKu
ID: 24139012
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

Open in new window

0
 

Author Comment

by:SteveQ2
ID: 24139862
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?
0
 
LVL 22

Accepted Solution

by:
danaseaman earned 500 total points
ID: 24140153
Whatever GetDc is returning appears to not have the corresponding TextBox Font.
Try this code which uses DrawText and the Form hDc.
Note that Form Font has been set to TextBox Font.

Option Explicit
 

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

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 

Private Type RECT

   Left                 As Long

   Top                  As Long

   Right                As Long

   Bottom               As Long

End Type
 

Private Const DT_CALCRECT As Long = &H400

Private TextBoxClientW  As Long
 

Private Sub Form_Load()

   Dim rct              As RECT

   GetClientRect Text1.hwnd, rct

   TextBoxClientW = (rct.Right - rct.Left)

   Set Me.Font = Text1.Font

End Sub
 

Private Sub Text1_KeyPress(KeyAscii As Integer)

   Debug.Print TextWidthA(Text1, Chr(KeyAscii)), TextBoxClientW

   If KeyAscii > 31 Then

      If TextWidthA(Text1, Chr(KeyAscii)) > TextBoxClientW Then

         KeyAscii = 0

         Debug.Print "Reached limit"

      End If

   End If

End Sub
 

Private Function TextWidthA(tb As TextBox, sChar As String) As Long

   Dim rct              As RECT

   DrawText Me.hdc, tb.Text & sChar, -1, rct, DT_CALCRECT

   TextWidthA = rct.Right - rct.Left

End Function

Open in new window

0
 
LVL 16

Expert Comment

by:HooKooDooKu
ID: 24140589
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

Open in new window

0
 

Author Closing Comment

by:SteveQ2
ID: 31569321
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!  
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

759 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now