Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

Drag & Drop - Editor zum Erstellen von Flussdiagrammen

Uploader:Mitgliedgrindstone
Datum/Zeit:17.10.2016 17:19:15
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Drag & Drop - Editor zum Erstellen von Flussdiagrammen, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
Warnung: Es steht bereits eine neuere Version des Quelltexts zur Verfügung. Die hier vorliegende alte Version könnte Fehler enthalten, die in der neuen Version vielleicht ausgebessert wurden.

#Include "file.bi"

Const pi As Double = ACos(0)*2
Const rest = 0

Dim Shared As ULong schwarz = RGB(0,0,0), _
                      weiss = RGB(255,255,255), _
                        rot = RGB(255,0,0), _
                  hellgruen = RGB(0,128,0), _
                      gruen = RGB(0,255,0)

Enum
    oval = 1
    rechteck
    raute
    rhombus
    unterprogramm
    punkt
End Enum

Enum
    _ndef = 0
    _oben
    _unten
    _rechts
    _links
End Enum

Enum
    _legende = 1
    _diagramm
    _raster
    _grafik
    _hintergrund
End Enum

Type tPunkt
    x As Integer
    y As Integer
    typ As UByte 'oben/unten/rechts/links
    ofs As Integer 'länge des anfangs-/endstücks
    index As Integer
End Type

Type tPfeilparameter
    von As tPunkt
    bis As tPunkt
    verlauf As String = ""
    text As String = ""
    farbe As ULong = RGB(255,255,255)
    grafikpuffer As Any Ptr
End Type

Operator + (punkt As tPunkt, offset As Integer) As tPunkt
    'zum festlegen der individuellen länge des anfangs- bzw. endstückes des verbindungspfeils
    Dim As tPunkt pReturn

    pReturn = punkt
    pReturn.ofs = offset
    Return pReturn
End Operator


Type tDiagramm
    muster As UByte
    Union
        xpos As Integer
        musterposx As Integer 'fd(0)
    End Union
    ypos As Integer
    Union
        breite As Integer
        fangbereich As Integer 'fd(0)
    End Union
    hoehe As Integer
    ofsdefault As Integer = 20
    text As String
    farbe As ULong = RGBA(255,255,255,255)
    textfarbe As ULong = RGBA(255,255,255,255)
    indexfarbe As ULong = RGBA(0,255,0,255)
    Union
        flag As UByte
        rasterflag As UByte 'fd(0), zum ANZEIGEN des rasters
    End Union
    arrayptr As Any Ptr
    grafikpuffer As Any Ptr

    Static As ULong hintergrundfarbe
    Static As Any Ptr diagrammpuffer

    Declare Property oben As tPunkt
    Declare Property unten As tPunkt
    Declare Property rechts As tPunkt
    Declare Property links As tPunkt
    Declare Property index As String

    Declare Sub zeichnen
    Declare Sub pfeil (von As tPunkt, bis As tPunkt, text As String = "", farbe As ULong = RGBA(255,255,255,255))
    Declare Function pfeil(von As tPunkt, verlauf As String, text As String = "", farbe As ULong = RGBA(255,255,255,255)) As tPunkt
    Declare Function hindernis(von As tPunkt, bis As tPunkt) As Integer
End Type

Static As ULong tDiagramm.hintergrundfarbe
Static As Any Ptr tDiagramm.diagrammpuffer

Property tDiagramm.oben As tPunkt 'oberer anschlusspunkt
    If muster = punkt Then
        tDiagramm.oben = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
    Else
        tDiagramm.oben = Type<tPunkt>(xpos, ypos - hoehe / 2, _oben, ofsdefault, 0)
    EndIf
End Property

Property tDiagramm.unten As tPunkt 'unterer anschlusspunkt
    If muster = punkt Then
        tDiagramm.unten = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
    Else
        tDiagramm.unten = Type<tPunkt>(xpos, ypos + hoehe / 2, _unten, ofsdefault, 0)
    EndIf
End Property

Property tDiagramm.links As tPunkt 'linker anschlusspunkt
    If muster = punkt Then
        tDiagramm.links = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
    Else
        tDiagramm.links = Type<tPunkt>(xpos - breite / 2, ypos, _links, ofsdefault, 0)
    EndIf
End Property

Property tDiagramm.rechts As tPunkt 'rechter anschlusspunkt
    If muster = punkt Then
        tDiagramm.rechts = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
    Else
        tDiagramm.rechts = Type<tPunkt>(xpos + breite / 2, ypos, _rechts, ofsdefault, 0)
    EndIf
End Property

Property tDiagramm.index As String
    If arrayptr Then
        Return Str((Cast(UInteger,@This) - Cast(UInteger,arrayptr)) / SizeOf(This))
    Else
        Return ""
    EndIf
End Property

Sub tDiagramm.zeichnen
    Dim As Integer h2 = hoehe / 2
    Dim As Integer b2 = breite / 2
    Dim As Integer a, e
    ReDim As String t(0)

    'element zeichnen
    Select Case muster
        Case oval
            Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos - b2  + breite - h2, ypos - h2), farbe
            Line grafikpuffer, (xpos - b2  + h2, ypos + h2) - (xpos - b2  + breite - h2, ypos + h2), farbe
            Circle grafikpuffer, (links.x + h2, links.y), h2, farbe, pi/2, pi/2*3
            Circle grafikpuffer, (rechts.x - h2, rechts.y), h2, farbe,  pi/2*3, pi/2
        Case rechteck
            Line grafikpuffer, (xpos - b2, ypos - h2) - (xpos + b2, ypos + h2), farbe, B
        Case raute
            Line grafikpuffer, (links.x, links.y) - (oben.x, oben.y), farbe
            Line grafikpuffer, (oben.x, oben.y) - (rechts.x, rechts.y), farbe
            Line grafikpuffer, (rechts.x, rechts.y) - (unten.x, unten.y), farbe
            Line grafikpuffer, (unten.x, unten.y) - (links.x, links.y), farbe
        Case rhombus
            Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos + b2, ypos - h2), farbe
            Line grafikpuffer, (xpos - b2, ypos + h2) - (xpos + b2 - h2, ypos + h2), farbe
            Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos - b2, ypos + h2), farbe
            Line grafikpuffer, (xpos + b2, ypos - h2) - (xpos + b2 - h2, ypos + h2), farbe
        Case unterprogramm
            Line grafikpuffer, (xpos - b2, ypos - h2) - (xpos + b2, ypos + h2), farbe, B
            Line grafikpuffer, (xpos - b2 + 10, ypos - h2) - (xpos - b2 + 10, ypos + h2), farbe
            Line grafikpuffer, (xpos + b2 - 10, ypos - h2) - (xpos + b2 - 10, ypos + h2), farbe
    End Select

    'text hineinschreiben
    a = 1
    Do 'teilstrings in array schreiben
        ReDim Preserve t(UBound(t) + 1)
        e = InStr(e + 1,text,"\n")
        t(UBound(t)) = Mid(text,a,e - a)
        a = e + 2
    Loop While e

    For a = 1 To UBound(t) 'text zentriert ausgeben
        Draw String grafikpuffer, (oben.x - (Len(t(a)) * 8 / 2), links.y - (UBound(t) * 4 - 1) + 8 * (a - 1)), t(a), textfarbe
    Next

    'optionalen index ausgeben
    Draw String grafikpuffer, (oben.x - Len(index) * 8 / 2, oben.y + 2), index, indexfarbe

    flag = 1 'sperrflag setzen
End Sub

Sub tDiagramm.pfeil(von As tPunkt, bis As tPunkt, text As String = "", farbe As ULong = RGBA(255,255,255,255))
    'parameter:
    'von     - anfangspunkt der verbindung
    'bis     - endpunkt der verbindung
    'text    - optionaler text am anfang der verbindungslinie
    'farbe   - farbe der verbindungslinie (default: weiss)

    Dim As tPunkt von2, bis2
    Dim As Integer spitzenlaenge = 8 'länge der pfeilspitze
    Dim As String verlauf

    'anfangsstück
    von2 = von
    Select Case von.typ
        Case _ndef
            '"punkt" als anfang hat kein anfangsstück
            verlauf = ""
        Case _oben',_ndef
            von2.y -= von.ofs
            verlauf = "o" + Str(von.ofs)
        Case _unten
            von2.y += von.ofs
            verlauf = "u" + Str(von.ofs)
        Case _rechts 'falls erforderlich, linie um den text herumführen
            von2.x += IIf((von.ofs < Len(text) * 8 + 4) And (von.y > bis.y), Len(text) * 8 + 4, von.ofs)
            verlauf = "r" + Str(Abs(von.x - von2.x))
        Case _links 'falls erforderlich, linie um den text herumführen
            von2.x -= IIf((von.ofs < Len(text) * 8 + 4) And (von.y > bis.y), Len(text) * 8 + 4, von.ofs)
            verlauf = "l" + Str(Abs(von.x - von2.x))
    End Select

    'länge des endabschnitts setzen
    bis2 = bis
    Select Case bis.typ
        Case _ndef
            '"punkt" als ziel hat keinen endabschnitt
        Case _oben', _ndef
            bis2.y -= bis.ofs
        Case _unten
            bis2.y += bis.ofs
        Case _rechts
            bis2.x += bis.ofs
        Case _links
            bis2.x -= bis.ofs
    End Select

    If von.typ = _ndef Then
        von.typ = _unten
        If von2.x > bis2.x Then
            von.typ = _links
        ElseIf von2.x < bis2.x Then
            von.typ = _rechts
        ElseIf von2.y > bis2.y Then
            von.typ = _oben
        EndIf
    EndIf

    Select Case von.typ
        Case _oben
            If bis2.y < von2.y Then 'ende höher als anfang
                verlauf += "o" + Str(Abs(von2.y - bis2.y)) 'zuerst y
                verlauf += IIf(von2.x < bis2.x, "r" ,"l") + Str(Abs(von2.x - bis2.x)) 'dann x
            Else
                verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x)) 'zuerst x
                verlauf += "u" + Str(Abs(von2.y - bis2.y)) 'dann y
            EndIf

        Case _unten
            If bis2.y < von2.y Then 'ende höher als anfang
                verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x))
                verlauf += "o" + Str(Abs(von2.y - bis2.y))
            Else
                verlauf += "u" + Str(Abs(von2.y - bis2.y))
                verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x))
            EndIf

        Case _links
            If bis2.x < von2.x Then 'ende weiter links als anfang
                verlauf += "l" + Str(Abs(von2.x - bis2.x))
                verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
            Else
                verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
                verlauf += "r" + Str(Abs(von2.x - bis2.x))
            EndIf

        Case _rechts
            If bis2.x < von2.x Then 'ende weiter links als anfang
                verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
                verlauf += "l" + Str(Abs(von2.x - bis2.x))
            Else
                verlauf += "r" + Str(Abs(von2.x - bis2.x))
                verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
            EndIf

    End Select

    'endabschnitt
    Select Case bis.typ
        Case _oben
            verlauf += "u" + Str(Abs(bis.y - bis2.y))
        Case _unten
            verlauf += "o" + Str(Abs(bis.y - bis2.y))
        Case _rechts
            verlauf += "l" + Str(Abs(bis.x - bis2.x))
        Case _links
            verlauf += "r" + Str(Abs(bis.x - bis2.x))
    End Select

    If bis.typ <> _ndef Then 'pfeilspitze, wenn muster <> "punkt"
        verlauf += "p"
    EndIf

    pfeil(von, verlauf, text, farbe) 'zeichnen

