[[20150326105138]]　『開いているメモ帳(複数)の選択範囲の文字列を取得』（のらじろう）　ページの最後に飛ぶ

『開いているメモ帳(複数)の選択範囲の文字列を取得』（のらじろう）

 開いているメモ帳のドラッグで選択している範囲を取得するコードを書こうとしています。

 ↓の過去ログ「開いているメモ帳の内容を取得する」でメモ帳の全範囲を取得する方法はわかりました。

https://www.excel.studio-kazu.jp/kw/20111206231619.html

 これを、ドラッグで選択している範囲、とするにはどう書き換えたらいいでしょうか？
 開いているのが無題のメモ帳で、かつ、一つだけだったら

 AppActivate ～
 と
 SendKeys
 を使って出来そうなのですが、メモ帳が複数起動していると方法が分かりません。

 ご指導お願いします。

＜使用 Excel：Excel2007、使用 OS：WindowsVista ＞

開いているメモ帳全てのハンドルを得ることはできますが、範囲選択中かどうかまでは判らないような？

とりあえず、片っ端からCTRL+Cを送ってはクリップボードを調べていく、という方法はどうですか？
そんなプログラムが、何の役に立つか判りませんし、Excel VBAでやるような機能には思えませんが。
（普通のアプリは、他のアプリが何をやっているか、なんて、知ったことじゃないです）
（???） 2015/03/26(木) 11:04

範囲選択されていれば、「編集」－「コピー」が選択可能になりますね。APIを駆使してこれを調べれば何とかなるかな。
APIは、自分で調べる能力がない人が使うべきではありませんので、あとはご自分で試行錯誤してください。
（???） 2015/03/26(木) 11:07

 もし複数のメモ帳が立ち上がっていて、その複数のメモ帳のいずれもがドラッグで選択している状態だったとしたら
 その中のどれを参照したいのですか？

 目的がわかりません。

 ドラッグしたものをエクセル側に取り込みたいのなら、ドラッグしっぱなしではなく、ドラッグして Ctrl/cをやって
 それを取り込めばいいのでは？
 メモ帳側でCtrl/c をやらない理由は何ですか？

（β） 2015/03/26(木) 11:14

仮にこれを作ったとしていちいちメモ帳をドラッグしてVBA起動して貼り付けするのめんどうではありませんか

メモ帳からデータを持ってきてVBAでいらないデータを削除したりする方が簡単だと思います。
（デイト） 2015/03/26(木) 11:24

ちょこっと実験したところ、以下の方法で実現できそうです。

（１）一旦、全ての対象のhWndEditを調べて、配列に記憶。
（２）配列数分ループして、1つずつSetForegroundWindowしてはSendkeysでCTRL+Cを送った後、クリップボードのテキストを得る。

クリップボードのテキストを得るには、MSForms.DataObjectの.GetTextを使うと良いでしょう。
ハンドルを配列に格納するのは、1つのメモ帳をアクティブにすると次のFindWindowExの結果が変わってしまい、同じメモ帳を何度も調べてしまうのを防ぐためです。

また、AppActivateではなく、APIのSetForegroundWindowを使うのは、対象のメモ帳はExcelから起動したものではないためです。

範囲選択していないものを除外したい場合、更にアプリのメニュー文字列を調べるようなコーディングを追加してください。（かなり面倒）
（???） 2015/03/26(木) 13:21

 >また、AppActivateではなく、APIのSetForegroundWindowを使うのは、対象のメモ帳はExcelから起動したものではないためです

 自身が起動したものではなくても、キャプションを与えて、AppActivate はできますよね。
 もっとも、今回の場合は、同じキャプションのメモ帳がたくさんあるので特定はできないわけですが。

 Sub test()
    AppActivate "無題 - メモ帳", True
 End Sub

