VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. Debug print class


メモ帳にDebug.print改めメモ帳をVBAでいじり倒す

 

Accessのメモ型フィールドの長文を表示させるのにメモ帳を使おうと思い、更に編集後書き戻す機能も持たせたいと欲張り
果ては、メモ帳からは簡単に終了できない様にして、Accessに書き戻した後に、Accessから終了させたい等盛り込んでみました。

○下記は以前のコメントです。備忘録に残しておきます
イミディウェイトウィンドウに出力する代わりにメモ帳を起動して書き込むクラスモジュールを作成してみた。
最前面にしてあるので、実行結果がリアルタイムに見られて良いかもしれない。
行の折り返しと、スクロールの設定もしてみようとしたが、調べてみるとメモ帳は折り返し有り・無しの二種類のEditコントロールを切り替えて機能を実現しており、 どうやらCreateWindowの時に設定しないと無効らしいので、諦めた。と言うわけですこぶる単機能です。



☆標準モジュール：使い方
Sub test()
  Dim ctrlMemoCls As ctrlNotePadClass
  
  Set ctrlMemoCls = New ctrlNotePadClass
  
  ctrlMemoCls.caption = "My Window Caption"
  ctrlMemoCls.disableCloseButton
  ctrlMemoCls.resize 800, 600
  
  ctrlMemoCls.linePrint "一行目"
  ctrlMemoCls.linePrint "二行目"
  'テキスト取得
  Debug.Print ctrlMemoCls.Text
  
  '強制終了
'  ctrlMemoCls.terminate
End Sub


☆クラスモジュール
Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" _
 (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
  ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
 (ByVal hwnd As Long, ByVal Msg As Long, wParam As Long, lParam As Long) As Long

Private Declare Function SendMessageAny Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal Msg As Long, wParam As Long, lParam As Any) As Long

'wParam, LParamにByValをつけないと、GETTEXTが動作しなかった。GETTEXTLENGTHはOKだったのだが。
Private Declare Function SendMessageString Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private Declare Function MoveWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long

Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
      ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
      ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
     
'閉じるボタン、メニュー操作関係
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
     
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd&) As Long

Private Declare Function GetWindowRect Lib "user32" _
    (ByVal hwnd As Long, lpRect As RECT) As Long
    
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

'Process関係
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwAccess As Long, ByVal fInherit As Integer, ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Long
'ウィンドウを作成したスレッドの ID が返る。プロセス ID の取得もできる。
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

'Process関係定数
Private Const SYNCHRONIZE = 1048576
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const PROCESS_TERMINATE = &H1

'Edit Control 制御用定数
Private Const EM_GETSEL = &HB0                '選択開始位置と終了位置の取得
Private Const EM_SETSEL = &HB1                '選択開始位置と終了位置の設定
Private Const EM_REPLACESEL = &HC2            '選択文字列を指定の文字列に置換
Private Const WM_SETTEXT = &HC                'テキストの設定
Private Const WM_GETTEXT = &HD                'テキストの取得
Private Const WM_GETTEXTLENGTH = &HE          'テキストの長さの取得（NULLを含まず）
Private Const WM_IME_CHAR = &H286

Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
'メニュー、Window右上ボタン関係
Private Const SC_CLOSE = &HF060 'システムメニューの閉じる
Private Const MF_BYCOMMAND = &HD 'メニー項目指定
Private Const MF_BYPOSITION = &H400 'ポジション指定

'モジュールレベル変数
Private lnghWnd As Long   'hWnd of top level (Parent) window
Private lnghWndTarget As Long 'hWnd of target (Child) window
'Private udtprocinfo As PROCESS_INFORMATION
Private hProcess As Long

'Set Window Caption
Public Property Let caption(newCaption As String)
  SetWindowText lnghWnd, newCaption
End Property

Private Sub Class_Initialize()
  Dim lngProcessID As Long
  Dim lngRC As Long
  Dim hMenu As Long
  
  Dim myProcessID As Long
  
'  Dim udtprocinfo As PROCESS_INFORMATION
'  Dim udtStartInfo As STARTUPINFO
'  Dim lngret As Long

  'これで起動すると何故かハンドルが取得できなかった。
