Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

画像のトレース 試し①

使えるものにまでならなさそうですが,やってみようと思い,画像をトレースする方法を考え中です。

完全に趣味です。

面白いことに出会うかもしれないしやってみようという感じ。

今までのコードを寄せ集めてとりあえず動くものにしてみました。

ほんと,わかってない分野が多数なので,なんかしらんけどとりあえずそれっぽく動いたというレベル。

少しずつ良くしていってみようと思います。

コードはこちら。

※追記 載せてしまった後ですが,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

準備として二つの図形が必要です。
f:id:chemiphys:20170305232739p:plain

TSという黒を含む連続した線の図形(小さめがいいです)とtxtというテキストを表示できる箱がいります。

色情報を覚えさせる場所としてPublic宣言した ptsという配列を使用しています。
今はとにかくほんとにできるのかなという段階なので,効率度外視トライ&エラー中です。
色情報の取得にものすごく時間がかかりますので,一度取得したらしばらく使えるようにPublicで宣言しています。

実行の順番としてはGetColorPTで色情報を取得
DrawLineでその情報を使って線を描くという二段階です。

時間がとってもかかるので,動画での紹介は載せませんが,
f:id:chemiphys:20170305233218p:plain

このように,確かに色情報をもとに形を若干再現できています。

もっと線の真ん中をとるようにするとか(今は線の上端に反応しています)するといい感じになるかもしれませんし,
座標の扱いがよくわからないんですね。。
スライドショー中ではなく,編集画面での座標で色取得ができれば変に数倍したりしているあたりがきれいになります。

とにかく座標関連がめためたなまま,とりあえず動かすとこまできました。

あと,今は全ポイントを等間隔に走査しているわけですが,ライントレースカーみたいに,前の点から次の点を捜索する方法を考えたりすると,
ずいぶん速くなると思ったりします。

まぁ遊び始めただけの話なんですが,とりあえず同じような形を実現できたのは十分な一歩です。

徐々に改善していこうと思います。

使えるレベルまで到達する気がしないけど,まぁガンバル。