（β） 2015/03/26(木) 13:52

 ???さん、βさん、デイトさん、ご回答ありがとうございます。

 >もし複数のメモ帳が立ち上がっていて、その複数のメモ帳のいずれもがドラッグで選択している状態だったとしたら
 >その中のどれを参照したいのですか？

 ドラッグしたものはすべて参照します。

 >ドラッグしたものをエクセル側に取り込みたいのなら、ドラッグしっぱなしではなく、ドラッグして Ctrl/cをやって
 >それを取り込めばいいのでは？
 >メモ帳側でCtrl/c をやらない理由は何ですか？

 Ctrl+Cですと、最後にコピーしたものしかクリップボードに残らないからです。

 >メモ帳からデータを持ってきてVBAでいらないデータを削除したりする方が簡単だと思います。

 全部コピーしてしまうと、どこをドラッグで選択したかを一々元のメモ帳を参照して確認する必要が出てきます。

 まだ設計段階なのですが、複数の起動しているメモ帳の選択している範囲を個別に取得し、それを並び変えたり不要なものは
 破棄、場合によってはさらに複写、最終的には一つのテキストファイルとして保存したりメールの本文に取込んでメール送信
 したり、ということを考えています。

 APIは初めてですが、ご教示いただきましたことを基に調べてみます。
 必ず作り上げてご報告いたします。亀レスになると思いますが、長～い目で見てやってください。よろしくお願いいたします。
（のらじろう） 2015/03/26(木) 23:47

 健闘を祈ります。

 API については　FindWindowEx　もいいと思いますが、EnumWindowsでクラス"NotePad" をすべて取得して実行する手もあるかと思います。

 それより、運用を考えますと、(デイト)さんがリコメンドしておられる方式、必要なメモ帳を選択してすべてエクセルに取り込み
 取り込んだシート上で、必要な文字列を指定しながら処理をするほうが、APIも不要で、コードもすっきりし
 また、処理、あるいはコードの柔軟性も増すような気がします。

（β） 2015/03/27(金) 07:04

 もし私がこの案件をやるとしたら、

 対象のテキストファイルを指定して（フォルダ下のファイルをすべて？ファイルを個別に？）、
 EXCEL にテキストボックスを挿入し、各ファイルごとにテキストを読み込みます。
 （テキストはシートごと？シート内に順番に？）

 各テキストボックス内で、範囲選択の変わりに選択した範囲の文字色を変更しておきます。
 範囲指定（文字色変更）後、マクロ等で指定した範囲を一括処理します。
 のような、ストーリーを考えるでしょうか。

 単なる感想で、すみません。 
（Mook） 2015/03/27(金) 16:24

だいだいの使い方は判りましたし、メモ帳である点がミソですね。テキストデータなら何でも良いし、無題の状態でも、
そこに書いた文字さえあれば切り取れる、という事でしょう。

自動化することに関して、気になる点が。
メモ帳全てを列挙して、そこから選択範囲を抜き出して、結合して、１つのテキストにするわけですが、
抜き出す順番が不定になってしまうのです。かといって、ファイル名を利用しようにも、無題ならば、みな同じになるし…。
ハンドルの値なんて、windowsが勝手に振った番号であり、順不同だし。

順番がばらばらでも、使い物になるかが心配です。
私なら、ひとつ範囲選択する度にコピーし、まとめ用のメモ帳に貼り付けちゃいますね。
範囲選択＋コピー、貼り付けまでで1セットです。ツール化する意味がないと思うのは、この順番のためです。
範囲選択した状態で次のメモ帳をクリックするとして、クリック場所を間違えて、選択状態を解除してしまうリスクもあります。

ただし、もう一歩使い方を進めて、例えば1つの切り取りを1つのテキストボックスとしてExcelに貼っていく機能と、
テキストボックスが並んでいる順番に内容を連結していって1つにする、という機能に分けても良いかもです。
テキストボックスを並べ替えるのは手動でもいい。Y座標の小さいものから順に処理すればいい。いかがでしょうか。
（???） 2015/03/27(金) 16:45

