[[20150903011516]] 『テキストファイル保存で文字化けが起きる』(原人ザボーガー) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『テキストファイル保存で文字化けが起きる』(原人ザボーガー)

 こんばんは、よろしくお願いいたします。

 ↓のカシスソーダさんのコードをお借りして使わせていただいております。
 開いているテキストファイル(メモ帳)の内容を取得してテキストファイルとして
 保存するものです。

[[20111214000005]] 『メモ帳内容取得で文字数制限を外す』(カシスソーダ)

 コードはほとんどそのままで今回一部改変しました。
 開いているメモ帳の内容に環境依存文字が含まれている場合は出来上がる
 テキストファイル内容が環境依存文字の部分が文字化けしてしまいます。
 テキストファイル作成(Function txtsakusei)の部分を書き換えてみましたが
 文字化けは改善しませんでした。

 メモ帳を手動でunicode形式で保存した場合は文字化けは起こりませんでした。
 環境依存文字の種類によっては文字化けしますが、手動でも文字化けする文字
 については目をつぶっております。

 手動で保存したら文字化けしない文字についてはマクロで自動保存しても文字
 化けしないようにするにはどのようにすればいいでしょうか?
 ご教示頂きますようお願いいたします。

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

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

 Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" _
  (ByVal hWnd As Long) As Long

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

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

 Const WM_GETTEXT As Long = &HD
 Const WM_GETTEXTLENGTH As Long = &HE
 Const WM_DESTROY As Long = &H2

 Sub test()
  Dim genzai As String
  Dim hWnd As Long, hWndEdit As Long
  Dim lngRet As Long
  Dim Title As String
  Dim TitleLen As Long
  Dim sts As Boolean
  Dim Ans  As Long
  Dim myText As String
  Dim MyLen As Long
  Dim tmp As String
  Dim newtxtstr As String
  Dim txtmei As String
  Dim fol As String
  Dim cnt As Integer
   '現在時刻
   genzai = Format(Now, "yy年mm月dd日hh時mm分ss秒")
   'フォルダ名
   fol = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
    & "\" & Format(Now, "yymmdd_hhmmss")
   cnt = 0
   hWnd = FindWindowEx(0, 0, "Notepad", vbNullString)
   If hWnd = 0 Then
      MsgBox "メモ帳が見つかりません。"
      Exit Sub
   End If
   Do While hWnd <> 0
    cnt = cnt + 1
    'フォルダ作成
    If cnt = 1 Then MkDir (fol)
    'タイトル取得
    TitleLen = GetWindowTextLength(hWnd)
    Title = String(TitleLen + 1, 0)
    sts = GetWindowText(hWnd, Title, TitleLen + 1)
    txtmei = Title
    txtmei = Left(txtmei, InStr(txtmei, vbNullChar) - 1)
    If Right(txtmei, 10) = ".txt - メモ帳" Then
       txtmei = Left(txtmei, Len(txtmei) - 10)
    ElseIf txtmei = "無題 - メモ帳" Then
       txtmei = "無題"
    End If
    'タイトルをテキストファイル名に改変
    txtmei = genzai & "_" & Format(cnt, "000") & "(" & txtmei & ")" & ".txt"
    hWndEdit = FindWindowEx(hWnd, 0, "Edit", "")
    MyLen = SendMessage(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&)
    myText = String(MyLen + 1, vbNullChar)
    lngRet = SendMessage(hWndEdit, WM_GETTEXT, Len(myText), ByVal myText)
    tmp = Left$(myText, InStr(1, myText, vbNullChar) - 1)
    newtxtstr = tmp & vbCrLf & genzai
    '新規テキストファイル出力
    Call txtsakusei(newtxtstr, fol & "\" & txtmei, "unicode") '変えてあります
    Ans = SendMessage(hWnd, WM_DESTROY, 0&, 0&)
    hWnd = FindWindowEx(0, hWnd, "NotePad", vbNullString)
   Loop
 End Sub

 '変えてあります
 Function txtsakusei(ByVal txtstr As String, txtpath As String, cset As String)
  Dim strm As New ADODB.Stream '★
   With strm
    .Charset = cset
    'Streamオブジェクトを開く
    .Open
    .writeText (txtstr)
    .saveToFile txtpath, 2
    'Streamオブジェクトを閉じる
    .Close
    Set strm = Nothing
   End With
 End Function

 ’付加
 Function CharSetOfText(Path)
  Dim FSO As Object
  Dim objFile As Object
  Dim htmlfile As Object
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set objFile = FSO.GetFile(Path)
  Set htmlfile = GetObject(objFile.Path, "htmlfile")
  Do While htmlfile.readyState <> "complete"
   Sleep 100
   DoEvents
  Loop
  CharSetOfText = htmlfile.Charset
  Set objFile = Nothing
  Set FSO = Nothing
 End Function

< 使用 Excel:Excel2007、使用 OS:WindowsVista >


こんにちは

https://msdn.microsoft.com/ja-jp/library/Cc364313.aspx

に有る通り、渡せる文字でないものは文字化けするのは仕方ないのでは?

後は、ADODB.Stream を使わない方法に変更するかです。

(ウッシ) 2015/09/03(木) 08:24


 ウッシさん、ご回答ありがとうございます。

 リンク元の

 Function txtsakusei(ByVal txtstr As String, txtpath As String)
  Dim fnum As Integer
   fnum = FreeFile
   Open txtpath For Output As fnum
    Print #fnum, txtstr;
   Close fnum
 End Function

 のままだったら文字化けしたので今回変えて試してみました。
(原人ザボーガー) 2015/09/03(木) 08:36

 > tmp = Left$(myText, InStr(1, myText, vbNullChar) - 1)
 >  newtxtstr = tmp & vbCrLf & genzai

 ↓のように変えてみました。
 テキストファイルに書き込む内容を一旦セルに書き出してみました。
 セルに転記された文字列は文字化けしてました。
 メモ帳内容取得段階で既に文字化けしているようです。

  tmp = Left$(myText, InStr(1, myText, vbNullChar) - 1)
  ActiveCell.Value = tmp
  DoEvents
  Sleep 2000
  newtxtstr = tmp & vbCrLf & genzai
(原人ザボーガー) 2015/09/03(木) 08:53

こんにちは

lngRet = SendMessage(hWndEdit, WM_GETTEXT, Len(myText), ByVal myText)

のSendMessageの段階で文字化けしてますね。

APIのSendMessageの問題なので、別の方法でメモ帳のデータを取得するか、
開いてるメモ帳を名前を付けて保存する方向に変更した方がいいかも・・・

(ウッシ) 2015/09/03(木) 09:24


 ウッシさん、ご回答ありがとうございます。

 >APIのSendMessageの問題なので、別の方法でメモ帳のデータを取得するか、 
 >開いてるメモ帳を名前を付けて保存する方向に変更した方がいいかも・・・ 

 その方向で進めてみます。
 ありがとうございました。
(原人ザボーガー) 2015/09/03(木) 09:41

 ANSI対応のものを呼んでいるからUnicodeは拾えない道理なので
Unicode対応のものを呼んでみようじゃないかという話で
元の記述をそのまま拾い上げつつとりあえず動いたコードぺたり
 
Option Explicit
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageUni Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SendMessageUniStr Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const WM_GETTEXT As Long = &HD
Const WM_GETTEXTLENGTH As Long = &HE
Const WM_DESTROY As Long = &H2
Sub test()
    Dim genzai As String
    Dim hWnd As Long
    Dim hWndEdit As Long
    Dim lngRet As Long
    Dim Title As String
    Dim TitleLen As Long
    Dim sts As Boolean
    Dim Ans  As Long
    Dim myText As String
    Dim MyLen As Long
    Dim tmp As String
    Dim newtxtstr As String
    Dim txtmei As String
    Dim fol As String
    Dim cnt As Integer
    Dim byt() As Byte
    Dim bytfooter() As Byte
    Dim fnum As Integer
    '現在時刻
    genzai = Format(Now, "yy年mm月dd日hh時mm分ss秒")
    bytfooter = vbCrLf & genzai 'フッタとして書き込むByte配列をセット
    'フォルダ名
    fol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, "yymmdd_hhmmss")
    cnt = 0
    hWnd = FindWindowEx(0, 0, "Notepad", vbNullString)
    If hWnd = 0 Then
        MsgBox "メモ帳が見つかりません。"
        Exit Sub
    End If
    Do While hWnd <> 0
        cnt = cnt + 1
        'フォルダ作成
        If cnt = 1 Then MkDir (fol)
        'タイトル取得
        TitleLen = GetWindowTextLength(hWnd)
        Title = String(TitleLen + 1, 0)
        sts = GetWindowText(hWnd, Title, TitleLen)
        txtmei = Title
        txtmei = Left(txtmei, InStr(txtmei, vbNullChar) - 1)
        If Right(txtmei, 10) = ".txt - メモ帳" Then
            txtmei = Left(txtmei, Len(txtmei) - 10)
        ElseIf txtmei = "無題 - メモ帳" Then
            txtmei = "無題"
        End If
        'タイトルをテキストファイル名に改変
        txtmei = genzai & "_" & Format(cnt, "000") & "(" & txtmei & ")" & ".txt"
        hWndEdit = FindWindowEx(hWnd, 0, "Edit", "")
        MyLen = SendMessageUni(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) '文字数が取得される様子
        ReDim byt(0 To MyLen * 2 - 1) '1文字2Byte前提で領域確保
        'byt = String(MyLen, vbNullChar) 'NULL文字で初期化と考えても良いか
        lngRet = SendMessageUniStr(hWndEdit, WM_GETTEXT, UBound(byt) + 1, VarPtr(byt(0)))
        '新規テキストファイル出力
        fnum = FreeFile
        Open fol & "\" & txtmei For Binary As #fnum
        Put #fnum, , &HFEFF 'BOM
        Put #fnum, , byt
        Put #fnum, , bytfooter
        Close #fnum
        Ans = SendMessage(hWnd, WM_DESTROY, 0&, 0&)
        hWnd = FindWindowEx(0, hWnd, "NotePad", vbNullString)
    Loop
