Hi Joe,
Zwischenergebnis, sieh mal. ob Du etwas davon gebrauchen kannst.
In der Form:
Option Explicit
Private Declare Function CreateFont Lib "gdi32" Alias \_
"CreateFontA" (ByVal H As Long, ByVal w As Long, \_
ByVal E As Long, ByVal O As Long, ByVal w As \_
Long, ByVal i As Long, ByVal u As Long, ByVal S \_
As Long, ByVal C As Long, ByVal OP As Long, ByVal \_
CP As Long, ByVal Q As Long, ByVal PAF As Long, \_
ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal \_
hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal \_
hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" \_
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, \_
ByVal lpString As String, ByVal nCount As Long) As Long
Dim x&, y&
Dim Dest() As Integer
Dim Kommentar() As String
Dim Src As Integer
Private Sub Form\_Load()
ReDim Dest(Pic.LBound To Pic.UBound)
ReDim Kommentar(Pic.LBound To Pic.UBound)
End Sub
Private Sub anzeigen()
Dim w As Long
Dim i As Integer
Me.Cls
For i = Pic.LBound To Pic.UBound
If Dest(i) 0 Then
w = -Winkel(Pic(i).Left, Pic(i).Top, Pic(Dest(i)).Left, Pic(Dest(i)).Top)
TOut Pic(i).Left, Pic(i).Top, w, 12, " " + Kommentar(i)
Line (Pic(Dest(i)).Left, Pic(Dest(i)).Top)-(Pic(i).Left, Pic(i).Top), vbBlack
End If
Next
End Sub
Private Sub Pic\_Click(Index As Integer)
Dim w As Long
If Dest(Index) 0 Then
Kommentar(Dest(Index)) = ""
Kommentar(Index) = ""
Pic(Index).BackColor = Me.BackColor
Pic(Dest(Index)).BackColor = Me.BackColor
Dest(Dest(Index)) = 0
Dest(Index) = 0
End If
If Src = 0 Then
Src = Index
Pic(Index).BackColor = vbRed
Else
Dest(Index) = Src
Dest(Src) = Index
Kommentar(Dest(Index)) = InputBox("Kommentar eingeben", "Kommentar")
Kommentar(Index) = Kommentar(Dest(Index))
anzeigen
Pic(Src).BackColor = vbWhite
Pic(Dest(Src)).BackColor = vbWhite
Src = 0
End If
End Sub
Private Sub Command1\_Click()
Dim i As Integer
List1.Clear
For i = Pic.LBound To Pic.UBound
List1.AddItem CStr(i) & " - " & CStr(Dest(i)) + " - " + Kommentar(i)
Next
End Sub
Private Sub TOut(x&, y&, Winkel&, Size%, Text$)
Dim hFont&, FontMem&, Bold&, Result&
If Me.FontBold Then
Bold = 700
Else
Bold = 400
End If
hFont = CreateFont(-Size, 0, Winkel \* 10, 0, Bold, \_
Me.FontItalic, Me.FontUnderline, 0, 1, 4, &H10, \_
2, 4, "Arial")
FontMem = SelectObject(Me.hdc, hFont)
Result = TextOut(Me.hdc, x, y, Text, Len(Text))
Result = SelectObject(Me.hdc, FontMem)
Result = DeleteObject(hFont)
End Sub
Dann musst Du noch ein Modul hinzufügen, die Winkelberechnung wollte ich nicht auch noch in der Form haben.
Im Modul:
Option Explicit
Public Const Pi = 3.14159265358979
Public Function Winkel(ByVal xt As Integer, ByVal yt As Integer, \_
ByVal xb As Integer, ByVal yb As Integer) As Long
Dim alpha As Double
Dim atan As Double
Dim dx As Integer
Dim dy As Integer
Dim hyp As Integer
Dim SinAlpha As Single
Dim CosAlpha As Single
Dim w As Single
Dim sel As Integer
dx = xb - xt
dy = yb - yt
hyp = Sqr(dx ^ 2 + dy ^ 2)
SinAlpha = dy / hyp
CosAlpha = dx / hyp
If Sqr(-SinAlpha \* SinAlpha + 1) \> 0 Then
Winkel = Atn(SinAlpha / Sqr(-SinAlpha \* SinAlpha + 1)) / Pi \* 180
Else
Winkel = 90
End If
sel = Sgn(SinAlpha) + (2 \* Sgn(CosAlpha))
Select Case sel
Case -3
Winkel = 180 + Abs(Winkel)
Case -1
Winkel = 180 - Winkel
Case 1
Winkel = 360 - Abs(Winkel)
Case Else
End Select
If Winkel = 90 Or Winkel = 270 Then
Winkel = Winkel + 180
End If
If Winkel = 0 And xt \> xb Then
Winkel = 180
End If
End Function
Inzwischen ist der Code doch etwas umfangreicher. Verstehst Du noch alles?
Gruß, Rainer
