Microsoft Access Club Access超初心者対象Forum Access初・中級者対象Forum Access VBA Tips Forum DAO、ADO、SQL Forum

     

リストへもどる

投稿記事の一括表示

タイトルクリップボードのhtmlを取得する。
記事No83173
投稿日: 2017/11/15(Wed) 22:48
投稿者チョコ
解決済: ON
OS:win7
Access Version:2013

よろしくお願い申し上げます。

何らかのホームページの全てを選択して、コピーしクリップボードにコピーします。
そのhtmlソースを取得したいと思い、下記サイトを参考にAPIにて実装しました。

ところが、日本語の部分が文字化けしてしまいます。
対処方法はないでしょうか?
https://support.microsoft.com/en-us/help/274326/how-to-add-html-code-to-the-clipboard-by-using-visual-basic

以下は実装したコードです。
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpData As Long) As Long
Private Const m_sDescription = "Version:1.0" & vbCrLf & _
"StartHTML:aaaaaaaaaa" & vbCrLf & _
"EndHTML:bbbbbbbbbb" & vbCrLf & _
"StartFragment:cccccccccc" & vbCrLf & _
"EndFragment:dddddddddd" & vbCrLf
Private m_cfHTMLClipFormat As Long

Public Const CF_TEXT As Long = 1


Function RegisterCF() As Long
If (m_cfHTMLClipFormat = 0) Then
m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
End If
RegisterCF = m_cfHTMLClipFormat
End Function

Public Function GetHTMLClipboard() As String
Dim sData As String
If RegisterCF = 0 Then Exit Function
If CBool(OpenClipboard(0)) Then
Dim hMemHandle As Long, lpData As Long
Dim nClipSize As Long
GlobalUnlock hMemHandle
hMemHandle = GetClipboardData(m_cfHTMLClipFormat)
If CBool(hMemHandle) Then
lpData = GlobalLock(hMemHandle)
If lpData <> 0 Then
nClipSize = lstrlen(lpData)
sData = String(nClipSize + 10, 0)
Call CopyMemory(ByVal sData, ByVal lpData, nClipSize)
Dim nStartFrag As Long, nEndFrag As Long
Dim nIndx As Long
nIndx = InStr(sData, "StartFragment:")
If nIndx Then
nStartFrag = CLng(Mid(sData, nIndx + Len("StartFragment:"), 10))
End If
nIndx = InStr(sData, "EndFragment:")
If nIndx Then
nEndFrag = CLng(Mid(sData, nIndx + Len("EndFragment:"), 10))
End If
If (nStartFrag > 0 And nEndFrag > 0) Then
GetHTMLClipboard = Mid(sData, nStartFrag + 1, (nEndFrag - nStartFrag))
End If
End If
End If
Call CloseClipboard
End If
End Function

タイトルRe: クリップボードのhtmlを取得する。
記事No83174
投稿日: 2017/11/16(Thu) 17:50
投稿者mayu
解決済: ON
> ところが、日本語の部分が文字化けしてしまいます。

メモリ上のデータが UTF-8 / UTF-16 だからでしょう。

VBAで文字列変数を扱う ANSI へのコード変換も面倒でしょうから
CP932 の クリップボードフォーマット CF_TEXT を
GetClipboardData関数の引数に指定すればどうでしょうか。
なお、クリップボードから取得した文字列が html になっているかどうかは
別途、スクレイピングを実施すればいいと思います。


Private Declare Function OpenClipboard Lib "user32" ( _
    ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" ( _
    ByVal lpString1 As Any, _
    ByVal lpString2 As Any) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal format As Long) As Long

Private Const CF_TEXT = &H1

Function sample() As String
  Dim lngHandle As Long
  Dim lpData    As Long
  Dim strBuff   As String
  
  sample = vbNullString
  If (OpenClipboard(0&) = 0) Then Exit Function
  
  If (IsClipboardFormatAvailable(CF_TEXT) <> 0) Then
    lngHandle = GetClipboardData(CF_TEXT)
    If (lngHandle <> 0) Then
      lpData = GlobalLock(lngHandle)
      
      If (lpData <> 0) Then
        strBuff = String$(GlobalSize(lpData), vbNullChar)
        If (lstrcpy(strBuff, lpData) <> 0) Then
          sample = Mid$(strBuff, 1, InStr(1, strBuff, vbNullChar, vbBinaryCompare) - 1)
        End If
        Call GlobalUnlock(lngHandle)
      End If
    End If
  End If
  
  Call CloseClipboard
