Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Drag & Drop - Editor zum Erstellen von Flussdiagrammen
| Uploader: |  grindstone |
| Datum/Zeit: | 16.10.2016 20:54:14 |
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 And 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ö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ö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ö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ö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ö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ü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 And 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 And 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 And 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 And 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 And 1) And (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ö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 And 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 And 1
puffergroesseAnpassen
ElseIf tasten And 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 And 1) and (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ö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ö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 And 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' : mx += xanf : my += yanf
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 ü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