End Sub
(ご近所PG) 2015/09/03(木) 12:22

 ご近所PGさん、ご回答ありがとうございます。

 バイナリーモードというのを初めて見ました。
 というか、今まで見ていたとは思うのですが、頭に入っていなかったのだ
 と思います。まだ少しだけしか調べてませんが、使いこなしたら便利に
 なると思います。
 勉強してみます。ありがとうございました。
(原人ザボーガー) 2015/09/03(木) 13:40

こんにちは、ご近所PGさん

SendMessageWってあったんですね。

(ウッシ) 2015/09/03(木) 14:13


 テキストファイル出力部分のみ目が行ってましたが、

 Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Private Declare Function SendMessageUni Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
 Private Declare Function SendMessageUniStr Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

 の部分が付加されていたんですね。勉強します。
(原人ザボーガー) 2015/09/03(木) 15:22

 主眼はソコです。
ここら辺を見てみてください。
 
文字列を使用する
https://msdn.microsoft.com/ja-jp/library/windows/desktop/ff381407%28v=vs.85%29.aspx
この真ん中らへんくらい

Unicode 関数と ANSI 関数

マイクロソフトが Windows に Unicode のサポートを導入したときは、スムーズな移行を実現するために ANSI 文字列と Unicode 文字列のそれぞれに対応する 2 つの API を提供しました。たとえば、ウィンドウのタイトル バーのテキストを設定する関数には次の 2 つがあります。

