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

    How to persistently assign windows function keys

    Hi,

    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:

    Code:
    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
                Next
    
    			Select cboAction.SelectedItem.ToString()
    			Case "Print Screen"
    				'Assign function key to the Print Screen action
    				RegisterHotKey(
    				Me.Handle,
    				100,
    				vbNull,
    				intKeyPressed
    				)
    
    			Case "Print File Name List"
    				'Assign function key to the Print File Name List action
    				RegisterHotKey(
    				Me.Handle,
    				200,
    				vbNull,
    				intKeyPressed
    				)
    
    			Case Else
    				'Error - no action selected
    				MsgBox("An action must be selected.", MsgBoxStyle.OkOnly, "Error")
    
    			End Select
    		Else
    			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
     			Try
    				CaptureScreen()
    				AddHandler pd.PrintPage, AddressOf Me.PrintImage
    				pd.Print()
    
    			Catch ex As Exception
    			End Try
    
    		Case "200"
                'Print the file name list
    			Try
    				strPath = GetExplorerPath()
    				strFilenames = GetFilenamesAsText(strPath)
    				strFilenames = GetFilenamesAsText(strPath)
    
    				'Try
    					'printFont = New Font("Courier New", 10)
    					'AddHandler pd.PrintPage, AddressOf Me.PrintFileList
    					'pd.Print()
    				'Finally
    					'streamToPrint.Close()
    				'End Try
    			Catch ex As Exception
    				MessageBox.Show(ex.Message)
    			End Try
    		End Select
    
    		MyBase.WndProc(oMsg)
        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))
    		DeleteObject(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)
    		Else
    			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
            Else
                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
    		Next
    
    		If Directory.Exists(strPath) Then
    			strDir = strPath
    		ElseIf File.Exists(strPath)
    			strDir = Path.GetDirectoryName(strPath)
    		Else
    			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
            Next
    
    		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
                pd.Print()
    			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
    Debbie

  2. #2
    Join Date
    Jan 2018
    Posts
    15

    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
    Location
    England
    Posts
    7,822

    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 https://creativecommons.org/publicdomain/zero/1.0/ 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++23 Compiler: Microsoft VS2022 (17.6.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

Featured