End Function

タイトルRe^2: クリップボードのhtmlを取得する。
記事No83175
投稿日: 2017/11/16(Thu) 22:49
投稿者チョコ
解決済: ON
ご回答ありがとうございます。

書き込んで頂きましたコードをテストして見たところ、
デバックプリントでは、ソースではなく、日本語だけの表示になっています。

私の貼り付けたコードのどこを修正すめば良いのでしょうか。
お手数をお掛けいたします。

タイトルRe^3: クリップボードのhtmlを取得する。
記事No83176
投稿日: 2017/11/18(Sat) 11:02
投稿者mayu
解決済: ON
> デバックプリントでは、ソースではなく、日本語だけの表示になっています。
> 私の貼り付けたコードのどこを修正すれば良いのでしょうか。

クリップボードの Common Text Formats の指定を HTML Format にしたまま
html中の日本語も正確に表示したいとなると
データを String配列ではなく、Byte配列に格納して
CopyMemory APIの引数の型も適宜変更します。こんな感じでしょうか。


Private Declare Function OpenClipboard Lib "user32" ( _
    ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal format As Long) As Long
Private Declare Function RegisterClipboardFormatA Lib "user32.dll" ( _
    ByVal lpszFormat As String) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
    ByVal Source As Long, _
    ByVal Length As Long)

Function GetHTMLClipboardEX() As String
  Dim lngCF_HTML As Long
  Dim lngHandle As Long
  Dim lngSize  As Long
  Dim lpData   As Long
  Dim idx    As Long
  Dim iStart   As Long
  Dim btBuff()  As Byte
  Dim strHTML  As String
  
  GetHTMLClipboardEX = vbNullString
  lngCF_HTML = RegisterClipboardFormatA("HTML Format")
  
  If (IsClipboardFormatAvailable(lngCF_HTML) = 0) Then Exit Function
  If (OpenClipboard(0&) = 0) Then Exit Function
  lngHandle = GetClipboardData(lngCF_HTML)
  
  If (lngHandle <> 0) Then
    lpData = GlobalLock(lngHandle)
    
    If (lpData <> 0) Then
      lngSize = GlobalSize(lpData)
      ReDim btBuff(CLng(lngSize) - CLng(1)) As Byte
      Call MoveMemory(CLng(VarPtr(btBuff(0))), lpData, lngSize)
      strHTML = GetString(btBuff) 'Qiita掲載の関数にバイト配列を渡す
      
      idx = InStr(1, strHTML, "<!--StartFragment-->", vbBinaryCompare)
      If (idx) Then
        iStart = idx + Len("<!--StartFragment-->")
        idx = InStr(1, strHTML, "<!--EndFragment-->", vbBinaryCompare)
        If (idx) Then
          GetHTMLClipboardEX = Mid(strHTML, iStart, (idx - iStart))
        End If
      End If
      
      Call GlobalUnlock(lngHandle)
    End If
  End If
  Call CloseClipboard
End Function



'/*
' **************************************************************
' *
' *  ■ 以下、【 VBA で UTF-8 変換 】
' *  https://qiita.com/RelaxTools/items/fc54192201d24b466cb5
' *  から転用
' *
' **************************************************************
'*/
Public Function GetString(ByRef bytBuf() As Byte) As String

  Dim bytRet() As Byte
  Dim i As Long
  Dim lngPos As Long
  Dim b0 As Long
  Dim b1 As Long
  Dim b2 As Long
  Dim b3 As Long

  GetString = ""

  On Error GoTo e

  i = LBound(bytBuf)
  ReDim bytRet(0 To (UBound(bytBuf) + 1) * 2)
  i = 0
  lngPos = 0

  Do Until i > UBound(bytBuf)

    b0 = bytBuf(i): i = i + 1

    Select Case True

'      // UTF-8:   [0xxx xxxx]
'      // Unicode: [0000 0000] [0xxx xxxx]
      Case (b0 < &H80&)
        bytRet(lngPos) = b0: lngPos = lngPos + 1
        bytRet(lngPos) = 0:  lngPos = lngPos + 1

'      // UTF-8:   [110y yyyy] [10xx xxxx]
'      // Unicode: [0000 0yyy] [yyxx xxxx]
      Case ((b0 And &HE0&) = &HC0 And (b0 And &H1E&) <> 0)

        b1 = bytBuf(i): i = i + 1
        Dim c As Long
        c = ((LShift(b0, 6)) And &H7C0&) Or (b1 And &H3F&)

        bytRet(lngPos) = LByte(c): lngPos = lngPos + 1
        bytRet(lngPos) = UByte(c): lngPos = lngPos + 1