SetWindowTextA: ANSI 文字列を使用します。
SetWindowTextW: Unicode 文字列を使用します。

 みたいな。
あ、ちなみに「SendMessageStr」は自分で検証するために追加しただけで
実際にコードの中では使用してません。(デバッグで使っただけ)
(ご近所PG) 2015/09/03(木) 16:06

 別々のテキストファイルではなく一つのテキストファイルに保存、としてみました。
 ありがとうございました。

 Option Explicit
 Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
 Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
 Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
 Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
 Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Private Declare Function SendMessageUni Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
 Private Declare Function SendMessageUniStr Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Const WM_GETTEXT As Long = &HD
 Const WM_GETTEXTLENGTH As Long = &HE
 Const WM_DESTROY As Long = &H2

 Sub test()
     Dim genzai As String
     Dim hWnd As Long
     Dim hWndEdit As Long
     Dim lngRet As Long
     Dim Title As String
     Dim TitleLen As Long
     Dim sts As Boolean
     Dim Ans  As Long
     Dim myText As String
     Dim MyLen As Long
     Dim tmp As String
     Dim newtxtstr As String
     Dim txtmei As String
     Dim fol As String
     Dim cnt As Integer
     Dim byt() As Byte
     Dim bytlf() As Byte
     Dim bytfooter() As Byte
     Dim fnum As Integer
     '現在時刻
     genzai = Format(Now, "yy年mm月dd日hh時mm分ss秒")
     bytlf = vbCrLf & "----------" & vbCrLf  'ファイルとファイルの間に書き込む改行と区切りByte配列をセット
     bytfooter = genzai  'フッタとして書き込むByte配列をセット
     'フォルダ名
     fol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
      'テキストファイルパス指定
     txtmei = fol & "\" & genzai & ".txt"
     cnt = 0
     hWnd = FindWindowEx(0, 0, "Notepad", vbNullString)
     If hWnd = 0 Then
         MsgBox "メモ帳が見つかりません。"
         Exit Sub
     End If
     Do While hWnd <> 0
         cnt = cnt + 1
         If cnt = 1 Then 'テキストファイルを開く
            fnum = FreeFile
            Open txtmei For Binary As #fnum
            Put #fnum, , &HFEFF 'BOM
         End If
         'タイトル取得
         'TitleLen = GetWindowTextLength(hWnd)
         'Title = String(TitleLen + 1, 0)
         'sts = GetWindowText(hWnd, Title, TitleLen)
         'txtmei = Title
         'txtmei = Left(txtmei, InStr(txtmei, vbNullChar) - 1)
         'If Right(txtmei, 10) = ".txt - メモ帳" Then
         '    txtmei = Left(txtmei, Len(txtmei) - 10)
         'ElseIf txtmei = "無題 - メモ帳" Then
         '    txtmei = "無題"
         'End If
         hWndEdit = FindWindowEx(hWnd, 0, "Edit", "")
         MyLen = SendMessageUni(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) '文字数が取得される様子
         ReDim byt(0 To MyLen * 2 - 1) '1文字2Byte前提で領域確保
         'byt = String(MyLen, vbNullChar) 'NULL文字で初期化と考えても良いか
         lngRet = SendMessageUniStr(hWndEdit, WM_GETTEXT, UBound(byt) + 1, VarPtr(byt(0)))
         'テキストファイル出力
         Put #fnum, , byt '内容
         Put #fnum, , bytlf '改行と区切り文字付加
         Ans = SendMessage(hWnd, WM_DESTROY, 0&, 0&)
         hWnd = FindWindowEx(0, hWnd, "NotePad", vbNullString)
     Loop
     If cnt <> 0 Then 'テキストファイルを閉じる
        Put #fnum, , bytfooter
        Close #fnum
    End If
 End Sub
