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


This topic was automatically closed 91 days after the last reply. New replies are no longer allowed.