画像のトレース　試し① - インストールレスプログラミング( ´ー`)

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

完全に趣味です。

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

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

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

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

コードはこちら。

※追記　載せてしまった後ですが，GetColorPtのところで，各座標を２倍しているところがあります。これはわたしの環境ではそうしないと図形の座標を見れていなかったというせいです。
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