I was just wondering if there was a possible way to add a custom button into the title bar using VB.NET. I've seen many such questions on Stack Overflow but failed to get a sure-shot and a working answer.
Can anyone help me around with this issue? I've checked on Google and other website too but it fails to render. I want the code to work on Windows XP, Windows Vista and Windows 7.
I would be grateful if you will be able to give a working code and the button must even be able to accept click events and post it to the form it is on for some action.
Thanks in advance
If you mean winforms, I can think of two ways to do this:
Hide the titlebar and replace it with your own, which I don't recommend.
Build the button as a very small form that you keep docked in the correct position every time your window moves.
Here is an example with some working code:
http://www.dreamincode.net/forums/topic/69215-2008-custom-title-bar/
Basically, you need to create a form with no border, then roll your own "Titlebar" which will basically be an area at the top that you can customize however you want. This is a difficult solution to fully implement properly, but it is probably the way that will best accomplish this.
As Matthew Scharley writes in his answer here:
The following will work in XP, I have no Vista machine handy to test
it, but I think you're issues are steming from an incorrect hWnd
somehow. Anyway, on with the poorly commented code.
I think this doesn't show up graphically in Vista and 7. The translated version of Matthew's code is as follows:
' The state of our little button
Private _buttState As ButtonState = ButtonState.Normal
Private _buttPosition As New Rectangle()
<DllImport("user32.dll")> _
Private Shared Function GetWindowDC(hWnd As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")> _
Private Shared Function GetWindowRect(hWnd As IntPtr, ByRef lpRect As Rectangle) As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function ReleaseDC(hWnd As IntPtr, hDC As IntPtr) As Integer
End Function
Protected Overrides Sub WndProc(ByRef m As Message)
Dim x As Integer, y As Integer
Dim windowRect As New Rectangle()
GetWindowRect(m.HWnd, windowRect)
Select Case m.Msg
' WM_NCPAINT
' WM_PAINT
Case &H85, &Ha
MyBase.WndProc(m)
DrawButton(m.HWnd)
m.Result = IntPtr.Zero
Exit Select
' WM_ACTIVATE
Case &H86
MyBase.WndProc(m)
DrawButton(m.HWnd)
Exit Select
' WM_NCMOUSEMOVE
Case &Ha0
' Extract the least significant 16 bits
x = (CInt(m.LParam) << 16) >> 16
' Extract the most significant 16 bits
y = CInt(m.LParam) >> 16
x -= windowRect.Left
y -= windowRect.Top
MyBase.WndProc(m)
If Not _buttPosition.Contains(New Point(x, y)) AndAlso _buttState = ButtonState.Pushed Then
_buttState = ButtonState.Normal
DrawButton(m.HWnd)
End If
Exit Select
' WM_NCLBUTTONDOWN
Case &Ha1
' Extract the least significant 16 bits
x = (CInt(m.LParam) << 16) >> 16
' Extract the most significant 16 bits
y = CInt(m.LParam) >> 16
x -= windowRect.Left
y -= windowRect.Top
If _buttPosition.Contains(New Point(x, y)) Then
_buttState = ButtonState.Pushed
DrawButton(m.HWnd)
Else
MyBase.WndProc(m)
End If
Exit Select
' WM_NCLBUTTONUP
Case &Ha2
' Extract the least significant 16 bits
x = (CInt(m.LParam) << 16) >> 16
' Extract the most significant 16 bits
y = CInt(m.LParam) >> 16
x -= windowRect.Left
y -= windowRect.Top
If _buttPosition.Contains(New Point(x, y)) AndAlso _buttState = ButtonState.Pushed Then
_buttState = ButtonState.Normal
' [[TODO]]: Fire a click event for your button
' however you want to do it.
DrawButton(m.HWnd)
Else
MyBase.WndProc(m)
End If
Exit Select
' WM_NCHITTEST
Case &H84
' Extract the least significant 16 bits
x = (CInt(m.LParam) << 16) >> 16
' Extract the most significant 16 bits
y = CInt(m.LParam) >> 16
x -= windowRect.Left
y -= windowRect.Top
If _buttPosition.Contains(New Point(x, y)) Then
m.Result = DirectCast(18, IntPtr)
Else
' HTBORDER
MyBase.WndProc(m)
End If
Exit Select
Case Else
MyBase.WndProc(m)
Exit Select
End Select
End Sub
Private Sub DrawButton(hwnd As IntPtr)
Dim hDC As IntPtr = GetWindowDC(hwnd)
Dim x As Integer, y As Integer
Using g As Graphics = Graphics.FromHdc(hDC)
' Work out size and positioning
Dim CaptionHeight As Integer = Bounds.Height - ClientRectangle.Height
Dim ButtonSize As Size = SystemInformation.CaptionButtonSize
x = Bounds.Width - 4 * ButtonSize.Width
y = (CaptionHeight - ButtonSize.Height) \ 2
_buttPosition.Location = New Point(x, y)
' Work out color
Dim color As Brush
If _buttState = ButtonState.Pushed Then
color = Brushes.LightGreen
Else
color = Brushes.Red
End If
' Draw our "button"
g.FillRectangle(color, x, y, ButtonSize.Width, ButtonSize.Height)
End Using
ReleaseDC(hwnd, hDC)
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs)
_buttPosition.Size = SystemInformation.CaptionButtonSize
End Sub
Related
I have a app which is loading between 32^2 to 32768 8x8 px pictureboxes. All pictureboxes are on screen so I need to load them all and can't just load some.
As it stands, my program won't even run. Is there a better way to load that many pictureboxes?
I would like to share with you my project, but I don't know how to.............
Thanks though!
You'd likely run into a MemoryOverflowException with this design. From the sound of it, you're probably trying to render a map of some sort if that's the case then this answer is for you (otherwise just ignore it).
At a high level you should only create the number of PictureBox controls that can fit on the screen at any given time. You can calculate this with the following function:
Private Function CalculateSizeToFitParent(ByVal parent As Control, ByVal childSize As Size) As Size
Return New Size(parent.Width \ childSize.Width, parent.Height \ childSize.Height)
End Sub
You would implement it as such to create a PictureBox to fill up the visible area of the current Form:
Dim pictureBoxSize As Size = New Size(8, 8)
Dim visibleArea(pictureBoxSize.Width - 1, pictureBoxSize.Height - 1) As PictureBox
Dim numberOfPictureBoxes As Size = CalculateSizeToFitParent(Me, pictureBoxSize)
For x As Integer = 0 To numberOfPictureBoxes.Width - 1
For y As Integer = 0 To numberOfPictureBoxes.Height - 1
visibleArea(x, y) = New PictureBox() With {
.Location = New Point(x * pictureBoxSize.Width, y * pictureBoxSize.Height)
.Size = pictureBoxSize
}
Me.Controls.Add(visibleArea(x, y))
Next
Next
The next part is two-fold:
You need to keep track of where the top-left corner of the current visible are is
You will need to reload the images in the respective visual area of the map.
This assumes that you have a 2D array that stores your images. And please note that you don't recreate the PictureBox controls but rather you just reload the image of the existing control:
Private _currentLocation As Point = New Point(0, 0) ' If you're starting somewhere else change it here
Public Property CurrentLocation As Point
Get
Return _currentLocation
End Get
Set(ByVal value As Point)
If (value <> _currentLocation) Then
_currentLocation = value
Me.OnCurrentLocationChanged()
End If
End Set
End Property
Protected Overridable Sub OnCurrentLocationChanged()
RaiseEvent CurrentLocationChanged(Me, EventArgs.Empty)
End Sub
Public Event CurrentLocationChanged(ByVal sender As Object, ByVal e As EventArgs)
Private Sub MyForm_CurrentLocationChanged(ByVal sender As Object, ByVal e As EventArgs) Handles Me.CurrentLocationChanged
If (visibleArea Is Nothing) Then
Throw New Exception("The visible area has not been generated yet.")
End If
If (_currentLocation Is Nothing) Then
Throw New Exception("The CurrentLocation cannot be null.")
End If
Dim widthUpperBounds As Integer = My2DArrayOfImageLocations.GetUpperBounds(0) - 1
Dim heightUpperBounds As Integer = My2DArrayOfImageLocations.GetUpperBounds(1) - 1
For x As Integer = 0 To visibleArea.GetUpperBounds(0) - 1
For y As Integer = 0 To visibleArea.GetUpperBounds(1) - 1
If (x + _currentLocation.Width > widthUpperBounds OrElse y + _currentLocation.Height) Then
'This "block" is outside the view area (display a blank tile?)
Else
visibleArea(x, y).Load(My2DArrayOfImageLocations(x + _currentLocation.Width, y + _currentLocation.Height))
End If
Next
Next
End Sub
Now whenever you reset the CurrentLocation property (however you'd do that, e.g. arrow keys, asdw, etc.) it will redraw the visible area of the map.
Update
Please note that I "free-typed" this example and you may need to tweak it a bit. After some more thought, you'll probably also need to call the Refresh method of the PictureBox when you load in the image (I didn't test).
Today i continue my work, Building a menu with a vb.net console application. I found more samples to build with Windows forms. Still i try to get Basic Knowledge with the console surface.I was not able to put the following marquee text in a scroll menu, the second Code past the marquee text.
Module Module1
Dim aTimer As New System.Timers.Timer
Const marqueeText As String = "The quick brown fox... "
Dim sb As New System.Text.StringBuilder
Dim direction As Boolean = False
Sub Main()
aTimer.AutoReset = True
aTimer.Interval = 100 '1/10 second
AddHandler aTimer.Elapsed, AddressOf tick
aTimer.Start()
Console.ReadKey()
End Sub
Private Sub tick(ByVal sender As Object, ByVal e As System.Timers.ElapsedEventArgs)
Console.Clear()
If sb.Length = 0 Then sb.Append(marqueeText)
If direction Then
sb.Insert(0, sb(sb.Length - 1))
sb.Remove(sb.Length - 1, 1)
Else
sb.Append(sb(0))
sb.Remove(0, 1)
End If
Console.CursorLeft = 10 'no visible change
Console.CursorTop = 10 'visible change
Console.Write("{0}{1}", vbCr, sb.ToString)
End Sub
End Module
The marquee text Output from above is not easy to manage with the console.cursorleft command. I have no clue how to move it to the right or to put the marquee Output in the following Code, a scroll menu, on the third line.
Module Module1
Dim MenuList As New List(Of String)
Sub PrintMenu(highlight As Integer, left As Integer, top As Integer)
Dim Nickvektor() As Integer = {1, 2, 3, 4, 5}
For I = 0 To MenuList.Count - 1
Console.CursorLeft = left
Console.CursorTop = top + I
If I = highlight Then
Console.Write("{0}", "[" & Nickvektor(I) & "]")
Else
Console.Write(MenuList(I))
End If
Next
End Sub
Sub Main()
Console.CursorVisible = False
Dim x As Integer = 0
Dim Nickvektor() As String = {" "}
For counter As Integer = 0 To 0
Do
For Each s In Nickvektor
MenuList.Add(s)
Next
x += 1
Loop Until x = 5
Next
Console.SetCursorPosition(10, 16)
Console.Write("[ ]")
Dim CurrentItem As Integer = 0
Dim CurrentKey As ConsoleKey
While CurrentKey <> ConsoleKey.Enter
PrintMenu(CurrentItem, 10, 10)
CurrentKey = Console.ReadKey(True).Key
Select Case CurrentKey
Case ConsoleKey.DownArrow
CurrentItem += 1
Case ConsoleKey.UpArrow
CurrentItem -= 1
End Select
CurrentItem = (CurrentItem + MenuList.Count) Mod MenuList.Count
End While
End Sub
End Module
The menu Frame for the above Code can be used with the up and down arrows on the Keyboard.
Maybe it is to much work but i have no clue how to continue.
The first Solution for the marquee Output is an easy change of the original code. The wrap, vbCr, was the main Problem to move the text output toward the right edge oft he screen. The following code can be used to change the cursorTop Positon and also the cursorLeft Position of the Text.
Console.CursorVisible = False
Console.CursorLeft = 30
Console.CursorTop = 10
Console.Write("{0}", sb.ToString)
The heavy part are the Menu code Lines. To answer my own question some additional help was necessary.
I posted my question on the MS developer Network written in german language. With the following link it can be viewed.
For the case the link should be broken or other cases i post the code on this site.
Module Module1
Dim MenuList As New List(Of String)
Dim aTimer As New System.Timers.Timer
Const marqueeText As String = "The quick brown fox... "
Dim sb As New System.Text.StringBuilder
Dim direction As Boolean = False
Sub PrintMenu(highlight As Integer, left As Integer, top As Integer)
Dim Nickvektor() As Integer = {1, 2, 3, 4, 5}
For I = 0 To MenuList.Count - 1
Console.CursorLeft = left
Console.CursorTop = top + I
If I = highlight Then
Console.Write("{0}", "[" & Nickvektor(I) & "]")
Else
Console.Write(MenuList(I))
End If
Next
End Sub
Sub Main()
Console.CursorVisible = False
aTimer.AutoReset = True
aTimer.Interval = 100 '1/10 second
AddHandler aTimer.Elapsed, AddressOf tick
Dim x As Integer = 0
Dim Nickvektor() As String = {" "}
For counter As Integer = 0 To 0
Do
For Each s In Nickvektor
MenuList.Add(s)
Next
x += 1
Loop Until x = 5
Next
Console.SetCursorPosition(10, 16)
Console.Write("[ ]")
Dim CurrentItem As Integer = 0
Dim CurrentKey As ConsoleKey
While CurrentKey <> ConsoleKey.Enter
If CurrentItem = 2 Then ' Zero can be used to show the marquee output prompt
aTimer.Start() ' With a change to two or four the timer can be stoped:
'Else
'If aTimer.Enabled Then
' aTimer.Stop()
'End If
End If
PrintMenu(CurrentItem, 10, 10)
CurrentKey = Console.ReadKey(True).Key
Select Case CurrentKey
Case ConsoleKey.DownArrow
CurrentItem += 1
Case ConsoleKey.UpArrow
CurrentItem -= 1
End Select
CurrentItem = (CurrentItem + MenuList.Count) Mod MenuList.Count
End While
End Sub
Private Sub tick(ByVal sender As Object, ByVal e As System.Timers.ElapsedEventArgs)
If sb.Length = 0 Then sb.Append(marqueeText)
If direction Then
sb.Insert(0, sb(sb.Length - 1))
sb.Remove(sb.Length - 1, 1)
Else
sb.Append(sb(0))
sb.Remove(0, 1)
End If
Console.CursorVisible = False
Console.CursorLeft = 20
Console.CursorTop = 12 ' For the first Element CursorTop=10, fort he third 12
Console.Write("{0}", sb.ToString)
End Sub
End Module
To learn an other language like English i have to search a lot. Visual Basic Code is mostly written with English key words for the commands. I think it is easier to look up the maintainable changes for your self. To search is not every day funny.
this is my first time posting so please accept my apologies if im not doing this right and please feel free to correct me for any formatting or posting guidelines. I am doing this in VB.Net with .NET Framework 4.5.2.
I have a large collection called gBoard in a class.
Private gBoard As Collection
It contains roughly 2000 instances of a class.
What i am trying to achieve is for each item in the class, i want to look at each other item in the class and then update the first item based on variables in the second.
Currently i have the following code:
In the main class:
Private gBoard As New Collection ' This is populated elsewhere in the code
Private Sub CheckSurroundings()
For i As Integer = 1 To (xBoxes)
For j As Integer = 1 To (yBoxes)
For x = 1 As Integer To (xBoxes)
For y = 1 As Integer To (yBoxes)
Tile(New Point(i, j)).CheckDistance(Tile(New Point(x, y)))
Next y
Next x
Next j
Next i
End Sub
Private Function Tile(ByVal aPoint As Point) As clsTile
Return gBoard.Item("r" & aPoint.Y & "c" & aPoint.X)
End Function
In clsTile i have the following (as well as other items):
Private Function SurroundingTerrain(ByVal aTer As String) As clsTerrain
Return mySurroundings.Item(aTer) ' a small collection (6 items of clsTerrain type)
End Function
Public Sub CheckDistance(ByRef aTile As clsTile)
SurroundingTerrain(aTile.Terrain).CheckDistance(CalcDistance(Location, aTile.Location))
End Sub
Private Function CalcDistance(ByVal myPoint As Point, ByVal aPoint As Point) As Double
Dim myReturn As Double = 0
Dim xDiff As Integer = 0
Dim yDiff As Integer = 0
Dim tDiff As Integer = 0
xDiff = Math.Abs(myPoint.X - aPoint.X)
yDiff = Math.Abs(myPoint.Y - aPoint.Y)
tDiff = xDiff + yDiff
myReturn = (MinInt(xDiff, yDiff) * 1.4) + (tDiff - MinInt(xDiff, yDiff))
Return myReturn
End Function
Private Function MinInt(ByVal a As Integer, ByVal b As Integer) As Integer
Dim myReturn As Integer = a
If b < myReturn Then
myReturn = b
End If
Return myReturn
End Function
in clsTerrain i have the following sub that is called:
Public Sub CheckDistance(ByVal aDist As Double)
If aDist < Distance Then
Distance = aDist
End If
End Sub
This runs and works file but as you can guess it runs so slow... I have been trying to work out how to make this run faster and i looked into threading/tasks but it doesnt seem to work. There are no errors but the objects don't appear to update correctly (or at all). The code i tried was:
In the main class:
Private Sub CheckSurroundings()
Dim tasks As New List(Of Task)
Dim pTile As clsTile
For Each pTile In gBoard
tasks.Add(Task.Run(Sub() TileToCheck(pTile)))
Next
Task.WaitAll(tasks.ToArray())
End Sub
Private Sub TileToCheck(ByRef aTile As clsTile)
For x As Integer = 1 To (xBoxes)
For y As Integer = 1 To (yBoxes)
aTile.CheckDistance(Tile(New Point(x, y)))
Next y
Next x
End Sub
Does anyone have any suggestions or ideas for how to get this to work?
Sorry for any headaches or facepalms caused...
I am developing an application with a custom title bar. The form design requires it to be resizable. Keeping in mind that it has a custom title bar, using the normal route to remove the title bar in the custom form is not working. It appears that the Windows 10 API is forcing a small white "chunk" to remain at the top of the screen above the title bar.
My question to you is this: Has anyone encountered this issue, and do you know a fix or a work-around so that we can get the forms to look correct in Windows 10?
Here is my current code:
Dim testform As New Form
testform.Width = 350
testform.Height = 100
testform.FormBorderStyle = FormBorderStyle.Sizable
testform.ControlBox = False
testform.Text = String.Empty
testform.Show()
We tested for the API issue due to a suggestion by another support forum that has since seemed to be exhausted as far as help. I compiled our existing code and ran the executable on a Windows 7 machine. On the Windows 7 machine the form opens properly with 0 space between the top of the ClientRectangle and the Form.
Here's an example of how to do (something) like what you want. My VB is really rusty, so make sure you test and debug this carefully.
First Add a Form to your project. For this example I've left the name Form1 but you probably want to change that to something meaningful. On that form I set the BorderStyle property to None. (That's the only change I made)
The code for Form1 is as follows:
Public Class Form1
Public Const WM_NCHITTEST As Integer = &H84
Public Const BorderSize As Integer = 10
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = WM_NCHITTEST Then
Dim x As Integer = m.LParam.ToInt32 And &HFFFF
Dim y As Integer = (m.LParam.ToInt32 >> 16) And &HFFFF
Dim p As Point = New Point(x, y)
If Me.Bounds.Contains(p) Then
Dim top As Boolean = Math.Abs(Me.Bounds.Y - y) < BorderSize
Dim bottom As Boolean = Math.Abs(Me.Bounds.Bottom - y) < BorderSize
Dim left As Boolean = Math.Abs(Me.Bounds.X - x) < BorderSize
Dim right As Boolean = Math.Abs(Me.Bounds.Right - x) < BorderSize
If top And left Then
m.Result = NCHITTEST.HTTOPLEFT
ElseIf top And right Then
m.Result = NCHITTEST.HTTOPRIGHT
ElseIf bottom And left Then
m.Result = NCHITTEST.HTBOTTOMLEFT
ElseIf bottom And right Then
m.Result = NCHITTEST.HTBOTTOMRIGHT
ElseIf top Then
m.Result = NCHITTEST.HTTOP
ElseIf bottom Then
m.Result = NCHITTEST.HTBOTTOM
ElseIf left Then
m.Result = NCHITTEST.HTLEFT
ElseIf right Then
m.Result = NCHITTEST.HTRIGHT
Else
m.Result = NCHITTEST.HTCAPTION
End If
Exit Sub
End If
End If
MyBase.WndProc(m)
End Sub
End Class
Additionally, somewhere in that makes sense in your project include the following enum. (I've stripped out the values I'm not using, but they are all available in the documentation) For the purposes of this demonstration I placed it directly beneath the End Class for Form1.
Public Enum NCHITTEST
HTBOTTOM = 15
HTBOTTOMLEFT = 16
HTBOTTOMRIGHT = 17
HTCAPTION = 2
HTLEFT = 10
HTRIGHT = 11
HTTOP = 12
HTTOPLEFT = 13
HTTOPRIGHT = 14
End Enum
The way it's implemented, there is an invisible 10px border where the mouse will change to the resize cursor. This is controlled by the BorderSize constant. You can move the form by clicking and dragging anywhere in the background. (That's what HTCAPTION does.)
TheB had the best answer, and I had to amend it slightly to work with my coding. Thank you for all of the help, sir!
So, when altering this code to work with a dynamically-created control a few changes needed to be made. Here is how I got it to work:
Create a new class specifically named: SubclassHWND.vb
(As gathered from Microsoft)
Public Class SubclassHWND
Inherits NativeWindow
Public Const WM_NCHITTEST = &H84
Public Const BorderSize As Integer = 10
Public frm As Form = Nothing
Public Sub setFrm(ByVal sender As Form)
frm = sender
End Sub
Protected Overloads Overrides Sub WndProc(ByRef m As Message)
if m.Msg = WM_NCHITTEST Then
Dim x As Integer = m.LParam.ToInt32 And &HFFFF
Dim y As Integer = (m.LParam.ToInt32 >> 16) And &HFFFF
Dim p As Point = New Point(x, y)
If frm.Bounds.Contains(p) Then
Dim top As Boolean = Math.Abs(frm.Bounds.Y - y) < BorderSize
Dim bottom As Boolean = Math.Abs(frm.Bounds.Bottom - y) < BorderSize
Dim left As Boolean = Math.Abs(frm.Bounds.X - x) < BorderSize
Dim right As Boolean = Math.Abs(frm.Bounds.Right - x) < BorderSize
If top And left Then
m.Result = NCHITTEST.HTTOPLEFT
ElseIf top And right Then
m.Result = NCHITTEST.HTTOPRIGHT
ElseIf bottom And left Then
m.Result = NCHITTEST.HTBOTTOMLEFT
ElseIf bottom And right Then
m.Result = NCHITTEST.HTBOTTOMRIGHT
ElseIf top Then
m.Result = NCHITTEST.HTTOP
ElseIf bottom Then
m.Result = NCHITTEST.HTBOTTOM
ElseIf left Then
m.Result = NCHITTEST.HTLEFT
ElseIf right Then
m.Result = NCHITTEST.HTRIGHT
Else
m.Result = NCHITTEST.HTCAPTION
End If
Exit Sub
End If
End If
Debug.WriteLine(m.ToString())
MyBase.WndProc(m)
End Sub
End Class
Public Enum NCHITTEST
HTBOTTOM = 15
HTBOTTOMLEFT = 16
HTBOTTOMRIGHT = 17
HTCAPTION = 2
HTLEFT = 10
HTRIGHT = 11
HTTOP = 12
HTTOPLEFT = 13
HTTOPRIGHT = 14
End Enum
This is basically the same exact code that #TheB supplied me with for the fix earlier with a couple of changes. We went ahead and created a new Public frm variable. We set this in the next set of code so we can reference the dynamic form that the WndProc evaluation will Override.
In the form generation code we added these lines to create the re-sizable window that has no title bar API in Windows 10:
newForm.FormBorderStyle = FormBorderStyle.FixedToolWindow
newForm.ControlBox = False
newForm.Text = String.Empty
Dim s As SubclassHWND = New SubclassHWND()
s.setFrm(newForm)
s.AssignHandle(newForm.Handle)
Now every dynamically-created form in the project uses the Overrides that we specified in SubclassHWND.vb! Thanks go out to everyone and all of their valuable input.
I currently use this code and it works flawlessly
My question is how do I modify the WndProc to stop at my preferred limit of Width and Height. Okay I solved that by setting the MinimumSize, but a new problem arises when the aspect ratio of the form reaches the limit of the windows desktop maximum right size it starts to mess up the aspect ratio starts streching instead of locking up.
Need to somehow fix the WndProc with SystemInformation.VirtualScreen.Width to stop increasing both sizes when the limit Width is hit.
I added this which works but it's still only for my resolution how do I make it universal to support all resolutions.
If r.right - r.left > SystemInformation.VirtualScreen.Width Then
r.bottom = 900 'quick fix (not good) how to calculate this value?
End If
source of code:
http://www.vb-helper.com/howto_net_form_fixed_aspect.html
Imports System.Runtime.InteropServices
...
Public Structure Rect
Public left As Integer
Public top As Integer
Public right As Integer
Public bottom As Integer
End Structure
Protected Overrides Sub WndProc(ByRef m As _
System.Windows.Forms.Message)
Static first_time As Boolean = True
Static aspect_ratio As Double
Const WM_SIZING As Long = &H214
Const WMSZ_LEFT As Integer = 1
Const WMSZ_RIGHT As Integer = 2
Const WMSZ_TOP As Integer = 3
Const WMSZ_TOPLEFT As Integer = 4
Const WMSZ_TOPRIGHT As Integer = 5
Const WMSZ_BOTTOM As Integer = 6
Const WMSZ_BOTTOMLEFT As Integer = 7
Const WMSZ_BOTTOMRIGHT As Integer = 8
If m.Msg = WM_SIZING And m.HWnd.Equals(Me.Handle) Then
' Turn the message's lParam into a Rect.
Dim r As Rect
r = DirectCast( _
Marshal.PtrToStructure(m.LParam, _
GetType(Rect)), _
Rect)
' The first time, save the form's aspect ratio.
If first_time Then
first_time = False
aspect_ratio = (r.bottom - r.top) / (r.right - _
r.left)
End If
' Get the current dimensions.
Dim wid As Double = r.right - r.left
Dim hgt As Double = r.bottom - r.top
' Enlarge if necessary to preserve the aspect ratio.
If hgt / wid > aspect_ratio Then
' It's too tall and thin. Make it wider.
wid = hgt / aspect_ratio
Else
' It's too short and wide. Make it taller.
hgt = wid * aspect_ratio
End If
' See if the user is dragging the top edge.
If m.WParam.ToInt32 = WMSZ_TOP Or _
m.WParam.ToInt32 = WMSZ_TOPLEFT Or _
m.WParam.ToInt32 = WMSZ_TOPRIGHT _
Then
' Reset the top.
r.top = r.bottom - CInt(hgt)
Else
' Reset the height to the saved value.
r.bottom = r.top + CInt(hgt)
End If
' See if the user is dragging the left edge.
If m.WParam.ToInt32 = WMSZ_LEFT Or _
m.WParam.ToInt32 = WMSZ_TOPLEFT Or _
m.WParam.ToInt32 = WMSZ_BOTTOMLEFT _
Then
' Reset the left.
r.left = r.right - CInt(wid)
Else
' Reset the width to the saved value.
r.right = r.left + CInt(wid)
End If
' Update the Message object's LParam field.
Marshal.StructureToPtr(r, m.LParam, True)
End If
MyBase.WndProc(m)
End Sub
You can find out user's desktop resolution with Screen.PrimaryScreen.Bounds.Bottom and Screen.PrimaryScreen.Bounds.Right