I'm creating a Windows Console application in VB.NET, and I am unable to set the window position relative to the screen. In short, I want a function to centre the window to the screen.
I have tried to use Console.SetWindowPosition(w, h) method and Console.WindowTop, Console.WindowLeft properties. When returning the values for WindowTop and WindowLeft, they both return 0, and if I attempt to change these values with Console.WindowLeft = n (n > 0), the program throws an OutOfBounds exception, stating that the Window's size must fit within the console's buffer.
I run Console.SetWindowSize(80, 35) and Console.SetBufferSize(80, 35) before attempting to position the window, yet it still throws the exception if n is greater than 0. When returning both WindowTop and WindowLeft values, both of them are 0, even if the console window has been moved before returning those values.
The methods that you are calling don't work with the Console window, but with the character buffer that is showed by the console window. If you want to move the console window I am afraid that you need to use Windows API
Imports System.Runtime.InteropServices
Imports System.Drawing
Module Module1
<DllImport("user32.dll", SetLastError:=True)> _
Private Function SetWindowPos(ByVal hWnd As IntPtr, _
ByVal hWndInsertAfter As IntPtr, _
ByVal X As Integer, _
ByVal Y As Integer, _
ByVal cx As Integer, _
ByVal cy As Integer, _
ByVal uFlags As UInteger) As Boolean
End Function
<DllImport("user32.dll")> _
Private Function GetSystemMetrics(ByVal smIndex As Integer) As Integer
End Function
Sub Main()
Dim handle As IntPtr = System.Diagnostics.Process.GetCurrentProcess().MainWindowHandle
Center(handle, New System.Drawing.Size(500, 400))
Console.ReadLine()
End Sub
Sub Center(ByVal handle As IntPtr, ByVal sz As System.Drawing.Size)
Dim SWP_NOZORDER = &H4
Dim SWP_SHOWWINDOW = &H40
Dim SM_CXSCREEN = 0
Dim SM_CYSCREEN = 1
Dim width = GetSystemMetrics(SM_CXSCREEN)
Dim height = GetSystemMetrics(SM_CYSCREEN)
Dim leftPos = (width - sz.Width) / 2
Dim topPos = (height - sz.Height) / 2
SetWindowPos(handle, 0, leftPos, topPos, sz.Width, sz.Height, SWP_NOZORDER Or SWP_SHOWWINDOW)
End Sub
End Module
This code doesn't take in consideration the presence of a second monitor
Related
I need to prevent the user of my console program from resizing the window, only allowing it to be changed programmatically. If the user changes the width or hight, everything messes up. Also, I want to therefore disable/remove the maximise button. I belive that it was previously possible in VB.Net 2015 [See this answer]. However everything i am seeing is outdated and doesn't work.
I also need to prevent resizing of the window when it is snapped to a corner.
This was the old VB.Net code:
`Module Module1
Private Const MF_BYCOMMAND As Integer = &H0
Public Const SC_CLOSE As Integer = &HF060
Public Const SC_MINIMIZE As Integer = &HF020
Public Const SC_MAXIMIZE As Integer = &HF030
Public Const SC_SIZE As Integer = &HF000
Friend Declare Function DeleteMenu Lib "user32.dll" (ByVal hMenu As IntPtr, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Friend Declare Function GetSystemMenu Lib "user32.dll" (hWnd As IntPtr, bRevert As Boolean) As IntPtr
Sub Main()
Dim handle As IntPtr
handle = Process.GetCurrentProcess.MainWindowHandle ' Get the handle to the console window
Dim sysMenu As IntPtr
sysMenu = GetSystemMenu(handle, False) ' Get the handle to the system menu of the console window
If handle <> IntPtr.Zero Then
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) ' To prevent user from closing console window
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND) 'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND) 'To prevent the use from re-sizing console window
End If
Do Until (Console.ReadKey.Key = ConsoleKey.Escape)
'This loop keeps the console window open until you press escape
Loop
End Sub
End Module
`
I have also considered using console.setbuffersize but wouldn't know how to have the programm continually set the buffer to that size as my program is across a lot of subroutines.
This will prevent the console window from being resized by the user. First, add this into your module:
<System.Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True)>
Friend Function MoveWindow(ByVal hWnd As IntPtr, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Boolean) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("user32.dll")>
Friend Function GetWindowRect(ByVal hWnd As IntPtr, ByRef rect As RECT) As Boolean
End Function
<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>
Public Structure RECT
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
Then in your Main sub add this code, before anything else:
Dim CurrentProcess As Process = Process.GetCurrentProcess()
Dim hWnd As IntPtr = CurrentProcess.MainWindowHandle
Dim RECT As New RECT()
GetWindowRect(hWnd, RECT)
Dim Width As Integer = RECT.Right - RECT.Left
Dim Height As Integer = RECT.Bottom - RECT.Top
Dim X As Integer = RECT.Left
Dim Y As Integer = RECT.Top
Dim WorkerThread As New Threading.Thread(Sub()
While (True)
MoveWindow(CurrentProcess.MainWindowHandle, X, Y, Width, Height, True)
End While
End Sub)
WorkerThread.Start()
This will allow the program to change the width, height or position of the window, by changing the values of the variables. Here is an example:
Width = 200
Height = 150
You would place that somewhere else in the Main sub.
I assume that your using a .Net Framework, not .Net Core.
I'm making a text editor application using vb2010 WinForm. Instead of scrolling with scrollbar, users can scroll directly on the richtextbox with the mouse, similar to adobe acrobat reader. To scroll richtextbox programatically I'm using SendMessage user32 API.
I have two problems:
If the text in richtextbox is big and I scrolled near the end of integer value then scrollbar will scroll back to its initial position.
The scrollbar value that has been set using SendMessage is not the same when we read it later with GetScrollPos. As a result, when I dragged the text using mouse, the richtextbox does not scroll smoothly at the beginning, it's jump.
Here's what I've done:
Public Class Form1
Dim StartMouseDownPos As New Point
Dim StartScrollBarPos As New Point
Const WM_USER = &H400
Const EM_GETSCROLLPOS = WM_USER + 221
Const EM_SETSCROLLPOS = WM_USER + 222
Public Declare Auto Function RtfScroll Lib "user32.dll" Alias "SendMessage" ( _
ByVal hWnd As IntPtr, _
ByVal Msg As Integer, _
ByVal wParam As IntPtr, _
ByRef lParam As System.Drawing.Point) As Integer
Private Sub RichTextBox1_MouseDown(ByVal sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles RichTextBox1.MouseDown
'Capture the initial mouse position
StartMouseDownPos.X = e.X
StartMouseDownPos.Y = e.Y
'Capture the initial scrollbar position
RtfScroll(RichTextBox1.Handle, EM_GETSCROLLPOS, 0, StartScrollBarPos)
End Sub
Private Sub RichTextBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles RichTextBox1.MouseMove
'Verify left button is pressed while the mouse is moving
If e.Button = Windows.Forms.MouseButtons.Left Then
'Prevent the text in RichTextBox1 to be unintentionally selected when user dragged the text while the cursor shape at that moment is a hand.
ActiveControl = Nothing
NewScrollBarPos.X = StartScrollBarPos.X + (StartMouseDownPos.X - e.X)
NewScrollBarPos.Y = StartScrollBarPos.Y + (StartMouseDownPos.Y - e.Y)
RtfScroll(RichTextBox1.Handle, EM_SETSCROLLPOS, 0, NewScrollBarPos)
End If
End Sub
I tried to change the problematic statement above: RtfScroll(RichTextBox1.Handle, EM_SETSCROLLPOS, 0, NewScrollBarPos) with the following:
Public Declare Function GetScrollPos Lib "user32.dll" ( _
ByVal hWnd As IntPtr, _
ByVal nBar As Integer) As Integer
Public Declare Function SetScrollPos Lib "user32.dll" ( _
ByVal hWnd As IntPtr, _
ByVal nBar As Integer, _
ByVal nPos As Integer, _
ByVal bRedraw As Boolean) As Integer
Public Declare Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As IntPtr, _
ByVal wMsg As Integer, _
ByVal wParam As Integer, _
ByVal lParam As Integer) As Boolean
'Scroll the horizontal scrollbar according to the drag of the mouse
SetScrollPos(RichTextBox1.Handle, SBS_HORZ, NewScrollBarPos.X, True)
SetScrollPos(RichTextBox1.Handle, SBS_VERT, NewScrollBarPos.Y, True)
'Scroll the text according to the drag of the mouse
PostMessageA(RichTextBox1.Handle, WM_HSCROLL, SB_THUMBPOSITION + &H10000 * GetScrollPos(RichTextBox1.Handle, SBS_HORZ), Nothing)
PostMessageA(RichTextBox1.Handle, WM_VSCROLL, SB_THUMBPOSITION + &H10000 * GetScrollPos(RichTextBox1.Handle, SBS_VERT), Nothing)
The result is even worse: an overflow exception raised at multiplication of &H10000 * GetScrollPos(RichTextBox1.Handle, SBS_HORZ), Nothing), that happen when I tried to scroll beyond integer value.
So, my question is how to solve these two problems?
I've made a small program to find out what the cause of my problem, and it turns out that the problem is this: RtfScroll function alias "SendMessage" which uses Point as input doesn't get or set the correct value. This doesn't happen to GetScrollPos, SetScrollPos, and PostMessageA.
So, don't use a combination of RtfScroll(RichTextBox1.Handle, EM_SETSCROLLPOS, 0, New Point(countX, countY)) & RtfScroll(RichTextBox1.Handle, EM_GETSCROLLPOS, 0, point).
Just use a combination of GetScrollPos, SetScrollPos, and PostMessageA.
I'm trying to use a PrivateFontCollection for my application, so it can print a document with a specific font. note that i can not "install" the font as the Windows directory is admin protected.
The code I have works, in the sense that provided I close my application, and restart it, when i restart it, it will recognise that the font is there and can be used. But if I click the command button to install the font as a privatefontcollection, and then refresh my PrintDocument, it does not show it using the newly installed font. I have to close the app and open it, and then it does.
Public Shared Function AddFontResource(ByVal lpFileName As String) As Integer
End Function
<DllImport("user32.dll")>
Public Shared Function SendMessage(ByVal hWnd As Integer, ByVal Msg As UInteger, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
End Function
<DllImport("kernel32.dll", SetLastError:=True)>
Shared Function WriteProfileString(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Integer
End Function
<DllImport("user32.dll", SetLastError:=True)>
Public Shared Function SendMessageTimeout(ByVal hWnd As IntPtr,
ByVal msg As Integer,
ByVal wParam As IntPtr,
ByVal lParam As IntPtr,
ByVal flags As SendMessageTimeoutFlags,
ByVal timeout As Integer,
ByRef result As IntPtr) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Public Shared Function SendNotifyMessage(
ByVal hWnd As IntPtr,
ByVal msg As UInteger,
ByVal wParam As UIntPtr,
ByVal lParam As IntPtr
) As Boolean
End Function
<Flags()>
Public Enum SendMessageTimeoutFlags
SMTO_NORMAL = 0
SMTO_BLOCK = 1
SMTO_ABORTIFHUNG = 2
SMTO_NOTIMEOUTIFNOTHUNG = 8
End Enum
Private Sub RibbonButton1_Click(sender As Object, e As EventArgs) Handles RibbonButton1.Click
Try
If IsFontInstalled("Open Sans ExtraBold") = False Then
Dim Fonts_Source As String = Path.Combine(Application.StartupPath, "Resources\OpenSans-ExtraBold.ttf")
Dim Fonts_Install As String = My.Computer.FileSystem.CombinePath(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), "OpenSans-ExtraBold.ttf")
Dim Ret As Integer
Dim Res As Integer
Dim FontPath As String
Const WM_FONTCHANGE As Integer = &H1D
Const HWND_BROADCAST As Integer = &HFFFF
FontPath = Fonts_Install.ToString
Ret = AddFontResource(Fonts_Source.ToString)
Res = SendMessageTimeout(HWND_BROADCAST, WM_FONTCHANGE, IntPtr.Zero, IntPtr.Zero,
SendMessageTimeoutFlags.SMTO_ABORTIFHUNG Or
SendMessageTimeoutFlags.SMTO_NOTIMEOUTIFNOTHUNG,
5000, IntPtr.Zero)
Ret = WriteProfileString("Fonts", Path.GetFileName(FontPath) & " (TrueType)", FontPath.ToString)
End If
Catch ex As Exception
MsgBox("Error: " & ex.Message)
End Try
End Sub
This next subroutine is the one that draws the document. I have a function to check if the font is installed, and if its not then the an alternative font is used.
Dim TitleFont As New Font("Segoe UI Black", Font48Pt, FontStyle.Bold)
If IsFontInstalled("Open Sans ExtraBold") = True Then TitleFont = New Font("Open Sans ExtraBold", Font48Pt)
If Title <> "Everyday" Then
'TITLE TEXT DRAWN
Dim TitleRect As RectangleF = New RectangleF()
TitleRect.Location = New Point(20, 25)
TitleRect.Size = New Size(DrawWidth, CInt(e.Graphics.MeasureString(Title, TitleFont, DrawWidth, CenterAlignment).Height))
e.Graphics.DrawString(Title, TitleFont, ForeColourBrush, TitleRect, CenterAlignment)
End If
the function that checks if the font is installed.
Public Function IsFontInstalled(ByVal FontName As String) As Boolean
Using TestFont As Font = New Font(FontName, 10)
Return CBool(String.Compare(FontName, TestFont.Name, StringComparison.InvariantCultureIgnoreCase) = 0)
End Using
End Function
this function above could be the problem as it returns false. mind you if I close the app and restart it, then this same function will then detect the privatefontcollection and return true, and I can successfully print my document with my font.
I did try adding the install font subroutine, to the very start of my app. then raising a flag if a font was installed and then tried to call the Application.Restart() method, so that while the splash screen was up it could install the font, then immediately restart the app, which of course would then latch onto the installed font, but this method just left the app in a loop of opening and closing.
I made some research, but I can't find something really "interesting". I tried my best to find any kind of documentation or questions that are closest to my case as following:
How to find main window title name of application
how to get the window title of a process
How to get the Title Bar Text by its Process Id
getting the name of a process
How do I get list of Process Names running
Check to see if process is running
How To Get Process Owner ID
How to get the title/name of the last active window?
Get Process ID from Window Title
and also
Process.GetProcessesByName Method
The code I am using to open the process window
Private Async Function ParentMethod() As Task
Dim filePath As String = Await Task.Run(
Function()
Return Directory.EnumerateFiles(My.Settings.Cartellasalvataggio, titolo & ".mp3",
SearchOption.AllDirectories).FirstOrDefault()
End Function)
If Not String.IsNullOrEmpty(filePath) Then
LinkLabel1.Text = "File exist already"
LinkLabel1.Visible = True
PictureBox7.Visible = True
Else
MsgBox("it doesn't exist")
End If
End Function
and the helper class
Imports System.IO
Imports System.Runtime.InteropServices
Public Class NativeMethods
<DllImport("shell32.dll", SetLastError:=True)>
Private Shared Function SHOpenFolderAndSelectItems(
pidlFolder As IntPtr, cidl As UInteger,
<[In], MarshalAs(UnmanagedType.LPArray)> apidl As IntPtr(),
dwFlags As UInteger) As Integer
End Function
<DllImport("shell32.dll", SetLastError:=True)>
Private Shared Sub SHParseDisplayName(
<MarshalAs(UnmanagedType.LPWStr)> name As String,
bindingContext As IntPtr, <Out> ByRef pidl As IntPtr,
sfgaoIn As UInteger, <Out> ByRef psfgaoOut As UInteger)
End Sub
Public Shared Sub OpenFolderAndSelectFile(filePath As String)
Dim dirPath As String = Path.GetDirectoryName(filePath)
Dim fileName As String = Path.GetFileName(filePath)
OpenFolderAndSelectFile(dirPath, fileName)
End Sub
Public Shared Sub OpenFolderAndSelectFile(dirPath As String, fileName As String)
Dim nativeFolder As IntPtr
Dim psfgaoOut As UInteger
SHParseDisplayName(dirPath, IntPtr.Zero, nativeFolder, 0, psfgaoOut)
If nativeFolder = IntPtr.Zero Then
' Log error, can't find folder
Return
End If
Dim nativeFile As IntPtr
SHParseDisplayName(Path.Combine(dirPath, fileName),
IntPtr.Zero, nativeFile, 0, psfgaoOut)
Dim fileArray As IntPtr()
If nativeFile = IntPtr.Zero Then
' Open the folder without the file selected if we can't find the file
fileArray = New IntPtr(-1) {}
Else
fileArray = New IntPtr() {nativeFile}
End If
SHOpenFolderAndSelectItems(nativeFolder, CUInt(fileArray.Length), fileArray, 0)
Marshal.FreeCoTaskMem(nativeFolder)
If nativeFile <> IntPtr.Zero Then
Marshal.FreeCoTaskMem(nativeFile)
End If
End Sub
End Class
then calling it with
NativeMethods.OpenFolderAndSelectFile(filepath,filename & "extension"))
Since I am opening the process this way and NOT with Process class, almost all of them are not suitable to be considered for my case as many of them refer to notepad, while I think the explorer window title and ID changes for every file ( obviously), while "notepad" process, stay "notepad".
I also tried BringToFront, but this latter moves a control in front of other controls, but in this case Explorer is not a control, right?
The least I want to do is to
Get a list of active windows & their process names
as It will waste memory and time usage for no reason as I will need to "filter" process to find my process.
Hope we can find a solution to this, Thanks in advance.
Mattia
This is the solution to it using FindWindowW e SetWindowPos Api.
It is showing Explorer folder on top of top most form.
<DllImport("user32.dll", EntryPoint:="FindWindowW")>
Public Shared Function FindWindowW(<MarshalAs(UnmanagedType.LPTStr)> ByVal lpClassName As String, <MarshalAs(UnmanagedType.LPTStr)> ByVal lpWindowName As String) As IntPtr
End Function
<DllImport("user32.dll")>
Shared Function SetWindowPos(ByVal hWnd As IntPtr, ByVal hWndInsertAfter As IntPtr, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal uFlags As UInteger) As Boolean
End Function
Shared ReadOnly HWND_TOPMOST As IntPtr = New IntPtr(-1)
Const SWP_NOSIZE As UInt32 = &H1
Const SWP_NOMOVE As UInt32 = &H2
Const SWP_SHOWWINDOW As UInt32 = &H40
Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
Dim inptr = FindWindowW("CabinetWClass", Nothing)
SetWindowPos(inptr, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW)
End Sub
Does anyone know how to change the kerning (space between characters) in vb.net? For example, i would like to change "STRING" to "S T R I N G". If possible i would like to be able to create my own font where i can specify the kerning as i wish! Thanks in advance!
The only way I found is to P/Invoke. Assumming a generic form with a generic button this code will work.
Imports System.Runtime.InteropServices
Public Class Form1
Declare Function SetTextCharacterExtra Lib "gdi32" Alias "SetTextCharacterExtra" (ByVal hDC As Integer, ByVal nCharExtra As Integer) As Integer
<DllImport("gdi32")> _
Private Shared Function TextOut(ByVal hdc As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal textstring As String, ByVal charCount As Integer) As Boolean
End Function
<DllImport("gdi32")> _
Private Shared Function SelectObject(ByVal hdc As IntPtr, ByVal hgdiobj As IntPtr) As IntPtr
End Function
<DllImport("gdi32")> _
Private Shared Function DeleteObject(ByVal objectHandle As IntPtr) As Boolean
End Function
<DllImport("gdi32")> _
Private Shared Function SetBkColor(ByVal hdc As IntPtr, ByVal crColor As Integer) As UInt32
End Function
<DllImport("gdi32")> _
Private Shared Function SetTextColor(ByVal hdc As IntPtr, ByVal crColor As Integer) As UInt32
End Function
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Using G = Graphics.FromHwnd(Me.Handle)
Using myFont As New System.Drawing.Font("Arial", 20, FontStyle.Regular, GraphicsUnit.Pixel)
'Regular Way
Dim LeftEdge = 20
G.DrawString("Hello", myFont, Brushes.Red, LeftEdge, 40)
'If you want kerning
Dim Kerning As Integer = 6 'I think this is twips
Dim Hdc As IntPtr
Dim FontPtr As IntPtr
Try
'Grab the Graphic object's handle
Hdc = G.GetHdc()
'Set the current GDI font
FontPtr = SelectObject(Hdc, myFont.ToHfont())
'Set the drawing surface background color
SetBkColor(Hdc, ColorTranslator.ToWin32(Me.BackColor))
'Set the text color
SetTextColor(Hdc, ColorTranslator.ToWin32(Color.Red))
'Set the kerning
SetTextCharacterExtra(Hdc, Kerning)
Dim Text = "Hello"
'Draw the text at (20,60), Kerning will be applied so reset the left edge to half of kerning
TextOut(Hdc, LeftEdge + (Kerning \ 2), 60, Text, Text.Length)
Catch ex As Exception
Finally
'Release the font
DeleteObject(FontPtr)
'Release the handle on the graphics object
G.ReleaseHdc()
End Try
End Using
End Using
End Sub
End Class
You can use CSS.
I usually set the letter-spacing style attribute in my aspx page.