Okay, so I have this character, and I want it to smoothly move. I have it's walking animation powered with 6 sprites, and this is how the animation is functioning right now:
First, I have a KeyDown sub:
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
...
Select Case KeyCode
Case vbKeyLeft: 'move left
MoveLeft Character, Speed
Case vbKeyRight: 'move right
MoveRight Character, Speed
Case vbKeyUp: 'jump
Jump Character
Case vbKeyDown:
Duck Character
End Select
...
End Sub
The Select then triggers the MoveLeft/MoveRight funcitons when they press right or left arrow keys.
Public Function MoveRight(Character As Image, Speed As Integer)
SaveSetting "MLP", "Game", "direction", "right"
Character.Left = Character.Left + Speed
Select Case GetSetting("MLP", "Game", "right_animation", 0)
Case 0:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_27.gif")
SaveSetting "MLP", "Game", "right_animation", 1
Case 1:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_28.gif")
SaveSetting "MLP", "Game", "right_animation", 2
Case 2:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_29.gif")
SaveSetting "MLP", "Game", "right_animation", 3
Case 3:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_30.gif")
SaveSetting "MLP", "Game", "right_animation", 4
Case 4:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_31.gif")
SaveSetting "MLP", "Game", "right_animation", 5
Case 5:
Character.Picture = LoadPicture(App.Path & "\images\characters\" & GetSetting("MLP", "Game", "pony", "twilight") & "\sprite_32.gif")
SaveSetting "MLP", "Game", "right_animation", 0
End Select
End Function
Only one of the functions because both are identical. Now, I want to add a delay in here, of 100MS. I have a pause function I found:
Public Function Pause(Milliseconds As Single)
Dim T As Single, t2 As Single
T = GetTickCount(): t2 = GetTickCount()
Do Until t2 - T >= Milliseconds
t2 = GetTickCount(): Sleep 1: DoEvents
Loop
End Function
And this pause function works great, but not in this case for some reason. Ive tried putting the pause before the function is triggered in the Form_KeyDown Select, I've tried it before each picture is changed, I've tried it after each picture is changed, I've tried it before the Select in MoveRight/MoveLeft, but they all result in no animation, like the character just slides with no sprite change/animation. What could be the problem and how can I fix this?
If you are wondering what it does with no Pause like the code I posted here, it animates but really fast, you can notice the sprite changes and it looks animated but its not smooth, it goes way to fast.
It looks like your frame per second is powered by the rate at which key_down is fired, or the keyboard repeat speed/rate and delay. You can adjust that delay in your application by using some VB code that I do not know off my head (but you can search I believe).
But if I were doing it, I will use a "Game Loop". for a simplistic solution, you need:
Timer component and its Tick event, set to 33ms interval, to act as the Game Loop
global boolean flags for moveleft, moveright.
global int milliseconds_elasped.
The keydown and keyup functions to set and clear the moveleft and moveright flags.
In the keydown function, set/clear the moveleft or moveright flags exclusively.
In the timer_tick() Sub, check the flag for moveleft, if it is set, animate the character by x = x + speed * timer.interval., at the same time let the character object know how much milliseconds_elpased has passed so that it will display the correct frame itself. Do the similar for moveright.
The timer will refresh the animation at the rate timer.interval (FPS); while the character animates independant of the FPS as it uses the milliseconds_elpased to determine which frame it should be at.
My final and most successful solution was a combination of both Jake's and mine.
First, I used Jake's Timer idea, and secondly, instead of using images, I used a flash image with Wmode set to transparent. Instead of cycling through images, i would cycle through 1-framed SWF files which rendered much more beautifully and flicker-free! Here is a taste of the new Select Case:
Select Case CurrentState
Case 0:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_1.swf"
CurrentState = 1
Case 1:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_2.swf"
CurrentState = 2
Case 2:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_3.swf"
CurrentState = 3
Case 3:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_4.swf"
CurrentState = 4
Case 4:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_5.swf"
CurrentState = 5
Case 5:
Character.LoadMovie 0, App.Path & "\swf\twilight\walk_6.swf"
CurrentState = 0
End Select
Also if you notice, I am no longer using Save/GetSetting, and a global public variable to improve efficiency, which was suggested by Deanna. Thank you everyone, we all helped in the process of achieving this answer.
Related
I am fixing an old application which built on top of Visual Basic 6 code. There is an requirement that adding a statusbar on the bottom of the form. My status bar is as below:
I can show the text correctly but I also want to add a red background color. I found out there is no such option for StatusBar Panel. When I open the property of StatusBar, it shows as below:
I found out I can add picture. But When I added the red color picture, the text will be cover by the picture. I am stuck. Any advice will be helpful. Thanks!!
UPDATE
I simply used the code from the link #Étienne Laneville provided in the comment. The background color added and also the text added.
Here is my code to call the function:
PanelText StatusBar1, 9, "ATM (" & cntATM & ")", QBColor(12), QBColor(0)
But the text position is like below:
I have to make the text like below to position it, because this task was urgent for now and I have no time to investigate more.
PanelText StatusBar1, 9, "ATM (" & cntATM & ") ", QBColor(12), QBColor(0)
Below is my output:
UPDATE 2
I tried the code provided by Brian M Stafford. But I got the same results. The text is still not at the center (Or to the Left). Below are my code and screenshot of status bar:
The function:
Private Sub PanelText(sb As StatusBar, pic As PictureBox, Index As Long, aText As String, bkColor As Long, _
fgColor As Long, lAlign As Integer)
Dim R As RECT
SendMessage sb.hWnd, SB_GETRECT, Index - 1, R
With pic
Set .Font = sb.Font
.Move 0, 0, (R.Right - R.Left + 2) * Screen.TwipsPerPixelX, (R.Bottom - R.Top) * Screen.TwipsPerPixelY
.BackColor = bkColor
.Cls
.ForeColor = fgColor
.CurrentY = (.Height - .TextHeight(aText)) \ 2
Select Case lAlign
Case 0 ' Left Justified
.CurrentX = 0
Case 1 ' Right Justified
.CurrentX = .Width - .TextWidth(aText) - Screen.TwipsPerPixelX * 2
Case 2 ' Centered
.CurrentX = (.Width - .TextWidth(aText)) \ 2
End Select
pic.Print aText
sb.Panels(Index).Text = aText
sb.Panels(Index).Picture = .Image
End With
End Sub
The API:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WM_USER = &H400
Private Const SB_GETRECT = (WM_USER + 10)
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
Calling the function:
PanelText StatusBar1, picPanel, 9, "Test1", vbRed, vbBlack, 2
PanelText StatusBar1, picPanel, 10, "DFM (" & cntDFM & ")", vbRed, vbBlack, 2
I do not know why. May be I missed something or may be I set some property values to the StatusBar1 or picPanel(PictureBox).
SOLUTION
I set pictureBox, property AutoRedraw = True, and StatusBar, Panel, Alignment = sbrLeft. And everything works.
Here's the code referenced in a comment with some enhancements. One enhancement is a parameter to specify text alignment:
Private Sub StatusBarPanelText(sb As StatusBar, pic As PictureBox, index As Long, aText As String, bkColor As Long, fgColor As Long, lAlign As Integer)
Dim r As RECT
SendMessage sb.hWnd, SB_GETRECT, index - 1, r
With pic
Set .Font = sb.Font
.Move 0, 0, (r.Right - r.Left + 2) * Screen.TwipsPerPixelX, (r.Bottom - r.Top) * Screen.TwipsPerPixelY
.BackColor = bkColor
.Cls
.ForeColor = fgColor
.CurrentY = (.Height - .TextHeight(aText)) \ 2
Select Case lAlign
Case 0 ' Left Justified
.CurrentX = 0
Case 1 ' Right Justified
.CurrentX = .Width - .TextWidth(aText) - Screen.TwipsPerPixelX * 2
Case 2 ' Centered
.CurrentX = (.Width - .TextWidth(aText)) \ 2
End Select
pic.Print aText
sb.Panels(index).Text = aText
sb.Panels(index).Picture = .Image
End With
End Sub
Here's the Windows API code:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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 WM_USER = &H400
Private Const SB_GETRECT = (WM_USER + 10)
The code is then used like this:
Picture2.AutoRedraw = True
Picture2.Visible = False
StatusBarPanelText sbConfig, Picture2, 4, & _
Format(Value / 1024, "#,###") & " KB", vbRed, vbWhite, 0
I know I'm late arriving here and this particular issue may no longer matter, but here I am anyway. In trying to write a VB6 program for all versions of Windows from W-95 on, I ran into some color issues related to Microsoft's decision to change named color schemes for subsequent releases of Windows. What I have found is that using a virtual machine with Windows-98 and VB6 installed I can change the backgound color of status bars natively. That property is in the Properties box when using Win-98 but not XP and beyond. I guess the boys in Redmond wanted to enforce their look on our work and so removed that choice. I know this isn't a perfect solution, but it may be something you can live with.
Sorry, but this was my mistake. When I copied my files over from Win-7 to Win-98, VB6 replaced the status bar control with a picture box and named it statusbar1. I'm not sure why because the common controls option is checked and the status bar appears in the toolbox. Looks like the above solutions are the valid ones and mine isn't.
I dont know when this stopped working to be frank but not long switched to using Office 2016. Either way now a VBA event that previously was firing is not now doing so. At least it does not stop at the first position in the sub where I can set a breakpoint.
There is no use of EnableEvents in this project or other open project, and where the event previously fired, the process reformatting the active cell and another, now it does nothing.
Any help most appreciated!
Public Sub Worksheet_Change(ByVal Target As Range)
Const STATUSCOL1 = "L"
Const STATUSCOL2 = "M"
Const STATUSCOL3 = "N"
Const STATUSCOL4 = "O"
Const STATUSCOL5 = "P"
Const STATUSCOL6 = "Q"
Const STATUSCOL7 = "R"
Const STATUSCOL8 = "S"
Const ACTIONCOL1 = "NOT IMPLEMENTED"
Dim Cell As Range
Dim ac As String
Dim rgtCellVal As Integer
Set Cell = Target
ac = Split(Cell.Address, "$")(1) 'For Column Letter
'if any changes at all mark colum J in Green
If Target.Cells.Count = 1 Then
'If Cell <> IIf(vOldData = vbNullString, "(Null)", vOldData) Then
If Cell.Value <> vOldData Then
Select Case ac
Case ACTIONCOL1
Cells(Cell.Row, Range("J" & 1).Column).Interior.ColorIndex = 42 'Aqua
Case Else
Cells(Cell.Row, Range("J" & 1).Column).Interior.ColorIndex = 4 'bright green
End Select
End If
End If
'Status
'---------------------------------------------------------------------------------------------------------
'Installed & Active
'I&A with Bugs
'Compromise
'If Required
'NotActivatedOrUsed
'UserBlogUseOnly
'UpdateHold
'------------------------------------------
'Deactivated
'Depricated
'Removed
'Not Installed
'------------------------------------------
'Failed
'Broken but activated
'Broken and deactivated
'------------------------------------------
'Status in question
'Ignore
'N.A.
'Not Actionable
'In Progress
'Review
'ConsiderNew
If ac = STATUSCOL1 Or ac = STATUSCOL2 Or ac = STATUSCOL3 Or ac = STATUSCOL4 Or ac = STATUSCOL5 Or ac = STATUSCOL6 Or ac = STATUSCOL7 Or ac = STATUSCOL8 Then
Select Case Cell
Case ""
Cell.Interior.ColorIndex = xlColorIndexNone 'none
Case "Installed & Active"
Cell.Interior.ColorIndex = 43 'Lime
Case "I&A with Bugs"
Cell.Interior.ColorIndex = 36 'Light Yellow
Case "Compromise"
Cell.Interior.ColorIndex = 35 'Light Green
Case "If Required"
Cell.Interior.ColorIndex = 15 'Grey - 25%
Case "UserBlogUseOnly"
Cell.Interior.ColorIndex = 15 'Grey - 25%
Case "UpdateHold"
Cell.Interior.ColorIndex = 46 'Orange
'------------------------------------------
Case "NotActivatedOrUsed"
Cell.Interior.ColorIndex = 15 'Grey - 25%
Case "Deactivated"
Cell.Interior.ColorIndex = 15 'Grey - 25%
Case "Depricated"
Cell.Interior.ColorIndex = 37 'pale blue
Case "Removed"
Cell.Interior.ColorIndex = 41 'Light blue
Case "Rejected"
Cell.Interior.ColorIndex = 41 'Light blue
Case "Not Installed"
Cell.Interior.ColorIndex = 37 'pale blue
'------------------------------------------
Case "Failed"
Cell.Interior.ColorIndex = 3 'Red
Case "Broken"
Cell.Interior.ColorIndex = 3 'Red
Case "BrokenButDeactivated"
Cell.Interior.ColorIndex = 37 'pale blue
'------------------------------------------
Case "StatusInQuestion"
Cell.Interior.ColorIndex = 44 'Gold
Case "Ignore"
Cell.Interior.ColorIndex = xlColorIndexNone 'none
Case "N.A."
Cell.Interior.ColorIndex = xlColorIndexNone 'none
Case "Not Actionable"
Cell.Interior.ColorIndex = xlColorIndexNone 'none
Case "In Progress"
Cell.Interior.ColorIndex = 15 'Grey - 25%
Case "Review"
Cell.Interior.ColorIndex = 33 'Sky Blue
Case "ConsiderAlt"
Cell.Interior.ColorIndex = 44 'Gold
Case "------------------------------------------"
Cell.Interior.ColorIndex = xlColorIndexNone 'none
Case Else
Cell.Interior.ColorIndex = 40 'Tan
rgtCellVal = Cell.Offset(0, 1).Interior.ColorIndex
If (Cell = "") And rgtCellVal = 15 Then
Cell.Interior.ColorIndex = 15
End If
End Select
End If
End Sub
I don't have Excel 2016 yet, but in 2007-2013 you can check macro setting under
File --> Options --> Trust Center --> Trust Center Settings... --> Macro Settings
Make sure that Disable all macros with notification or better is selected
If it was an Add-In, I'd say check to the disabled Add-In's, but it doesn't look like one.
Where is the file located? If it's on a network drive does it work when you copy it to a local drive?
If so then, the check the Trusted Documents options under the Trust Center Settings...
Ok I have the answer:
Trust Center. Macro Settings tab. Developer Macro Settings section. Trust Access to the VBA project object model. Tick Yes!
In a RichTextBox, when sending EM_LINEINDEX to get the index of the first character of a line, the index will be affected by soft line breaks. Consider the following text box:
Calling SendMessage hWnd, EM_LINEINDEX, 1, 0 will result in 25, while I would expect it to return 45 (line 1 should be "this is another line" not "and continues here").
Is there a way to get the real first char index of the second line using WinAPI calls?
This is from a working program. I play with right margin.
Sub mnuWordWrap_Click()
'On Error Resume Next
If txtNote.RightMargin = 0 Then
txtNote.RightMargin = &HFFFE&
mnuWordWrap.Checked = False
Else
txtNote.RightMargin = 0
mnuWordWrap.Checked = True
End If
txtNote.SetFocus
txtNote_SelChange
End Sub
In another program I do this, though this is Vista's RTF window (not a control so not the old ANSI version of RTF as in VB6)
If mnuViewWordWrap.Checked = True Then
Ret = SendMessageByVal(gRtfHwnd, EM_SETTARGETDEVICE, GetDC(gRtfHwnd), -1800)
If Ret = 0 Then ReportError "Form Resize", "Set Target Device"
Else
Ret = SendMessageByVal(gRtfHwnd, EM_SETTARGETDEVICE, GetDC(gRtfHwnd), 4000000)
If Ret = 0 Then ReportError "Form Resize", "Set Target Device"
End If
I'm trying to build a program that counts how long it's been since the mouse was last clicked (and performs some action after a given interval of inactivity). Unfortunately, the mouse click event seems to fire constantly. txtLastMouseMove continually updates to show the current time every second, and txtTimeSinceMouseMove never gets above 1, and is usually 0.
Timer1 is set to 100 ms. Setting it to a longer interval slows down the updates, but they still never count properly.
What am I missing here? Why does the left-click mouse event happen continuously?
' Detect mouse clicks.
Private Declare Function GetAsyncKeyState Lib "User32" (ByVal vKey As Long) As Integer
Private Type POINTAPI
x As Long
y As Long
End Type
' Detect mouse clicks.
Private Sub Timer1_Timer()
Dim Ret As Integer
Static datLastMouseMove As Date
Dim datThisMouseMove As Date
if (datLastMouseMove=0) then datLastMouseMove=now()
Ret = GetAsyncKeyState(1) 'vbKeyLButton = 1
If Ret < 1 Then
' The left mouse button was clicked.
datThisMouseMove = Now()
txtLastMouseMove.Text = Format(datThisMouseMove, "hh:mm:ss")
txtTimeSinceMouseMove = Format(datThisMouseMove - datLastMouseMove, "hh:mm:ss")
If ((datThisMouseMove - datLastMouseMove) * 24 * 60 * 60 > CDbl(txtInterval)) Then
MsgBox "Mouse has not moved in " & Format(datThisMouseMove - datLastMouseMove, "hh:mm:ss")
End If
datLastMouseMove = datThisMouseMove
End If
End Sub
Nevermind, I'm stupid.
"If Ret < 1 Then" fires anytime the mouse button ISN'T clicked. It should read "If Ret Then".
Platform: Windows XP
Development Platform: VB6
When trying to set an application title via the Project Properties dialog on the Make tab, it seems to silently cut off the title at a set number of characters. Also tried this via the App.Title property and it seems to suffer from the same problem. I wouldn't care about this but the QA Dept. insists that we need to get the entire title displayed.
Does anyone have a workaround or fix for this?
Edit: To those who responded about a 40 character limit, that's what I sort of suspected--hence my question about a possible workaround :-) .
Actually I posted this question to try to help a fellow developer so when I see her on Monday, I'll point her to all of your excellent suggestions and see if any of them help her get this straightened out. I do know that for some reason some of the dialogs displayed by the app seem to pick up the string from the App.Title setting which is why she had asked me about the limitation on the length of the string.
I just wish I could find something definitive from Microsoft (like some sort of KB note) so she could show it to our QA department so they'd realize this is simply a limitation of VB.
The MsgBox-Function takes a parameter for the title. If you dont want to change every single call to the MsgBox-Function, you could "override" the default behavior:
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: As Mike Spross notes: This only hides the normal MsgBox-Function. If you wanted to access your custom MsgBox from another project, you would have to qualify it.
I just created a Standard EXE project in the IDE and typed text into the application title field under the Project Properties Make tab until I filled the field. From this quick test, it appears that App.Title is limited to 40 characters. Next I tried it in code by putting the following code in the default form (Form1) created for the project:
Private Sub Form_Load()
App.Title = String(41, "X")
MsgBox Len(App.Title)
End Sub
This quick test confirms the 40-characater limit, because the MsgBox displays 40, even though the code attempts to set App.Title to a 41-character string.
If it's really important to get the full string to display in the titlebar of a Form, then only way I can think of to ensure that the entire title is displayed would be to get the width of the titlebar text and use that to increase the width of your Form so that it can accommodate the complete title string. I may come back and post code for this if I can find the right API incantations, but it might look something like this in the Form_Load event:
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
One solution using the Windows API
Disclaimer: IMHO this seems like overkill just to meet the requirement stated in the question, but in the spirit of giving a (hopefully) complete answer to the problem, here goes nothing...
Here is a working version I came up with after looking around in MSDN for awhile, until I finally came upon an article on vbAccelerator that got my wheels turning.
See the vbAccelerator page for the original article (not directly related to the question, but there was enough there for me to formulate an answer)
The basic premise is to first calculate the width of the form's caption text and then to use GetSystemMetrics to get the width of various bits of the window, such as the border and window frame width, the width of the Minimize, Maximize, and Close buttons, and so on (I split these into their own functions for readibility/clarity). We need to account for these parts of the window in order to calculate an accurate new width for the form.
In order to accurately calculate the width ("extent") of the form's caption, we need to get the system caption font, hence the SystemParametersInfo and CreateFontIndirect calls and related goodness.
The end result all this effort is the GetRecommendedWidth function, which calculates all of these values and adds them together, plus a bit of extra padding so that there is some space between the last character of the caption and the control buttons. If this new width is greater than the form's current width, GetRecommendedWidth will return this (larger) width, otherwise, it will return the Form's current width.
I only tested it briefly, but it appears to work fine. Since it uses Windows API functions, however, you may want to exercise caution, especially since it's copying memory around. I didn't add robust error-handling, either.
By the way, if someone has a cleaner, less-involved way of doing this, or if I missed something in my own code, please let me know.
To try it out, paste the following code into a new module
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
Then place the following in your Form_Load event
Private Sub Form_Load()
Me.Caption = String(100, "x") 'replace this with your caption'
Me.Width = GetRecommendedWidth(Me)
End Sub
It appears that VB6 limits the App.Title property to 40 characters. Unfortunately, I can't locate any documentation on MSDN detailing this behavior. (And unfortunately, I don't have documentation loaded onto the machine where my copy of VB6 still resides.)
I ran an experiment with long titles, and that was the observed behavior. If your title is longer than 40 characters, it simply will get truncated.