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:
- Is this possible to do?
- 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