- ホーム
- Other
- CBからSYLK形式データ取得
セルコピー後、クリップボードからSYLK形式データ取得
エクセルのセルをコピー後、クリップボードからSYLK形式データを取得し、ワークシートに書き出す
何に役立つかって？う～ん、思いつかない。
'----------------------------------------------------------------------------
'クリップボード関連
'----------------------------------------------------------------------------
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8
Private Const CF_DIF = 5
Private Const CF_DSPBITMAP = &H82
Private Const CF_DSPENHMETAFILE = &H8E
Private Const CF_DSPMETAFILEPICT = &H83
Private Const CF_DSPTEXT = &H81
Private Const CF_ENHMETAFILE = 14
Private Const CF_GDIOBJFIRST = &H300
Private Const CF_GDIOBJLAST = &H3FF
Private Const CF_METAFILEPICT = 3
Private Const CF_OEMTEXT = 7
Private Const CF_OWNERDISPLAY = &H80
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_PRIVATEFIRST = &H200
Private Const CF_PRIVATELAST = &H2FF
Private Const CF_RIFF = 11
Private Const CF_SYLK = 4
Private Const CF_TEXT = 1
Private Const CF_TIFF = 6
Private Const CF_UNICODETEXT = 13
Private Const CF_WAVE = 12
'----------------------------------------------------------------------------
'メモリ関連
'----------------------------------------------------------------------------
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem 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 Const GMEM_MOVEABLE = &H2
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long)
Declare Function WideCharToMultiByte Lib "kernel32" _
(ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByRef lpMultiByteStr As Any, _
ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As String, _
ByVal lpUsedDefaultChar As Long) As Long
Declare Function MultiByteToWideChar Lib "kernel32" _
(ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByRef lpMultiByteStr As Any, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long) As Long
'------------------------------------------------
' クリップボードからデータ取得（SYLK形式）
'------------------------------------------------
'http://www.sanryu.net/acc/tips/tips289.htm
'http://hpcgi1.nifty.com/MADIA/VBBBS/wwwlng.cgi?print+200910/09100010.txt
'http://support.microsoft.com/kb/410409/ja 本家SYLKフォーマット
'http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/01047.html
Sub test()
Dim data() As Byte
Dim hMem As Long
Dim dwBytes As Long
Dim p As Long
Dim i As Long, j As Long
Dim strResult As String
Dim buf As Variant
Dim S As String, L2 As String
Dim myData As Variant
Dim myRow As Long, myCol As Long
Dim StartRow As Long, StartCol As Long
Dim StartX As Long, StartY As Long
'クリップボードを開く
If OpenClipboard(0&) Then
hMem = GetClipboardData(CF_SYLK)
If hMem Then
'バイト数取得
dwBytes = GlobalSize(hMem)
'グローバルメモリオブジェクトをロック(ポインタ取得)
p = GlobalLock(hMem)
'再割り当て
ReDim data(0 To dwBytes - 1)
'コピー
MoveMemory VarPtr(data(0)), p, dwBytes
'メモリオブジェクトのロックを解除
GlobalUnlock hMem
CloseClipboard
For i = 0 To dwBytes - 1
If data(i) = 0 Then
data(i) = Asc(" ")
End If
Next i
strResult = AnsiToUnicode(data())
buf = Split(strResult, vbCrLf)
For j = LBound(buf) To UBound(buf)
If Left(buf(j), 1) = "C" Then
Debug.Print buf(j)
' {X座標のデータがあれば Col を更新}
If InStr(buf(j), ";X") > 0 Then
':Xから後ろを抽出する、最後の引数は大きめに設定している
L2 = Mid(buf(j), InStr(buf(j), ";X") + 2, Len(buf(j)))
If InStr(L2, ";") > 0 Then L2 = Mid(L2, 1, InStr(L2, ";") - 1)
myCol = StartCol - StartX + CLng(L2)
myCol = CLng(L2)
End If
'{Y座標のデータがあれば Row を更新}
If InStr(buf(j), ";Y") > 0 Then
L2 = Mid(buf(j), InStr(buf(j), ";Y") + 2, Len(buf(j)))
If InStr(L2, ";") > 0 Then L2 = Mid(L2, 1, InStr(L2, ";") - 1)
myRow = StartRow - StartY + CLng(L2)
myRow = CLng(L2)
End If
'{データがあるときには読み出してシートに書き込む}
If (InStr(buf(j), ";K") > 0) And (myRow > 0) And (myCol > 0) Then
myData = Mid(buf(j), InStr(buf(j), ";K") + 2, Len(buf(j)))
If InStr(myData, ";") > 0 Then _
myData = Mid(myData, 1, InStr(myData, ";") - 1)
If Left(myData, 1) = """" Then _
myData = Mid(myData, 2, Len(myData) - 2)
Sheets(2).Cells(myRow, myCol) = myData
End If
End If
Next j
End If
End If
End Sub
'SHIFT-JISからUnicodeに変換する
Private Function AnsiToUnicode(ByRef strAnsi() As Byte) As String
On Error GoTo ErrHandler
Dim lngSize As Long
Dim strBuf As String
Dim lngBufLen As Long
Dim lngRtnLen As Long
lngSize = UBound(strAnsi) + 1
lngBufLen = lngSize * 2 + 10
strBuf = String$(lngBufLen, vbNullChar)
lngRtnLen = MultiByteToWideChar(0, 0, strAnsi(0), lngSize, StrPtr(strBuf), lngBufLen)
If lngRtnLen > 0 Then
AnsiToUnicode = Left$(strBuf, lngRtnLen)
End If
ErrHandler:
End Function