(原人サボーガー) 2015/09/03(木) 19:00

 少し処理を変えて、というか、発展させてみようと思います。
 現在は、メモ帳の内容全体が取得対象になっていますが、今度は、メモ帳のウィンドウで
 マウスで選択した範囲のテキストを取得する、というのをやってみようと考えています。

 調べたら、
 EM_GETSEL
 というのが使えるかもしれない、ということが分かりました。

 これを使うと、ウィンドウの中の選択範囲の開始と終わりが取得できるようです。

http://wisdom.sakura.ne.jp/system/winapi/win32/win67.html

 >エディットコントロールの情報を得る場合もメッセージを使う
 >EM_GETSEL を送れば、現在選択されているテキストの位置を知ることができる
 >これは、WPARAM に開始位置を格納するための32ビット整数型変数へのポインタを
 >LPARAM には、終了位置を格納するための32ビット整数型変数へのポインタを指定します

 >ただし、このメッセージは SendMessage() 関数の戻り値からも値を取得できます
 >下位ワードに選択範囲の開始位置、上位ワードに終了位置が格納されています
 >この方法で値を取得する時、変数で受け取る必要がない場合
 >WPARAM と LPARAM のパラメータには NULL を指定することができます

 コードの宣言部に
 Const EM_GETSEL As Long = &HB0
 を付加、
 >MyLen = SendMessageUni(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) '文字数が取得される様子
 の部分に
 EM_GETSEL
 を組み込んでやればいいと思うのですが、組み込み方と、
 >lngRet = SendMessageUniStr(hWndEdit, WM_GETTEXT, UBound(byt) + 1, VarPtr(byt(0)))
 をどのように変えたらいいかが分かりません。

 ヒントや参考ページがありましたらご教示お願いいたします。
