画像のトレース 試し①
使えるものにまでならなさそうですが,やってみようと思い,画像をトレースする方法を考え中です。
完全に趣味です。
面白いことに出会うかもしれないしやってみようという感じ。
今までのコードを寄せ集めてとりあえず動くものにしてみました。
ほんと,わかってない分野が多数なので,なんかしらんけどとりあえずそれっぽく動いたというレベル。
少しずつ良くしていってみようと思います。
コードはこちら。
※追記 載せてしまった後ですが,GetColorPtのところで,各座標を2倍しているところがあります。これはわたしの環境ではそうしないと図形の座標を見れていなかったというせいです。
test2というマクロが残っていますが,これがマウスポインタの座標と色を試すマクロです。こいつでだいたい自分の環境では何倍になるのか判断して,取り掛かるとなってしまいます。
ほんと・・座標面の解決がまったくできておりません(;´▽`A``
Option Explicit Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As Long) Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Declare PtrSafe Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal nXPos As Long, ByVal nYPos As Long) As Long Type POINTAPI X As Long Y As Long End Type Public pts() As Long Function GetColor(ptX As Long, ptY As Long) As Long Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1) Dim hdc As Long, Color As Long Dim pt As POINTAPI Dim i As Long hdc = GetDC(0) Color = GetPixel(hdc, ptX, ptY) Call ReleaseDC(0, hdc) Dim R As Byte, G As Byte, B As Byte R = Color And &HFF G = Color \ &H100 And &HFF B = Color \ &H10000 And &HFF TargetSlide.Shapes("txt").TextFrame.TextRange = ptX & "," & ptY TargetSlide.Shapes("txt").Fill.ForeColor.RGB = RGB(R, G, B) GetColor = RGB(R, G, B) End Function Sub test2() Dim pt As POINTAPI Dim ret Do Call GetCursorPos(pt) ret = GetColor(pt.X, pt.Y) DoEvents Sleep 10 Loop End Sub Sub GetColorPt() Dim StartX As Long, StartY As Long, EndX As Long, EndY As Long Dim TargetShape As Shape, i As Long, j As Long Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1) ActivePresentation.SlideShowSettings.Run Set TargetShape = TargetSlide.Shapes("TS") StartX = TargetShape.Left * 2 EndX = StartX + TargetShape.Width * 2 StartY = TargetShape.Top * 2 EndY = StartY + TargetShape.Height * 2 ReDim pts(TargetShape.Width * 0.4 + 1, TargetShape.Height * 0.4 + 1) Dim k As Long, l As Long For i = StartX To EndX Step 5 l = 0 For j = StartY To EndY Step 5 pts(k, l) = GetColor(i, j) l = l + 1 DoEvents Next k = k + 1 Next SlideShowWindows(1).View.Exit End Sub Sub DrawLine() Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1) Dim drw As FreeformBuilder, flgFirst As Boolean flgFirst = True Dim i As Long, j As Long For i = 0 To UBound(pts, 1) For j = 0 To UBound(pts, 2) If pts(i, j) = 0 Then If flgFirst = True Then Set drw = TargetSlide.Shapes.BuildFreeform(msoEditingAuto, i * 5, j * 5) flgFirst = False Else drw.AddNodes msoSegmentCurve, msoEditingAuto, i * 5, j * 5 End If Exit For End If Next Next drw.ConvertToShape End Sub
準備として二つの図形が必要です。
TSという黒を含む連続した線の図形(小さめがいいです)とtxtというテキストを表示できる箱がいります。
色情報を覚えさせる場所としてPublic宣言した ptsという配列を使用しています。
今はとにかくほんとにできるのかなという段階なので,効率度外視トライ&エラー中です。
色情報の取得にものすごく時間がかかりますので,一度取得したらしばらく使えるようにPublicで宣言しています。
実行の順番としてはGetColorPTで色情報を取得
DrawLineでその情報を使って線を描くという二段階です。
時間がとってもかかるので,動画での紹介は載せませんが,
このように,確かに色情報をもとに形を若干再現できています。
もっと線の真ん中をとるようにするとか(今は線の上端に反応しています)するといい感じになるかもしれませんし,
座標の扱いがよくわからないんですね。。
スライドショー中ではなく,編集画面での座標で色取得ができれば変に数倍したりしているあたりがきれいになります。
とにかく座標関連がめためたなまま,とりあえず動かすとこまできました。
あと,今は全ポイントを等間隔に走査しているわけですが,ライントレースカーみたいに,前の点から次の点を捜索する方法を考えたりすると,
ずいぶん速くなると思ったりします。
まぁ遊び始めただけの話なんですが,とりあえず同じような形を実現できたのは十分な一歩です。
徐々に改善していこうと思います。
使えるレベルまで到達する気がしないけど,まぁガンバル。