私も便乗してもしやることになったらどうするか考えました。
まず最初に考えたのがメモ帳をあきらめます。
テキストデータを貼り付けるなら別にメモ帳じゃなくてもいい
ショートカットキーで次のテキストに行けるエディタで作れるようにします。

では例として、サクラエディタというテキストエディタを利用し事前に選択したデータを後ろから順番に貼り付けるというのをやります。
Sub text_Click()

        Dim ret As Variant
        Dim rc As Long
        rc = Shell("C:\Program Files (x86)\sakura\sakura.exe", vbNormalFocus)

        AppActivate rc
        SendKeys "^{F4}", True
        SendKeys "^c", True
        SendKeys "^{F4}", True
        AppActivate "Microsoft Excel", False
        ThisWorkbook.Worksheets(1).Activate
        Range("a1").Select
        SendKeys "^v", True

        rc = Shell("C:\Program Files (x86)\sakura\sakura.exe", vbNormalFocus)

        AppActivate rc
        SendKeys "^{F4}", True
        SendKeys "^c", True
        SendKeys "^{F4}", True
        AppActivate "Microsoft Excel", False
        ThisWorkbook.Worksheets(1).Activate
        Range("B1").Select
        SendKeys "^v", True

End Sub

無理やり実現すると今の私はこうなります。私はほかの方と比べてまだVBAは浅いのでほかの方のを参考にした方がいいです。
（デイト） 2015/03/27(金) 17:45

???さん、βさん、デイトさん、Mookさん、ご回答ありがとうございます。

まだまだ継ぎ接ぎの状態ですが、ネットで調べて下記の状態まで出来ました。
便宜的に一つのメモ帳の選択範囲を一つのテキストファイルとして保存する
形にしてますが、これを基に一つづつテキストボックスに表示するなどの形
にする予定です。ここから先は上司と相談して作りこむことになります。
テキストボックスとリストボックスを連動させてテキストボックスの文字を
連結する順序を変える、という形になりそうです。

これで一応の完成です。ご指導いただきました回答者の方々、ありがとう
ございました。

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

Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _

     ByVal hWnd As Long, _
     ByVal lpString As String, _
     ByVal cch As Long _
     ) As Long
Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
     ByVal hWnd As Long, _
     ByVal lpClassName As String, _
     ByVal nMaxCount As Long _
     ) As Long
Declare Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function IsWindowEnabled Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function EnumWindows Lib "user32.dll" ( _
     ByVal lpEnumFunc As Long, _
     lParam As Long _
     ) As Long

Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long

