Public Type points

  x As Long

  y As Long

End Type

Sub LINETEST_WIA()



 Dim newp() As points

 Dim cnt As Long

 Dim cp As points

 Dim tp As points

 Dim tp2 As points

  cp.x = 300

  cp.y = 1200

  tp.x = 1200

  tp.y = 1000

    

  newp = LINEf(cp.x, cp.y, tp.x, tp.y, 10)

 

  Dim fn As String

  Dim fn2 As String

  fn = "C:\Users\Y2\Desktop\ファイルフォルダー\0T(5,6)30.png"

  fn2 = "C:\Users\Y2\Desktop\ファイルフォルダー\0T(5,6)30_LINE.png"

  

 Call test5LINE_WIA(newp, fn, fn2)



End Sub





Sub test5LINE_WIA(p() As points, fn As String, fn2 As String)



    ' wiaaut.dll を参照設定しておく 

    '  Microsoft Windows Image Acquisition Library v2.0 

    ' 

    Dim objIF As WIA.ImageFile

    Set objIF = New WIA.ImageFile

    objIF.LoadFile fn

    

    Dim h As Long, w As Long

    h = objIF.height

    w = objIF.width



    Dim pi() As Long

    ReDim pi(UBound(p))

    

    pi = points2index(p, w, h)

    

    Dim vec As WIA.vector

    Set vec = objIF.ARGBData

    

     Dim vecT As WIA.vector

     Set vecT = objIF.ARGBData

     vecT.Clear

    

    Dim temp() As Long

    ReDim temp(h * w)

    For t = 1 To UBound(pi)

     temp(pi(t)) = 1

    Next

    

  i = 0

  For y = 1 To h

    For x = 1 To w

     i = i + 1

        

     If temp(i) = 1 Then

        vecT.Add -65536

       Else

        vecT.Add vec.Item(i)

       End If

     Next

    Next

    

    Dim objIFnew As WIA.ImageFile

    

    Set oIFNew = vecT.ImageFile(w, h)

    

    oIFNew.SaveFile fn2



    

End Sub



Function points2index(p() As points, width As Long, height As Long) As Long()



  Dim temp() As Long

  cnt = UBound(p)

  Dim y As Long

  Dim x As Long

  ReDim temp(UBound(p))

  

  For i = 0 To cnt - 1

  y = p(i).y

  x = p(i).x

  temp(i) = y * width + x

  Next

  

   points2index = temp

  

End Function

Function LINEf(x0 As Long, y0 As Long, x1 As Long, y1 As Long, 太さ As Long) As points()

'https://fussy.web.fc2.com/algo/algo1-1.htm 

Dim E As Long

Dim x As Long

Dim y As Long

 Dim dx As Long

 Dim dy As Long

 Dim sx As Long

 Dim sy As Long

 

 Dim temp() As points

 Dim temp2() As points

 Dim temp3() As points

 Dim newpT() As points

 

 If (x1 > x0) Then

   dx = x1 - x0

   sx = 1

  Else

   dx = x0 - x1

   sx = -1

 End If

 If (y1 > y0) Then

   dy = y1 - y0

   sy = 1

  Else

   dy = y0 - y1

   sy = -1

 End If

'  傾きが1より小さい場合 



  太さ = Int(太さ / 2 + 0.5) * 2



 If (dx > dy) Then

    ReDim Preserve temp(dx * (太さ + 1))

    E = -dx

    x = x0

    y = y0

    For i = 0 To dx Step 1

     For B = 0 To 太さ / 2

     temp(i + B * dx).y = y + B

     temp(i + B * dx).x = x

     Next

     For B = 太さ / 2 + 1 To 太さ

     temp(i + B * dx).y = y - (B - 太さ / 2)

     temp(i + B * dx).x = x

     Next

        

      x = x + sx

      E = E + 2 * dy

      If (E >= 0) Then

        y = y + sy

        E = E - 2 * dx

      Else

      End If

   Next

  Else

    ReDim Preserve temp(dy * (太さ + 1))

  '  傾きが1以上の場合 

    E = -dy

    x = x0

    y = y0

    For i = 0 To dy Step 1

     For B = 0 To 太さ / 2

     temp(i + B * dy).y = y

     temp(i + B * dy).x = x + B

     Next

     For B = 太さ / 2 + 1 To 太さ

     temp(i + B * dy).y = y

     temp(i + B * dy).x = x - (B - 太さ / 2)

     Next



      y = y + sy

      E = E + 2 * dx

      If (E >= 0) Then

        x = x + sx

        E = E - 2 * dy

     Else

     End If

    Next

 End If

 

 LINEf = temp

End Function