End Sub

Function tDiagramm.pfeil(von As tPunkt, verlauf As String, text As String = "", farbe As ULong = RGBA(255,255,255,255)) As tPunkt
    Dim As Integer a = 1, h
    Dim As String richtung
    Dim As tPunkt p1, p2 = von
    Dim As Integer spitzenlaenge = 8 'länge der pfeilspitze

    'optionalen text ausgeben
    Select Case von.typ
        Case _oben
            Draw String grafikpuffer, (von.x + 2, von.y - 9), text, farbe
        Case _unten
            Draw String grafikpuffer, (von.x + 2, von.y + 2), text, farbe
        Case _rechts
            Draw String grafikpuffer, (von.x + 2, von.y - 9), text, farbe 'linksbündig über der linie
        Case _links
            Draw String grafikpuffer, (von.x -(Len(text) * 8 + 1), von.y - 9), text, farbe 'rechtsbündig über der linie
        Case Else
            Draw String grafikpuffer, (von.x + 2, von.y + 2), text, farbe
    End Select

    Do 'verlauf abarbeiten
        p1 = p2 'endpunkt als neuen anfangspunkt setzen
        Select Case Mid(verlauf,a,1)
            Case "o"
                a += 1 'zeiger auf längenangabe
                richtung = "o" 'letzte richtung merken
                p2.y -= Val(Mid(verlauf,a)) 'endpunkt setzen
                h = hindernis(p1,p2) 'auf hindernis prüfen
                If h Then 'linie nur bis zum hindernis zeichnen
                    p2.y = p1.y - h
                    If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
                        a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
                    Else
                        a = Len(verlauf) 'linie beenden
                    EndIf
                EndIf
                Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe 'linie zeichnen
            Case "u"
                a += 1
                richtung = "u"
                p2.y += Val(Mid(verlauf,a))
                h = hindernis(p1,p2) 'auf hindernis prüfen
                If h Then 'linie nur bis zum hindernis zeichnen
                    p2.y = p1.y + h
                    If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
                        a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
                    Else
                        a = Len(verlauf) 'linie beenden
                    EndIf
                EndIf
                Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
            Case "r"
                a += 1
                richtung = "r"
                p2.x += Val(Mid(verlauf,a))
                h = hindernis(p1,p2) 'auf hindernis prüfen
                If h Then 'linie nur bis zum hindernis zeichnen
                    p2.x = p1.x + h
                    If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
                        a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
                    Else
                        a = Len(verlauf) 'linie beenden
                    EndIf
                EndIf
                Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
            Case "l"
                a += 1
                richtung = "l"
                p2.x -= Val(Mid(verlauf,a))
                h = hindernis(p1,p2) 'auf hindernis prüfen
                If h Then 'linie nur bis zum hindernis zeichnen
                    p2.x = p1.x - h
                    If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
                        a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
                    Else
                        a = Len(verlauf) 'linie beenden
                    EndIf
                EndIf
                Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
            Case "p" 'pfeilspitze
                spitzenlaenge = Val(Mid(verlauf,a + 1))
                If spitzenlaenge = 0 Then
                    spitzenlaenge = 8 'defaultwert
                Else
                    a += 1
                EndIf
                Select Case richtung 'richtung der letzten linie
                    Case "o"
                        Line grafikpuffer, (p2.x, p2.y + spitzenlaenge) - (p2.x, p2.y), hintergrundfarbe 'linie innerhalb des pfeils löschen
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge/2, p2.y + spitzenlaenge), farbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge/2, p2.y + spitzenlaenge), farbe
                        Line grafikpuffer, (p2.x + spitzenlaenge/2, p2.y + spitzenlaenge) - (p2.x - spitzenlaenge/2, p2.y + spitzenlaenge), farbe
                    Case "u"
                        Line grafikpuffer, (p2.x, p2.y - spitzenlaenge) - (p2.x, p2.y), hintergrundfarbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge/2, p2.y - spitzenlaenge), farbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge/2, p2.y - spitzenlaenge), farbe
                        Line grafikpuffer, (p2.x - spitzenlaenge/2, p2.y - spitzenlaenge) - (p2.x + spitzenlaenge/2, p2.y - spitzenlaenge), farbe
                    Case "r"
                        Line grafikpuffer, (p2.x - spitzenlaenge, p2.y) - (p2.x, p2.y), hintergrundfarbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge, p2.y - spitzenlaenge/2), farbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge, p2.y + spitzenlaenge/2), farbe
                        Line grafikpuffer, (p2.x - spitzenlaenge, p2.y - spitzenlaenge/2) - (p2.x - spitzenlaenge, p2.y + spitzenlaenge/2), farbe
                    Case "l"
                        Line grafikpuffer, (p2.x + spitzenlaenge, p2.y) - (p2.x, p2.y), hintergrundfarbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge, p2.y - spitzenlaenge/2), farbe
                        Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge, p2.y + spitzenlaenge/2), farbe
                        Line grafikpuffer, (p2.x + spitzenlaenge, p2.y - spitzenlaenge/2) - (p2.x + spitzenlaenge, p2.y + spitzenlaenge/2), farbe
                End Select
                a += 1
        End Select

        Do While InStr("0123456789 ", Mid(verlauf,a,1)) 'zeiger hinter längenangabe setzen
            a += 1
        Loop
    Loop While a <= Len(verlauf)

    Select Case richtung
        Case "o"
            p2.typ = _oben
        Case "u"
            p2.typ = _unten
        Case "r"
            p2.typ = _rechts
        Case "l"
            p2.typ = _links
    End Select

    Return p2

End Function

Function tDiagramm.hindernis(von As tPunkt, bis As tPunkt) As Integer
    Dim As Integer i, d
    Dim As Any Ptr puffer

    If diagrammpuffer Then
        puffer = diagrammpuffer 'pointer auf externen puffer
    Else
        puffer = grafikpuffer 'pointer von element
    EndIf

    If von.x = bis.x Then 'senkrechte linie
        d = Abs(von.y - bis.y)
        If von.y < bis.y Then 'nach oben
            For i = 1 To d
                If Point(von.x, von.y + i, puffer) <> hintergrundfarbe Then
                    Return IIf(i > 2, i, 0)
                EndIf
            Next
        Else 'nach unten
            For i = 1 To d
                If Point(von.x, von.y - i, puffer) <> hintergrundfarbe Then
                    Return IIf(i > 2, i, 0)
                EndIf
            Next
        EndIf
    ElseIf von.y = bis.y Then 'waagerechte linie
        d = Abs(von.x - bis.x)
        If von.x < bis.x Then 'nach rechts
            For i = 1 To d
                If Point(von.x + i, von.y, puffer) <> hintergrundfarbe Then
                    Return IIf(i > 2, i, 0)
                EndIf
            Next
        Else 'nach links
            For i = 1 To d
                If Point(von.x - i, von.y, puffer) <> hintergrundfarbe Then
                    Return IIf(i > 2, i, 0)
                EndIf
            Next
        EndIf
    EndIf
    Return 0

End Function

'#################################################################################
'#################################################################################
'#################################################################################
'#################################################################################
'#################################################################################

Type tFlag
    edit : 1 As Integer
    maus : 1 As Integer
End Type
Dim As tFlag flag

Type tMenu 'zur übergabe der parameter von mausMenu an menuInput
    As Integer dummy
    Static As Integer yPos, xPos
    Static As ULong foreground, background
    Static As String text
    Static As Any Ptr buffer
End Type

Static As Integer tMenu.yPos, tMenu.xPos
Static As ULong tMenu.foreground, tMenu.background
Static As String tMenu.text
Static As Any Ptr tMenu.buffer