Declare Function OpenClipboard Lib "user32" _

        (ByVal hWndNewOwner As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EmptyClipboard Lib "user32" () As Long

Dim CB As New DataObject

Dim cnt As Long
Dim ws As Worksheet

Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long

 Dim mycls As String
 Dim StrCap As String
 Dim StrCls As String

  StrCap = String(100, Chr(0))
  Call GetWindowText(hWnd, StrCap, Len(StrCap))

  StrCls = String(50, Chr(0))
  Call GetClassName(hWnd, StrCls, Len(StrCls))

  mycls = Left(StrCls, InStr(1, StrCls, Chr(0)) - 1)

  If mycls = "Notepad" Then
     cnt = cnt + 1

     ws.Cells(cnt, 1).Value = Left(StrCap, InStr(1, StrCap, Chr(0)) - 1)
     ws.Cells(cnt, 2).Value = Left(StrCls, InStr(1, StrCls, Chr(0)) - 1)

     ws.Cells(cnt, 3).Value = hWnd
   End If
   EnumWindowsProc = 1
End Function

Sub SampleEnumWindows()

 Dim i As Integer
 Dim txtpath As String
 Dim cntb As Integer
 Dim genzai As String

  cnt = 1
  Set ws = ThisWorkbook.Worksheets(1)
  Application.ScreenUpdating = False
  ws.Cells.Clear
  ws.Cells(cnt, 1).Value = "タイトル"
  ws.Cells(cnt, 2).Value = "クラス"
  Call EnumWindows(AddressOf EnumWindowsProc, 0)
  genzai = Format(Now, "yymmdd_hhmmss")
  cntb = 0
  If ws.Cells(2, 3).Value <> "" Then
     For i = 2 To ws.Cells(Cells.Rows.Count, 3).End(xlUp).Row
      Call cbclr
      Call SetForegroundWindow(ws.Cells(i, 3).Value)
      SendKeys "^c"
      Sleep 50
      Err.Clear
      On Error Resume Next
      With CB
       .GetFromClipboard
       cbstr = .GetText
       If Err.Number = -2147221404 Then
       Else
          cntb = cntb + 1
          txtpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & genzai & "_" & Format(cntb, "00") & ".txt"
          Sleep 50
          Call TxtOutput(txtpath, CStr(cbstr))
       End If
      End With
      On Error GoTo 0
     Next i
  End If
 Application.ScreenUpdating = True
End Sub

Sub cbclr()

 If OpenClipboard(0) Then
    EmptyClipboard
    CloseClipboard
 End If
End Sub

Function TxtOutput(ByVal newtxtpath As String, newtxtstr As String)

 Dim fnum As Integer
  fnum = FreeFile
  Open newtxtpath For Output As #fnum
   Print #fnum, newtxtstr;
  Close fnum
End Function
（のらじろう） 2015/04/09(木) 10:08

ちゃんと形になりましたね。もうちょっとだけデバッグでしょうか。

・On Error でエラー検出する範囲は、狭い方が良いです。Err.Number を変数に代入しておけばいい。
・SpecialFolders("Desktop")は、1回だけ実行すれば良い。ループで毎回得るのは無駄なので、変数に代入しましょう。
（変わるのはファイル名部分だけですよね）

特に On Error のせいで、以下に問題が出ると、予想外の結果になります。
（このサブプロシジャを目的のシートモジュール以外に置いた場合、Cells.Rows.Countはシートを特定していないためエラーなのに、無視するため）

     For i = 2 To ws.Cells(Cells.Rows.Count, 3).End(xlUp).Row

あと、試しに動かしてみたところ、複数のテキストファイルが同じ内容になる現象が出ました。
私が2回目に指摘したことが発生するようです。
（ハンドルを得るのと、テキストを得るのを、別のループにすれば良いはず）
（???） 2015/04/09(木) 11:45

 ご指導いただきました点を修正してみました。
 起動しているメモ帳一覧をセル転記から配列格納に変更、文字列が選択されている
 メモ帳 のタイトル、選択内容を配列格納、としてみました。

 私の方で８つほどメモ帳を立ち上げ、そのうちの５つほどメモ帳の文字列を選択した
 状態で実行したら一応はうまくいっているようです。

 もしお気づきの点がございましたらご指摘ください。

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

 Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
      ByVal hWnd As Long, _
      ByVal lpString As String, _
      ByVal cch As Long _
      ) As Long

 Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
      ByVal hWnd As Long, _
      ByVal lpClassName As String, _
      ByVal nMaxCount As Long _
      ) As Long

 Declare Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function IsWindowEnabled Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function EnumWindows Lib "user32.dll" ( _
      ByVal lpEnumFunc As Long, _
      lParam As Long _
      ) As Long

 Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function OpenClipboard Lib "user32" _
         (ByVal hWndNewOwner As Long) As Long
 Declare Function CloseClipboard Lib "user32" () As Long

 Declare Function EmptyClipboard Lib "user32" () As Long

 Dim CB As New DataObject
 Dim ary() As Variant
 Dim cnt As Integer

 Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long
  Dim mycls As String
  Dim StrCls As String
  Dim StrCap As String

   StrCap = String(100, Chr(0))
   Call GetWindowText(hWnd, StrCap, Len(StrCap))

   StrCls = String(50, Chr(0))
   Call GetClassName(hWnd, StrCls, Len(StrCls))

   mycls = Left(StrCls, InStr(1, StrCls, Chr(0)) - 1)
   If mycls = "Notepad" Then
      cnt = cnt + 1
      ReDim Preserve ary(1, cnt)
      ary(0, cnt) = hWnd
      ary(1, cnt) = Left(StrCap, InStr(1, StrCap, Chr(0)) - 1)
    End If
    EnumWindowsProc = 1
 End Function

 Sub SampleEnumWindows()
  Dim i As Integer
  Dim txtpath As String
  Dim genzai As String
  Dim ernum As Long
  Dim cbstr As String
  Dim cntb As Integer
  Dim selstrary() As Variant
  Dim newfol As String
   ernum = -2147221404
   genzai = Format(Now, "yymmdd_hhmmss")
   folpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & genzai
   MkDir (folpath)
   cnt = -1
   Call EnumWindows(AddressOf EnumWindowsProc, 0)
   If cnt <> -1 Then
      cntb = -1
      For i = 0 To cnt
       Call cbclr
       Call SetForegroundWindow(ary(0, i))
       SendKeys "^c"
       Sleep 50
       Err.Clear
       cbstr = ""
       With CB
        On Error Resume Next
        .GetFromClipboard
        cbstr = .GetText
       End With
       If Err.Number = ernum Then
       Else
          cntb = cntb + 1
          ReDim Preserve selstrary(1, cntb)
          selstrary(0, cntb) = cbstr
          selstrary(1, cntb) = ary(1, i)
       End If
       On Error GoTo 0
      Next i
      If cntb <> -1 Then
         For i = 0 To cntb
           txtpath = folpath & "\" & genzai & "_" & selstrary(1, i) & ".txt"
           Call TxtOutput(txtpath, CStr(selstrary(0, i)))
         Next i
      End If
      If cntb <> -1 Then Erase selstrary
   End If
   If cnt <> -1 Then Erase ary
   Call cbclr
 End Sub

 Function cbclr()
  If OpenClipboard(0) Then
     EmptyClipboard
     CloseClipboard
  End If
 End Function

 Function TxtOutput(ByVal newtxtpath As String, newtxtstr As String)
  Dim fnum As Integer
   fnum = FreeFile
   Open newtxtpath For Output As #fnum
   Print #fnum, newtxtstr;
   Close fnum
 End Function
