Bird-Soft Weblog

画像からGetPixelでピクセル情報を取得し、セルの色を変更する Excel VBAのコードを書いてみました。
Excelで使える色数に制限があるため、うまくいかないこともありますが、
作ってしまったので載せておきます。

なぜこんなものを作ったかというと、以前の記事と組み合わせて、
画像からピクセル情報をテキストに落としたかったため。

C#を使えばすぐにできるのですが、Excelのセルにも反映させてたら
おもしろそうだと思ってしまったためです。思ったより苦労しました。
VBAでいろいろやろうとすると難しいです＞＜


★概要
・画像を読み込み、Pixel情報を取得
・Excelのセルの色を取得した色に変更
・取得した値をセルの値として入力

↑実行のイメージ
　※実際はセルに値が入ります。
　※Excelの制限により、うまく色がつかないことがあります。
　　⇒参考記事


※画像関連の主要コード（WinAPIを使って、hDCを取得するところ）は
　「Excel VBA質問箱 IV」の「 【54098】Re:フォーム上のイメージに文字を追加する方法」
　http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=54098;id=excel
　のコードを使わせていただきました。ありがとうございます。
　まだ未整理のため、使わないコードもまざっていますがご了承ください。


↑あらかじめCommandButton1、Image1をUserFormに作成しておきます。
　今回、コードはUserForm1だけに書くだけでよいです。
　C:\test.bmp"にテスト用の画像を配置しておきます。
　（サンプルでは20*20まで。重くなるが、コード変更でさらに大きい画像でも対応可）

Private Const DT_LEFT As Long = &H0 Private Const DT_BOTTOM As Long = &H8 Private Const DT_SINGLELINE As Long = &H20 Private Const TRANSPARENT As Long = 1 Private Const GUID_IDISPATCH_INTERFACE As String = "{00020400-0000-0000-C000-000000000046}" Private Const CF_BITMAP As Long = 2 Private Const CF_PALETTE As Long = 9 Private Const PICTYPE_BITMAP As Long = 1 Private Const IMAGE_BITMAP As Long = 0 Private Const LR_COPYRETURNORG As Long = &H4 Private Const LR_LOADFROMFILE As Long = &H10 Private Const LOGPIXELSX As Long = 88 Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function GetObject Lib "gdi32" _ Alias "GetObjectA" _ (ByVal hObject As Long, _ ByVal nCount As Long, _ ByRef lpObject As Any) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hDC As Long, _ ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long '★ Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Private Sub CommandButton1_Click() Const FILE_ORIGINAL As String = "C:\test.bmp" Dim hDC As Long Dim hBmp As Long Dim hOrgBmp As Long Dim hOrgFont As Long Dim hPalette As Long Dim hImg As Long Dim tBitmap As BITMAP Dim Pic As stdole.IPictureDisp Dim Ratio As Single '---------- Dim i, j, cnt Dim BB, GG, RR Dim BBh, GGh, RRh Dim strBGR Dim strBGRLen '---------- On Error Resume Next With Me.Image1 'Image1に元画像を表示 .Picture = stdole.LoadPicture(FILE_ORIGINAL) .AutoSize = False .AutoSize = True ' MsgBox "変換前" '元画像ＢＭＰファイルからデバイスコンテキストを直接作成 hBmp = LoadImage(0, FILE_ORIGINAL, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) hDC = CreateCompatibleDC(0) hOrgBmp = SelectObject(hDC, hBmp) GetObject hBmp, Len(tBitmap), tBitmap '---------- '★下位から 8 ビット単位で B、G、R、未使用の順に並んでいます 'MsgBox (Hex(GetPixel(hDC, 1, 1))) 'セルの幅を変更 Columns("A:DD").Select Selection.ColumnWidth = 0.62 Rows("1:100").Select Selection.RowHeight = 6 For j = 1 To 20 Step 1 '縦方向 For i = 1 To 20 Step 1 '横方向 strBGR = (Hex(GetPixel(hDC, i, j))) 'ピクセル取得 strBGRLen = Len(strBGR) '文字列の長さを取得 '0の数が足りない場合、補う（6桁になるように左に0を追加） If strBGRLen < 6 Then For cnt = 1 To 6 - strBGRLen Step 1 '6 - strBGRLen回繰り返す strBGR = "0" & strBGR '左に0を追加 Next cnt End If '16進数で取り出し BBh = Left(strBGR, 2) '左から2つ取り出し GGh = Mid(strBGR, 3, 2) '3つめから2つ取り出し RRh = Right(strBGR, 2) '右から2つ取り出し '10進数に変換 BB = Val("&H" & BBh) GG = Val("&H" & GGh) RR = Val("&H" & RRh) 'セルの色を書き換える Cells(j, i).Interior.Color = RGB(RR, GG, BB) Cells(j, i).Value = (RR & "," & GG & "," & BB & " / " & strBGR) Next i Next j '描画オブジェクト／デバイスコンテキストの後始末 SelectObject hDC, hOrgFont SelectObject hDC, hOrgBmp DeleteDC hDC DeleteObject hBmp End With End Sub

