Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

11908 / 76734

←次へ　｜　前へ→


	【70355】Re:ルールの管理による色の取得

亜矢 - 11/11/5(土) 15:35 -


	引用なし

	パスワード

▼n さん：
>データバーやアイコンセット以外の単純単色の条件付き書式だったら。
>..力技的ですが:D
>
>'■標準Module
>'■参照設定:[Microsoft Forms 2.0 Object Library]
>Option Explicit
>
>Private Declare Function CloseClipboard Lib "user32.dll" () As Long
>
>Private Declare Function OpenClipboard Lib "user32.dll" ( _
>　　　　　　　　　　　　　　　　　　　 ByVal hwnd As Long) As Long
>
>Private Declare Function GetClipboardData Lib "user32.dll" ( _
>　　　　　　　　　　　　　　　　　　　　　ByVal wFormat As Long) As Long
>
>Private Declare Function RegisterClipboardFormatA Lib "user32.dll" ( _
>　　　　　　　　　　　　　　　　　　　　　　　　　ByVal lpszFormat As String) As Long
>
>Private Declare Function GlobalSize Lib "kernel32.dll" ( _
>　　　　　　　　　　　　　　　　　　ByVal hMem As Long) As Long
>
>Private Declare Function GlobalLock Lib "kernel32.dll" ( _
>　　　　　　　　　　　　　　　　　　ByVal hMem As Long) As Long
>
>Private Declare Function GlobalUnlock Lib "kernel32.dll" ( _
>　　　　　　　　　　　　　　　　　　　ByVal hMem As Long) As Long
>
>Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
>　　　　　　　　　　　　　　　　　ByVal hpvDest As Any, _
>　　　　　　　　　　　　　　　　　ByVal hpvSource As Any, _
>　　　　　　　　　　　　　　　　　ByVal cbCopy As Long)
>'-------------------------------------------------
>
>Sub test()
>　　If TypeName(Selection) = "Range" Then
>　　　　MsgBox getcol(Selection)
>　　End If
>End Sub
>'-------------------------------------------------
>Private Function getcol(ByRef r As Range)
>　　Dim buf As String
>　　Dim mem As Long
>　　Dim sz　As Long
>　　Dim lk　As Long
>　　Dim x　 As Long
>
>　　Application.ScreenUpdating = False
>　　r.Item(1).Copy
>　　OpenClipboard 0&
>　　mem = GetClipboardData(RegisterClipboardFormatA("HTML Format"))
>　　CloseClipboard
>　　If mem = 0 Then Exit Function
>　　sz = GlobalSize(mem)
>　　lk = GlobalLock(mem)
>　　buf = String(sz + 1, vbNullChar)
>　　RtlMoveMemory buf, lk, sz
>　　GlobalUnlock mem
>　　buf = Left$(buf, InStr(buf, vbNullChar) - 1)
>　　buf = Replace$(buf, "mso-ignore:style;", "") '■2007,2010では無くてもOK
>　　With New DataObject
>　　　　.Clear
>　　　　.SetText buf
>　　　　.PutInClipboard
>　　End With
>　　With Workbooks.Add
>　　　　.Sheets(1).Paste
>　　　　x = Selection.Interior.ColorIndex
>　　　　.Close False
>　　End With
>　　getcol = x
>　　Application.ScreenUpdating = True
>End Function
ありがとうございました。色の取得をあきらめていました。
これで解決しました。本当にありがとうございました。

13 hits

▼

【70344】ルールの管理による色の取得 亜矢 11/11/3(木) 13:52