'      // UTF-8:   [1110 zzzz] [10yy yyyy] [10xx xxxx]
'      // Unicode: [zzzz yyyy] [yyxx xxxx]
      Case ((b0 And &HF0&) = &HE0&)

        b1 = bytBuf(i): i = i + 1
        b2 = bytBuf(i): i = i + 1

        c = ((LShift(b0, 12)) And &HF000&) Or ((LShift(b1, 6)) And &HFC0&) Or (b2 And &H3F&)

        bytRet(lngPos) = LByte(c)
        lngPos = lngPos + 1
        bytRet(lngPos) = UByte(c)
        lngPos = lngPos + 1

'      // UTF-8:   [1111 0uuu] [10uu zzzz] [10yy yyyy] [10xx xxxx]*
'      // Unicode: [1101 10ww] [wwzz zzyy] (high surrogate)
'      //          [1101 11yy] [yyxx xxxx] (low surrogate)
'      //          * uuuuu = wwww + 1
      Case ((b0 And &HF8) = &HF0&)

        b1 = bytBuf(i): i = i + 1
        b2 = bytBuf(i): i = i + 1
        b3 = bytBuf(i): i = i + 1

        Dim uuuuu As Long
        Dim wwww As Long
        Dim zzzz As Long
        Dim yyyyyy As Long
        Dim xxxxxx As Long
        Dim hs As Long
        Dim ls As Long

'        // decode bytes into surrogate characters
        uuuuu = ((LShift(b0, 2)) And &H1C&) Or ((RShift(b1, 4)) And &H3&)
'        If (uuuuu > &H10) Then
'          invalidSurrogate(uuuuu);
'        End If
        wwww = uuuuu - 1
        zzzz = b1 And &HF&
        yyyyyy = b2 And &H3F&
        xxxxxx = b3 And &H3F&

        hs = &HD800& Or ((LShift(wwww, 6)) And &H3C0&) Or (LShift(zzzz, 2)) Or (RShift(yyyyyy, 4))
        ls = &HDC00& Or ((LShift(yyyyyy, 6)) And &H3C0&) Or xxxxxx

        bytRet(lngPos) = LByte(hs)
        lngPos = lngPos + 1
        bytRet(lngPos) = UByte(hs)
        lngPos = lngPos + 1

        bytRet(lngPos) = LByte(ls)
        lngPos = lngPos + 1
        bytRet(lngPos) = UByte(ls)
        lngPos = lngPos + 1

    End Select

  Loop

  GetString = LeftB(bytRet, lngPos)
  Exit Function
e:

End Function
'------------------------------------------------------------------------------------------------------------------------
' UTF-16(LE) → UTF-8
'------------------------------------------------------------------------------------------------------------------------
Public Function getBytes(ByVal strBuf As String) As Byte()

  Dim bytBuf() As Byte
  Dim lngBuf As Long
  Dim bytRet() As Byte

  Dim i As Long
  Dim lngPos As Long

  On Error GoTo e

  If strBuf = "" Then
    Exit Function
  End If

  bytBuf = strBuf

  'バッファを最大 1文字×4バイト分確保
  ReDim bytRet(0 To (Len(strBuf) * 4))

  lngPos = 0

  For i = LBound(bytBuf) To UBound(bytBuf) Step 2

    lngBuf = LShift(bytBuf(i + 1), 8) + bytBuf(i)

    Select Case lngBuf

      Case Is < &H80&

        'UTF-8(ASCII)
        bytRet(lngPos) = lngBuf
        lngPos = lngPos + 1

      Case Is < &H800&

        'UTF-8(2バイト)
        bytRet(lngPos) = &HC0& Or RShift(lngBuf, 6)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (lngBuf And &H3F&)
        lngPos = lngPos + 1

      Case &HD800& To &HDBFF&

        Dim lngHigh As Long
        Dim lngLow As Long

        lngHigh = lngBuf

        i = i + 2
        lngLow = LShift(bytBuf(i + 1), 8) + bytBuf(i)

        'サロゲート(UTF-16→Unicode)
        lngBuf = &H10000 + (lngHigh - &HD800&) * &H400& + (lngLow - &HDC00&)

        'UTF-8(4バイト)
        bytRet(lngPos) = &HF0& Or RShift(lngBuf, 18)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (RShift(lngBuf, 12) And &H3F&)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (RShift(lngBuf, 6) And &H3F&)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (lngBuf And &H3F&)
        lngPos = lngPos + 1

      Case Else

        'UTF-8(3バイト)
        bytRet(lngPos) = &HE0& Or RShift(lngBuf, 12)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (RShift(lngBuf, 6) And &H3F&)
        lngPos = lngPos + 1

        bytRet(lngPos) = &H80& Or (lngBuf And &H3F&)
        lngPos = lngPos + 1

    End Select

  Next

  getBytes = LeftB(bytRet, lngPos)
  Exit Function