Declare Function parse OverLoad(satz As String = "", trenner As String = "") As String
Declare Function parse(flag As Integer) As String
Declare Sub parliste(par As String, parameter() As String)
Declare Sub neuZeichnen()
Declare Sub pfeil(par As tPfeilparameter)
Declare Function istAnschlussPunkt(index As Integer = 0) As tPunkt
Declare Sub textInput(ByRef txt As String, ByRef sp As Integer)
Declare Function zeichenEntfernen(text As String, zeichen As String) As String
Declare Sub pfeileAnpassen(index As Integer)
Declare Sub diagrammVerschieben
Declare Sub puffergroesseAnpassen
Declare Sub neuesRaster()
Declare Sub diagrammLaden()
Declare Sub diagrammSpeichern()
Declare Sub programmEnde()
Declare Sub umlaute(ByRef text As String)
Declare Function ini(datei As String, variable As String) As String
Declare Function menuInput OverLoad (value As Integer, xPos As Integer = 0, yPos As Integer = 0) As Integer
Declare Function menuInput(value As String, xPos As Integer = 0, yPos As Integer = 0) As String
Declare Function mausMenu(text As String, _
                          separator As String = "", _
                          xPos As Integer = 0, _
                            yPos As Integer = 0, _
                            foreground As ULong, _
                            background As ULong, _
                            mode As UByte = 0, _
                            buffer As Any Ptr = 0) As Integer


Dim As String g, ausgabedatei, txt, datei, inivarname

Dim As Integer x, y, a, e, ms, sp,  cp,  inival, ff, fangbereich, _
               breite, hoehe, bpp, sc_breite, sc_hoehe, _
               mx, my, rad, tasten, radvor, radvor2, _
               musterbreite = 140, musterabstand = 50

Dim As tPunkt anfangspunkt, endpunkt

Dim Shared As Any Ptr puffer(_raster)

Dim Shared As String letztedatei

Dim Shared As Integer pufferbreite, pufferhoehe, xanf, yanf, _
                      ofsanfang, ofsende, ovalbreite, ovalhoehe, rechteckbreite, _
                      rechteckhoehe, rautenbreite, rautenhoehe, rhombusbreite, _
                      rhombushoehe, subbreite, subhoehe

Dim Shared As tPunkt raster, rastervorgabe

Dim As tDiagramm muster(punkt) 'oval, rechteck, raute, rhombus, unterprogramm, punkt

ReDim As String parameter(0)
ReDim As String text(0)

ReDim Shared As tDiagramm fd(0)
ReDim Shared As tPfeilparameter pfeile(0)

ScreenRes 1000, 800, 32
ScreenInfo sc_breite, sc_hoehe

pufferbreite = sc_breite * 2 'anfangswerte
pufferhoehe = sc_hoehe * 2


#Macro mausLoslassen
    Do
        GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
        Sleep 1
    Loop While tasten
#EndMacro

#Macro inispeichern
    Print #ff, "letzteDatei=";letztedatei
    Print #ff, "ofsanfang=";Str(ofsanfang)
    Print #ff, "ofsende=";Str(ofsende)
    Print #ff, "ovalbreite=";Str(ovalbreite)
    Print #ff, "ovalhoehe=";Str(ovalhoehe)
    Print #ff, "rechteckbreite=";Str(rechteckbreite)
    Print #ff, "rechteckhoehe=";Str(rechteckhoehe)
    Print #ff, "rautenbreite=";Str(rautenbreite)
    Print #ff, "rautenhoehe=";Str(rautenhoehe)
    Print #ff, "rhombusbreite=";Str(rhombusbreite)
    Print #ff, "rhombushoehe=";Str(rhombushoehe)
    Print #ff, "subbreite=";Str(subbreite)
    Print #ff, "subhoehe=";Str(subhoehe)
    Print #ff, "rasterx=";Str(raster.x)
    Print #ff, "rastery=";Str(raster.y)
    Print #ff, "rastervorgabex=";Str(rastervorgabe.x)
    Print #ff, "rastervorgabey=";Str(rastervorgabe.y)
#EndMacro

#Macro iniholen
    Seek ff,1
    Do
        Line Input #ff, g
        inivarname = Left(g, InStr(g, "=") - 1)
        inival = Val(Mid(g, InStr(g, "=") + 1))
        Select Case inivarname
            Case "letzteDatei"
                letztedatei = Mid(g, InStr(g, "=") + 1)
            Case "ofsanfang"
                ofsanfang = inival
            Case "ofsende"
                ofsende = inival
            Case "ovalbreite"
                ovalbreite = inival
            Case "ovalhoehe"
                ovalhoehe = inival
            Case "rechteckbreite"
                rechteckbreite = inival
            Case "rechteckhoehe"
                rechteckhoehe = inival
            Case "rautenbreite"
                rautenbreite = inival
            Case "rautenhoehe"
                rautenhoehe = inival
            Case "rhombusbreite"
                rhombusbreite = inival
            Case "rhombushoehe"
                rhombushoehe = inival
            Case "subbreite"
                subbreite = inival
            Case "subhoehe"
                subhoehe = inival
            Case "rasterx"
                raster.x = inival
            Case "rastery"
                raster.y = inival
            Case "rastervorgabex"
                rastervorgabe.x = inival
            Case "rastervorgabey"
                rastervorgabe.y = inival
        End Select
    Loop Until EOF(ff)
#EndMacro

#Macro defaultwerteSetzen
    ofsanfang = 20
    ofsende = 20
    ovalbreite = 200
    ovalhoehe = 20
    rechteckbreite = 200
    rechteckhoehe = 40
    rautenbreite = 200
    rautenhoehe = 50
    rhombusbreite = 200
    rhombushoehe = 40
    subbreite = 200
    subhoehe = 40
    rastervorgabe.x = 150
    rastervorgabe.y = 100
    raster = rastervorgabe
#EndMacro


puffer(_legende) = ImageCreate(sc_breite, sc_hoehe, RGB(255,0,255), 32) 'hintergrund transparent
puffer(_diagramm) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
puffer(_raster) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)

tDiagramm.diagrammpuffer = puffer(_diagramm)

defaultwerteSetzen

'werte aus inidatei laden
datei = Command(0) 'programmname mit pfad
datei = Left(datei, InStrRev(datei, ".exe") - 1) + ".ini"
If FileExists(datei) Then
    ff = FreeFile
    Open datei For Input As #ff
    iniholen
    Close ff
EndIf

'musterpuffer anlegen
With muster(oval)
    .muster = oval
    .breite = musterbreite
    .hoehe = 20
    .text = "Start / Ende"
    .ypos = .hoehe / 2 + 10
End With