追記：
「excel vba ゲーム」で検索してみたら、
pacmanパックマン
http://www.geocities.jp/nchikada/pac/index.htm
を見つけました。
Excelのセルの色だけでアクションゲームを作ってしまっています。
これはすごいです。まねできません・・・。


追記2：
エクセルを使って動画にしている人がいました（笑）
さすがにリアルタイムではなくて、
動画からビットマップ抜き出し
⇒減色ツールで減色
⇒Excelのセルに反映
⇒Excel画面のスクリーンショットを取る
⇒上記をつなげて動画にする
のようにしているみたいです。

エクセルでひぐらしのなく頃に解OP‐ニコニコ動画(夏)
http://www.nicovideo.jp/watch/sm1642964

おまけを解説してみた‐ニコニコ動画(夏)
http://www.nicovideo.jp/watch/sm2026262


◆おすすめ減色ソフト
Padie - 高精度な減色専用ツール
http://www.vector.co.jp/soft/win95/art/se063024.html

投稿者: BIRD 日時: 10:21 | パーマリンク | コメント (2) | トラックバック (0)

前回のExcel VBAでは、オレンジが46など、
Excel VBA特有の色の指定の仕方をしました。

⇒例）
　　Range("A1").Interior.ColorIndex = 46

ところで、Excel VBAでは、このような指定の仕方以外にも
RGBを指定して色を変えられるようです。
⇒例）
　　Range("A1").Interior.Color = RGB(255, 255, 0)

そこで、その方法を使ってみましたが、うまく行かないこともあるような・・・。
理論上は任意の色を作り出せるはずですが、できないことがあります。
（私のやり方が悪いのかもしれないですが・・・）

ためしにサンプルを作ってみました。
RGBの値を1ずつ変えながら実行するだけのものです。
本当ならきれいなグラデーションとなるはずが、色が分離してしまっています↓

↑色が分かれてしまっている（Excel VBAでのセルの色分けテスト)
　
　

↑本来はこうなるはず（Visual C#での色塗りテスト)
　
　　
もう一例やってみたので紹介します(続きから）

やはりだめなよう。

↑色が分かれてしまっている（Excel VBAでのセルの色分けテスト)
　しかも、途中に変な灰色がはいっている・・・。
　
　

↑本来はこうなるはず（Visual C#での色塗りテスト)

回避方法がわかる方、教えてください・・・。

追記：
以下のページに同じ悩みがありました。やはり同時に使える色が限られているようです。
Excelのセルの色の変更方法

同時に使える色が限られてはいますが、
下記のように、カラーパレットを変更すると任意の色にすることはできます。
ThisWorkbook.Colors(1) = RGB(255, 123, 0)
　
以下のページが参考になります。
エクセル：カラーパレット
http://adamontn.blog.ocn.ne.jp/analyst/2007/05/post_4164.html
　
　
※カラーパレットの変更はExcelのメニューバーの
　ツール⇒オプション⇒タブ「色」　からも可能

投稿者: BIRD 日時: 01:55 | パーマリンク | コメント (0) | トラックバック (0)