画像そっくりのオートシェイプを作成するには
Excelで資料を作るときに画像やオートシェイプなどを利用することがあります。
その際によくあるのが、ネットから画像を拝借して資料に載せる、というところですが、著作権の問題もありますのでそのまま使うのはさすがに気が引ける、というのがあります。
そこで、マクロで画像を基にオートシェイプを作って、それを加工すればいいじゃん、と思ったのがこのマクロを作ったきっかけです。
が。画像を直接加工した方が速いというのにすぐ気が付いてしまい。うーん。用途があるとは思えなくなりました。
それ以外にもいろいろと問題があるのですが、せっかく作ったので載せます。
とは言いつつも、完全にお遊びプログラムです。実用性があるかどうかは不明です。
実行例
完全に元画像をコピーするため、絵画のような味わいは皆無です。こんな感じ。下の絵がオートシェイプで作成されてます。
400倍した元画像。元々画質がよくないですが。。
400倍したオートシェイプ。ドット絵みたいになってます。
考え方とか実現方法とか
シートに写真でもなんでもいいので画像を配置します。どうやってこのオートシェイプを作っているかというと、元画像の縦と横のピクセル数を計測して、全ピクセルの色を１ピクセルずつ取得し、それを１ポイント（ピクセルじゃなくてExcelでのポイント単位）ごとの四角のオートシェイプを作って背景色を元画像の通りに配色しています。
Windowsのウィンドウ上の座標や「ピクセル」と、Excelのシート上の「ポイント」は単位が異なるため、それを調整する必要があります。
ウィンドウ上の座標を取得するために、WindowオブジェクトのPointsToScreenPixelsXメソッドとPointsToScreenPixelsYメソッドを使って、ピクセルとポイントの差を吸収するような演算をやってたりします。このあたりは「ポイント、ピクセル、インチ、センチ、ミリの相互変換」をご参照ください。
難点
このプログラムと実行結果には以下の難点があります。
- 処理が遅い。Win32APIのGetPixelで1ピクセルずつ取得しているのが原因。
- 縦横1ポイントの四角オートシェイプを縦×横の数だけ作成するため、小さい画像でも数万個のオートシェイプが作成され、当然重くなる。
- ってのを分かってるけど、どうにかするつもりがない。（実用性を感じないのでよりよくする気にならない。。。）
GetPixelが遅いのは別の方法で解決できますが、オートシェイプが多いのを解決するにはちょっと面倒なので、もうこのままにします。
コード
シートに写真でもなんでもいいのでjpegとかpngとかの画像を配置します。
それを選択して、以下のStartMain()関数を実行すると、元画像の５セルぐらい下にオートシェイプを作成します。
ただ、５分とか１０分とかめちゃくちゃ時間がかかるため、動かす場合は1cm四方程度の小さい画像をお勧めします。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
'// 32bit版のWin32APIを使う場合はコメントアウトしている方を使ってください '// デバイスコンテキストのハンドルを取得 'Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr '// デバイスコンテキストのハンドルを解放 'Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long '// 指定座標の色を取得 'Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long '// 画像情報構造体 Type ST_IMAGE_INFO Left As Double '// 左位置 Top As Double '// 上位置 Width As Double '// 幅 Height As Double '// 高さ ScreenX As Double '// スクリーン上の横座標 ScreenY As Double '// スクリーン上の縦座標 End Type '// 処理メイン Sub StartMain() Dim pos As ST_IMAGE_INFO '// 画像情報構造体 Dim arXYColor() As Long '// 選択画像の色情報二次元配列（X,Y=color） Dim t1, t2 '// ズームを初期化（100%でないと画像の座標位置がずれるため強制的に100%にする） ActiveWindow.Zoom = 100 '// 選択画像の情報取得 Call GetImageInfo(pos) '// A1セルを選択。画像選択時のサイズ調整の線を消すのが目的 Range("A1").Select '// セル選択待ちで1秒 Application.Wait [Now() + "00:00:01"] '// 配列領域確保 ReDim arXYColor(Int(pos.Width * 4 / 3), Int(pos.Height * 4 / 3)) t1 = Timer '// 画像情報を取得 Call GetPictureColor(pos, arXYColor) t2 = Timer Debug.Print t2 - t1 t1 = Timer '// オートシェイプ作成 Call CreateAutoShapeMain(pos, arXYColor) t2 = Timer Debug.Print t2 - t1 End Sub '// 選択画像情報取得 Sub GetImageInfo(a_pos As ST_IMAGE_INFO) Dim pic As Object '// 選択画像 Dim iBaseX '// 基準横位置 Dim iBaseY '// 基準縦位置 '// 選択画像を変数に格納（しなくてもSelectionのままでもOK） Set pic = Selection '// 画像の左位置、上位置、幅、高さを取得 a_pos.Left = pic.Left a_pos.Top = pic.Top a_pos.Width = pic.Width a_pos.Height = pic.Height '// 基準位置取得 iBaseX = ActiveWindow.PointsToScreenPixelsX(0) iBaseY = ActiveWindow.PointsToScreenPixelsY(0) '// スクリーン上の位置取得 a_pos.ScreenX = (a_pos.Left * 96 / 72) + iBaseX a_pos.ScreenY = (a_pos.Top * 96 / 72) + iBaseY End Sub Sub GetPictureColor(a_pos As ST_IMAGE_INFO, arXYColor() As Long) ' Dim hDC As Long '// デバイスコンテキスト（32bit版はこちらを利用） Dim hDC As LongPtr '// デバイスコンテキスト（64bit版はこちらを利用） ' Dim pos As ST_POINT '// 座標構造体 Dim iRed As Long '// RGBのRed Dim iGreen As Long '// RGBのGreen Dim iBlue As Long '// RGBのBlue Dim iX As Long '// X軸ループカウンタ Dim iY As Long '// Y軸ループカウンタ Dim iColor As Long '// スクリーン上の色 '// デバイスコンテキスト取得 hDC = GetDC(0) '// X軸ループ（幅数） For iX = 0 To Int(a_pos.Width * 4 / 3) '// Y軸ループ（高さ） For iY = 0 To Int(a_pos.Height * 4 / 3) '// スクリーン上の対象座標の色を取得 iColor = GetPixel(hDC, a_pos.ScreenX + iX, a_pos.ScreenY + iY) '// 現座標の色を配列に保持 arXYColor(iX, iY) = iColor Next Next '// デバイスコンテキストの解放 Call ReleaseDC(0, hDC) End Sub '// オートシェイプ作成呼び出し Sub CreateAutoShapeMain(a_pos As ST_IMAGE_INFO, a_arXYColor() As Long) Dim iX As Long '// X軸ループカウンタ Dim iY As Long '// Y軸ループカウンタ Dim iXMax As Long '// X軸最大値 Dim iYMax As Long '// Y軸最大値 '// 最大値取得 iXMax = UBound(a_arXYColor, 1) iYMax = UBound(a_arXYColor, 2) '// X軸ループ For iX = 0 To iXMax '// Y軸ループ For iY = 0 To iYMax Call CreateAutoShape(a_pos, iX, iY, a_arXYColor(iX, iY)) Next Next End Sub '// オートシェイプ作成 Sub CreateAutoShape(a_pos As ST_IMAGE_INFO, a_x As Long, a_y As Long, a_iColor As Long) Dim shp As Shape '// オートシェイプ Set shp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartProcess, a_pos.Left + (0.75 * a_x), a_pos.Top + (0.75 * a_y) + a_pos.Height + 50, 1, 1) shp.Fill.ForeColor.RGB = a_iColor shp.Line.Visible = msoFalse End Sub |
コード説明
Win32APIのGetDC()、GetPixel()、ReleaseDC()を使ってます。ウィンドウ上の色を取得するのに使ってます。詳細は省略します。
Win32APIは32bit版と64bit版で定義が異なるため、コード内では32bit版をコメントアウトし、64bit版を利用するようにしています。もし32bit版を利用する場合はコメント化を外して、64bit版のコードを削除（もしくはコメントアウト）してください。対象は４か所あり、そのうちの３か所はコード先頭のGetDC()、GetPixel()、ReleaseDC()で、残りの１か所はGetPictureColor関数の中で定義しているLongPtr型の変数hDCです。
Win32APIの32bit版を64bit版にしたい場合の詳細については「VBAでWin32API（WindowsAPI）を64bit対応する方法」をご参照ください。
やりたいことは、選択した画像のウィンドウ上の座標をとって、そこにある色を1ピクセルずつとって、それをオートシェイプとして作成する、という内容です。
「* 4 / 3」とか「0.75」とかはExcelのポイント単位とWindowsのピクセル単位の違いを吸収するための調整値です。1インチは72ポイントであり、また、96ピクセルでもあります。それらの単位の相関関係については「ポイント、ピクセル、インチ、センチ、ミリの相互変換」をご参照ください。