Hej. Har en utmaning till er. Ni ska skriva en funktion som kontrolerar om två linjer korsar varandra.

Funktion kan se ut så här:

Public Function LinesCross(Line1X1, Line1Y1,Line1X2, Line1Y2,Line2X1, Line2Y1,Line2X2, Line2Y2) as Boolean

End Function

Överkurs är att retunera positionen där linnjerna korsar varandra...

Kanske detta skulle funka (har inte testat) !

Public Function LinesCross(Line1X1, Line1Y1,Line1X2, Line1Y2,Line2X1, Line2Y1,Line2X2, Line2Y2) as Boolean
Dim X1#,X2#,k1#,k2#,minX#,maxx#,x0#,y0#

'Förutsätter att det inte funkar
LinesCross = False

X1 = (Linje1Y1 - Linje1Y2) / (Linje1X1 - Linje1X2)
k1 = Linje1Y1 -(LinjeX1*X1)

X2 = (Linje2Y1 - Linje2Y2) / (Linje2X1 - Linje2X2)
k2 = Linje2X1 - (Linje2X1*X2)

if x1 = x2 then
msgbox "Linjerna har samma lutning och kommer därför aldrig att krossas !"' (Vilket är teoretiskt omöjligt om linjerna är oändligt långa !)
else
'X1 + k1 = X2 + k2

x0 = (X1-x2) / (k2-k1)

y0 = x0 * X1 + k1

msgbox "Linjerna bryts i punkten " & x0 & "," & y0 & " !"


'Ligger brytningen utanför någon av linernas avslutande ?

minX = Linje1X1
if Linje1X2 < minX then minX = LinjeX2

maxX = Linje1x1
if Linje1x2 > maxX then maxx = Linje1x2

if x0 >= minX and x0 <= Maxx then

minX = Linje2X1
if Linje2X2 < minX then minX = Linje2X2

maxX = Linje2x1
if Linje2x2 > maxX then maxx = Linje2x2

if x0 >= minX and x0 <= Maxx then
msgbox "Brytningspunkten ligger innom det båda linjernas avslutande !"
LinesCross = True
endif


else
'Brytningspunkten ligger utanför linjen1´s avslut !"
endif
endif

Exit Function

'------------------------------------------------------------------------------

MVH
/Peter S

Fick den inte att fungera efter jag korrigerat stavfel. Klarar den att linjerna ser ut hur som helst? Vertikala linjer kommer ju orsaka divesioner på noll.

Tror jag kommit på hur man ska göra. Vet bara inte hur man gör det.

Option Explicit

Public Const Pi As Double = 3.14159265358979

Public Function LinesCross(Line1X1 As Long, Line1Y1 As Long, Line1X2 As Long, Line1Y2 As Long, Line2X1 As Long, Line2Y1 As Long, Line2X2 As Long, Line2Y2 As Long) As Boolean
Dim Angel1 As Double
Dim Angel11 As Double
Dim Angel12 As Double
Dim Angel2 As Double
Dim Angel21 As Double
Dim Angel22 As Double

Angel1 = GetAngle(Line1X1, Line1Y1, Line1X2, Line1Y2)
Angel11 = GetAngle(Line1X1, Line1Y1, Line2X1, Line2Y1)
Angel12 = GetAngle(Line1X1, Line1Y1, Line2X2, Line2Y2)

Angel2 = GetAngle(Line1X2, Line1Y2, Line1X1, Line1Y1)
Angel21 = GetAngle(Line1X2, Line1Y2, Line2X1, Line2Y1)
Angel22 = GetAngle(Line1X2, Line1Y2, Line2X2, Line2Y2)

End Function

Public Function GetAngle(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) As Double
Dim DX As Long
Dim DY As Long
DX = X2 - X1: DY = Y2 - Y1

If DY Then
Select Case DY
Case Is > 0
GetAngle = Atn(DX / DY)
Case Is < 0
GetAngle = Atn(DX / DY) + Pi
End Select
Else
Select Case DX
Case Is < 0
GetAngle = 3 * Pi / 2
Case Is > 0
GetAngle = Pi / 2
End Select
End If
End Function

Function DegToRad(Degrees As Double) As Double
DegToRad = Degrees / 180 * Pi
End Function

Function RadToDeg(Radians As Double) As Double
RadToDeg = Radians * 180 / Pi
End Function


Man kollar helt enkelt om Angel1 Befinner sig mellan Angel11 och Angel12. Samt att Angel2 Befinner sig mellan Angel21 och Angel22. Nån som vet hur man gör?

P.S.
GetAngle retunerar Radius
D.S.

Har laggt upp ett program exempel på filarean hur man kan kontroller om och var två linjer möts.

/MVH
Peter S

Jag kunde inte låta bli att komma med min egen version.
Den baseras på att linjer även skrivs på normalform - ax+by=c
Om du på något sätt vill returnera koordinaterna så är det lätt. Det är helt enkelt x och y i LinesCross.


<code>

Option Explicit

Private Type LineType 'ax+by=c
a As Double
b As Double
c As Double
End Type

Public Function LinesCross(Line1X1, Line1Y1, Line1X2, Line1Y2, Line2X1, Line2Y1, Line2X2, Line2Y2) As Boolean
Dim Line1 As LineType, Line2 As LineType
Dim X As Double, Y As Double
Line1 = CreateLine(Line1X1, Line1Y1, Line1X2, Line1Y2)
Line2 = CreateLine(Line2X1, Line2Y1, Line2X2, Line2Y2)