（のらじろう） 2015/04/09(木) 21:00

 保存対象メモ帳がないのにフォルダが作成される、無題メモ帳が複数ある場合にテキストファイルのパスが重複してしまう、という不具合がありましたので
 修正しました。

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

 Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
      ByVal hWnd As Long, _
      ByVal lpString As String, _
      ByVal cch As Long _
      ) As Long

 Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
      ByVal hWnd As Long, _
      ByVal lpClassName As String, _
      ByVal nMaxCount As Long _
      ) As Long

 Declare Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function IsWindowEnabled Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function EnumWindows Lib "user32.dll" ( _
      ByVal lpEnumFunc As Long, _
      lParam As Long _
      ) As Long

 Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function OpenClipboard Lib "user32" _
         (ByVal hWndNewOwner As Long) As Long
 Declare Function CloseClipboard Lib "user32" () As Long

 Declare Function EmptyClipboard Lib "user32" () As Long

 Dim CB As New DataObject
 Dim ary() As Variant
 Dim cnt As Integer

 Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long
  Dim mycls As String
  Dim StrCls As String
  Dim StrCap As String

   StrCap = String(100, Chr(0))
   Call GetWindowText(hWnd, StrCap, Len(StrCap))

   StrCls = String(50, Chr(0))
   Call GetClassName(hWnd, StrCls, Len(StrCls))

   mycls = Left(StrCls, InStr(1, StrCls, Chr(0)) - 1)
   If mycls = "Notepad" Then
      cnt = cnt + 1
      ReDim Preserve ary(1, cnt)
      ary(0, cnt) = hWnd
      ary(1, cnt) = Left(StrCap, InStr(1, StrCap, Chr(0)) - 1)
    End If
    EnumWindowsProc = 1
 End Function

 Sub SampleEnumWindows()
  Dim i As Integer
  Dim txtpath As String
  Dim genzai As String
  Dim ernum As Long
  Dim cbstr As String
  Dim cntb As Integer
  Dim selstrary() As Variant
  Dim folpath As String
   ernum = -2147221404
   genzai = Format(Now, "yymmdd_hhmmss")
   folpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & genzai
   cnt = -1
   Call EnumWindows(AddressOf EnumWindowsProc, 0)
   If cnt <> -1 Then
      cntb = -1
      For i = 0 To cnt
       Call cbclr
       Call SetForegroundWindow(ary(0, i))
       SendKeys "^c"
       Sleep 50
       Err.Clear
       cbstr = ""
       With CB
        On Error Resume Next
        .GetFromClipboard
        cbstr = .GetText
       End With
       If Err.Number = ernum Then
       Else
          cntb = cntb + 1
          If cntb = 0 Then MkDir (folpath)
          ReDim Preserve selstrary(1, cntb)
          selstrary(0, cntb) = cbstr
          selstrary(1, cntb) = ary(1, i)
       End If
       On Error GoTo 0
      Next i
      If cntb <> -1 Then
         For i = 0 To cntb
           txtpath = folpath & "\" & genzai & "_" & Format(i, "00") & "_" & selstrary(1, i) & ".txt"
           Call TxtOutput(txtpath, CStr(selstrary(0, i)))
         Next i
      End If
      If cntb <> -1 Then Erase selstrary
   End If
   If cnt <> -1 Then Erase ary
   Call cbclr
 End Sub

 Function cbclr()
  If OpenClipboard(0) Then
     EmptyClipboard
     CloseClipboard
  End If
 End Function

 Function TxtOutput(ByVal newtxtpath As String, newtxtstr As String)
  Dim fnum As Integer
   fnum = FreeFile
   Open newtxtpath For Output As #fnum
   Print #fnum, newtxtstr;
   Close fnum
 End Function
