How to persistently assign windows function keys


#1

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:

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


closed #2

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