'  udtStartInfo.cb = LenB(udtStartInfo)
'  lngret = CreateProcess(vbNullString, "NOTEPAD.EXE", ByVal 0&, ByVal 0&, 1&, NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, udtStartInfo, udtprocinfo)

  lngProcessID = Shell(Environ("WINDIR") & "\NOTEPAD.EXE", vbNormalFocus)
  '下記は無くても起動はできる。
  hProcess = OpenProcess(SYNCHRONIZE Or PROCESS_TERMINATE, True, lngProcessID)
  Sleep 100
  
'  getWindowHandle
  'お洒落に？クラスID（から求めたプロセスID）からWindow Handleを求めようと思ったが、EnumWindowsでコールバック関数を動かして、GetWindowThreadProcessIDにより取得したProcessIDと照合する事になり、AddressOfが標準モジュールの関数にしか使えない事から、クラスモジュールだけで完結しなくなるので断念した。
  lnghWnd = FindWindowEx(0, 0, "Notepad", "無題 - メモ帳")
  
  '念のためProcessIDの合致を確認
  lngRC = GetWindowThreadProcessId(lnghWnd, myProcessID)
  '既存の無題メモ帳が存在しても新しい方が捕捉されるらく、意味なし。
  If myProcessID <> lngProcessID Then
    MsgBox "無題のメモ帳が既に開かれています" & vbCrLf & "それらを閉じてやり直して下さい"
  End If
  
  lnghWndTarget = FindWindowEx(lnghWnd, 0, "Edit", "")
  lngRC = SetWindowPos(lnghWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
  lngRC = MoveWindow(lnghWnd, 0, 10, 300, 200, 1)
  
End Sub

'位置寸法の設定
Public Sub move_resize(Left As Long, Top As Long, x As Long, y As Long)
  Dim lngRC As Long
  
  lngRC = MoveWindow(lnghWnd, Left, Top, x, y, 1)
End Sub

Public Sub resize(x As Long, y As Long)
  Dim lngRC As Long
  Dim myRect As RECT
  
   '位置、サイズ情報の取得
    GetWindowRect lnghWnd, myRect
  lngRC = MoveWindow(lnghWnd, myRect.Left, myRect.Top, x, y, 1)
End Sub


'×ボタンを無効にする（表示は無くならない）
Public Sub disableCloseButton()
  Dim hMenu As Long
  
  hMenu = GetSystemMenu(lnghWnd, 0)
  DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND
End Sub


'メモ帳を強制終了
Public Sub terminate()
  '本来はWM_CLOSEをSendMessageするのが筋。今回はファイル保存ニーズ無し故に強制終了

  Call TerminateProcess(hProcess, 0&)
  Call CloseHandle(hProcess)
End Sub

'一行入力（複数行まとめて貼り付けもOK)
Public Sub linePrint(newValue As Variant)
  Dim lngRC As Long
  Dim ndx As Long
  Dim newText As String
  
  If TypeName(newValue) = "String" Then
    newText = newValue
  Else
    newText = CStr(newValue)
  End If
  'Editへの追記
  ndx = SendMessage(lnghWndTarget, WM_GETTEXTLENGTH, 0, 0&)
  If ndx <> 0 Then
    SetFocusAPI lnghWndTarget
    lngRC = SendMessage(lnghWndTarget, EM_SETSEL, ndx, ndx)
    newText = vbCrLf & newText
    lngRC = SendMessageAny(lnghWndTarget, EM_REPLACESEL, 0, ByVal newText)
  Else
    lngRC = SendMessageAny(lnghWndTarget, WM_SETTEXT, 0, ByVal newText)
  End If
End Sub

'メモ帳のテキストを戻す
Public Property Get Text() As String
  Dim length As Long, lngret As Long
  Dim str As String
  
  length = SendMessageString(lnghWndTarget, WM_GETTEXTLENGTH, 0, 0)
  length = length + 1 'Null文字分足す
  str = String(length, vbNullChar)
  
  lngret = SendMessageString(lnghWndTarget, WM_GETTEXT, length, ByVal str)
  Text = Left(str, InStr(str, vbNullChar) - 1)
End Property