With muster(rechteck)
    .muster = rechteck
    .breite = musterbreite
    .hoehe = 20
    .text = "Anweisung"
    .ypos = muster(rechteck - 1).ypos + muster(rechteck - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With

With muster(raute)
    .muster = raute
    .breite = musterbreite
    .hoehe = 40
    .text = "Entscheidung"
    .ypos = muster(raute - 1).ypos + muster(raute - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With

With muster(rhombus)
    .muster = rhombus
    .breite = musterbreite
    .hoehe = 20
    .text = "Ein- / Ausgabe"
    .ypos = muster(rhombus - 1).ypos + muster(rhombus - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With

With muster(unterprogramm)
    .muster = unterprogramm
    .breite = musterbreite
    .hoehe = 20
    .text = "Unterprogramm"
    .ypos = muster(unterprogramm - 1).ypos + muster(unterprogramm - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With

With muster(punkt)
    .muster = punkt
    .breite = musterbreite
    .hoehe = 20
    .text = "Punkt"
    .ypos = muster(punkt - 1).ypos + muster(punkt - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With

'werte für erforderliche höhe und breite des musterpuffers berechnen
x = 0
y = 0
For i As Integer = 1 To UBound(muster) 'grössten x- und y - wert suchen
    With muster(i)
        If .unten.y > y Then
            y = .unten.y
        EndIf
        If .breite > x Then
            x = .breite
        EndIf
    End With
Next

fd(0).musterposx = sc_breite - x - 20 'x - position der legende im grafikfenster
Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende

For i As Integer = 1 To UBound(muster)
    With muster(i)
        .xpos = sc_breite - x / 2 - 10
        .grafikpuffer = puffer(_legende)
    End With
Next

tDiagramm.hintergrundfarbe = Point(0,0,puffer(_diagramm))
raster = rastervorgabe
flag.edit = 1 'für anzeige der indices
fangbereich = 5
fd(0).fangbereich = fangbereich

neuesRaster

GetMouse mx, my, rad, tasten
radvor2 = rad

Do 'hauptschleife
    neuZeichnen()
    GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
    'xanf / yanf --> obere linke ecke des im screenfenster angezeigten ausschnitts des diagrammpuffers

    If tasten = -1 Then 'maus ist ausserhalb des fensters
        If InKey = Chr(255,107) Then 'schliessen - button wurde angeklickt
            programmEnde()
        EndIf
        flag.maus = 1
        Sleep 1
        Continue Do
    Else
        If flag.maus Then 'maus ist neu im fenster
            radvor = rad
            radvor2 = rad
            flag.maus = 0
        EndIf
    EndIf

    'musterbereich / legende / neues element anlegen
    For x = 1 To UBound(muster)
        With muster(x)
            If ((mx - xanf) >= .xpos - .breite / 2) AndAlso _
                 ((mx - xanf) <= .xpos + .breite / 2) AndAlso _
                 ((my - yanf) >= .ypos - .hoehe / 2) AndAlso _
                 ((my - yanf) <= .ypos + .hoehe / 2) Then 'mauszeiger über muster
                .farbe = rot
                .textfarbe = rot
                If tasten = 1 Then 'linke maustaste gedrückt --> neues element anlegen
                    ReDim Preserve fd(UBound(fd) + 1) 'neuen platz im array anlegen
                    With fd(UBound(fd))
                        fd(UBound(fd)) = muster(x) 'muster in array kopieren
                        Select Case .muster 'auf elementgröße setzen
                            Case oval
                                .breite = ovalbreite
                                .hoehe = ovalhoehe
                            Case rechteck
                                .breite = rechteckbreite
                                .hoehe = rechteckhoehe
                            Case raute
                                .breite = rautenbreite
                                .hoehe = rautenhoehe
                            Case rhombus
                                .breite = rhombusbreite
                                .hoehe = rhombushoehe
                            Case unterprogramm
                                .breite = subbreite
                                .hoehe = subhoehe
                            Case punkt
                                .breite = 20 'fangbereich zum verschieben
                                .hoehe = 20
                        End Select

                        For i As Integer = 0 To UBound(fd) 'neuer arraypointer (für indexanzeige)
                            fd(i).arrayptr = IIf(flag.edit, @fd(0), 0)
                        Next

                        .farbe = weiss
                        .textfarbe = weiss
                        .grafikpuffer = puffer(_diagramm)
                        Do 'neues element an seinen platz ziehen
                            GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                            If Abs(mx - .xpos) > raster.x / 2 Then
                                .xpos = Int(mx / raster.x) * raster.x
                            EndIf
                            If Abs(my - .ypos) > raster.y / 2 Then
                                .ypos = Int(my / raster.y) * raster.y
                            EndIf
                            neuZeichnen()
                            Sleep 1
                        Loop Until tasten = 0 'auf loslassen der maustaste warten
                        .text = "" 'musterbezeichnung löschen
                        puffergroesseAnpassen
                    End With
                EndIf
            Else
                .farbe = weiss
                .textfarbe = weiss

                'legendenmenü
                ms = muster(unterprogramm).links.x - 8 'spalte für mausmenü
                ScreenSync
                If mausMenu(" Breite = " + Str(ovalbreite),"= ", ms + 10*8, muster(oval).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    ovalbreite = menuInput(ovalbreite)

                ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(ovalhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    ovalhoehe = menuInput(ovalhoehe)

                ElseIf mausMenu(" Breite = " + Str(rechteckbreite),"= ", ms + 10*8, muster(rechteck).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rechteckbreite = menuInput(rechteckbreite)

                ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rechteckhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rechteckhoehe = menuInput(rechteckhoehe)

                ElseIf mausMenu(" Breite = " + Str(rautenbreite),"= ", ms + 10*8, muster(raute).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rautenbreite = menuInput(rautenbreite)

                ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rautenhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rautenhoehe = menuInput(rautenhoehe)

                ElseIf mausMenu(" Breite = " + Str(rhombusbreite),"= ", ms + 10*8, muster(rhombus).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rhombusbreite = menuInput(rhombusbreite)

                ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rhombushoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rhombushoehe = menuInput(rhombushoehe)

                ElseIf mausMenu(" Breite = " + Str(subbreite),"= ", ms + 10*8, muster(unterprogramm).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    subbreite = menuInput(subbreite)

                ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(subhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    subhoehe = menuInput(subhoehe)

                ElseIf mausMenu(" Pfeil Anfang = " + Str(ofsanfang),"= ", ms + 13*8, -7*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    ofsanfang = menuInput(ofsanfang)

                ElseIf mausMenu(" Pfeil   Ende = " + Str(ofsende),"= ", ms + 13*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    ofsende = menuInput(ofsende)


                ElseIf mausMenu(" Raster x = " + Str(rastervorgabe.x),"= ", ms + 9*8, -3*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rastervorgabe.x = menuInput(rastervorgabe.x)
                    raster = rastervorgabe
                    neuesRaster
                    neuZeichnen()

                ElseIf mausMenu(" Raster y = " + Str(rastervorgabe.y),"= ", ms + 9*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    rastervorgabe.y = menuInput(rastervorgabe.y)
                    raster = rastervorgabe
                    neuesRaster
                    neuZeichnen()

                ElseIf mausMenu(" Raster " + IIf(fd(0).rasterflag,"AN  ", "AUS "),, ms, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    fd(0).rasterflag = IIf(fd(0).rasterflag, 0, 1)
                    raster.x = IIf(raster.x = 1, rastervorgabe.x, 1)
                    raster.y = IIf(raster.y = 1, rastervorgabe.y, 1)

                ElseIf mausMenu(" Indexanzeige " + IIf(flag.edit,"AUS ", "AN  "),, ms, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    If flag.edit Then
                        flag.edit = 0
                        For i As Integer = 0 To UBound(fd)
                            fd(i).arrayptr = 0
                        Next
                    Else
                        flag.edit = 1
                        For i As Integer = 0 To UBound(fd)
                            fd(i).arrayptr = @fd(0)
                        Next
                    EndIf

                ElseIf mausMenu(" Werte zur" & Chr(129) & "cksetzen ",,  ms, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    defaultwertesetzen
                    Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende
                    neuesRaster
                    neuZeichnen

                ElseIf mausMenu(" Diagramm laden ",,  ms, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    diagrammLaden()

                ElseIf mausMenu(" Diagramm speichern ",, 0, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    diagrammSpeichern()

                ElseIf mausMenu(" Grafik erstellen ",, 0, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    ScreenInfo sc_breite, sc_hoehe
                    Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf
                    Draw String (fd(0).musterposx / 2 -(21 * 8 / 2), sc_hoehe / 2), "Grafik erstellen.."

                    ausgabedatei = Left(letztedatei, InStrRev(letztedatei, ".") - 1) + ".bmp"

                    ImageInfo puffer(_diagramm), breite, hoehe, bpp
                    puffer(_grafik) = ImageCreate(breite, hoehe,, bpp * 8) 'grafikpuffer erzeugen
                    puffer(_hintergrund) = ImageCreate(breite, hoehe, weiss, bpp * 8) 'grafikpuffer mit weissem hintergrund erzeugen
                    Get puffer(_diagramm), (0,0)-(breite - 1, hoehe - 1), puffer(_grafik) 'diagramm in puffer1 laden
                    Put puffer(_grafik), (0,0), puffer(_hintergrund), Xor 'farben invertieren
                    BSave(ausgabedatei, puffer(_grafik), breite * hoehe * bpp) 'diagramm speichern
                    ImageDestroy puffer(_grafik)
                    puffer(_grafik) = 0
                    ImageDestroy puffer(_hintergrund)
                    puffer(_hintergrund) = 0

                    Draw String (fd(0).musterposx / 2 -(21 * 8 / 2), sc_hoehe / 2 + 16), "fertig"
                    Sleep 1000
                    neuZeichnen

                ElseIf mausMenu(" Beenden ",, 0, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
                    programmEnde()

                EndIf
            EndIf
            .zeichnen
        End With
    Next

    'existierende elemente bearbeiten
    For x = 1 To UBound(fd)
        With fd(x)
            anfangspunkt = istAnschlussPunkt(x) 'anfangspunkt
            If anfangspunkt.index = x Then 'mauscursor befindet sich über einem anschlusspunkt
                '*** PFEILE ***
                .farbe = weiss
                pfeile(0).von = anfangspunkt

                neuZeichnen()

                'pfeilarray durchsuchen
                For y = 1 To UBound(pfeile)
                    If (pfeile(y).von.x = anfangspunkt.x) And (pfeile(y).von.y = anfangspunkt.y) Then 'vom punkt geht schon ein pfeil aus
                        Exit For 'y ist der index des verbundenen pfeils
                    EndIf
                Next

                If tasten = 1 Then 'linke maustaste gedrückt --> pfeilanfang
                    mausloslassen

                    If y > UBound(pfeile) Then 'pfeil anlegen
                        Do 'schleife für pfeil anlegen
                            neuZeichnen()

                            GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                            endpunkt = istAnschlussPunkt() 'endpunkt
                            If endpunkt.index Then 'mauszeiger ist auf anschlusspunkt
                                pfeile(0).bis = endpunkt
                                pfeile(0).bis.ofs = IIf(fd(endpunkt.index).muster = punkt, 0, ofsende)
                            Else
                                pfeile(0).bis.index = 0
                                pfeile(0).bis.typ = _ndef
                                pfeile(0).bis.ofs = 0
                                pfeile(0).bis.x = mx
                                pfeile(0).bis.y = my
                            EndIf

                            pfeile(0).text = ""
                            pfeile(0).farbe = weiss
                            pfeile(0).von.ofs = IIf(fd(anfangspunkt.index).muster = punkt, 0, ofsanfang)
                            pfeile(0).grafikpuffer = puffer(_diagramm)

                            If tasten = 1 Then
                                If endpunkt.index Then 'mauszeiger ist auf anschlusspunkt --> pfeil abspeichern
                                    ReDim Preserve pfeile(y)
                                    pfeile(y) = pfeile(0)
                                    mausLoslassen
                                    Exit Do 'pfeil anlegen beenden
                                Else
                                    diagrammVerschieben
                                EndIf
                            ElseIf tasten = 2 Then 'abbrechen
                                mausLoslassen
                                Exit Do
                            EndIf

                            If rad > radvor2 Then 'scrollen mit mausrad
                                yanf += (radvor2 - rad) * 50
                                radvor2 = rad
                                neuZeichnen
                            ElseIf rad < radvor2 Then
                                yanf -= (rad - radvor2) * 50
                                radvor2 = rad
                                neuZeichnen
                            EndIf

                            Sleep 1
                        Loop
                        pfeile(0).grafikpuffer = 0
                    EndIf

                ElseIf (tasten = 2) And (y <= UBound(pfeile)) Then 'rechte maustaste --> pfeil editieren
                    Do 'schleife für mausmenü
                        radvor = rad
                        radvor2 = rad
                        ms = anfangspunkt.x - xanf
                        ScreenSync
                        If mausMenu(" Text ",, ms + 16, anfangspunkt.y + 8 - yanf, weiss, schwarz) = 9 Then
                            sp = Len(pfeile(y).text) + 1
                            Do 'texteingabe
                                neuZeichnen()
                                textInput(pfeile(y).text, sp)

                                'blinkender cursor
                                If Frac(Timer) > .5 Then
                                    With pfeile(y).von
                                        Select Case .typ
                                            Case _oben
                                                Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y - 9 - yanf), "_", weiss
                                            Case _unten
                                                Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y + 2 - yanf), "_", weiss
                                            Case _rechts
                                                Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y - 9 - yanf), "_", weiss
                                            Case _links
                                                Draw String (.x - 1 + (sp - Len(pfeile(y).text)- 2)*8 - xanf, .y -9 - yanf), "_", weiss
                                            Case Else
                                        End Select
                                    End With
                                EndIf

                                GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                                If (tasten = 1) Or (InStr(pfeile(y).text, Chr(13))) Then 'texteingabe beenden
                                    pfeile(y).text = zeichenEntfernen(pfeile(y).text, Chr(13))
                                    pfeile(y).farbe = weiss
                                    Exit Do, Do
                                EndIf
                                Sleep 100
                            Loop
                        EndIf

                        Select Case mausMenu(" Anfang = " + Str(pfeile(y).von.ofs),"= ", ms + 8*9, -2*8,weiss, schwarz)
                            Case 8
                                GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                                If rad < radvor Then
                                    pfeile(y).von.ofs += 10
                                    neuZeichnen()
                                ElseIf rad > radvor Then
                                    pfeile(y).von.ofs = IIf(pfeile(y).von.ofs >= 10,pfeile(y).von.ofs - 10, 0)
                                    neuZeichnen()
                                EndIf
                            Case 9
                                pfeile(y).von.ofs = menuInput(pfeile(y).von.ofs)
                                neuZeichnen()
                        End Select

                        Select Case mausMenu(" Ende = " + Str(pfeile(y).bis.ofs),"= ", ms + 7*8, -2*8, weiss, schwarz)
                            Case 8
                                GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                                If rad < radvor Then
                                    pfeile(y).bis.ofs += 10
                                    neuZeichnen()
                                ElseIf rad > radvor Then
                                    pfeile(y).bis.ofs = IIf(pfeile(y).bis.ofs >= 10,pfeile(y).bis.ofs - 10, 0)
                                    neuZeichnen()
                                EndIf
                            Case 9
                                pfeile(y).bis.ofs = menuInput(pfeile(y).bis.ofs)
                                neuZeichnen()
                        End Select

                        If mausMenu(" L" & Chr(148) & "schen (" + Str(anfangspunkt.index) + "->" + Str(pfeile(y).bis.index) + ") ",, ms + 2*8, -2*8, weiss, schwarz) = 9 Then
                            For j As Integer = y To UBound(pfeile) - 1
                                pfeile(j) = pfeile(j + 1)
                            Next
                            ReDim Preserve pfeile(UBound(pfeile) - 1)
                            Exit Do

                        ElseIf (mausMenu(" OK ",, 0, -2*8,weiss, schwarz) = 9) Or (InKey = Chr(27)) Then
                            pfeile(y).farbe = weiss
                            Exit Do
                        EndIf
                        Sleep 1
                    Loop
                EndIf

            ElseIf (mx >= .xpos - .breite / 2) AndAlso _
                     (mx <= .xpos + .breite / 2) AndAlso _
                     (my >= .ypos - .hoehe / 2) AndAlso _
                     (my <= .ypos + .hoehe / 2) Then 'mauszeiger über element
                '*** ELEMENTE ***
                .farbe = rot
                If tasten = 1 Then 'linke maustaste --> element verschieben
                    Do 'ziehen des elements mit gedrückter linker maustaste
                        GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                        If Abs(mx - .xpos) > raster.x / 2 Then
                            .xpos = Int(mx / raster.x) * raster.x
                        EndIf
                        If Abs(my - .ypos) > raster.y / 2 Then
                            .ypos = Int(my / raster.y) * raster.y
                        EndIf
                        pfeileAnpassen(x)
                        neuZeichnen()
                        Sleep 1
                    Loop While tasten = 1
                    puffergroesseAnpassen

                ElseIf tasten = 2 Then 'rechte maustaste --> element editieren
                    mausLoslassen
                    'editmodus für element
                    Do 'schleife für mausmenü
                        ms = .rechts.x - xanf
                        ScreenSync
                        If mausMenu(" Text ", "", ms + 2*8, .oben.y - yanf, weiss, schwarz) = 9 Then
                            'texteingabe
                            neuZeichnen()
                            .grafikpuffer = 0 'auf screen schreiben
                            .xpos -= xanf
                            .ypos -= yanf
                            txt = .text
                            While InStr(txt,"\n")
                                txt = Left(txt, InStr(txt,"\n") - 1) + Chr(13) + Mid(txt, InStr(txt,"\n") + 2)
                            Wend
                            .zeichnen
                            sp = Len(txt) + 1
                            Do 'eingabeschleife für text
                                textInput(txt, sp)
                                .text = txt
                                While InStr(.text, Chr(13)) 'alle Chr(13) durch "\n" ersetzen
                                    .text = Left(.text, InStr(.text, Chr(13)) - 1) + "\n" + Mid(.text, InStr(.text, Chr(13)) + 1)
                                Wend

                                ReDim text(0)
                                Do 'teilstrings in array schreiben
                                    ReDim Preserve text(UBound(text) + 1)
                                    e = InStr(e + 1,txt,Chr(13))
                                    text(UBound(text)) = Mid(txt,a,e - a)
                                    a = e + 1
                                Loop While e

                                'automatische höhenanpassung
                                If UBound(text) * 8 + 4 > .hoehe Then
                                    .hoehe = UBound(text) * 8 + 4
                                    pfeileAnpassen(x)
                                    neuZeichnen()
                                EndIf

                                ScreenLock
                                Line(.links.x, .oben.y) - (.rechts.x, .unten.y), schwarz,BF 'bereich löschen
                                .zeichnen

                                'blinkender cursor
                                If Frac(Timer) > .5 Then
                                    cp = 0
                                    For y = 1 To UBound(text)
                                        cp += Len(text(y)) + 1
                                        If cp >= sp Then 'cursorzeile gefunden
                                            cp -= Len(text(y)) + 1
                                            cp = sp - cp - 1
                                            Exit For
                                        EndIf
                                    Next
                                    Draw String(.xpos - Len(text(y)) * 4 + cp * 8 - 1, .ypos - UBound(text) * 4 + (y - 1) * 8 + 1), "_", .textfarbe
                                EndIf
                                ScreenUnlock

                                GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
                                If tasten = 1 Then 'linke maustaste gedrückt --> texteingabe beenden
                                    .grafikpuffer = puffer(_diagramm)
                                    .xpos += xanf
                                    .ypos += yanf
                                    mausLoslassen
                                    Exit Do, Do 'editmodus beenden
                                EndIf
                                Sleep 1
                            Loop

                        ElseIf mausMenu(" Breite = " + Str(.breite) + " ", "= ", ms + 9*8, -2*8, weiss, schwarz) = 9 Then
                            'neue breite eingeben
                            .breite = menuInput(.breite)
                            pfeileAnpassen(x)
                            neuZeichnen()

                        ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(.hoehe) + " ", "= ", ms + 7*8, -2*8, weiss, schwarz) = 9 Then
                            'neue höhe eingeben
                            .hoehe = menuInput(.hoehe)
                            pfeileAnpassen(x)
                            neuZeichnen()

                        ElseIf mausMenu(" L" & Chr(148) & "schen ", "", ms + 2*8, -2*8, weiss, schwarz) = 9 Then
                            'element löschen
                            Do 'alle verbundenen pfeile löschen
                                For y = 1 To UBound(pfeile)
                                    If (pfeile(y).von.index = x) Or (pfeile(y).bis.index = x) Then 'pfeil ist mit dem zu löschenden element verbunden
                                        For j As Integer = y To UBound(pfeile) - 1
                                            pfeile(j) = pfeile(j + 1)
                                        Next
                                        ReDim Preserve pfeile(UBound(pfeile) - 1)
                                        Continue Do 'wiederholen
                                    EndIf
                                Next
                                Exit Do 'alle pfeile gelöscht
                            Loop

                            For y As Integer = x + 1 To UBound(fd) 'nachfolgende elemente nach oben schieben
                                fd(y - 1) = fd(y)
                                For j As Integer = 1 To UBound(pfeile) 'pfeilindices neu zuordnen
                                    If pfeile(j).von.index = y  Then
                                        pfeile(j).von.index -= 1
                                    EndIf
                                    If pfeile(j).bis.index = y  Then
                                        pfeile(j).bis.index -= 1
                                    EndIf
                                Next
                            Next
                            ReDim Preserve fd(UBound(fd) - 1) 'freien platz löschen
                            For i As Integer = 0 To UBound(fd) 'arraypointer aktualisieren (für indexanzeige)
                                fd(i).arrayptr = IIf(flag.edit, @fd(0), 0)
                            Next
                            mausLoslassen
                            puffergroesseAnpassen
                            Continue Do, Do

                        ElseIf (mausMenu(" OK ", "", 0, -2*8, weiss, schwarz) = 9) Or (InKey = Chr(27)) Then
                            Continue Do,Do 'editmodus beenden
                        EndIf
                        Sleep 1
                    Loop
                EndIf
            Else
                .farbe = weiss
            EndIf
            .zeichnen
        End With
    Next

    If tasten = 1 Then 'linke maustaste --> diagramm verschieben
        diagrammVerschieben
    EndIf

    'vertikal scrollen mit mausrad
    If rad > radvor2 Then
        yanf += (radvor2 - rad) * 50
        radvor2 = rad
        neuZeichnen
    ElseIf rad < radvor2 Then
        yanf -= (rad - radvor2) * 50
        radvor2 = rad
        neuZeichnen
    EndIf

    Sleep 1
Loop

Function parse(flag As Integer) As String
    If flag = 0 Then
        Return parse(, Chr(0)) 'rest des strings zurückgeben
    EndIf
End Function

Function parse(satz As String = "", trenner As String = "") As String
    Static As String s, t, r
    Static As Integer a, e

    If trenner = Chr(0) Then 'rest des textes zurückgeben
        r = Mid(s, e + 1)
        e = Len(s)
        Return r
    ElseIf Len(trenner) Then
        t = trenner
    EndIf

    If Len(satz) Then 'neuer satz
        s = satz
        e = 0 'zeiger auf anfang
    EndIf

    a = e + 1
    Do While InStr(t, Mid(s, a, 1)) 'nächsten wortanfang suchen
        If a >= Len(s) Then
            Return ""
        EndIf
        a += 1
    Loop

    e = a
    Do
        If Mid(s, e, 1) = """" Then 'anführungsstriche
            Do 'ende des textes in anführungsstrichen suchen
                e += 1
                If e > Len(s) Then 'text zuende
                    Exit Do, Do
                EndIf
            Loop Until Mid(s, e, 1) = """"
        EndIf

        e += 1
        If e > Len(s) Then 'text zuende
            Exit Do
        EndIf

    Loop Until InStr(t, Mid(s, e, 1)) 'trenner gefunden
    e -= 1 'zeiger vor trenner setzen

    r = Mid(s, a, e - a + 1) 'textstück isolieren
    Return Trim(r,"""")

End Function

Sub parliste(par As String, parameter() As String)
    Dim As Integer e, quoteflag
    Dim As String g

    g = par
    ReDim parameter(0)

    Do
        g = Trim(g)
        For e = 0 To Len(g) - 1
            If g[e] = Asc("""") Then 'anführungsstriche
                quoteflag Xor= 1
            EndIf
            If g[e] = Asc(",") And quoteflag = 0 Then 'komma gefunden
                Exit For
            EndIf
        Next

        ReDim Preserve parameter(UBound(parameter) + 1) 'arrayplatz anlegen
        parameter(UBound(parameter)) = Trim(Left(g,e)) 'parameter in array schreiben

        g = Mid(g, e + 2) 'behandelten parameter entfernen

    Loop While Len(g)

End Sub


Sub neuZeichnen()
    Dim As Integer mx, my, rad, tasten, x, breite, hoehe, sc_breite, sc_hoehe
    Dim As tPunkt pkt

    GetMouse mx, my, rad, tasten

    ScreenInfo sc_breite, sc_hoehe
    ImageInfo puffer(_diagramm), breite, hoehe

    If xanf > breite - sc_breite Then
        xanf = breite - sc_breite 'erlaubter maximalwert
    ElseIf xanf < 0 Then
        xanf = 0 'erlaubter minimalwert
    EndIf

    If yanf > hoehe - sc_hoehe Then
        yanf = hoehe - sc_hoehe 'erlaubter maximalwert
    ElseIf yanf < 0 Then
        yanf = 0 'erlaubter minimalwert
    EndIf

    Line puffer(_diagramm), (0,0) - (breite - 1, hoehe - 1), schwarz, bf 'diagrammpuffer löschen
    For y As Integer = 1 To UBound(fd) 'elemente zeichnen
        fd(y).zeichnen
    Next

    For y As Integer = IIf(pfeile(0).grafikpuffer, 0, 1) To UBound(pfeile) 'pfeile zeichnen
        pfeil(pfeile(y))
    Next

    ScreenLock
    Put (0,0), puffer(_diagramm), (xanf, yanf) - (xanf + sc_breite, yanf + sc_hoehe), PSet 'diagramm auf grafikscreen

    If fd(0).rasterflag = 0 Then
        Put (0,0), puffer(_raster), (xanf, yanf) - (xanf + sc_breite, yanf + sc_hoehe), Or
    EndIf

    pkt = istAnschlussPunkt()
    If pkt.index Then
        Circle (pkt.x - xanf, pkt.y - yanf), 5, rot,,,,F
    EndIf

    'senkrechter balken
    Dim As Integer gesamtlaenge = sc_hoehe - 40
    Dim As Integer balkenlaenge = gesamtlaenge * sc_hoehe / hoehe
    Dim As Integer balkenpos = yanf / hoehe * gesamtlaenge + 10

    Line puffer(_legende), (10, 10) - (20, gesamtlaenge + 10), schwarz, bf 'löschen
    Line puffer(_legende), (10, 10) - (20, gesamtlaenge + 10), weiss, b 'rahmen

    Line puffer(_legende), (10, balkenpos) - (20, balkenpos + balkenlaenge), weiss, bf 'balken

    'waagerechter balken
    gesamtlaenge = fd(0).musterposx - 50
    balkenlaenge = gesamtlaenge * sc_breite / breite
    balkenpos = xanf / breite * gesamtlaenge + 30

    Line puffer(_legende), (30, sc_hoehe - 10) - (fd(0).musterposx - 20, sc_hoehe - 20), schwarz, bf 'löschen
    Line puffer(_legende), (30, sc_hoehe - 10) - (fd(0).musterposx - 20, sc_hoehe - 20), weiss, b 'rahmen

    Line puffer(_legende), (balkenpos, sc_hoehe - 10) - (balkenpos + balkenlaenge, sc_hoehe - 20), weiss, bf 'balken

    Put (0,0), puffer(_legende), Trans

    ScreenUnlock

End Sub

#Macro PrintMenuItem()

    bufferForegroundColor = foreground
    bufferBackgroundColor = background
    PrintMenuItemMain()

#EndMacro

#Macro PrintMenuItemInv()

    bufferForegroundColor = background
    bufferBackgroundColor = foreground
    PrintMenuItemMain()

#EndMacro

#Macro PrintMenuItemMain()

    Line buffer, (xPos,yPos - 1)-(xPos + Len(text) * 8, yPos + 8),bufferBackgroundColor, bf
    Draw String buffer, (xPos, yPos), text, bufferForegroundColor

    If (mode And 2) Then 'draw frame around text
        Line buffer, (xPos - 1, yPos - 2)-(xPos + 1 + Len(text) * 8, yPos + 9),bufferForegroundColor, b
    EndIf

#EndMacro

Function mausMenu(text As String, _
                    separator As String = "", _
                    xPos As Integer = 0, _
                    yPos As Integer = 0, _
                    foreground As ULong, _
                    background As ULong, _
                    mode As UByte = 0, _
                    buffer As Any Ptr = 0) As Integer
  'mode 0 -> highlight at touch with cursor (default)
  'mode 1 -> highlight at click
  'mode 2 -> draw a frame around the text

  Dim As Integer mx, my, wheel, buttons, separatorpos, returnValue = 0
  Dim As ULongInt bufferForegroundColor, bufferBackgroundColor

  umlaute(text)

  If yPos = 0 Then
    yPos = tMenu.yPos
  ElseIf yPos < 0 Then
    yPos = tMenu.yPos - yPos
    yPos = IIf(yPos < 0, 0, yPos)
  EndIf

  If xPos = 0 Then
    xPos = tMenu.xPos
  ElseIf xPos < 0 Then
    xPos = tMenu.xPos - xPos
    xPos = IIf(xPos < 0, 0, xPos)
  EndIf

  'adjust text position
  If separator = "" Then
    separatorpos = Len(text) * 8
  Else
    separatorpos = (InStr(text,separator) - 1) * 8
    xPos = xPos - separatorpos + 8 'position text at separator
  EndIf

  tMenu.yPos = yPos
  tMenu.xPos = xPos
  tMenu.foreground = foreground
  tMenu.background = background
  tMenu.text = Left(text, InStr(text,separator) - 1 + Len(separator))
    tMenu.buffer = buffer

    GetMouse (mx,my,wheel,buttons)

  Select Case (mode And 1)
    Case 0 'highlight at touch
        If (mx >= xpos) AndAlso (mx <= xpos + Len(text) * 8) AndAlso _
             (my >= yPos) AndAlso (my <= ypos + 8) Then 'mouse cursor touches the text
            returnValue Or= 8
            PrintMenuItemInv() 'highlight menu item
            If buttons Then 'mouse button pressed
                returnValue Or= buttons
                Do 'wait for release of the mouse button
                    GetMouse (mx,my,wheel,buttons)
                    Sleep 1
                Loop While buttons
            EndIf
            Return returnValue
        EndIf
    Case 1 'highlight at click
        If buttons Then 'mouse button pressed
            returnValue Or= buttons
            If (mx >= xpos) AndAlso (mx <= xpos + Len(text) * 8) AndAlso _
             (my >= yPos) AndAlso (my <= ypos + 8) Then 'mouse cursor touches the text
                returnValue Or= 8
                PrintMenuItemInv() 'highlight menu item
                Do 'wait for release of the mouse button
                    GetMouse (mx,my,wheel,buttons)
                    Sleep 1
                Loop While buttons
                Return returnValue
            EndIf
        EndIf
  End Select

  PrintMenuItem()

End Function

Sub pfeil(par As tPfeilparameter)
    Dim As tPunkt pvon, pbis
    Dim As Any Ptr gpmerken

    pvon = par.von
    If par.von.index Then
        Select Case par.von.typ
            Case _oben, _ndef
                pvon = fd(par.von.index).oben
            Case _unten
                pvon = fd(par.von.index).unten
            Case _rechts
                pvon = fd(par.von.index).rechts
            Case _links
                pvon = fd(par.von.index).links
        End Select
        pvon.ofs = par.von.ofs
    EndIf

    pbis = par.bis
    If par.bis.index Then
        Select Case par.bis.typ
            Case _oben, _ndef
                pbis = fd(par.bis.index).oben
            Case _unten
                pbis = fd(par.bis.index).unten
            Case _rechts
                pbis = fd(par.bis.index).rechts
            Case _links
                pbis = fd(par.bis.index).links
        End Select
        pbis.ofs = par.bis.ofs
    EndIf

    gpmerken = fd(1).grafikpuffer
    fd(1).grafikpuffer = par.grafikpuffer
    If Len(par.verlauf) Then
        fd(1).pfeil(pvon, par.verlauf, par.text, par.farbe)
    Else
        fd(1).pfeil(pvon, pbis, par.text, par.farbe)
    EndIf
    fd(1).grafikpuffer = gpmerken

End Sub

Function istAnschlussPunkt(index As Integer = 0) As tPunkt
    Dim As tPunkt pr
    Dim As Integer mx, my, rad, tasten, anfang, ende, x

    If index Then 'nur ein element prüfen
        anfang = index
        ende = index
    Else 'alle elemente prüfen
        anfang = 1
        ende = UBound(fd)
    EndIf

    GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
    For x = anfang To ende
        With fd(x)
            If (Abs(mx - .oben.x) < fd(0).fangbereich) AndAlso (Abs(my - .oben.y) < fd(0).fangbereich) Then
                pr = .oben
                pr.index = x
                Return pr
            ElseIf (Abs(mx - .unten.x) < fd(0).fangbereich) AndAlso (Abs(my - .unten.y) < fd(0).fangbereich) Then
                pr = .unten
                pr.index = x
                Return pr
            ElseIf (Abs(mx - .rechts.x) < fd(0).fangbereich) AndAlso (Abs(my - .rechts.y) < fd(0).fangbereich) Then
                pr = .rechts
                pr.index = x
                Return pr
            ElseIf (Abs(mx - .links.x) < fd(0).fangbereich) AndAlso (Abs(my - .links.y) < fd(0).fangbereich) Then
                pr = .links
                pr.index = x
                Return pr
            EndIf
        End With
    Next
    pr.index = 0
    Return pr

End Function

Sub textInput(ByRef txt As String, ByRef sp As Integer)
    Dim As Integer gi
    Dim As String g

    g = Inkey
    If Len(g) = 1 Then 'regular character
    If g[0] > 31 Then 'alphabetic character
      txt = Left(txt, sp - 1) + g + Mid(txt, sp)
      sp += 1
    Else 'control character
      Select Case g[0]
        Case 8 'backspace
          If sp > 1 Then
            txt = Left(txt, sp - 2) + Mid(txt, sp)
            sp -= 1
          End If
        Case 13 'return
          txt = Left(txt, sp - 1) + g + Mid(txt, sp)
          sp += 1
      End Select
    End If
    ElseIf Len(g) = 2 Then 'control character
    gi = g[1]
    Select Case gi 'control character
        Case 75 'left arrow -> cursor left
        If sp > 1 Then
          sp -= 1
        End If
        Case 77 'right arrow -> cursor right
        If sp <= Len(txt) Then
            sp += 1
        EndIf
        Case 14 'backspace -> delete character before cursor
        If sp > 1 Then
          txt = Left(txt, sp - 1) + Mid(txt, sp)
          sp -= 1
        End If
        Case 83 'del -> delete chracter behind cursor
        If sp <= Len(txt) Then
          txt = Left(txt, sp - 1) + Mid(txt, sp + 1)
        End If
        Case 71 'pos1 -> move cursor to the begin of the string
        sp = 1
        Case 79 'end -> move cursor to the end of the string
        sp = Len(txt) + 1
    End Select
    End If

End Sub

Function menuInput(value As Integer, xPos As Integer = 0, yPos As Integer = 0) As Integer

    Return Val(menuInput(Str(value), xPos, yPos))

End Function

Function menuInput(value As String, xPos As Integer = 0, yPos As Integer = 0) As String

    Dim As String g, text
    Dim As Integer sp, wsp

    text = tMenu.text

  If xPos = 0 Then
    xPos = tMenu.xPos
  EndIf

  If yPos = 0 Then
    yPos = tMenu.yPos
  EndIf

    If tMenu.buffer Then 'delete buffer background
        Line tMenu.buffer, (xPos, yPos - 1) - (xPos + (Len(text) + Len(value)) * 8, yPos + 8), tMenu.background, BF
    EndIf

    ScreenSync
    'prompt
    Line (xPos, yPos - 1) - (xPos + (Len(text) + Len(value)) * 8, yPos + 8), tMenu.background, BF 'delete screen background
    Draw String (xPos, yPos), text, tMenu.foreground

    wsp = xPos + Len(text) * 8
    sp = Len(value) + 1

    'value
    Do
        textInput(value, sp)
        ScreenSync
        Line (xPos + Len(text) * 8, yPos - 1) - (xPos + (Len(text) + Len(value) + 3) * 8, yPos + 8), tMenu.background, BF 'delete screen background
        Draw String (wsp, yPos), value, tMenu.foreground

        'flashing cursor
        If Frac(Timer) > .5 Then
            Draw String (wsp + (sp - 1) * 8, yPos), "_", tMenu.foreground
        EndIf

        Sleep 1
    Loop Until InStr(value, Chr(13))

    value = zeichenEntfernen(value, Chr(13))
    Return value

End Function

Function zeichenEntfernen(text As String, zeichen As String) As String
    Dim As Integer x = InStr(text, zeichen)

    While x
        text = Left(text, x - 1) + Mid(text, x + Len(zeichen))
        x = InStr(text, zeichen)
    Wend
    Return text

End Function

Sub pfeileAnpassen(index As Integer)

    With fd(index)
        For i As Integer = 1 To UBound(pfeile)
            If pfeile(i).von.index = index Then
                Select Case pfeile(i).von.typ
                    Case _oben, _ndef
                        pfeile(i).von.x = .oben.x
                        pfeile(i).von.y = .oben.y
                    Case _unten
                        pfeile(i).von.x = .unten.x
                        pfeile(i).von.y = .unten.y
                    Case _rechts
                        pfeile(i).von.x = .rechts.x
                        pfeile(i).von.y = .rechts.y
                    Case _links
                        pfeile(i).von.x = .links.x
                        pfeile(i).von.y = .links.y
                End Select
                pfeile(i).von.index = index
            EndIf
            If pfeile(i).bis.index = index Then
                Select Case pfeile(i).bis.typ
                    Case _oben, _ndef
                        pfeile(i).bis.x = .oben.x
                        pfeile(i).bis.y = .oben.y
                    Case _unten
                        pfeile(i).bis.x = .unten.x
                        pfeile(i).bis.y = .unten.y
                    Case _rechts
                        pfeile(i).bis.x = .rechts.x
                        pfeile(i).bis.y = .rechts.y
                    Case _links
                        pfeile(i).bis.x = .links.x
                        pfeile(i).bis.y = .links.y
                End Select
                pfeile(i).bis.index = index
            EndIf
        Next
    End With

End Sub

Sub diagrammVerschieben
    Dim As Integer xmerken, ymerken, mx, my, rad, tasten, xam, yam

    GetMouse xmerken, ymerken, rad, tasten
    xam = xanf
    yam = yanf
    Do
        GetMouse mx, my, rad, tasten
        xanf = xam + xmerken - mx
        yanf = yam + ymerken - my
        neuZeichnen()
    Loop While tasten
    xanf = xam + xmerken - mx
    yanf = yam + ymerken - my

End Sub

Sub puffergroesseAnpassen
    Dim As Integer xmax, ymax, x, y, breite, hoehe, sc_breite, sc_hoehe

    ScreenInfo sc_breite, sc_hoehe
    ImageInfo puffer(_diagramm), breite, hoehe

    For x = 1 To UBound(fd) 'maximale koordinaten ermitteln
        With fd(x)
            If .rechts.x > xmax Then
                xmax = .rechts.x
            EndIf
            If .unten.y > ymax Then
                ymax = .unten.y
            EndIf
        End With
    Next

    If ((pufferbreite - xmax) < sc_breite) Or _
         ((pufferbreite - xmax) > (2 * sc_breite)) Or _
         ((pufferhoehe - ymax) < sc_hoehe) Or _
         ((pufferhoehe - ymax) > (2 * sc_hoehe)) Then

        pufferbreite = sc_breite * (Int(xmax / sc_breite) + 2)
        pufferhoehe = sc_hoehe * (Int(ymax / sc_hoehe) + 2)

        'puffer neu anlegen
        ImageDestroy puffer(_diagramm)
        puffer(_diagramm) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
        ImageDestroy puffer(_raster)
        puffer(_raster) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)

        'pointer aktualisieren
        tDiagramm.diagrammpuffer = puffer(_diagramm)
        For x = 0 To UBound(fd)
            fd(x).grafikpuffer = puffer(_diagramm)
        Next
        For x = 1 To UBound(pfeile)
            pfeile(x).grafikpuffer = puffer(_diagramm)
        Next

        neuesRaster
        neuZeichnen()
    EndIf

End Sub

Sub umlaute(ByRef text As String)
    'ä 228 132
    'ö 246 148
    'ü 252 129
    'Ä 196 142
    'Ö 214 153
    'Ü 220 154
    'ß 223 225
    For x As Integer = 0 To Len(text) - 1
        Select Case text[x]
            Case 228
                text[x] = 132
            Case 246
                text[x] = 148
            Case 252
                text[x] = 129
            Case 196
                text[x] = 142
            Case 214
                text[x] = 153
            Case 220
                text[x] = 154
            Case 223
                text[x] = 225
        End Select
    Next
End Sub

Function ini(datei As String, variable As String) As String
    Dim As Integer ff
    Dim As String g

    ff = FreeFile
    Open datei For Input As #ff
    Do
        Line Input #ff, g
        If Left(g, InStr(g,"=") - 1) = variable Then
            Close ff
            Return Mid(g, InStr(g,"=") + 1)
        EndIf
    Loop
    Return ""

End Function

Sub neuesRaster
    Dim As Integer x, y
    ' neues raster erzeugen
    Line puffer(_raster), (0,0) - (pufferbreite - 1, pufferhoehe - 1), schwarz, bf
    If raster.x > 1 Then
        For x = 0 To pufferbreite - 1 Step raster.x
            For y = 0 To pufferhoehe - 1 Step raster.y
                PSet puffer(_raster), (x,y), weiss
            Next
        Next
    EndIf
End Sub

Sub diagrammLaden()
    Dim As Integer ff, inival, i, sc_breite, sc_hoehe
    Dim As String g, inivarname, datei
    ReDim As String parameter(0)

    ScreenInfo sc_breite, sc_hoehe
    Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf

    Do
        tMenu.xPos = 200
        tMenu.yPos = 100
        g = Dir(ExePath + "/*.fds")

        ScreenSync
        Draw String(tMenu.xPos, tMenu.yPos - 16), "DIAGRAMM LADEN", weiss
        Draw String(tMenu.xPos, tMenu.yPos - 14), "______________", weiss

        Do 'auswahlmenü dateien
            If mausMenu(g,, 0, -2*8, IIf(g = Mid(letztedatei, InStrRev(letztedatei, "/") + 1), RGB(0,255,255), weiss), schwarz) = 9 Then
                datei = ExePath + "/" + g
                Exit Do, Do
            EndIf
            g = Dir()
        Loop While Len(g)

        If mausMenu("Abbrechen",, 0, -4*8, weiss, schwarz) = 9 Then
            Exit Sub
        EndIf
        Sleep 1
    Loop

    ff = FreeFile
    Open datei For Input As #ff
    iniholen
    letztedatei = datei
    ReDim Preserve fd(0)
    ReDim Preserve pfeile(0)
    xanf = 0
    yanf = 0
    Seek ff,1
    Do 'skript einlesen
        Line Input #ff, g
        g = Trim(g)

        If Val(g) Then 'string beginnt mit zahl --> element
            i = Val(parse(g, " ,"))
            If i > UBound(fd) Then
                ReDim Preserve fd(i)
            EndIf
            With fd(i)
                Select Case parse() 'muster
                    Case "oval"
                        .muster = oval
                    Case "rechteck"
                        .muster = rechteck
                    Case "raute"
                        .muster = raute
                    Case "rhombus"
                        .muster = rhombus
                    Case "unterprogramm"
                        .muster = unterprogramm
                    Case "punkt"
                        .muster = punkt
                End Select
                parliste(parse(rest), parameter())
                .xpos = Val(parameter(1))
                .ypos = Val(parameter(2))
                .breite = Val(parameter(3))
                .hoehe = Val(parameter(4))
                .text = Trim(parameter(5),"""")
                .farbe = Val(parameter(6))
                .textfarbe = Val(parameter(7))
                .indexfarbe = Val(parameter(8))
            End With
        ElseIf parse(g, " ,") = "pfeil" Then
            ReDim Preserve pfeile(UBound(pfeile) + 1)
            parliste(parse(rest), parameter())
            With pfeile(UBound(pfeile))
                .von.x = Val(parameter(1))
                .von.y = Val(parameter(2))
                .von.typ = Val(parameter(3))
                .von.ofs = Val(parameter(4))
                .von.index = Val(parameter(5))

                .bis.x = Val(parameter(6))
                .bis.y = Val(parameter(7))
                .bis.typ = Val(parameter(8))
                .bis.ofs = Val(parameter(9))
                .bis.index = Val(parameter(10))
                .verlauf = parameter(11)

                .text = Trim(parameter(12),"""")
                .farbe = Val(parameter(13))

                .grafikpuffer = puffer(_diagramm)
            End With
        EndIf
    Loop Until EOF(ff)
    Close ff

    For i = 1 To UBound(fd)
        With fd(i)
            .arrayptr = @fd(0)
            .grafikpuffer = puffer(_diagramm)
        End With
    Next
    puffergroesseAnpassen

    Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende
    neuesRaster
    neuZeichnen
    WindowTitle datei

End Sub

Sub diagrammSpeichern()
    Dim As String g, datei
    Dim As Integer ff, i, sc_breite, sc_hoehe, xmerken, ymerken
    Dim As tMenu menuMerken

    Do
        ScreenInfo sc_breite, sc_hoehe
        Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf
        Do
            g = Dir(ExePath + "/*.fds")
            tMenu.xPos = 200
            tMenu.yPos = 100
            ScreenSync
            Draw String(tMenu.xPos, tMenu.yPos - 16), "DIAGRAMM SPEICHERN", weiss
            Draw String(tMenu.xPos, tMenu.yPos - 14), "__________________", weiss

            Do
                If mausMenu(g,, 0, -2*8, IIf(g = Mid(letztedatei, InStrRev(letztedatei, "/") + 1), RGB(0,255,255), weiss), schwarz) = 9 Then
                    datei = ExePath + "/" + g
                    Exit Do, Do
                EndIf
                g = Dir()
            Loop While Len(g)

            If mausMenu("Speichern unter...",, 0, -4*8, weiss, schwarz) = 9 Then
                datei = Mid(letztedatei, InStrRev(letztedatei, "/") + 1)
                datei = Left(datei, InStr(datei, ".") - 1)
                Line(tMenu.xPos, tMenu.yPos - 1) - (tMenu.xPos + 20*8, tMenu.yPos + 8) , schwarz, bf
                datei = menuInput(datei)
                datei = ExePath + "/" + datei
                If InStr(datei, ".") = 0 Then
                    datei += ".fds"
                EndIf
                Exit Do, Do
            ElseIf mausMenu("Abbrechen",, 0, -4*8, weiss, schwarz) = 9 Then
                Exit Sub
            EndIf

            xmerken = tMenu.xPos
            ymerken = tMenu.yPos
            Sleep 1
        Loop

        g = "Datei " & Chr(129) & "berschreiben ?"
        umlaute(g)
        If FileExists(datei) Then
            Draw String(xmerken, ymerken + 5*8), g, weiss
            Do
                If mausMenu(" Ja ",, xmerken + 200, ymerken + 5*8, weiss, schwarz, 2) = 9 Then
                    Exit Do, Do
                ElseIf mausMenu(" Nein ",, -50, 0, weiss, schwarz, 2) = 9 Then
                    Continue Do, Do
                EndIf
            Sleep 1
            Loop
        Else
            Exit Do
        EndIf
    Loop

    letztedatei = datei
    ff = FreeFile
    Open datei For Output As #ff
    inispeichern
    Print #ff, ""
    For i = 1 To UBound(fd)
        With fd(i)
            .arrayptr = @fd(0)
            Print #ff, .index;" ";
            Select Case .muster
                Case oval
                    Print #1, "oval ";
                Case rechteck
                    Print #1, "rechteck ";
                Case raute
                    Print #1, "raute ";
                Case rhombus
                    Print #1, "rhombus ";
                Case unterprogramm
                    Print #1, "unterprogramm ";
                Case punkt
                    Print #1, "punkt ";
            End Select
            Print #ff, .xpos;",";.ypos;",";.breite;",";.hoehe;",";
            Print #ff, """";.text;"""";",";
            Print #ff, .farbe;",";.textfarbe;",";.indexfarbe

        End With
    Next
    Print #ff, ""
    For i = 1 To UBound(pfeile)
        With pfeile(i)
            Print #ff, "pfeil ";.von.x;",";.von.y;",";.von.typ;",";.von.ofs;",";.von.index;",";
            Print #ff, .bis.x;",";.bis.y;",";.bis.typ;",";.bis.ofs;",";.bis.index;",";
            Print #ff, .verlauf;",";
            Print #ff, """";.text;"""";",";
            Print #ff, .farbe
        End With
    Next
    Close #ff

    WindowTitle datei

End Sub

Sub programmEnde()
    Dim As Integer x, ff
    Dim As String datei

    For x = 1 To UBound(puffer)
        ImageDestroy puffer(x)
    Next
    datei = Command(0)
    datei = Left(datei, InStrRev(datei, ".exe") - 1) + ".ini"
    ff = FreeFile
    Open datei For Output As #ff
    inispeichern
    Close ff
    End
End Sub