RegisterHotKeyを呼び出す

• RegisterHotKey 関数

WindowsのRegisterHotKeyを呼び出したくて、RWHを読んで、
hsc2hsを使って、モジュールを作成してみた。

以下のようにして、hscファイルをhsに変換して使う

$ hsc2hs HotKey.hsc
$ ghc --make HotKey.hs
$ runghc .\TestHotKey.hs

設定したHotKey(ソースでは、Shift+Space)を押すと、プログラムが終了する。
ただし、HotKeyの登録に失敗すると、（すでに使用されているホットキーを指定したりして）
終了できなくなくなる。その場合は、タスクマネージャーから強制終了する^^。

UnregisterHotKeyも作成したけど、サンプルでは使ってない。
ちゃんとするときは、呼び出す必要あり。

HotKey.hsc

{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module HotKey
  ( FsModifiers
  , modAlt
  , modControl
  , modShift
  , modWin
  , combineModifiers
  , registerHotKey
  , unregisterHotKey
  , wM_HOTKEY
  ) where

import Foreign
import Foreign.C.Types
import System.Win32.Types
import Graphics.Win32.GDI.Types
import Graphics.Win32.Key
import Graphics.Win32.Message

#include <windows.h>

newtype FsModifiers = FsModifiers { unFsModifiers :: UINT }
  deriving (Eq,Show)

#{enum FsModifiers, FsModifiers
 , modAlt = MOD_ALT
 , modControl = MOD_CONTROL
 , modShift = MOD_SHIFT
 , modWin = MOD_WIN
}

wM_HOTKEY :: WindowMessage
wM_HOTKEY = #const WM_HOTKEY

combineModifiers :: [FsModifiers] -> FsModifiers
combineModifiers = FsModifiers . foldr ((.|.) . unFsModifiers) 0

registerHotKey :: HWND -> Int -> FsModifiers -> VKey -> IO BOOL
registerHotKey hwnd id m vkey = do
  isBool <- c_RegisterHotKey hwnd id (unFsModifiers m) vkey
--  errCode <- getLastError
--  print errCode
--  errMsg <- getErrorMessage errCode
--  print errMsg
  return isBool

unregisterHotKey :: HWND -> Int -> IO BOOL
unregisterHotKey hwnd id = c_UnregisterHotKey hwnd id

foreign import stdcall "windows.h RegisterHotKey"
  c_RegisterHotKey :: HWND -> Int -> UINT -> VKey -> IO BOOL

foreign import stdcall "windows.h UnregisterHotKey"
  c_UnregisterHotKey :: HWND -> Int -> IO BOOL

TestHotKey.hs (Programming Windows in Haskell - 取り急ぎブログですからパクって、必要なとこだけいただきました。感謝）

{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import System.Win32.DLL (getModuleHandle)
import Graphics.Win32
import Graphics.Win32.Key
import Graphics.Win32.Message
import Graphics.Win32.Window
import Data.Int
import Data.Maybe
import Control.Monad
import Foreign.C.String
import HotKey

foreign import stdcall "PostQuitMessage" postQuitMessage
   :: Int32 -> IO ()

main = do
  let clsName =  mkClassName "My Window Class"
  hinst       <- getModuleHandle Nothing
  whiteBrush  <- getStockBrush wHITE_BRUSH
  curArrow    <- loadCursor Nothing iDC_ARROW
  mAtom 	     <- registerClass (
      cS_DBLCLKS, 
      hinst,          -- HINSTANCE
      Nothing,        -- Maybe HICON
      Just curArrow,  -- Maybe HCURSOR
      Just whiteBrush,-- Maybe HBRUSH
      Nothing,        -- Maybe LPCTSTR
      clsName)

  when (isJust mAtom) $ do
    hwnd <- createWindow 
      clsName
      "HotKey Test Window" 
      (wS_THICKFRAME + wS_CAPTION + wS_SYSMENU) 
      Nothing 
      Nothing 
      Nothing 
      Nothing 
      Nothing 
      Nothing 
      hinst 
      wndProc

    -- キーを設定する
    isRegist <- registerHotKey hwnd 1 modShift vK_SPACE 
    print isRegist

    showWindow hwnd sW_SHOWNORMAL
    updateWindow hwnd
    allocaMessage pump
    unregisterClass clsName hinst

pump lpmsg = do
  fContinue <- getMessage lpmsg Nothing
  when fContinue $ do
    translateMessage lpmsg
    dispatchMessage lpmsg
    pump lpmsg

wndProc :: HWND -> 
  WindowMessage -> 
  WPARAM -> 
  LPARAM -> IO LRESULT
wndProc hwnd wm wp lp
　- HotKeyのイベントを受け取る
  | wm == wM_HOTKEY = print "Push HotKey" >> doFinish >> return 0
  | wm == wM_DESTROY     = postQuitMessage 0 >> return 0
  | otherwise            = defWindowProc (Just hwnd) wm wp lp
  where
    doFinish = sendMessage hwnd wM_CLOSE 1 0 >> return 0