画像のトレース 試し③ 一旦ここまで。

前のはかなり適当な部分が多かったので，さすがにあのままじゃあまずいので，整えました。

変な補正をかなり撤廃できていると思います。

ただ，とにかく色の取得時間がかかる。

色の取得ポイントを減らせばいいのか何をすればいいかなんともいえません。

座標変換については，SlideMasterの情報とPointToScreenPixelで確かにやれたと思います。

なので，今後にそれは生きるかなぁ。

明らかに図形を再現しつつはあるので，やろとうしたことはおかしくはないとは思うものの，求める精度までもっていくにはいろんな改善を加えないといけない気がします。

その時間は今はないので，この話はいったんここまでであきらめようと思っています。

次のネタをさがしつつ，正規表現の練習は続けているので，そちらにシフトしよう。。

左のでこぼこしているのがトレースの結果。ちっちゃめの図形なのに２８秒もかかりました。パソコンによってはさらに・・。
このスピードと精度ではちょいキビシイデス。

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
Public PtToPxRatio As Single
Public StX As Long, StY 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
    
    
    GetColor = RGB(R, G, B)
    
End Function
Sub test2()
Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
Dim Pt As POINTAPI
Dim ret
Do
    Call GetCursorPos(Pt)
    ret = GetColor(Pt.X, Pt.Y)
    TargetSlide.Shapes("txt").TextFrame.TextRange = Pt.X & "," & Pt.Y
    TargetSlide.Shapes("txt").Fill.ForeColor.RGB = ret
    DoEvents
    Sleep 10
Loop
End Sub

Sub 比率決定()
Dim AcP As Presentation: Set AcP = ActivePresentation
Dim pxWidth As Long, pxHeight As Long
Dim ptWidth As Long, ptHeight As Long
Dim EndX As Long, EndY As Long

ptWidth = AcP.SlideMaster.Width
ptHeight = AcP.SlideMaster.Height
StX = ActiveWindow.PointsToScreenPixelsX(0)
StY = ActiveWindow.PointsToScreenPixelsY(0)
EndX = ActiveWindow.PointsToScreenPixelsX(ptWidth)
EndY = ActiveWindow.PointsToScreenPixelsY(ptHeight)

PtToPxRatio = (EndX - StX) / ptWidth

End Sub
Function ChangePT(X_ As Long, y_ As Long) As POINTAPI
    ChangePT.X = (X_ - StX) / PtToPxRatio
    ChangePT.Y = (y_ - StY) / PtToPxRatio
End Function
Function ChangePX(X_ As Long, y_ As Long) As POINTAPI
    ChangePX.X = StX + X_ * PtToPxRatio
    ChangePX.Y = StY + y_ * PtToPxRatio
End Function

Sub GetColorPt3()
    比率決定
    
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)

    Dim TargetShape As Shape: Set TargetShape = TargetSlide.Shapes("TS")
    ReDim pts(Int(TargetShape.Width) + 1, Int(TargetShape.Height) + 1)
    
    Dim i As Long, j As Long, k As Long, l As Long
    k = 0: l = 0
    For i = Int(TargetShape.Top) To Int(TargetShape.Top + TargetShape.Height)
        k = 0
        For j = Int(TargetShape.Left) To Int(TargetShape.Left + TargetShape.Width)
            pts(k, l) = GetColor(ChangePX(j, i).X, ChangePX(j, i).Y)
            k = k + 1
        Next
        l = l + 1
    Next
    
    DrawLine
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, k As Long, flg As Boolean
    For i = 0 To UBound(pts, 1)
        flg = False
        For j = 0 To UBound(pts, 2)
            If pts(i, j) = 0 Then
                If flgFirst = True Then
                    Set drw = TargetSlide.Shapes.BuildFreeform(msoEditingAuto, i, (j + k))
                    flgFirst = False
                Else
                    drw.AddNodes msoSegmentCurve, msoEditingAuto, i, (j + k)
                End If
                Exit For
            End If
        Next
    Next
    drw.ConvertToShape
End Sub