2009年04月16日

vba:クリップボードへの読み書き

クリップボードで読み書き行うためだけに↓のようなAPIごりごりのコードは、なんかイヤになったんで、COMオブジェクトを作ってスッキリさせた。
Set cls = CreateObject("clisou.Clipboard")
WScript.Echo cls.Text
Set cls = Nothing

こんな感じでちょー簡単。このCOMオブジェクトはこちらのページへ


vbaでクリップボードへのテキストの読み書きを行う関数。

Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

Public Const CF_TEXT = 1
Public Const GMEM_MOVEABLE = 2
Public Const MAXSIZE = 1048576

Function GetClipboardText()
Dim ClipHandle As Long
Dim ClipAddr As Long
Dim s As String
    If OpenClipboard(0) = 0 Then
        MsgBox "クリップボードが開きません"
        Exit Function
    End If
    ClipHandle = GetClipboardData(CF_TEXT)
    If IsNull(ClipHandle) Then
        MsgBox "クリップボードのハンドルが取得できません"
        GoTo exit_proc
    End If
    ClipAddr = GlobalLock(ClipHandle)
    If IsNull(ClipAddr) Then
        MsgBox "クリップボードメモリがロックできません"
        GoTo exit_proc
    End If
    s = String(lstrlen(ClipAddr) + 1, vbNullChar)
    lstrcpy s, ClipAddr
    GlobalUnlock ClipHandle
    GetClipboardText = Mid(s, 1, InStr(1, s, vbNullChar, 0) - 1)
exit_proc:
    CloseClipboard
End Function

Sub SetClipboardText(ByVal Text As String)
Dim ClipHandle As Long
Dim ClipAddr As Long
    If OpenClipboard(0) = 0 Then
        MsgBox "クリップボードが開きません"
        Exit Sub
    End If
    EmptyClipboard
    ClipHandle = GlobalAlloc(GMEM_MOVEABLE, LenB(StrConv(Text, vbFromUnicode)) + 1)
    If IsNull(ClipHandle) Then
        MsgBox "メモリが確保できません"
        GoTo exit_proc
    End If
    ClipAddr = GlobalLock(ClipHandle)
    If IsNull(ClipAddr) Then
        MsgBox "メモリがロックできません"
        GoTo exit_proc
    End If
    lstrcpy ClipAddr, Text
    GlobalUnlock ClipHandle
    SetClipboardData CF_TEXT, ClipAddr
    GlobalFree ClipHandle
exit_proc:
    CloseClipboard
End Sub
posted by 忘却の達人 at 07:23| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする
この記事へのコメント
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

認証コード: [必須入力]


※画像の中の文字を半角で入力してください。

この記事へのトラックバック
×

この広告は180日以上新しい記事の投稿がないブログに表示されております。