#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(xpos, ypos, _ndef, ofsdefault, 0) Else tDiagramm.oben = Type(xpos, ypos - hoehe / 2, _oben, ofsdefault, 0) EndIf End Property Property tDiagramm.unten As tPunkt 'unterer anschlusspunkt If muster = punkt Then tDiagramm.unten = Type(xpos, ypos, _ndef, ofsdefault, 0) Else tDiagramm.unten = Type(xpos, ypos + hoehe / 2, _unten, ofsdefault, 0) EndIf End Property Property tDiagramm.links As tPunkt 'linker anschlusspunkt If muster = punkt Then tDiagramm.links = Type(xpos, ypos, _ndef, ofsdefault, 0) Else tDiagramm.links = Type(xpos - breite / 2, ypos, _links, ofsdefault, 0) EndIf End Property Property tDiagramm.rechts As tPunkt 'rechter anschlusspunkt If muster = punkt Then tDiagramm.rechts = Type(xpos, ypos, _ndef, ofsdefault, 0) Else tDiagramm.rechts = Type(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) 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 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