If Not Intersection(Line1, Line2, X, Y) Then
LinesCross = False
Exit Function
End If

If X < Min(Line1X1, Line1X2) Or X < Min(Line2X1, Line2X2) Or _
X > Max(Line1X1, Line1X2) Or X > Max(Line2X1, Line2X2) Or _
Y < Min(Line1Y1, Line1Y2) Or Y < Min(Line2Y1, Line2Y2) Or _
Y > Max(Line1Y1, Line1Y2) Or Y > Max(Line2Y1, Line2Y2) Then
LinesCross = False
Else
LinesCross = True
End If
End Function

Private Function Intersection(Line1 As LineType, Line2 As LineType, X As Double, Y As Double) As Boolean
Dim n As Double 'nämnaren (determinanten)
Intersection = True
n = Line2.a * Line1.b - Line2.b * Line1.a
If n = 0 Then Intersection = False: Exit Function

X = -(Line2.b * Line1.c - Line2.c * Line1.b) / n
Y = (Line2.a * Line1.c - Line2.c * Line1.a) / n
End Function

Private Function CreateLine(x1, y1, x2, y2) As LineType
Dim NewLine As LineType
Dim dx As Double, dy As Double
dx = x1 - x2
dy = y2 - y1
With NewLine
.a = dy
.b = dx
.c = dx * y1 + dy * x1
End With
CreateLine = NewLine
End Function

Private Function Min(a, b) As Double
If a < b Then Min = a Else Min = b
End Function

Private Function Max(a, b) As Double
If a > b Then Max = a Else Max = b
End Function


</code>



/Niklas Jansson

Hej
Frångår en princip , korsmailer detta inlägg.

Jag funderade en hel del på problemmet.Jag tänkte i helt
andra banor. Ser en skärm framför mig. läser vilka pixel
rsp linje omfattar.Om dom någonstans ockuperar samma pixel
så korsar dom varandra.
Dvs det finns en matematik lösning på ett papper och en
data lösning på en skärm,

mvh
Sven

Sven: Jag förstår vad du menar, men för att det skall vara hållbart måste man nästan använda två algoritmer (förmodligen bresenhams?) som man korsexekverar. Det kan bli ganska ineffektivt, och samtidigt inte så intiutivt.
Min funktion är visserligen inte speciellt lättförstålig den heller, men den är ganska effektiv. Vill man göra den effektivare är det bara att trixa med variablernas typer. Jag tror faktiskt inte att någon variabel måste vara flyttal.

Dessutom kan man justera a, b och c så att de blir mindre.

Om någon är intresserad av programmet kan jag förklara matematiken bakom. Säg bara till.

Det finns vissa förändringar/förbättringar man kan göra. Jag hjälper gärna till.


/Niklas Jansson

oj oj oj !!!!

Har varit och splelat lite golf sedan jag la upp programmet.
Blev lite stressigt att komma iväg. Prova i stort sett därför
inte programmet innan vilket man bör gjöra. Men tänkte att
'principen' på hur man gör borde framgå. Redan i bilen så
kom jag på en del buggar. Nu när jag tittar på det igen så
hittar jag på flera andra. Kommer att 'modifiera' programmet
något och skicka upp en ny version vid ca 23.00

MVH
/Peter S

Tack. Verkar fungera felfrit. Tagit mig friheten att städa upp den

<code>
Option Explicit

Private Type LineType
DX As Long
DY As Long
c As Double
MinY As Long
MaxY As Long
MinX As Long
MaxX As Long
End Type

Public Function LinesCross(Line1X1 As Long, Line1Y1 As Long, Line1X2 As Long, Line1Y2 As Long, Line2X1 As Long, Line2Y1 As Long, Line2X2 As Long, Line2Y2 As Long) As Boolean
Dim Line1 As LineType, Line2 As LineType
Dim X As Long, Y As Long
Line1 = CreateLine(Line1X1, Line1Y1, Line1X2, Line1Y2)
Line2 = CreateLine(Line2X1, Line2Y1, Line2X2, Line2Y2)

If Intersection(Line1, Line2, X, Y) Then
If X < Line1.MinX Then
ElseIf X < Line2.MinX Then
ElseIf X > Line1.MaxX Then
ElseIf X > Line2.MaxX Then
ElseIf Y < Line1.MinY Then
ElseIf Y < Line2.MinY Then
ElseIf Y > Line1.MaxY Then
ElseIf Y > Line2.MaxY Then
Else
LinesCross = True
End If
End If
End Function

Private Function Intersection(Line1 As LineType, Line2 As LineType, X As Long, Y As Long) As Boolean
Dim n As Double
n = Line2.DY * Line1.DX - Line2.DX * Line1.DY
If n Then
X = -(Line2.DX * Line1.c - Line2.c * Line1.DX) / n
Y = (Line2.DY * Line1.c - Line2.c * Line1.DY) / n
Intersection = True
End If
End Function

Private Function CreateLine(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) As LineType
With CreateLine
.DY = Y2 - Y1
.DX = X1 - X2
.c = .DX * Y1 + .DY * X1
If X1 > X2 Then
.MaxX = X1
.MinX = X2
Else
.MaxX = X2
.MinX = X1
End If
If Y1 > Y2 Then
.MaxY = Y1
.MinY = Y2
Else
.MaxY = Y2
.MinY = Y1
End If
End With
End Function</code>