(原人サボーガー) 2015/09/04(金) 08:46

 与えられた情報を見て考えるなら
例えばこんな感じとかで
 
Option Explicit
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageUni Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SendMessageUniStr Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_GETTEXT As Long = &HD
Const WM_GETTEXTLENGTH As Long = &HE
Const WM_DESTROY As Long = &H2
Const EM_GETSEL As Long = &HB0
Sub test()
    Dim genzai As String
    Dim hWnd As Long
    Dim hWndEdit As Long
    Dim lngRet As Long
    Dim MyLen As Long
    Dim txtmei As String
    Dim cnt As Integer
    Dim byt() As Byte
    Dim bytlf() As Byte
    Dim bytfooter() As Byte
    Dim fnum As Integer
    Dim i As Long
    Dim seltxtS As Long
    Dim seltxtE As Long
    genzai = Format(Now, "yy年mm月dd日hh時mm分ss秒") '現在時刻
    bytlf = vbCrLf & "----------" & vbCrLf  'ファイルとファイルの間に書き込む改行と区切りByte配列をセット
    bytfooter = genzai  'フッタとして書き込むByte配列をセット
    'ファイルパス指定
    txtmei = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    txtmei = txtmei & "\" & genzai & ".txt"
    cnt = 0
    hWnd = FindWindowEx(0, 0, "Notepad", vbNullString)
    If hWnd = 0 Then
        MsgBox "メモ帳が見つかりません。"
        Exit Sub
    End If
    Do While hWnd <> 0
        cnt = cnt + 1
        If cnt = 1 Then 'テキストファイルを開く
            fnum = FreeFile
            Open txtmei For Binary As #fnum
            Put #fnum, , &HFEFF 'BOM
        End If
        hWndEdit = FindWindowEx(hWnd, 0, "Edit", "")
        '初期化
        seltxtS = 0
        seltxtE = 0
        lngRet = SendMessageUni(hWndEdit, EM_GETSEL, VarPtr(seltxtS), VarPtr(seltxtE)) '範囲選択中の文字位置
        '戻り値から分けるなら
'        lngRet = SendMessageUni(hWndEdit, EM_GETSEL, 0&, 0&) '範囲選択中の文字位置
'        seltxtS = LW(lngRet)
'        seltxtE = HW(lngRet)
        MyLen = SendMessageUni(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) '文字数が取得される様子
        ReDim byt(0 To MyLen * 2 - 1) '1文字2Byte前提で領域確保
        lngRet = SendMessageUniStr(hWndEdit, WM_GETTEXT, UBound(byt) + 1, VarPtr(byt(0)))
        'ファイルへ出力
        If seltxtE - seltxtS = 0 Then
            Put #fnum, , byt() '範囲選択されていない 全内容出力
        Else
            '範囲選択部分のみ出力 1文字2Byte前提
            For i = seltxtS * 2 To seltxtE * 2 - 1
                Put #fnum, , byt(i)
            Next
        End If
        Put #fnum, , bytlf '改行と区切り文字付加
        lngRet = SendMessage(hWnd, WM_DESTROY, 0&, 0&)
        hWnd = FindWindowEx(0, hWnd, "NotePad", vbNullString)
    Loop
    If cnt <> 0 Then 'テキストファイルを閉じる
        Put #fnum, , bytfooter
        Close #fnum
    End If