（のらじろう） 2015/04/09(木) 22:45

 >Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long

 ここの
 >StrCap = String(100, Chr(0))

 を
 StrCap = String(255, Chr(0))
 に変えた方がいいようです。

 100だと、タイトルを取得するとき、長いタイトルだと途中までしか取得できませんでした。
 今のところ、私の環境では100だと不十分でしたが255で十分でした。
（のらじろう） 2015/04/10(金) 21:02

 メモ帳のウィンドウのTopが高い(小さい)順に選択内容を結合、としてみました。

 これと、もう一つは、
 リストボックスに格納しスピンボタンでリストボックスの二つの行を前後入れ替え、
 その順でテキストボックスに結合した内容を表示(テキストボックスは手動で編集もできる)、テキスト
 ボックスの内容をテキストファイル保存
 というものです。こちらはコードアップは省略させていただきます。

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

 Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
      ByVal hWnd As Long, _
      ByVal lpString As String, _
      ByVal cch As Long _
      ) As Long

 Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
      ByVal hWnd As Long, _
      ByVal lpClassName As String, _
      ByVal nMaxCount As Long _
      ) As Long

 Declare Function EnumWindows Lib "user32.dll" ( _
      ByVal lpEnumFunc As Long, _
      lParam As Long _
      ) As Long

 Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long

 Declare Function OpenClipboard Lib "user32" _
         (ByVal hWndNewOwner As Long) As Long
 Declare Function CloseClipboard Lib "user32" () As Long

 Declare Function EmptyClipboard Lib "user32" () As Long

 Declare Function GetWindowRect Lib "user32.dll" ( _
      ByVal hWnd As Long, _
      lpRect As RECT _
      ) As Long

 Declare Function GetClientRect Lib "user32.dll" ( _
      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

 Dim CB As New DataObject
 Dim mydic As Object
 Dim ary() As Variant
 Dim cnt As Integer

 Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long
  Dim mycls As String
  Dim StrCls As String
  Dim StrCap As String
   StrCap = String(255, Chr(0))
   Call GetWindowText(hWnd, StrCap, Len(StrCap))

   StrCls = String(50, Chr(0))
   Call GetClassName(hWnd, StrCls, Len(StrCls))

   mycls = Left(StrCls, InStr(1, StrCls, Chr(0)) - 1)
   If mycls = "Notepad" Then
      cnt = cnt + 1
      ReDim Preserve ary(1, cnt)
      ary(0, cnt) = hWnd
      ary(1, cnt) = Left(StrCap, InStr(1, StrCap, Chr(0)) - 1)
   End If
   EnumWindowsProc = 1
 End Function

 Sub SampleEnumWindows()
  Dim hwndtp As Single
  Dim wRECT As RECT
  Dim ky As Variant
  Dim sp As Variant
  Dim i As Integer
  Dim j As Integer
  Dim txtpath As String
  Dim txtstr As String
  Dim genzai As String
  Dim ernum As Long
  Dim cbstr As String
  Dim cntb As Integer
  Dim folpath As String
   Set mydic = CreateObject("Scripting.Dictionary")
   ernum = -2147221404
   genzai = Format(Now, "yymmdd_hhmmss")
   txtpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & genzai & ".txt"
   cnt = -1
   Call EnumWindows(AddressOf EnumWindowsProc, 0)
   For i = 0 To cnt
    Call GetWindowRect(ary(0, i), wRECT)
    hwndtp = wRECT.Top
    If mydic.exists(hwndtp) Then
       mydic.Item(hwndtp) = mydic.Item(hwndtp) & vbCrLf & ary(0, i)
    Else
       mydic.Add hwndtp, ary(0, i)
    End If
   Next i
   If mydic.Count <> 0 Then
      txtstr = ""
      For i = 1 To mydic.Count
       ky = WorksheetFunction.Small(mydic.keys, i)
       sp = Split(mydic.Item(ky), vbCrLf)
       For j = 0 To UBound(sp)
        Call cbclr
        Call SetForegroundWindow(sp(j))
        SendKeys "^c"
        Sleep 50
        Err.Clear
        cbstr = ""
        With CB
         On Error Resume Next
         .GetFromClipboard
         cbstr = .GetText
        End With
        If Err.Number = ernum Then
        Else
           If txtstr <> "" Then txtstr = txtstr & vbCrLf
           txtstr = txtstr & cbstr
        End If
        On Error GoTo 0
       Next j
       Erase sp
      Next i
   End If
   If txtstr <> "" Then Call TxtOutput(txtpath, txtstr)
   Call cbclr
 End Sub

 Function cbclr()
  If OpenClipboard(0) Then
     EmptyClipboard
     CloseClipboard
  End If
 End Function

 Function TxtOutput(ByVal newtxtpath As String, newtxtstr As String)
  Dim fnum As Integer
   fnum = FreeFile
   Open newtxtpath For Output As #fnum
   Print #fnum, newtxtstr;
   Close fnum
 End Function
（のらじろう） 2015/04/30(木) 22:43

コメント返信：

[ 一覧(最新更新順) ]

[[20150326105138]] 『開いているメモ帳(複数)の選択範囲の文字列を取得』（のらじろう） ページの最後に飛ぶ

[[20150326105138]]　『開いているメモ帳(複数)の選択範囲の文字列を取得』（のらじろう）　ページの最後に飛ぶ