CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums
Results 1 to 3 of 3
  1. #1
    Join Date
    Dec 2017

    How to persistently assign windows function keys


    I've created a VB program to assign the action of printing a screenshot of the current screen to a function key of choice, but I'm having trouble trying to get the assignment to persist after the program is closed.

    So a couple of questions arise:

    1. Is this possible to do?
    2. If so, does anyone know the way to do it?

    The code I currently have is:

    Imports System
    Imports System.IO
    Imports System.Drawing
    Imports System.Drawing.Printing
    Imports System.Windows.Forms.Keys
    Imports System.Runtime.InteropServices
    Imports Shell32               ' for ShellFolderView
    Imports SHDocVw               ' for IShellWindows
    Public Class frmFunctionKeyChanger
    	<DllImport("User32.dll")> _
    	Private Shared Function RegisterHotKey(ByVal hwnd As IntPtr, _
    							ByVal id As Integer, ByVal fsModifiers As Integer, _
    							ByVal vk As Integer) As Integer
    	End Function
        <DllImport("User32.dll")> _
        Private Shared Function UnregisterHotKey(ByVal hwnd As IntPtr, _
    							ByVal id As Integer) As Integer
        End Function
    	Private Declare Function CreateDC Lib "gdi32" Alias _
    	   "CreateDCA" (ByVal lpDriverName As String, _
    	   ByVal lpDeviceName As String, ByVal lpOutput As String, _
    	   ByVal lpInitData As String) As Integer
    	Private Declare Function CreateCompatibleDC Lib "GDI32" _
    	   (ByVal hDC As Integer) As Integer
    	Private Declare Function CreateCompatibleBitmap Lib "GDI32" _
    	   (ByVal hDC As Integer, ByVal nWidth As Integer, _
    	   ByVal nHeight As Integer) As Integer
    	Private Declare Function GetDeviceCaps Lib "gdi32" Alias _
    	   "GetDeviceCaps" (ByVal hdc As Integer, _
    	   ByVal nIndex As Integer) As Integer
    	Private Declare Function SelectObject Lib "GDI32" _
    	   (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
    	Private Declare Function BitBlt Lib "GDI32" _
    	   (ByVal srchDC As Integer, _
    	   ByVal srcX As Integer, ByVal srcY As Integer, _
    	   ByVal srcW As Integer, ByVal srcH As Integer, _
    	   ByVal desthDC As Integer, ByVal destX As Integer, _
    	   ByVal destY As Integer, ByVal op As Integer) As Integer
    	Private Declare Function DeleteDC Lib "GDI32" _
    	   (ByVal hDC As Integer) As Integer
    	Private Declare Function DeleteObject Lib "GDI32" _
    	   (ByVal hObj As Integer) As Integer
    	Const SRCCOPY As Integer = &HCC0020
    	Dim WithEvents printDoc As New Printing.PrintDocument()
        Private printFont As Font
        Private streamToPrint As StreamReader
    	Private bmpScreen As System.Drawing.Bitmap
    	Private pd As New PrintDocument()
        Private strPrintText As String
    	Private Sub btnAssign_Click(sender As Object, e As EventArgs) Handles btnAssign.Click
    		Dim aKeyCodes As AssocArray = New AssocArray
    		Dim intKeyPressed As Integer
    		If (Not cboAction.SelectedItem.ToString() = "" _
    		 &  Not cboFunctionKey.SelectedItem.ToString() = "" _
    			) Then
    			aKeyCodes.Fill(New String(){"F1","F2","F3","F4","F5","F6","F7","F8","F9","F10","F11","F12"} _
    						 , New String(){F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12}
                For Each varKey As Object In aKeyCodes.Elements
                    If (varKey(0) = cboFunctionKey.SelectedItem.ToString()) Then
    					intKeyPressed = varKey(1)
    					Exit For
                    End If
    			Select cboAction.SelectedItem.ToString()
    			Case "Print Screen"
    				'Assign function key to the Print Screen action
    			Case "Print File Name List"
    				'Assign function key to the Print File Name List action
    			Case Else
    				'Error - no action selected
    				MsgBox("An action must be selected.", MsgBoxStyle.OkOnly, "Error")
    			End Select
    			Select True
    			Case cboAction.SelectedItem.ToString() = ""
    				MsgBox("An action must be selected.", MsgBoxStyle.OkOnly, "Error")
    			Case cboFunctionKey.SelectedItem.ToString() = ""
    				MsgBox("An action must be selected.", MsgBoxStyle.OkOnly, "Error")
    			Case Else
    				'Unknown Error
    				MsgBox("Unknown Error.", MsgBoxStyle.OkOnly, "Error")
    			End Select
    		End If
    	End Sub
        Protected Overrides Sub WndProc(ByRef oMsg As System.Windows.Forms.Message)
            Dim id As IntPtr = oMsg.WParam
    		Dim strPath As String
    		Dim strFilenames As String
    		Select Case (id.ToString())
            Case "100"
                'Print the screen
    				AddHandler pd.PrintPage, AddressOf Me.PrintImage
    			Catch ex As Exception
    			End Try
    		Case "200"
                'Print the file name list
    				strPath = GetExplorerPath()
    				strFilenames = GetFilenamesAsText(strPath)
    				strFilenames = GetFilenamesAsText(strPath)
    					'printFont = New Font("Courier New", 10)
    					'AddHandler pd.PrintPage, AddressOf Me.PrintFileList
    				'End Try
    			Catch ex As Exception
    			End Try
    		End Select
        End Sub
    	Protected Sub CaptureScreen()
    		Dim hsdc, hmdc As Integer
    		Dim bmpHandle, OLDbmpHandle As Integer
    		Dim releaseDC As Integer
    		Dim intWidth, intHeight As Integer
    		hsdc = CreateDC("DISPLAY", "", "", "")
    		hmdc = CreateCompatibleDC(hsdc)
    		intWidth = GetDeviceCaps(hsdc, 8)
    		intHeight = GetDeviceCaps(hsdc, 10)
    		bmpHandle = CreateCompatibleBitmap(hsdc, _
    		 intWidth, intHeight)
    		OLDbmpHandle = SelectObject(hmdc, bmpHandle)
    		releaseDC = BitBlt(hmdc, 0, 0, intWidth, _
    		 intHeight, hsdc, 0, 0, 13369376)
    		bmpHandle = SelectObject(hmdc, OLDbmpHandle)
    		releaseDC = DeleteDC(hsdc)
    		releaseDC = DeleteDC(hmdc)
    		bmpScreen = Image.FromHbitmap(New IntPtr(bmpHandle))
    	End Sub
        Private Sub PrintImage(ByVal sender As Object, ByVal ev As PrintPageEventArgs)
    		Dim bnds As Rectangle
    		'Adjust the size of the image to the page to print the full image without losing any part of it
    		bnds = ev.MarginBounds
    		If (bmpScreen.Width / bmpScreen.Height > bnds.Width / bnds.Height) Then 'Image is wider
    			bnds.Height = CType((CType(bmpScreen.Height, Double) / CType(bmpScreen.Width, Double) * CType(bnds.Width, Double)), Integer)
    			bnds.Width = CType((CType(bmpScreen.Width, Double) / CType(bmpScreen.Height, Double) * CType(bnds.Height, Double)), Integer)
    		End If
            'Calculate optimal orientation
            pd.DefaultPageSettings.Landscape = bnds.Width > bnds.Height
            'Put image in center of page
            bnds.X = CType(((sender.DefaultPageSettings.PaperSize.Width - bnds.Width) / 2), Integer)
            bnds.Y = CType(((sender.DefaultPageSettings.PaperSize.Height - bnds.Height) / 2), Integer)
    		ev.Graphics.DrawImage(bmpScreen, bnds)
    	End Sub
        'The PrintPage event is raised for each page to be printed.
        Private Sub PrintFileList(ByVal sender As Object, ByVal ev As PrintPageEventArgs)
    		Dim linesPerPage As Single = 0
            Dim yPos As Single = 0
            Dim count As Integer = 0
            Dim leftMargin As Single = ev.MarginBounds.Left
            Dim topMargin As Single = ev.MarginBounds.Top
            Dim line As String = Nothing
            'Calculate the number of lines per page.
            linesPerPage = ev.MarginBounds.Height / printFont.GetHeight(ev.Graphics)
            'Print each line of the file.
            While count < linesPerPage
                line = streamToPrint.ReadLine()
    			If line Is Nothing Then
                    Exit While
                End If
    			yPos = topMargin + count * printFont.GetHeight(ev.Graphics)
                ev.Graphics.DrawString(line, printFont, Brushes.Black, leftMargin, yPos, New StringFormat())
                count += 1
            End While
            'If more lines exist, print another page.
            If (line IsNot Nothing) Then
                ev.HasMorePages = True
                ev.HasMorePages = False
            End If
    	End Sub
    	Private Function GetExplorerPath() As String
    		Dim exShell As New Shell
    		Dim strPath As String = ""
    		Dim strDir As String
    		For Each w As ShellBrowserWindow In DirectCast(exShell.Windows, IShellWindows)
    			' Try to cast to an Explorer folder
    			If TryCast(w.Document, IShellFolderViewDual) IsNot Nothing Then
    				strPath = DirectCast(w.Document, IShellFolderViewDual).FocusedItem.Path
    				Exit For
    			ElseIf TryCast(w.Document, ShellFolderView) IsNot Nothing Then
    				strPath = DirectCast(w.Document, ShellFolderView).FocusedItem.Path
    				Exit For
    			End If
    		If Directory.Exists(strPath) Then
    			strDir = strPath
    		ElseIf File.Exists(strPath)
    			strDir = Path.GetDirectoryName(strPath)
    			strDir = ""
    		End If
    		Return strDir
    	End Function
    	Private Function GetFilenamesAsText(strPath As String) As String
    		Dim strFilenames As String = ""
    		For Each filename As String In Directory.EnumerateFiles(strPath)
    			strFilenames = filename + vbCrLf
    		Return strFilenames.Substring(0, Len(strFilenames) - Len(vbCrLf))
    	End Function
        Public Sub PrintText(ByVal text As String, Optional ByVal printer As String = "")
    		Dim pd As New Printing.PrintDocument
            strPrintText = text
    		Using (pd)
    			If printer IsNot Nothing _
    			& printer <> "" Then
    				pd.PrinterSettings.PrinterName = printer
    			End If
    			AddHandler pd.PrintPage, AddressOf Me.PrintPageHandler
    			RemoveHandler pd.PrintPage, AddressOf Me.PrintPageHandler
            End Using
    	End Sub
        Private Sub PrintPageHandler(ByVal sender As Object, ByVal args As PrintPageEventArgs)
    		Dim myFont As New Font("Courier New", 9)
    		args.Graphics.DrawString(strPrintText, _
               New Font(myFont, FontStyle.Regular), _
               Brushes.Black, 50, 50)
    	End Sub
    End Class

  2. #2
    Join Date
    Jan 2018

    Re: How to persistently assign windows function keys

    Follow up. Hope you will get some advice soon!

  3. #3
    2kaud's Avatar
    2kaud is offline Super Moderator Power Poster
    Join Date
    Dec 2012

    Re: How to persistently assign windows function keys

    Quote Originally Posted by LinckeU View Post
    Follow up. Hope you will get some advice soon!
    ...and this helps how?
    All advice is offered in good faith only. All my code is tested (unless stated explicitly otherwise) with the latest version of Microsoft Visual Studio (using the supported features of the latest standard) and is offered as examples only - not as production quality. I cannot offer advice regarding any other c/c++ compiler/IDE or incompatibilities with VS. You are ultimately responsible for the effects of your programs and the integrity of the machines they run on. Anything I post, code snippets, advice, etc is licensed as Public Domain and can be used without reference or acknowledgement. Also note that I only provide advice and guidance via the forums - and not via private messages!

    C++20 Compiler: Microsoft VS2022 (17.0.5)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Click Here to Expand Forum to Full Width