End Sub
Private Function LW(ByVal Value As Long) As Long
    LW = IIf((Value And &HFFFF&) > &H7FFF, (Value And &HFFFF&) - &H10000, Value And &HFFFF&)
End Function
Private Function HW(ByVal Value As Long) As Long
    HW = (Value And &HFFFF0000) \ &H10000
End Function

 範囲選択された位置は位置で貰って、
テキスト取得は全部取得した上で
その中のどこを書き出すのよ、という流れで。
直接範囲部分だけを拾えるのかとかはわかりません。
(これらAPIの操作自体、この質問にある情報から調べただけなので経験値が無いです)
ちょっと関数名修正 13:38
(ご近所PG) 2015/09/04(金) 13:32

 ご近所PGさん、ご回答ありがとうございます。

 ↓が大いに勉強になりました。ありがとうございます。
 戻り値の取得方法がいまいちわかっておりませんでした。

 '        seltxtS = LW(lngRet)
 '        seltxtE = UW(lngRet)

 ご教示いただきました記述で作動しましたが、複数メモ帳が開いている状態で
 実行したら、選択内容が新規テキストファイルに反映されない場合がありました。

 ↓のようなテキストファイルが生成されます。

 aaa
 ----------
 bbb
 ----------

 ----------

 ----------
 15年09月04日19時07分26秒

   lngRet = SendMessage(hWnd, WM_DESTROY, 0&, 0&)

 をコメントアウトして続けて実行したら、反映されないメモ帳は同じものでした。

 一旦すべてのメモ帳とブックを閉じ、再度メモ帳とブックを開いてマクロを実行しても
 同様でした。

 しばらく時間をおいて同じ複数のメモ帳を開いて実行すると、今度は先ほどとは別の
 メモ帳の選択内容が反映されない、ということも起こっています。

 また、マクロを実行すると、エクセルが落ち、中途半端なテキストファイルが生成され
 ることもあります。

 たとえば、4つのメモ帳を開いて実行したら2つのメモ帳の内容は反映されてるけど
 他の2つのメモ帳の内容とフッターが反映されてない、という感じです。

 エラーの回避方法がありましたらご教示お願いいたします。
 お手数おかけしますがよろしくお願いいたします。
(原人ザボーガー) 2015/09/04(金) 19:15

 もしかしたら、ですけど、文字列が取得できないファイルは、選択範囲が小さくても
 元々のファイルのサイズが大きい場合のようです。
 ファイルサイズが16KBより大きいと途端に文字列が取得できなくなるような感じです。
(原人ザボーガー) 2015/09/04(金) 22:52

 パソコンの性能は詳しくないのですが、コントロールパネルで見たら、

 プロセッサ:Genuin Intel(R) CPU   @ 1.80GHz
 メモリ(RAM): 4.00GB
 システムの種類: 32ビットオペレーティングシステム

 となってました。
(原人ザボーガー) 2015/09/05(土) 08:37

 検証してはいないですが、
私の記述の中で以下の部分
        lngRet = SendMessageUniStr(hWndEdit, WM_GETTEXT, UBound(byt) + 1, VarPtr(byt(0)))
UBoundの戻り値を今まで気にしたことが無かったのですが、
どうもInteger型みたいなのでここが悪さしてるかもしれません。
(ご近所PG) 2015/09/05(土) 12:53

 と思ったらLongと書かれてるのもあるなぁ……
ちょっと細かに見る時間がないのでその辺を疑ってみて、もし解決しないなら
先にウッシさんも書かれてた様に一度ファイルに保存してから開いて読み込んで
みたいな流れを考えてみても良いかもしれません。
(ご近所PG) 2015/09/05(土) 12:57

 環境違うながらちょっと試すとファイルサイズ64K以上だとうまくGETTEXTでbyt配列に戻ってこないみたい?