e:

End Function

'------------------------------------------------------------------------------------------------------------------------
' 下位バイト取得
'------------------------------------------------------------------------------------------------------------------------
Function LByte(ByVal lngValue As Long) As Long
  LByte = lngValue And &HFF&
End Function
'------------------------------------------------------------------------------------------------------------------------
' 上位バイト取得
'------------------------------------------------------------------------------------------------------------------------
Function UByte(ByVal lngValue As Long) As Long
  UByte = RShift((lngValue And &HFF00&), 8)
End Function
'------------------------------------------------------------------------------------------------------------------------
' 右シフト
'------------------------------------------------------------------------------------------------------------------------
Function RShift(ByVal lngValue As Long, ByVal lngKeta As Long) As Long
  RShift = lngValue \ (2 ^ lngKeta)
End Function
'------------------------------------------------------------------------------------------------------------------------
' 左シフト
'------------------------------------------------------------------------------------------------------------------------
Function LShift(ByVal lngValue As Long, ByVal lngKeta As Long) As Long
  LShift = lngValue * (2 ^ lngKeta)
End Function

タイトル別案
記事No83177
投稿日: 2017/11/18(Sat) 11:04
投稿者mayu
解決済: ON
APIを使わず、PowerShellで記述したバッチファイルを作り、
VBAからバッチを実行して、その結果を取得する方法もありますので
参考までに手順を載せておきます。

---------------------------------------------------------------------
【 1 】
---------------------------------------------------------------------
デスクトップ上に choco.bat という名前でバッチファイルを作成します。
choco.bat の記述内容は以下のとおり。


<# : batch portion (begins PowerShell multi-line comment block)
@echo off & setlocal
powershell -STA -NoProfile -NoLogo -ExecutionPolicy Unrestricted "iex (${%~f0} | out-string)"
exit /b %errorlevel%
: end batch / begin PowerShell chimera #>

Add-Type -AssemblyName System.Windows.Forms
$ms = New-Object System.IO.MemoryStream
$ms = [System.Windows.Forms.Clipboard]::GetData( 'Html Format' )

if ( $ms -eq $null ) { exit }
[string] $html = [System.Text.Encoding]::UTF8.GetString( $ms.ToArray() )

[int] $index = $html.IndexOf( '<!--StartFragment-->' )
if ( $index -gt -1 ) {
  [int] $start = $index + '<!--StartFragment-->'.Length
  $index = $html.IndexOf( '<!--EndFragment-->' )
  if ( $index -gt -1 ) {
    $html = $html.substring( $start, $index - $start )
    echo $html
  }
}


---------------------------------------------------------------------
【 2 】
---------------------------------------------------------------------
デスクトップ上の choco.bat を実行して結果を取得します。


Sub bat_exec()
  With CreateObject("WScript.Shell")
    With .Exec("cmd /c " & .SpecialFolders("Desktop") & "\choco.bat")
      Debug.Print .StdOut.ReadAll
    End With
  End With
End Sub


なお、StdOut.ReadAll を実行すると プロンプトの起動がちらつきますが、
それが気になる場合は
bat では、取得した html をファイルにリダイレクトするようにして

その上で、VBAからは Exec ではなく Run メソッドで bat を実行し
bat から出力された Unicode テキストを
ADODB.Stream を利用して読むといいでしょう。

タイトルRe: 別案
記事No83178
投稿日: 2017/11/18(Sat) 23:05
投稿者チョコ
解決済: ON
凄いです。完璧に動作しました。
私には想像もつかない領域で、本当にありがとうございます。

- 以下のフォームから自分の投稿記事を修正・削除することができます -
処理 記事No パスワード

ページの先頭へ 前ページへ戻る