GETTEXTLENGHTは値を返してくるから他に書き方があるかもしれないけど、はて。
あとLW,HWで範囲の位置を拾うのは32Kまでしか返せないので直接値を得る記述の方使ってだと正しく位置は拾えてる。
(ご近所PG) 2015/09/05(土) 13:39

 ご近所PGさん、ご回答ありがとうございます。

 >先にウッシさんも書かれてた様に一度ファイルに保存してから開いて読み込んで
 >みたいな流れを考えてみても良いかもしれません。

 今回の質問を機にAPIを調べています。名前を付けて保存もAPIでメモ帳の子ウィンドウ
 を制御して名前を付けて保存のウィンドウを表示し、ファイル名と文字コードを設定、という
 流れのようです。

 ↓のNo.3の方の回答が参考になりそうです。
http://oshiete.goo.ne.jp/qa/2329915.html

 処理が違いますのでコマンドID等を調べ中です。
 ただ、当方VBの環境がないので調べるのに時間がかかりそうです。こちらも
 ヒントがありましたらご教示お願いいたします。

 過去ログを調べたら、のらじろうさんという方がやはりAPIを使った方法で似たような処理
 を行っていました。

[[20150517100427]] 『メモ帳内容の全範囲を選択しクリップボード格納(A』(のらじろう)

 こちらも勉強してみます。
(原人ザボーガー) 2015/09/06(日) 01:15

 とりあえずしばらく時間が作れませんという宣言だけ。気にはなってるのですが。
どなたか興味関心ある方はご参加のほど……
といってもExcelの範疇から外れてるのでアレですが。
(ご近所PG) 2015/09/07(月) 14:07

 ご近所PGさん、ご回答ありがとうございます。

 気に掛けていただきありがとうございます。

 調べながら気長にボチボチやってみます。
 何かありましたら書き込みいただきましたら幸いです。

(原人ザボーガー) 2015/09/07(月) 21:21


 いろいろ試してみましたが、エクセルが落ちたりするのを止められませんでした。
 そこで既に開いているメモ帳の内容を取得するのは諦めて、ユーザーフォームに
 マルチページを配置し、マルチページに必要なだけページを追加し、ページの中に
 テキストボックスを配置し、テキストボックスにテキストファイルの内容を表示、という
 方法に変えることにしました。
 まだ作成途中ですが、あとは自力で出来そうです。
 いろいろご教示いただきありがとうございました。

 ’マルチページにページとテキストボックスを追加
 ’この中にテキストファイルの内容を取得して転記する処理を追加する
 Private Sub CommandButton1_Click()
  Dim ctrl As Object
  Dim pg As Object
  With Me.MultiPage1
    Set pg = .Pages.Add
    With pg
     Set ctrl = .Controls.Add("Forms.TextBox.1")
     With ctrl
      .Top = 0
      .Left = 0
      .Height = Me.MultiPage1.Height - 20
      .Width = Me.MultiPage1.Width - 10
      .MultiLine = True
      .ScrollBars = fmScrollBarsBoth
      .Value = Now 'ここをテキストファイル内容取得に変更
     End With
    End With
  End With
 End Sub

 ’マルチページの各ページのテキストボックスで選択している範囲の文字列を取得
 Private Sub CommandButton2_Click()
  Dim i As Integer
  Dim cnt As Integer
   cnt = Me.MultiPage1.Pages.Count
   For i = 1 To cnt
    MsgBox Me.MultiPage1.Pages("Page" & i).Controls("textbox" & i).SelText
   Next i
 End Sub

 ’ユーザーフォーム起動時マルチページにテキストボックスを追加
 Private Sub UserForm_Initialize()
  Dim ctrl As Object
  Dim pg As Object
  With Me.MultiPage1
    Set pg = .Page1
    With pg
     Set ctrl = .Controls.Add("Forms.TextBox.1")
     With ctrl
      .Top = 0
      .Left = 0
      .Height = Me.MultiPage1.Height - 20
      .Width = Me.MultiPage1.Width - 10
      .MultiLine = True
      .ScrollBars = fmScrollBarsBoth
      .Value = Now
     End With
    End With
  End With
 End Sub
(原人ザボーガー) 2015/09/13(日) 21:36

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.