Attribute VB_Name = "PLTLIB" Rem ******************************************************************************** Rem * vlpltlib.bas VIMAGE SOURCE MODULE * Rem * * Rem * VLPLTLIB.BAS -- VIMAGE MATRIX PLOT LIBRARY (DIE PLOTLIB) * Rem * ======================================================== * Rem * * Rem * * Rem * DIE PLOTLIB IST SO ETWAS WIE EIN WINDOWS-GDI FÜR FIXBILDER. * Rem * * Rem * FRAGE: NA, WARUM MACHT ER DENN DAS NICHT MIT DEM GDI?? * Rem * * Rem * ANTWORT: WEIL DIE FIXBILDER 32-BIT-SINGLE-GRAUWERTE HABEN UND DAS * Rem * WINDOWS-GDI NUR 8-BIT-GRAUWERTE KENNT. * Rem * * Rem * TJA -- DESWEGEN MUSSTE PRAKTISCH DAS GANZE GDI NEU GESCHRIEBEN WERDEN. * Rem * * Rem * Dateiname: VLPLTLIB.BAS * Rem * Modulname: PLTLIB * Rem * * Rem * * Rem * Die Plotlib ist eine Unterprogrammbibliothek zum Zeichnen von Vektoren * Rem * in Fixbilder. * Rem * * Rem * Die Plotlib wird von Vimage über 3 Schnittstellen angesprochen: * Rem * * Rem * - über die interaktiven Zeichenwerkzeuge des Zeichenwerkzeugfensters * Rem * - über die Plotbefehle des Plotassemblers VPA * Rem * - über den SVG-Quelltext des SVG-Interpreters * Rem * * Rem * * Rem * Es gibt folgende Plotbefehle hier in der Darstellung von VPA: * Rem * * Rem * PIXEL P() Z() ' Pixel malen * Rem * FATPIXEL P() Z() ' 3*3-Pixelmatrix malen * Rem * POINT P() Z() ' Punkt malen * Rem * LINE P1() P2() Z() ' Linie malen * Rem * LINEAUX P1() P2() Z() ' Linie malen, Aux-Stärke * Rem * LINEDOUBLE P1() P2() Z() Z2() ' Doppelllinie malen * Rem * LINEDOUBLEAPP P1() P2() Z() Z2() ' wie Doppelllinie, anhängend * Rem * BEZIER P1() P2() P3() P4() Z() ' Bezierkurve malen * Rem * QBEZIER P1() P2() P3() Z() ' Quadratische Bezierkurve * Rem * ARC P1() R1 R2 A F1 F2 P2() z() ' Ellipsenbogen malen * Rem * CIRCLE MP() R S() T() ' Kreis malen, evtl. füllen * Rem * ELLIPSE MP() R1 R2 S() T() ' Ellipse malen, evtl. füllen * Rem * RECT P1() P2() S() T() ' Rechteck malen, evtl. füllen * Rem * POLYLINE PL() Z() ' Polylinie malen * Rem * POLYLINEDOUBLE PL() Z() ' Polylinie malen * Rem * POLYGON PL() Z() ' Polygon malen (nicht füllen) * Rem * POLYGONDOUBLE PL() Z() ' Polygon malen (nicht füllen) * Rem * PATH »PF« Z() ' Pfad malen (nicht füllen) * Rem * FILL P() ZB() Z() ' Fläche füllen * Rem * PIXELSIGN P() CODE ' Pixelsignatur malen * Rem * PIXELTEXT P() »TEXTSTRING« ' Pixeltext malen * Rem * BRUSH P() Z() ' Punkt mit Pinsel malen * Rem * COPYBRUSH P1() P2() ' Punkt mit Kopierpinsel malen * Rem * FILTERBRUSH P1() ' Punkt weichzeichnen * Rem * IMAGECOPYBRUSH P1() P2() ' Punkt von Bild zu Bild kopie-* Rem * POINTSIGN P() ' Punktsignatur malen [ren*) * Rem * * Rem * CROSSOPEN CH ' Kreuzchensystem eröffnen * Rem * CROSSNEW P() NR CH ' Kreuzchen malen * Rem * CROSSCLEAR NR CH ' Kreuzchen löschen * Rem * CROSSCLOSE CH ' Kreuzchensystem schliessen * Rem * CROSSABORT CH ' Kreuzchensystem abbrechen * Rem * * Rem * IMAGENEW X Y Z »RadMode« ' Neues Bild erzeugen * Rem * IMAGESET »NAME« WERT* ' Parameter des Bildes setzen * Rem * * Rem * INIT ' Initialisieren * Rem * SET »NAME« WERT ' Variablen setzen * Rem * SHOW ' Anzeigen * Rem * STOP »MITTEILUNG« ' Unterbrechen * Rem * REM »KOMMENTAR« ' Nichts machen * Rem * * Rem * *) Der IMAGECOPYBRUSH ist nicht über VPA aufrufbar. * Rem * * Rem * Es bedeuten: * Rem * * Rem * ABC ... Zahlenvariablen, z. B. für Werte oder Nummern: 128 * Rem * ABC() ... Vektorvariablen, z. B. für Koordinaten oder Farben: 32,32,0 * Rem * »ABC« ... Stringvariablen, z. B. für Text: ABCDEFG * Rem * ABC* ... Freie Variablen, Zahlen, Vektoren oder Strings * Rem * * Rem * Die Befehle werden durch 8 Zeichenspitzen realisiert: * Rem * * Rem * den POINT, dieser schreibt wirklich nur ein einziges Pixel; * Rem * den FASTPOINT, dieser schreibt auch nur ein Pixel, aber etwas schneller * Rem * den FATPOINT, dieser schreibt einen 3*3-Pixel-Punkt; * Rem * den PEN, der eine Kreisscheibe mit einem Durchmesser PENSIZE malt; * Rem * den BRUSH, der eine Form (Kreis oder Quadrat) volldeckend, unscharf und * Rem * transparent malen kann und hierzu die Parameter BRUSHMODE, BRUSHSIZE, * Rem * BRUSHOPACITY und BRUSHSTRENGTH auswertet; * Rem * den COPYBRUSH (Kopierpinsel), der wie der Brush funktioniert, aber * Rem * Grauwerte versetzt im Bild kopiert; * Rem * den FILTERBRUSH, der einen Punkt verschmiert, d. h. mit einem 5*5-Gauß- * Rem * filter aus dessen Umgebungsmittel aufbaut; * Rem * den IMAGECOPYBRUSH, der wir der Brush funktioniert, aber Grauwerte * Rem * von einem Bild in ein anderes überträgt. * Rem * * Rem * Diese Zeichenspitzen sind in einer »Phys«-Driverschicht gekapselt. * Rem * * Rem * Für den Anwender werden nur Pixel, Fatpixel, Pen und Brush sichtbar. * Rem * * Rem * Die Dokumentation schreibt INIT in die Textkette PLGHelpText * Rem * * Rem * Variablen mit dreibuchstabigem grossgeschriebenem Präfix sind Globals * Rem * und sind im Modul VDGLOBAL definiert. * Rem * * Rem * * Rem * (C) ROLF BÖHM BAD SCHANDAU 2000, 2003, 2004, 2005, 2006, 2007, 2008, * Rem * 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2020. * Rem * * Rem * Insgesamt umfasst das Plot-Subsystem nicht nur die Plotlib, sondern * Rem * folgende Teile: * Rem * * Rem * - die PLOTLIB ist ein Gleitkomma-GDI und plottet in Single-Felder * Rem * - VPA interpretiert VPA und plottet mit der Plotlib * Rem * - SVG interpretiert SVG und plottet mit der Plotlib * Rem * - VFDIAPLT, das Zeichenwerkzeugfenster ist eine nutzeroberfläche, die * Rem * hauptsächlich Werkzeugparameter setzt. Malen tut dann HFM. * Rem * - HFM interpretiert Mausklicks und malt anhald der Toolparameter mit der * Rem * - INIPLT definiert ein bißl für die Plotlib. [Plotlib * Rem * * Rem * Mensch -- und das ganze funktioniert ?? * Rem * * Rem * # # ##### # # # * Rem * # # # # # # # # # * Rem * # # # # # # # # # * Rem * # # # # # # # # # * Rem * # # # # # # # # # * Rem * # # # # # # # # * Rem * ### ### ##### ### ### # * Rem * * Rem * * Rem ******************************************************************************** Option Explicit Public Const PLTLIB_VERSION = "Float Plot Library PLTLIB 01.03.12 vom 31.01.2020" 'Rem 'Rem VERZEICHNIS DER EXTERNEN REFERNZEN DER PLOTLIB 'Rem ============================================== ' ' Die Plotlib referenziert die folgenden externen Bezeichner, die ' im rufenden Programmrahmen irgendwie definiert sein müssen. ' ' Vollständiger Test per 01.05.2003. Nicht laufendgehalten. ' 17.02.2005 Kurze Durchsicht ' 14.07.2006 Den Bildkopierpinsel neu implementiert (SUBPltImageCopyBrush und SUBPltPhysImageCoipyBrush) ' Achtung: Der Bildkopierpinsel ist nicht per Plotbefehl ansprechbar. ' 02.07.2009 Pixelschrift etwas überarbeitet (im Modul VDINIPLT) ' 'Rem 'Rem 1. KONSTANTEN 'Rem ------------- ' 'Public Const ACC As Long = 0 ' Nummer von Bild 0 'Public Const OPR As Long = 4 ' Nummer des Operandenbildes 'Public Const MAX_NUMBER_OF_CHANNELS As Long = 32 ' Max. Anzahl Bänder/Kanäle 'Public Const PUNPageLength As Long = 1000000 ' Max. Rückgängigpixel. 1 Mit braucht etwa 20 bis 25 MByte!! 'Public Const VIMAGE_ARC_SWEEP_ORIENTATION As Long = 0 ' 0 oder 1 -- dreht das SVG-Path-Arc-Sweep-Flag um 'Public Const VIMAGE_FILL_MAX_STACK_DEEPTH As Long = 100000 ' 3 Parameter für den FILL-Algorithmus in SUBPltFill 'Public Const VIMAGE_FILL_TIMEOUT As Long = 100000000 'Public Const VIMAGE_FILL_DIR_LIMIT As Long = 32 'Public Const MATH_PI As Double = 3.1415926535 ' 3 Math. Konstanten 'Public Const MATH_EPSILON As Double = 1E-18 'Public Const MATH_WEAK_EPSILON As Double = 0.000001 'Public Const MAX_NUMBER_OF_PASSPOINTS As Long = 20 ... 4000 (4000 ist aber das oberste Maximum. Mehr schafft die Matlib keinesfalls, ausserdem wird dann der Rückgängigspeicher zu groß) 'Public Const MAX_BRUSH_SIZE As Long = 50 ' Max. Pinseldurchmesser 'Public Const MAX_PEN_SIZE As Long = 50 ' Max. Stiftdurchmesser ' 'Rem 'Rem 2. WICHTIGE VIMAGE-HAUPTVARIABLEN 'Rem --------------------------------- ' 'Rem DIVERSICA ' 'Public VIMAGETest As Boolean ' True: Testgenerierung. Braucht, da standardmäßig False nicht initialisiert zu werden. 'Public VIMAGENullValue(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Standard-Null-Grauwert. Braucht, da standardmäßig False nicht initialisiert zu werden. 'Public DIPKernelMode As Boolean ' Blos irgendwie definieren und gut. 'Public ACCIsRestorable As Boolean ' Blos irgendwie definieren und gut. 'Public SQUAbort As Boolean ' Blos irgendwie definieren und gut. ' 'Rem DIE BILDSPEICHER INCL. VERWALTUNG ' 'Public RM00() As Single ' Die 32 Bildspeicher 'Public RM01() As Single ' ... ... 'Public RM29() As Single 'Public RM30() As Single 'Public RM31() As Single 'Public RMHD(0 To 31) As FIXHeader ' Die Fixbildköpfe. Siehe hierzu die Fixlib. 'Public RMIsInUse(0 To 31) As Boolean ' True: Das entsprechende Bild ist in Gebrauch 'Public RMFn(0 To 31) As String ' Dateinamen der Bildspeicher (Von Plotlib nicht benutzt) ' 'Rem 'Rem 3. EXTERNE ANZEIGEELEMENTE, AUF DENEN DIE PLOTLIB ÜBER IHRE ARBEIT INFORMIERT 'Rem ----------------------------------------------------------------------------- ' ' HF.Text2 -- Ein Text-Steuerelement mit den Eigenschaften Text und der Methode Refresh ' HF.Text1 -- Ein weiteres Text-Steuerelement mit den Eigenschaften Text und der Methode Refresh ' HF.Progressbar1 -- Ein Progressbar-Steuerelement mit den Eigenschaften Min, Max und Value ' 'Rem 'Rem 4. EXTERNE UNTERPROGRAMME 'Rem ------------------------- ' 'Rem ALLGEMEINE PRIMITIVROUTINEN AUS DER VIMLIB ' '' Grauwertvektor von a nach b kopieren 'Public Sub VIMAGEValueCopy(a() As Single, b() As Single) 'End Sub ' '' Euklidische Entfernung von Punkt a(1),a(2) nach b(1),b(2) 'Public Function VIMAGEEuklid(a() As Double, b() As Double) As Double 'End Function ' '' Ganz fundamental: Der Arcuscosinus 'Public Function Arccos(a As Double) As Double 'End Function ' '' Textzeichenkette präparieren. Macht im Zweifelsfall gar nichts 'Public Function VPAPreText(a As String) As String 'End Function ' '' Ein zufälliges Epsilon bereitstellen 'Public Function VIMAGERandomEpsilon(a As Long) 'End Function ' '' Ein korrektes Basic-Val (Macht aus String-Zahl a eine Double-Zahl) 'Public Function VIMAGEval(a As String) As Double 'End Function ' '' Minimum aus mehreren Werten a, b, c ... 'Public Function VIMAGEMin(a, Optional b, Optional c, Optional d) 'End Function ' '' Maximum aus mehreren Werten a, b, c ... 'Public Function VIMAGEMax(a, Optional b, Optional c, Optional d) ' VIMAGEMax = a 'End Function ' '' Wert w auf maximal Maxi, minimal Mini setzen ("clippen") 'Public Sub VIMAGEClip(w, Maxi, Mini) 'End Sub ' '' Fehlertext auf s setzen 'Public Sub VIMAGEErrorSetSubText(s As String) 'End Sub ' 'Rem BILDVERARBEITUNGS-PRIMITIVROUTINEN ("DIP-ROUTINEN"). AUS VPDIPBAS. ' '' Bild LM1, Nummer N1 nach LM2(), Nummer N2 kaskadierter FIR-Filten 'Public Sub DIPFirFilterKask(LM1() As Single, n1 As Long, lm2() As Single, n2 As Long, feld() As Single, size As Long, fac As Single, offset As Single, Optional NoVisualize As Boolean) 'End Sub ' '' Bildspeicher LM1(), Nummer n1 freigeben 'Public Sub DIPFree(LM1() As Single, n1 As Long) 'End Sub ' '' Bildspeicher LM1(), Nummer n1 nach Bildspeicher LM2, Nummer N2 kopieren 'Public Sub DIPCopy(LM1() As Single, n1 As Long, lm2() As Single, n2 As Long) 'End Sub ' 'Rem PIC-ANZEIGEELEMENTE. AUS VPPICSHO. ' '' Bild a anzeigen 'Public Function PICShow(a As Long) 'End Function '' Beschreibungsanzeigefenster von Bild a in Hauptfomular aktualisieren 'Public Function PICDescribe(a As Long) 'End Function ' 'Rem 'Rem 5. SUBPLTINITFONT -- INITIALISIERT DEN SCHRIFTFONT PLGFont 'Rem ---------------------------------------------------------- ' 'Rem SUBPltInitFont gehört quasi zur Plotlib dazu. ' '' Schriftfont PLGFont füllen 'Public Sub SubPltInitFont() 'End Sub ' 'Rem 'Rem 6. PLOTLIB GLOBALS. AUSGELAGERTE VARIABLEN, DIE IM MODUL VDGLOBAL STEHEN 'Rem ------------------------------------------------------------------------ ' 'Rem In den VDGLOBAL-Globals stehen lauter "Subsysteme", die Plotlib umfasst auch einige ... ' 'Rem DIE VARIABLEN DES SET ' 'Public PLTBrushMode As Long ' 0=quadratisch, 1=rund 'Public PLTBrushOpacity As Long ' Pinselopacity, 0 (=ausgeschaltet) ... 50 (halbtransoparent) ... 100 (volldeckend) 'Public PLTBrushSize As Long ' Pinselgrösse, 1 bis MAX_BRUSH_SIZE 'Public PLTBrushStrength As Long ' Pinselhärte, 0 (=weich) ... 100 (ganz hart) 'Public PLTCoordMode As Long ' 0=Bild-, 1=Geo-, 2=Kartenkoordinate 'Public PLTPenSize As Long ' Stiftgröße, 1 bis MAX_PEN_SIZE (etwa 50) 'Public PLTPenSizeAux As long ' Stiftgröße Aux, 1 bis PLTPenSize 'Public PLTStrain As Long ' [Bezier-]Freiheitsgrad. Verhältnis Kontrollpunktabstand:Gestreckte Länge in % 'Public PLTTextShift(1 To 2) As Long ' Textversetzung 'Public PLTTextSize As Long ' Textgrösse. 1 ... 10 'Public PLTTextMode As Long ' Textdicke. 0=Normal, 1*1, 1=Fett, 3*3 'Public PLTTextValue(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Textgrauwertvektor ' 'Rem DIE CURSORE ' 'Public PLCCursor(1 To 2) As Double ' Der Hauptcursor. Svw. vorhergehender Punkt. 'Public PLCCursorII(1 To 2) As Double ' Dessen 2. Kontrollpunkt. 'Public PLCMouse(1 To 2) As Double ' Der Mauscursor 'Public PLCMouseII(1 To 2) As Double ' Dessen 2. Kontrollpunkt 'Public PLCMouseIIb(1 To 2) As Double ' Dieser als Gegenpunkt (Um Mauscursor gespiegelt) 'Public PLCStartPoint(1 To 2) As Double ' Startpunkt bei zu schliessenden Kurven. 'Public PLCStartPointII(1 To 2) As Double ' Dessen 2. Kontrollpunkt bei Umrissbézierkurve 'Public PLCFillInitPoint(1 To 2) As Double ' Floodfill-Initialpunkt. ' 'Rem ALLGEMEINE VARIABLEN ' 'Public PLGIsInitialized As Boolean ' Die statischen Werte wurden (INIT-Befehl) initialisiert. 'Public PLGFont(0 To 255, 0 To 10) As String ' Der Font mit Zeichen 0 ... 255 zu je 9 Zeilen 'Public PLGHelpText As String ' Helptext ' 'Public PLGCrossBuffer1() As Single ' Puffer, in denen überschriebene Kreuzchen-Grauwerte gerettet werden 'Public PLGCrossBuffer2() As Single ' 'Public PLGSkelettFlag As Boolean ' True: Skelett plotten, False: Normal plotten 'Public PLGSkelettValue() As Single ' Grauwertvektor mit dem das Skelett geplottet wird ' 'Rem VARIABLEN FÜR DEN PHYSISCHEN DRIVER ' 'Public PLXPenIsChanged As Boolean ' Pen-Parameter wurden gewechselt; Pen muss neu erzeugt werden. 'Public PLXPenGenerationIsInProc As Boolean ' Pen wird gerade neu erzeugt. 'Public PLXPenInitCodeList() As Integer ' Der Init-Pen. Der Init-Pen ist gefüllt. 'Public PLXPenDrawCodeList() As Integer ' Der Draw-Pen ist im Gegensatz zum Init-Pen hohl. ' ' Mit (1..2,1..t) indiziert, (1,t) ist der x-, (2,t) ' ' der y-Abstand des Punktes t vom Zentralpunkt 'Public PLXBrushIsChanged As Boolean ' Brush-Parameter wurden gewechselt; Brush muss neu erzeugt werden. 'Public PLXBrushGenerationIsInProc As Boolean ' Brush wird gerade neu erzeugt. 'Public PLXBrushCodeList() As Integer ' Der Brush. (1..3,1..t) indiziert, (1,t) ist der x-, (2,t) der y- ' ' Abstand zum des Punktes t zum Zentralpunkt. (3,t) ist die Transparenz in 1/100 % (0..10000). 'Public PLXCopyBrushIsChanged As Boolean ' PLXCopyBrushOffset muss neu berechnet werden 'Public PLXCopyBrushSource(1 To 2) As Long ' Quellkoordinate des Kopierpinsels 'Public PLXCopyBrushOffset(1 To 2) As Long ' Kopierpinsels-Lese-Schreib-Positionsabstand ' 'Rem VARIABLEN FÜRS RÜCKGÄNGIGMACHEN ' 'Public PUNIsActive As Boolean ' True: PUN aktiviert 'Public PUNPage() As Single ' Die Plot-Undo-Seite. Rettungpuffer der bei Plot überschriebenen Grauwerte. ' ' 1. Dimension: 1=x 2=y 3=1.Band 4=2.Band 5=3.Band ... ' ' 2. Dimension: Laufende Einträge, 1 ... PUNPageLength 'Public PUNPointer As Long ' Zeiger in die 2. Dimension der PUNPage ' 'Rem VARIABLEN MIT SVG-BEZUG ' 'Public SVGPathErrorText As String ' SVG-Fehlertext ' 'Rem Ende Kommentar externe globale Referenzen Rem Rem D I E E I N Z E L N E N P L O T B E F E H L E Rem ================================================= Rem Rem BEFEHL PIXEL: EIN PIXEL MALEN Rem ============================= Public Sub SUBPltPixel(LM1() As Single, n1 As Long, p() As Double, z() As Single) Rem Rem SUBPltPixel plottet genau ein Pixel (p(1),p(2)). Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim s(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten s(1) = CLng(p(1)): s(2) = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Geo(RMHD(n1), p(1), p(2), wx, wy) Call FIXCoordGeo2Img(RMHD(n1), wx, wy, s(1), s(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) End Select If s(1) >= -15 And s(1) < RMHD(0).ImgXXXX + 16 And _ s(2) >= -15 And s(2) < RMHD(0).ImgYYYY + 16 Then Call SUBPltPhysPixel(LM1, s, z) End If End Sub Rem Rem BEFEHL PIXEL: EIN PIXEL MALEN Rem ============================= Public Sub SUBPltFatPixel(LM1() As Single, n1 As Long, p() As Double, z() As Single) Rem Rem SUBPltPixel plottet 3*3-Pixel (p(1),p(2)). Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim s(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten s(1) = CLng(p(1)): s(2) = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Geo(RMHD(n1), p(1), p(2), wx, wy) Call FIXCoordGeo2Img(RMHD(n1), wx, wy, s(1), s(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) End Select If s(1) >= -15 And s(1) < RMHD(0).ImgXXXX + 16 And _ s(2) >= -15 And s(2) < RMHD(0).ImgYYYY + 16 Then Call SUBPltPhysFatPixel(LM1, s, z) End If End Sub Rem Rem BEFEHL POINT: PUNKT MALEN Rem ========================= Public Sub SUBPltPoint(LM1() As Single, n1 As Long, p() As Double, z() As Single) Rem Rem SUBPltPoint plottet einen Punkt (p(1),p(2)). Ein Punkt wird mit dem Pen gemalt Rem und ist eine kleine Kreisscheibe. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim s(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten s(1) = CLng(p(1)): s(2) = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Geo(RMHD(n1), p(1), p(2), wx, wy) Call FIXCoordGeo2Img(RMHD(n1), wx, wy, s(1), s(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) End Select If s(1) >= -15 And s(1) < RMHD(0).ImgXXXX + 16 And _ s(2) >= -15 And s(2) < RMHD(0).ImgYYYY + 16 Then If PLGSkelettFlag = False Then Call SUBPltPhysPen(LM1, s, z) Else Call SUBPltPhysSkelettText(LM1, s, Chr(4), PLGSkelettValue) End If End If End Sub Rem Rem BEFEHL LINE: LINIE MALEN Rem ======================== Public Sub SUBPltLine(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, z() As Single, Optional IsRaw As Boolean) Rem Rem SUBPltLine plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) mit dem Pen. Rem Der Grauwert der Linie ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltLine ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag wird das Linienskelett gezeichnet. Rem Dim DoRaw As Boolean DoRaw = True If IsMissing(IsRaw) = False Then If IsRaw = False Then DoRaw = False End If End If Call SUBPltCommonLine(LM1(), n1, P1(), P2(), z(), DoRaw, False) End Sub Rem Rem BEFEHL LINE: AUX-LINIE MALEN Rem ============================ Public Sub SUBPltLineAux(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, z() As Single, Optional IsRaw As Boolean) Rem Rem SUBPltLineAux plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) mit dem Aux-Pen. Rem Der Grauwert der Linie ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltLineAux ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag Rem wird das Linienskelett gezeichnet. Rem Dim DoRaw As Boolean DoRaw = True If IsMissing(IsRaw) = False Then If IsRaw = False Then DoRaw = False End If End If Call SUBPltCommonLine(LM1(), n1, P1(), P2(), z(), DoRaw, True) PLGPlotCounter = PLGPlotCounter + 1 End Sub Rem Rem BEFEHL LINEDOUBLE: DOPPELLINIE MALEN Rem ==================================== Public Sub SUBPltLineDouble(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, y() As Single, z() As Single, Optional IsRaw As Boolean) Rem Rem SUBPltLineDouble plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) Rem zunächst mit dem Pen und Grauwert y, dann mit dem Aux-Pen und Grauwert z. Rem So entsteht eine Doppellinie. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltLineDouble ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag Rem wird das Linienskelett gezeichnet. Rem Dim DoRaw As Boolean DoRaw = True If IsMissing(IsRaw) = False Then If IsRaw = False Then DoRaw = False End If End If Call SUBPltCommonLine(LM1(), n1, P1(), P2(), y(), DoRaw, False) Call SUBPltCommonLine(LM1(), n1, P1(), P2(), z(), DoRaw, True) PLCLastLineStartPoint(1) = P1(1) PLCLastLineStartPoint(2) = P1(2) PLCLastLineEndPoint(1) = P2(1) PLCLastLineEndPoint(2) = P2(2) PLGPlotCounter = PLGPlotCounter + 1 PLGLastLinePlotCounter = PLGPlotCounter End Sub Rem Rem BEFEHL LINEDOUBLEAPP: DOPPELLINIE ANHÄNGEND MALEN Rem ================================================= Public Sub SUBPltLineDoubleApp(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, y() As Single, z() As Single, Optional IsRaw As Boolean) Rem Rem SUBPltLineDoubleApp plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) Rem zunächst mit dem Pen und Grauwert y, dann mit dem Aux-Pen und Grauwert z. Rem So entsteht eine Doppellinie. Rem Rem Unter gewissen Voiraussetzungen wird zum Schluss noch einmal die Rem letzte Aux-Linie geplottet, womit Linieninnenräume zur vorigen Linie geöffnet werden. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltLineDoubleApp ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag Rem wird das Linienskelett gezeichnet. Rem Dim DoRaw As Boolean DoRaw = True If IsMissing(IsRaw) = False Then If IsRaw = False Then DoRaw = False End If End If Call SUBPltCommonLine(LM1(), n1, P1(), P2(), y(), DoRaw, False) Call SUBPltCommonLine(LM1(), n1, P1(), P2(), z(), DoRaw, True) Rem "Anhängeoperation" If (PLCLastLineEndPoint(1) = P1(1) And PLCLastLineEndPoint(2) = P1(2)) Then If PLGPlotCounter = PLGLastLinePlotCounter Then Call SUBPltCommonLine(LM1(), n1, PLCLastLineStartPoint(), P1(), z(), DoRaw, True) End If End If Rem Weiterstellen PLCLastLineStartPoint(1) = P1(1) PLCLastLineStartPoint(2) = P1(2) PLCLastLineEndPoint(1) = P2(1) PLCLastLineEndPoint(2) = P2(2) PLGPlotCounter = PLGPlotCounter + 1 PLGLastLinePlotCounter = PLGPlotCounter End Sub Rem Rem BEFEHL BEZIER: BÉZIERKURVE MALEN Rem ================================ Public Sub SUBPltBezier(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, p3() As Double, p4() As Double, z() As Single) Rem Rem SUBPltBezier plottet eine Bezierkurve von (x1,y1) nach (x4,y4) mit den Kontroll- Rem punkten (x2,y2) und x3,y3). Es wird mit dem Pen geplottet. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim CC1(1 To 2) As Double ' Skalierte Bildkoord der 4 Kontrollpunkte Dim cc2(1 To 2) As Double Dim cc3(1 To 2) As Double Dim cc4(1 To 2) As Double Dim sc(1 To 2) As Double ' Koord auf Parameter = Schreibkoord Dim oc(1 To 2) As Double ' Alte Koord Dim wc(1 To 2) As Double ' Arbeits (Work) Koord Dim Bernstein03 As Double ' Bernstein-Polynomskalare Dim Bernstein13 As Double Dim Bernstein23 As Double Dim Bernstein33 As Double Dim ttt As Double ' Das ist der Parameter Dim tttInc As Double ' Schrittweite auf dem Parameter Dim stepwidth As Double ' Schrittweite Dim i As Long Dim c As Long Dim pixsize As Double Rem Laufbereich If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Rem Alles in Bildkoordinaten umrechnen Select Case PLTCoordMode Case 0: ' Bildkoordinaten CC1(1) = P1(1): CC1(2) = P1(2) cc2(1) = P2(1): cc2(2) = P2(2) cc3(1) = p3(1): cc3(2) = p3(2) cc4(1) = p4(1): cc4(2) = p4(2) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordGeo2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) Call FIXCoordGeo2Img(RMHD(n1), p4(1), p4(2), cc4(1), cc4(2)) Case 2: ' Kartenkoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordMap2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordMap2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) Call FIXCoordMap2Img(RMHD(n1), p4(1), p4(2), cc4(1), cc4(2)) Case Else: ' STandard: Geokoord Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordGeo2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) Call FIXCoordGeo2Img(RMHD(n1), p4(1), p4(2), cc4(1), cc4(2)) End Select If PLGSkelettFlag = True Then Call SUBPltPhysSkelettLine(LM1, CC1, cc2, PLGSkelettValue) Call SUBPltPhysSkelettLine(LM1, cc3, cc4, PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, CC1, Chr(4), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, cc2, Chr(2), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, cc3, Chr(2), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, cc4, Chr(4), PLGSkelettValue) End If Rem Kurve generieren tttInc = 0.01 ttt = 0 - tttInc oc(1) = CC1(1) oc(2) = CC1(2) While ttt <= 1 LBezierNochmal123: ttt = ttt + tttInc Bernstein03 = (1 - ttt) ^ 3 ' Hier steckt das Pascalsche Dreieck drin; Bernstein13 = 3 * ttt * (1 - ttt) ^ 2 ' Die Summe aller Bernstein-Polynome ist Bernstein23 = 3 * ttt ^ 2 * (1 - ttt) ' immer 1 Bernstein33 = ttt ^ 3 sc(1) = 0 ' X-Komponente sc(1) = sc(1) + CC1(1) * Bernstein03 sc(1) = sc(1) + cc2(1) * Bernstein13 sc(1) = sc(1) + cc3(1) * Bernstein23 sc(1) = sc(1) + cc4(1) * Bernstein33 sc(2) = 0 ' Y-Komponente sc(2) = sc(2) + CC1(2) * Bernstein03 sc(2) = sc(2) + cc2(2) * Bernstein13 sc(2) = sc(2) + cc3(2) * Bernstein23 sc(2) = sc(2) + cc4(2) * Bernstein33 stepwidth = Sqr((oc(1) - sc(1)) ^ 2 + (oc(2) - sc(2)) ^ 2) If stepwidth < 0.1 Then ' Wenn Schrittweite zu klein tttInc = tttInc * 2 ' Inkrement verdoppeln End If If stepwidth > 0.4 And tttInc > 0.000000001 Then ' Wenn Schrittweite zu gross (Ink aber nicht ganz klein, das würde die While-Schleife gefährden) ttt = ttt - tttInc ' alten Wert wiederherstellen tttInc = tttInc / 2 ' Inkrement halbieren GoTo LBezierNochmal123 ' Nochmal End If If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' wenn ungültig sind si/sj -9999 If PLGSkelettFlag = False Then If ttt = 0 Then Call SUBPltPhysPen(LM1, sc, z) ' Punkt malen, sofern im Bild Else Call SUBPltPhysPen(LM1, sc, z, True) ' Punkt malen, sofern im Bild End If If oc(1) <> sc(1) And oc(2) <> sc(2) Then ' Wenn Diagonalversatz (Achternachbarschaft!) dann wc(1) = sc(1): wc(2) = oc(2) ' Punkt so setzen, Call SUBPltPhysPen(LM1, wc, z) ' dass Vierernachbarchaft gewährleistet End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) End If End If oc(1) = sc(1) oc(2) = sc(2) Wend PLGPlotCounter = PLGPlotCounter + 1 End Sub Rem Rem BEFEHL QBEZIER: QUADRATISCHE BÉZIERKURVE MALEN Rem ============================================== Public Sub SUBPltQBezier(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, p3() As Double, z() As Single) Rem Rem SUBPltQBezier plottet eine quadratische Bezierkurve von (x1,y1) nach (x3,y3) mit dem Kontroll- Rem punkten (x2,y2) mit dem Pen. Der Grauwert der Kurve verläuft ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe Dim CC1(1 To 2) As Double ' Skalierte Bildkoord der 4 Kontrollpunkte Dim cc2(1 To 2) As Double Dim cc3(1 To 2) As Double Dim sc(1 To 2) As Double ' Koord auf Parameter = Schreibkoord Dim oc(1 To 2) As Double ' Alte Koord Dim wc(1 To 2) As Double ' Arbeits (Work) Koord Dim Bernstein02 As Double ' Bernstein-Polynomskalare Dim Bernstein12 As Double Dim Bernstein22 As Double Dim ttt As Double ' Das ist der Parameter Dim tttInc As Double ' Schrittweite auf dem Parameter Dim stepwidth As Double ' Schrittweite Dim i As Long Dim c As Long Dim pixsize As Double Rem Laufbereich If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Rem Grauwert übernehmen Call VIMAGEValueCopy(z, zs) Rem Alles in Bildkoordinaten umrechnen Select Case PLTCoordMode Case 0: ' Bildkoordinaten CC1(1) = P1(1): CC1(2) = P1(2) cc2(1) = P2(1): cc2(2) = P2(2) cc3(1) = p3(1): cc3(2) = p3(2) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordGeo2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) Case 2: ' Kartenkoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordMap2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordMap2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) Case Else: ' STandard: Geokoord Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), CC1(1), CC1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), cc2(1), cc2(2)) Call FIXCoordGeo2Img(RMHD(n1), p3(1), p3(2), cc3(1), cc3(2)) End Select If PLGSkelettFlag = True Then Call SUBPltPhysSkelettLine(LM1, CC1, cc2, PLGSkelettValue) Call SUBPltPhysSkelettLine(LM1, cc2, cc3, PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, CC1, Chr(4), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, cc2, Chr(2), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, cc3, Chr(4), PLGSkelettValue) End If Rem Kurve generieren tttInc = 0.01 ttt = 0 - tttInc oc(1) = CC1(1) oc(2) = CC1(2) While ttt <= 1 LBezierNochmal123: ttt = ttt + tttInc Bernstein02 = (1 - ttt) ^ 2 ' Hier steckt das Pascalsche Dreieck drin; Bernstein12 = 2 * ttt * (1 - ttt) ' Die Summe aller Bernstein-Polynome ist Bernstein22 = ttt ^ 2 sc(1) = 0 ' X-Komponente sc(1) = sc(1) + CC1(1) * Bernstein02 sc(1) = sc(1) + cc2(1) * Bernstein12 sc(1) = sc(1) + cc3(1) * Bernstein22 sc(2) = 0 ' Y-Komponente sc(2) = sc(2) + CC1(2) * Bernstein02 sc(2) = sc(2) + cc2(2) * Bernstein12 sc(2) = sc(2) + cc3(2) * Bernstein22 stepwidth = Sqr((oc(1) - sc(1)) ^ 2 + (oc(2) - sc(2)) ^ 2) If stepwidth < 0.1 Then ' Wenn Schrittweite zu klein tttInc = tttInc * 2 ' Inkrement verdoppeln End If If stepwidth > 0.4 And tttInc > 0.000000001 Then ' Wenn Schrittweite zu gross (Ink aber nicht ganz klein, das würde die While-Schleife gefährden) ttt = ttt - tttInc ' alten Wert wiederherstellen tttInc = tttInc / 2 ' Inkrement halbieren GoTo LBezierNochmal123 ' Nochmal End If If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' wenn ungültig sind si/sj -9999 If PLGSkelettFlag = False Then If ttt = 0 Then Call SUBPltPhysPen(LM1, sc, zs) ' Punkt malen, sofern im Bild Else Call SUBPltPhysPen(LM1, sc, zs, True) ' Punkt malen, sofern im Bild End If If oc(1) <> sc(1) And oc(2) <> sc(2) Then ' Wenn Diagonalversatz (Achternachbarschaft!) dann wc(1) = sc(1): wc(2) = oc(2) ' Punkt so setzen, Call SUBPltPhysPen(LM1, wc, zs) ' dass Vierernachbarchaft gewährleistet End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) End If End If oc(1) = sc(1) oc(2) = sc(2) Wend PLGPlotCounter = PLGPlotCounter + 1 End Sub Rem Rem ELLIPSENBOGEN ZEICHNEN Rem ---------------------- Public Sub SUBPltArc(LM1() As Single, n1 As Long, P1() As Double, R1 As Double, R2 As Double, ag As Double, f1 As Double, f2 As Double, P2() As Double, z() As Single) Rem Rem !!! DAS UNTERPROGRAMM IST EINE WEITGEHENDE ÜBERNAHME DES !!! Rem !!! UNTERPROGRAMMES EllipsenbogenZeichen AUS DER !!! Rem !!! ORIGINALTESTUMGEBUNG VFDIABEZ !!! Rem Rem SUBPltArc zeichnet einen VSG-konformen Ellipsenbogen von p1(1),P1(2) mit den Rem Halbachsen r1, r2, und der Verdrehung ag ("AlphaGrad") gegen die X-Achse nach Punkt p2(1),P2(2). Rem Rem Von den 4 möglichen Lösungen wählen die beiden Flags f1 (Large-Arc-Flag) und f1 Rem (Sweep-Flag) genau eine Lösung aus. Rem Rem Die Parametrierung der Funktion entspricht weitgehend der des A-Kommandos des SVG-Path-Elements. Rem Rem Die gesamten Formeln stehen in Appendix F: Implementation Requirements Rem der SVG 1.0-Dokumentation - Ausgabe 20010904, Abschnitt Rem F.6 Elliptical arc implematation notes Rem Rem Nicht völlig sicher ist die Orientierung des Sweep-Flags. Hierzu gibt es Rem die globale externe Konstante VIMAGE_ARC_SWEEP_ORIENTATION Rem Rem Globale externe Referenzen: Rem Rem MATH_PI Konstante, 3.14159265358979323846264338327950 Rem MATH_EPSILON Konstante, 1E-18 Rem VIMAGE_ARC_SWEEP_ORIENTATION Konstante, wenn 0 dann ist das Sweepflag wie in SVG orientiert, sonst andersherum Rem s=VIMAGEEuklid(a,b) Funktion, liefert die Länge s der Strecke (a(1),a(2))-(b(1),b(2) Rem w=Arcos(c) Funktion, -- die Arkuscosinusfunktion Rem Rem Es wird mit dem Pen (einer kleinen Kreisscheibe) geplottet. Rem Rem Parameter aus dem Aufruf Dim FlagA As Boolean Dim FlagS As Boolean Dim phi As Double Dim SweepFlag As Boolean Dim LargeArcFlag As Boolean Dim rX As Double Dim rY As Double Rem Variablen aus den Implementation Requirements Dim x1 As Double Dim y1 As Double Dim x2 As Double Dim y2 As Double Dim x1s As Double ' = x1' Dim y1s As Double ' = y1' Dim x2s As Double ' = x2' Dim y2s As Double ' = y2' Dim cXs As Double ' = cx' Dim cYs As Double ' = cy' Dim cx As Double Dim cy As Double Dim Theta1 As Double ' Das ist der erstberechnete Startpunktwinkel Dim DeltaTheta As Double Rem Sonstige Variablen Dim a As Double ' Allg. Variablen Dim b As Double ' Nur hier im Programm und nicht in der Dokumentation Dim c As Double Dim d As Double Dim e As Double Dim f As Double ' Farbe Dim n(1 To 2) As Double ' Nullvektor Dim u(1 To 2) As Double Dim v(1 To 2) As Double Dim x As Double Dim y As Double Dim cXs2 As Double ' cx' der falschen Ellipse Dim cYs2 As Double ' cy' der falschen Ellipse Dim cX2 As Double ' cx der falschen Ellipse Dim cY2 As Double ' cy der falschen Ellipse Dim stepwidth As Double Dim ThetaIsInvers As Boolean ' True: inverses Theta1 Dim lambda As Double ' Radien-Vergrößerungsfaktor Dim T As Double ' Parameter Theta; laufender Winkel auf Ellipsenumfang bei Zeichnen Dim DrawIsInit As Boolean ' Der erste Draw-Zyklus soll noch nicht malen Dim ecx As Double ' Zentrum für Ellipsengenerator Dim ecy As Double Dim e1(1 To 2) As Double ' Laufender Punkt für Ellipsengenerator Dim e2(1 To 2) As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Malfarbe (Strokefarbe) Rem Rem PARAMETERÜBERNAHME Rem ------------------ Rem Init If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Rem Anfangspunkt x1 = P1(1) y1 = P1(2) Rem Die fünf Parameter des A-Path-Kommandos bis auf den Endpunkt: rx, ry, Winkel und die beiden Flags rX = Abs(R1) rY = Abs(R2) If rX = 0 Then rX = 0.001 ' Quasi ein Epsilon, muss aber ganz "weich" bleiben, da es die Ellipsen mit 1/Epsilon streckt If rY = 0 Then rY = 0.001 phi = ag / 180 * MATH_PI FlagA = False FlagS = False If Round(f1) <> 0 Then FlagA = True If Round(f2) <> 0 Then FlagS = True LargeArcFlag = FlagA SweepFlag = FlagS Select Case VIMAGE_ARC_SWEEP_ORIENTATION Case 0: Case 1: SweepFlag = Not SweepFlag End Select Rem Den Endpunkt x2 = P2(1) y2 = P2(2) If x1 = x2 And y1 = y2 Then Exit Sub ' End=Startpunkt End If Rem Die Farbe übernehmen Call VIMAGEValueCopy(z, zs) Rem Rem VON ENDPOINT PARAMETRIZATION IN CENTERPOINT PARAMETRIZATION UMRECHNEN Rem --------------------------------------------------------------------- Rem Formeln aus den Implementation Requirements Rem 1/9 -- Step 1 Compute (x1' y1') according the formula x1s = 0 + Cos(phi) * ((x1 - x2) / 2) + Sin(phi) * ((y1 - y2) / 2) ' F.6.5.1 y1s = 0 - Sin(phi) * ((x1 - x2) / 2) + Cos(phi) * ((y1 - y2) / 2) If x1s = 0 Then x1s = 0.01 If y1s = 0 Then y1s = 0.01 Rem 2/9 -- Correction of out of range radii If rX = 0 Or rY = 0 Then Exit Sub ' Klar, aber die wurden oben auf Epsilon gesetzt lambda = Sqr(x1s ^ 2 / rX ^ 2 + y1s ^ 2 / rY ^ 2) ' F.6.6.2 (Lambda ist in der Originalformal noch nicht radiziert) If lambda > 1 Then lambda = lambda Else lambda = 1 End If rX = lambda * rX ' F.6.6.3 rY = lambda * rY Rem 3/9 -- Step 2 Compute (cx' cy') according the formula c = (rX ^ 2 * rY ^ 2) - (rX ^ 2 * y1s ^ 2) - (rY ^ 2 * x1s ^ 2) ' F.6.5.2 ' **** c = c / ((rX ^ 2 * y1s ^ 2) + (rY ^ 2 * x1s ^ 2)) c = Sqr(Abs(c)) If SweepFlag <> LargeArcFlag Then ' Das wählt die richtige Ellipse aus. c = 0 + c Else c = 0 - c End If cXs = c * (0 + (rX * y1s / rY)) cYs = c * (0 - (rY * x1s / rX)) Rem 4/9: Step 3 Compute (cx,cy) from (cx',cy') cx = (Cos(phi) * cXs - Sin(phi) * cYs) + ((x1 + x2) / 2) ' F.6.5.3 cy = (Sin(phi) * cXs + Cos(phi) * cYs) + ((y1 + y2) / 2) Rem 5/9 -- Eingeschoben: Das Zentrum der falschen Ellipse berechnen cXs2 = (0 - c) * (0 + (rX * y1s / rY)) ' ebenfalls F.6.5.2 cYs2 = (0 - c) * (0 - (rY * x1s / rX)) cX2 = (Cos(phi) * cXs2 - Sin(phi) * cYs2) + ((x1 + x2) / 2) ' ebenfalls F.6.5.3 cY2 = (Sin(phi) * cXs2 + Cos(phi) * cYs2) + ((y1 + y2) / 2) Rem 6/9 -- Step 4 Compute Theta1 and DeltaTheta -- Theta1 n(1) = 0 n(2) = 0 u(1) = 1 ' F.6.5.5 und F.6.5.4 u(2) = 0 v(1) = (x1s - cXs) / rX ' F.6.5.5 und F.6.5.4 v(2) = (y1s - cYs) / rY a = VIMAGEEuklid(n, u) b = VIMAGEEuklid(n, v) c = a * b If c = 0 Then c = MATH_EPSILON d = (u(1) * v(1) + u(2) * v(2)) / c Theta1 = Arccos(d) ' Die Funktion Arccos steht in der Matlib Rem 7/9 -- Zwischenoperation in Step 4: Rem Was nicht in den Reqirements steht: Theta1 mus evtl. invertiert werden! Rem Darum: Theta in die Ellipse einsetzen und gucken, wo P1 rauskommt: Rem ... Theta1 in die Ellipse einsetzen u(1) = Cos(phi) * (rX * Cos(Theta1)) - Sin(phi) * (rY * Sin(Theta1)) + cx u(2) = Sin(phi) * (rX * Cos(Theta1)) + Cos(phi) * (rY * Sin(Theta1)) + cy v(1) = x1 v(2) = y1 a = VIMAGEEuklid(u, v) ' Entweder a ist fast Null oder ... Rem ... Minus Theta1 in die Ellipse einsetzen u(1) = Cos(phi) * (rX * Cos(0 - Theta1)) - Sin(phi) * (rY * Sin(0 - Theta1)) + cx u(2) = Sin(phi) * (rX * Cos(0 - Theta1)) + Cos(phi) * (rY * Sin(0 - Theta1)) + cy v(1) = x1 v(2) = y1 b = VIMAGEEuklid(u, v) ' ... oder eben b ist fast Null If b < a Then ' Wenn b kleiner ist, Theta1 invertieren Theta1 = 0 - Theta1 ThetaIsInvers = True Else ThetaIsInvers = False End If If Theta1 < 0 Then Theta1 = Theta1 + 2 * MATH_PI ' Schliesslich ---> 0..720 Grad Rem 8/9 -- Step 4: Compute Theta1 and DeltaTheta« / DeltaTheta berechnen u(1) = (x1s - cXs) / rX ' F.6.5.6 und F.6.5.4 u(2) = (y1s - cYs) / rY v(1) = (0 - x1s - cXs) / rX v(2) = (0 - y1s - cYs) / rY a = VIMAGEEuklid(n, u) b = VIMAGEEuklid(n, v) c = a * b If c = 0 Then c = MATH_EPSILON d = (u(1) * v(1) + u(2) * v(2)) / c DeltaTheta = Arccos(d) ' Die Funktion Arccos steht in der Matlib If lambda > 1 Then DeltaTheta = MATH_PI ' Wenn Radien zu klein wird die Ellipse per Lambda vergrößert und Deltatheta wird immer 180 Grad d = DeltaTheta ' für TestTextzeile aufheben Rem 9/9 -- Fallunterscheidung für die Flags Rem Nicht ganz genauso wie in den Requirements -360°..360°, sondern mit 0°.. 720° If DeltaTheta < 0 Then DeltaTheta = DeltaTheta + MATH_PI * 2 If LargeArcFlag = False Then If DeltaTheta > MATH_PI Then ' Short Arc und Größer 180°: andersrum DeltaTheta = 2 * MATH_PI - DeltaTheta End If Else If DeltaTheta < MATH_PI Then ' Large Arc und Kleiner 180°: andersrum DeltaTheta = 2 * MATH_PI - DeltaTheta End If End If Rem Empirisch: Winkel liegen bei ungleichen Flags 180 Grad falsch, darum: If SweepFlag = False Then DeltaTheta = 0 - DeltaTheta Rem Nun haben wir eine Center Parametrization und es kann gemalt werden ... Rem Rem SKELETT Rem ------- If PLGSkelettFlag = True Then Select Case PLTCoordMode Case 0: ' Bildkoordinaten e1(1) = P1(1) e1(2) = P1(2) e2(1) = P2(1) e2(2) = P2(2) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), e1(1), e1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), e2(1), e2(2)) Case 2: ' Kartenkoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), e1(1), e1(2)) Call FIXCoordMap2Img(RMHD(n1), P2(1), P2(2), e2(1), e2(2)) Case Else: ' Standard: Geokoord Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), e1(1), e1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), e2(1), e2(2)) End Select Call SUBPltPhysSkelettText(LM1, e1, Chr(4), PLGSkelettValue) Call SUBPltPhysSkelettText(LM1, e2, Chr(4), PLGSkelettValue) End If Rem Rem ELLIPSENBOGEN ZEICHNEN Rem ---------------------- stepwidth = DeltaTheta / 1000 DrawIsInit = False ecx = cx ecy = cy ' Jetzt: Eigentlicher Ellipsenbogen For T = Theta1 To Theta1 + DeltaTheta Step stepwidth x = Cos(phi) * (rX * Cos(T)) - Sin(phi) * (rY * Sin(T)) + ecx y = Sin(phi) * (rX * Cos(T)) + Cos(phi) * (rY * Sin(T)) + ecy e2(1) = x e2(2) = y If DrawIsInit = True Then Call SUBPltLine(LM1, n1, e1, e2, zs(), True) ' zs() wird zwar im SVG-Fall ignoriert aber in Line neu eingesetzt. End If e1(1) = e2(1) e1(2) = e2(2) DrawIsInit = True Next T Exit Sub End Sub Rem Rem BEFEHL CIRCLE: KREIS MALEN Rem ========================== Public Sub SUBPltCircle(LM1() As Single, n1 As Long, mp() As Double, R1 As Double, zs() As Single, zf() As Single) Rem Rem SUBPltCircle plottet einen Kreis mit dem Mittelpunkt (mp(1),mp(2)), Radius r1, Liniengrauwert(vektor) zs Rem und dem Füllgrauwertvektor zf(). Rem Rem Bei nichtquadratischen Pixeln wirds eine Ellipse. Rem Rem Wenn der erste Wert in zs (zf) -9999 alias Empty ist, wird der Umfang (die Fläche) Rem nicht gezeichnet. Rem Rem Der Kreis wird mit dem Pen geplottet. Das hat zur Folge, dass der Kreisdurchmesser Rem tatsächlich r1+Pengrösse ist (Der Umfang wird mit einem etwas dicken Stift gemalt.) Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim radius As Double Dim ActRadius As Double Dim LastRadius As Double Dim i1 As Long ' Koord 1 Dim j1 As Long Dim i2 As Long ' Koord 2 Dim j2 As Long Dim wx As Double ' Zwischenkoordinaten, "work" Dim wy As Double Dim sx As Double ' Schreib-Rohkoord Dim sy As Double Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim anglestep As Double Dim Angle As Double Dim PIXX As Double Dim PIXY As Double Dim pixsize As Double Dim pixmiddle As Double Dim Value As Single Dim FirstPointIsPlotted As Boolean fixAbortFlag = False ' Die Routine reagiert auf fixAbortflag/Stopsignal FirstPointIsPlotted = False Rem Rem Initialisierungen Rem ----------------- Rem Init radius = R1 If PLGIsInitialized = False Then Call SUBPltInit FirstPointIsPlotted = True Rem Pixelgröße bestimmen Select Case PLTCoordMode Case 0: pixsize = 1 Case 1: Call FIXCoordGetPixelSize(RMHD(n1), PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist Case 2: Call FIXCoordGetParameters(RMHD(n1), , , , , , , , , PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist End Select If pixsize = 0 Then pixsize = 0.0000001 ' Nulldivisor Rem Textmitteilung HF.Text2.Text = "Vektorplot: Kreis malen ..." HF.Text2.Refresh Rem Rem Schrittweite auf Umfang berechnen Rem --------------------------------- anglestep = radius * MATH_PI / pixsize ' Auf dem Kreisumfang sind anglestep Pixel zu malen If zf(1) = -9999 Then anglestep = anglestep * 5 ' zur Sicherheit bei LeerkreisPunkte etwas dichter If anglestep = 0 Then anglestep = MATH_WEAK_EPSILON ' Nulldivisor anglestep = 1 / anglestep ' Das ist der Winkel von step zu step anglestep = anglestep * MATH_PI Rem Rem Kreise mit Radius Radius ... 0 mit dem Pixel malen Rem -------------------------------------------------- If zf(1) <> -9999 And PLGSkelettFlag = False Then ' Mit dem Pixel ausmalen For ActRadius = radius To 0 Step 0 - (pixsize / 2) For Angle = 0 To 2 * MATH_PI Step anglestep sx = mp(1) + ActRadius * Sin(Angle) sy = mp(2) + ActRadius * Cos(Angle) Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' Call SUBPltPhysPixel(LM1, sc, zf) ' Mit Point und Füllfarbe füllen End If Next Angle HF.Text2.Text = "Vektorplot: Kreis ... Radius = " & CLng(ActRadius) HF.Text2.Refresh DoEvents If fixAbortFlag = True Then GoTo LabPltCircleAborted Next ActRadius End If HF.Text2.Text = "Vektorplot: Gefüllte Kreisfläche fertig." HF.Text2.Refresh Rem Rem Einen Kreis mit dem Pen mit vollem Radius malen Rem ----------------------------------------------- ActRadius = radius If zs(1) <> -9999 Then For Angle = 0 To 2 * MATH_PI Step anglestep sx = mp(1) + ActRadius * Sin(Angle) sy = mp(2) + ActRadius * Cos(Angle) Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select ' If si >= -15 And sj >= -15 Then ' wenn ungültig -9999 If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' If PLGSkelettFlag = False Then If FirstPointIsPlotted = False Then Call SUBPltPhysPen(LM1, sc, zs, False) ' Den allerersten Pen gefüllt FirstPointIsPlotted = True Else Call SUBPltPhysPen(LM1, sc, zs, True) ' Dann immer hohl End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) End If End If Next Angle End If HF.Text2.Text = "Vektorplot: Kreisumfang fertig." HF.Text2.Refresh Rem Rem Mittelpunkt plotten Rem ------------------- If PLGSkelettFlag = True Then Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(mp(1)): sc(2) = CLng(mp(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) End Select Call SUBPltPhysSkelettText(LM1, sc, Chr(5), PLGSkelettValue) End If Exit Sub LabPltCircleAborted: HF.Text2.Text = "Vektorplot: Kreisfüll-Abbruch durch Bedienereingriff." HF.Text2.Refresh fixErrCode = 90 ' "Abbruch durch Interrupt" fixAbortFlag = False ' Gleich wieder löschen, sonst Endlosschleife Exit Sub End Sub Rem Rem BEFEHL ELLIPSE: ELLIPSE MALEN Rem ============================= Public Sub SUBPltEllipse(LM1() As Single, n1 As Long, mp() As Double, R1 As Double, R2 As Double, zs() As Single, zf() As Single) Rem Rem SUBPltEllipse plottet eine Ellipse mit dem Mittelpunkt (mp(1),mp(2)), den Halbachsen r1, r2 und dem Rem Strichgrauwert(vektor) zs und dem Füllgrauwert(vektor) zf. Rem Rem Wenn der erste Wert in zs (zf) -9999 alias Empty ist, wird der Umfang (die Fläche) nicht gezeichnet. Rem Rem Die Ellipse ist immer achsparallel. Das wird auch in dem SVG-Ellipse-Element so gehalten. Rem Für verdrehte Eillpsen nehme man Arc oder Path. Rem Rem Ellipse malt mit dem Pen, d. h. bei nicht unendlich kleinen Pengrößen malt die Pen-Kreisscheibe Rem auf dem Ellipsenumfang entlang. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim radius As Double Dim RadRatio As Double Dim ActRadius As Double Dim LastRadius As Double Dim i1 As Long ' Koord 1 Dim j1 As Long Dim i2 As Long ' Koord 2 Dim j2 As Long Dim wx As Double ' Zwischenkoordinaten, "work" Dim wy As Double Dim sx As Double ' Schreib-Rohkoord Dim sy As Double Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim anglestep As Double Dim Angle As Double Dim PIXX As Double Dim PIXY As Double Dim pixsize As Double Dim pixmiddle As Double Dim Value As Single Dim FirstPointIsPlotted As Boolean fixAbortFlag = False ' Die Routine reagiert auf fixAbortflag/Stopsignal Rem Rem Initialisierungen Rem ----------------- Rem Init radius = R1 If R1 = 0 Then R1 = MATH_WEAK_EPSILON RadRatio = R2 / R1 If PLGIsInitialized = False Then Call SUBPltInit FirstPointIsPlotted = True Rem Pixelgröße bestimmen Select Case PLTCoordMode Case 0: pixsize = 1 Case 1: Call FIXCoordGetPixelSize(RMHD(n1), PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist Case 2: Call FIXCoordGetParameters(RMHD(n1), , , , , , , , , PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist End Select If pixsize = 0 Then pixsize = 0.0000001 ' Nulldivisor If RadRatio > 1 Then pixsize = pixsize / RadRatio ' Bei grösserem Zweitradius Pixelsize verringern Rem Textmitteilung HF.Text2.Text = "Vektorplot: Ellipse malen ..." HF.Text2.Refresh Rem Rem Schrittweite auf Umfang berechnen Rem --------------------------------- anglestep = radius * MATH_PI / pixsize ' Auf dem Kreisumfang sind anglestep Pixel zu malen If zf(1) = -9999 Then anglestep = anglestep * 5 ' zur Sicherheit bei LeerkreisPunkte etwas dichter If anglestep = 0 Then anglestep = MATH_WEAK_EPSILON ' Nulldivisor anglestep = 1 / anglestep ' Das ist der Winkel von step zu step anglestep = anglestep * MATH_PI Rem Rem Ellipsen mit Radius Radius ... 0 mit dem Pixel malen Rem ---------------------------------------------------- If zf(1) <> -9999 And PLGSkelettFlag = False Then ' Mit dem Point ausmalen For ActRadius = radius To 0 Step 0 - (pixsize / 2) For Angle = 0 To 2 * MATH_PI Step anglestep sx = mp(1) + ActRadius * Sin(Angle) sy = mp(2) + ActRadius * RadRatio * Cos(Angle) Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' Call SUBPltPhysPixel(LM1, sc, zf) ' Ein Punkt mit dem Point und Füllfarbe End If Next Angle HF.Text2.Text = "Vektorplot: Ellipse ... Radius = " & CLng(ActRadius) HF.Text2.Refresh DoEvents If fixAbortFlag = True Then GoTo LabPltEllipseAborted Next ActRadius End If HF.Text2.Text = "Vektorplot: Gefüllte Ellipsenfläche fertig." HF.Text2.Refresh Rem Rem Einen Ellipsenumfang mit dem Pen mit voller Große malen Rem ------------------------------------------------------- ActRadius = radius If zs(1) <> -9999 Then For Angle = 0 To 2 * MATH_PI Step anglestep sx = mp(1) + ActRadius * Sin(Angle) sy = mp(2) + ActRadius * RadRatio * Cos(Angle) Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' If PLGSkelettFlag = False Then If FirstPointIsPlotted = False Then Call SUBPltPhysPen(LM1, sc, zs, False) ' Den allerersten Pen gefüllt FirstPointIsPlotted = True Else Call SUBPltPhysPen(LM1, sc, zs, True) ' Dann immer hohl End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) End If End If Next Angle End If HF.Text2.Text = "Vektorplot: Ellipsenumfang fertig." HF.Text2.Refresh Rem Rem Mittelpunkt plotten Rem ------------------- If PLGSkelettFlag = True Then Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(mp(1)): sc(2) = CLng(mp(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), mp(1), mp(2), sc(1), sc(2)) End Select Call SUBPltPhysSkelettText(LM1, sc, Chr(5), PLGSkelettValue) End If Exit Sub LabPltEllipseAborted: HF.Text2.Text = "Vektorplot: Ellipsenfüll-Abbruch durch Bedienereingriff." HF.Text2.Refresh fixErrCode = 90 ' "Abbruch durch Interrupt" fixAbortFlag = False ' Gleich wieder löschen, sonst Endlosschleife Exit Sub End Sub Rem Rem BEFEHL RECT: RECHTECK MALEN Rem =========================== Public Sub SUBPltRect(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, zs() As Single, zf() As Single) Rem Rem SUBPltRect plottet ein Rechteck mit den diagonalen Ecken (p1(1),p1(2)) und (p2(1),p2(2)), Linien- Rem Grauwert zs, Füllgrauwert zf. Rem Rem Wenn der erste Wert in zs (zf) -9999 alias Empty ist, wird der Umfang (die Fläche) nicht gezeichnet. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Rect malt mit dem Pen, d. h. bei nicht unendlich kleinen Pengrössen bekommt das Rechteck runde Ecken. Rem Dim i1 As Long ' Schreib-Bildkoord Diagonalecken Dim i2 As Long Dim j1 As Long Dim j2 As Long Dim wx1 As Double ' Arbeitskoord für Umrechnung Dim wy1 As Double Dim wx2 As Double Dim wy2 As Double Dim stepi As Double Dim stepj As Double Dim q1(1 To 2) As Double ' Schreib-Bildkoord 1. - 4. Ecke Dim q2(1 To 2) As Double Dim q3(1 To 2) As Double Dim q4(1 To 2) As Double Dim qt(1 To 2) As Double ' Laufender (parametrierter) Punkt Dim t1 As Double ' dessen Komponenten Dim t2 As Double Dim tmpCoordMode As Long If PLGIsInitialized = False Then Call SUBPltInit Rem Rem Koordinaten umrechnen Rem --------------------- Select Case PLTCoordMode Case 0: ' Bildkoordinaten q1(1) = P1(1) q1(2) = P1(2) q4(1) = P2(1) q4(2) = P2(2) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), q4(1), q4(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) Call FIXCoordMap2Img(RMHD(n1), P2(1), P2(2), q4(1), q4(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) Call FIXCoordGeo2Img(RMHD(n1), P2(1), P2(2), q4(1), q4(2)) End Select ' Testcode= Blöden Zeilensprung (s. u.) provozieren ... ' q1(1) = 10.5: q1(2) = 20.4: q4(1) = 210.5: q4(2) = 220.4 q2(1) = q1(1) q2(2) = q4(2) q3(1) = q4(1) q3(2) = q1(2) Rem Rem Rechteck ausmalen Rem ----------------- If zf(1) <> -9999 Then ' Rechteck ausmalen stepi = 1 If q4(1) < q1(1) Then stepi = -1 stepj = 1 If q4(2) < q1(2) Then stepj = -1 For t1 = q1(1) To q4(1) Step stepi For t2 = q1(2) To q4(2) Step stepj If t1 > -15 And t2 > -15 And t1 < RMHD(n1).ImgXXXX + 16 And t2 < RMHD(n1).ImgYYYY + 16 Then ' Blöder Zeilensprung: Wenn die Koord genau auf .500 steht, rundet Basic nach Geraderzahlregel! ' Das macht aus 1.5 2.5 3.5 4.5 5.5 6.5 --> 2 2 4 4 6 6. Damit das nicht passiert: If Abs(t1 - CInt(t1)) = 0.5 Then t1 = t1 + 0.001 If Abs(t2 - CInt(t1)) = 0.5 Then t2 = t2 + 0.001 qt(1) = t1 qt(2) = t2 Call SUBPltPhysPixel(LM1, qt, zf) End If Next t2 Next t1 End If Rem Rem Wenn Pen grösser 0: Rechteckrahmen Rem ---------------------------------- If zs(1) <> -9999 Then tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' Bildkoord einstellen, dann es sind schon solche; sonst werden die als Geo/Mapkoord von Linie nochmal umgerechnet ... Call SUBPltLine(LM1, n1, q1, q2, zs) ' zs wird im SVG-Fall ignoriert aber neu übernommen ... Call SUBPltLine(LM1, n1, q2, q4, zs) Call SUBPltLine(LM1, n1, q4, q3, zs) Call SUBPltLine(LM1, n1, q3, q1, zs) ' Line besorgt das Skelett mit PLTCoordMode = tmpCoordMode End If HF.Text2.Text = "Vektorplot: Rechteck fertig." HF.Text2.Refresh End Sub Rem Rem BEFEHL POLYLINE: POLYLINIE MALEN Rem ================================ Public Sub SUBPltPolyline(LM1() As Single, n1 As Long, pl() As Double, z() As Single) Rem Rem SUBPltPolyline plottet eine Polylinie (pl(1),pl(2)), (pl(3),pl(4)) ... (pl(n-1),pl(n))), Rem Grauwert z1. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Polyline male mit dem Pen. Rem Dim NofPoints As Long Dim Lastpoint(1 To 2) As Double Dim P1(1 To 2) As Double ' Schreib-Bildkoord 1. - 4. Ecke Dim tmpCoordMode As Long Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Tatsächliche Malfarbe Dim i As Long If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub NofPoints = UBound(pl, 1) NofPoints = CLng(NofPoints \ 2) HF.Text2.Text = "Vektorplot: Polyline ..." HF.Text2.Refresh Rem Farben ermitteln Call VIMAGEValueCopy(z, zs) Rem Koordinaten umrechnen For i = 1 To NofPoints Select Case PLTCoordMode Case 0: ' Bildkoordinaten P1(1) = pl(2 * i - 1) P1(2) = pl(2 * i) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) End Select tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten If i > 1 Then Call SUBPltLine(LM1, n1, Lastpoint, P1, z) ' Line besorgt das Skelett ggf. mit End If PLGPlotCounter = PLGPlotCounter + 1 PLTCoordMode = tmpCoordMode Lastpoint(1) = P1(1) Lastpoint(2) = P1(2) Next i HF.Text2.Text = "Vektorplot: Polylinie fertig." HF.Text2.Refresh End Sub Rem Rem BEFEHL POLYLINEDOUBLE: DOPPELPOLYLINIE MALEN Rem ============================================ Public Sub SUBPltPolylineDouble(LM1() As Single, n1 As Long, pl() As Double, y() As Single, z() As Single) Rem Rem SUBPltPolyline plottet eine Polylinie (pl(1),pl(2)), (pl(3),pl(4)) ... (pl(n-1),pl(n))), Rem Grauwerte y/z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Polyline male mit dem Pen. Rem Dim NofPoints As Long Dim Lastpoint(1 To 2) As Double Dim P1(1 To 2) As Double ' Schreib-Bildkoord 1. - 4. Ecke Dim tmpCoordMode As Long Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Tatsächliche Malfarbe Dim i As Long If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub NofPoints = UBound(pl, 1) NofPoints = CLng(NofPoints \ 2) HF.Text2.Text = "Vektorplot: Doppelpolyline ..." HF.Text2.Refresh Rem Farben ermitteln Call VIMAGEValueCopy(z, zs) Rem Koordinaten umrechnen For i = 1 To NofPoints Select Case PLTCoordMode Case 0: ' Bildkoordinaten P1(1) = pl(2 * i - 1) P1(2) = pl(2 * i) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) End Select tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten If i > 1 Then Call SUBPltLineDoubleApp(LM1, n1, Lastpoint, P1, y, z) ' Line besorgt das Skelett ggf. mit End If PLTCoordMode = tmpCoordMode Lastpoint(1) = P1(1) Lastpoint(2) = P1(2) Next i HF.Text2.Text = "Vektorplot: Doppelpolylinie fertig." HF.Text2.Refresh End Sub Rem Rem BEFEHL POLYGON: POLYGON MALEN Rem ============================= Public Sub SUBPltPolygon(LM1() As Single, n1 As Long, pl() As Double, z() As Single) Rem Rem SUBPltPolygon plottet eine Polygon (pl(1),pl(2)), (pl(3),pl(4)) ... (pl(n-1),pl(n))), Rem pl(1),pl(2)) ,Grauwert z1. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Polygon malt mit dem Pen. Rem Rem Im Gegensatz zum SVG-Polygon füllt SUBPltPolygon nie! Das muss extra mit SUBPltFill gemacht werden. Rem Hierfür braucht SUBPltFill einen Anfangspunkt. Rem Dim NofPoints As Long Dim Startpoint(1 To 2) As Double Dim Lastpoint(1 To 2) As Double Dim P1(1 To 2) As Double ' Aktueller Punkt Dim tmpCoordMode As Long Dim i As Long Dim j As Long Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichvalue Dim zf(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Füllvalue If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub NofPoints = UBound(pl, 1) NofPoints = CLng(NofPoints \ 2) HF.Text2.Text = "Vektorplot: Polygon ..." HF.Text2.Refresh Rem Farben ermitteln Call VIMAGEValueCopy(z, zs) Rem Polygon malen For i = 1 To NofPoints ' Koordinaten umrechnen Select Case PLTCoordMode Case 0: ' Bildkoordinaten P1(1) = pl(2 * i - 1) P1(2) = pl(2 * i) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) End Select ' Startpunkt merken If i = 1 Then Startpoint(1) = P1(1) Startpoint(2) = P1(2) ' Linie malen Else tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten Call SUBPltLine(LM1, n1, Lastpoint, P1, zs) ' Line besorgt ggf. das Skelett mit. PLTCoordMode = tmpCoordMode End If ' Zählen PLGPlotCounter = PLGPlotCounter + 1 ' Altpunkt merken Lastpoint(1) = P1(1) Lastpoint(2) = P1(2) Next i ' Polygon schliessen tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten Call SUBPltLine(LM1, n1, P1, Startpoint, zs) ' Schliessen. Line besorgt ggf. das Skelett mit. PLGPlotCounter = PLGPlotCounter + 1 Rem Polygon ausmalen Rem Das Plotlib-Polygon wird im Gegensatz zum SVG-Polygon nie ausgemalt! PLTCoordMode = tmpCoordMode HF.Text2.Text = "Vektorplot: Polygon fertig." HF.Text2.Refresh End Sub Rem Rem BEFEHL POLYGON: POLYGON MALEN Rem ============================= Public Sub SUBPltPolygonDouble(LM1() As Single, n1 As Long, pl() As Double, y() As Single, z() As Single) Rem Rem SUBPltPolygonDouble plottet eine Polygon (pl(1),pl(2)), (pl(3),pl(4)) ... (pl(n-1),pl(n))), Rem pl(1),pl(2)) ,Grauwerte y, z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Polygon malt mit dem Pen und dem Aux-Pen. Rem Rem Im Gegensatz zum SVG-Polygon füllt SUBPltPolygon nie! Das muss extra mit SUBPltFill gemacht werden. Rem Hierfür braucht SUBPltFill einen Anfangspunkt. Rem Dim NofPoints As Long Dim Startpoint(1 To 2) As Double Dim Secondpoint(1 To 2) As Double Dim Lastpoint(1 To 2) As Double Dim P1(1 To 2) As Double ' Aktueller Punkt Dim tmpCoordMode As Long Dim i As Long Dim j As Long 'Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichvalue 'Dim zf(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Füllvalue If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub NofPoints = UBound(pl, 1) NofPoints = CLng(NofPoints \ 2) HF.Text2.Text = "Vektorplot: Doppellliniges Polygon ..." HF.Text2.Refresh Rem Farben ermitteln 'Call VIMAGEValueCopy(z, zs) Rem Polygon malen For i = 1 To NofPoints ' Koordinaten umrechnen Select Case PLTCoordMode Case 0: ' Bildkoordinaten P1(1) = pl(2 * i - 1) P1(2) = pl(2 * i) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), pl(2 * i - 1), pl(2 * i), P1(1), P1(2)) End Select ' Startpunkt merken If i = 1 Then Startpoint(1) = P1(1) Startpoint(2) = P1(2) ' Linie malen Else If i = 2 Then Secondpoint(1) = P1(1) ' Auch den 2. Punkt merken Secondpoint(2) = P1(2) End If tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten Call SUBPltLineDoubleApp(LM1, n1, Lastpoint, P1, y, z) ' Line besorgt ggf. das Skelett mit. PLTCoordMode = tmpCoordMode End If ' Altpunkt merken Lastpoint(1) = P1(1) Lastpoint(2) = P1(2) Next i ' Polygon schliessen tmpCoordMode = PLTCoordMode PLTCoordMode = 0 ' SUBPltLine muss in Bildkoord arbeiten Call SUBPltLineDoubleApp(LM1, n1, P1, Startpoint, y, z) ' Schliessen. Line besorgt ggf. das Skelett mit. Call SUBPltLineAux(LM1, n1, Startpoint, Secondpoint, z) ' Schlusslinie nach 2. Punkt öffnen Rem Polygon ausmalen Rem Das Plotlib-Polygon wird im Gegensatz zum SVG-Polygon nie ausgemalt! PLTCoordMode = tmpCoordMode HF.Text2.Text = "Vektorplot: Doppellliniges Polygon fertig." HF.Text2.Refresh End Sub Rem Rem BEFEHL PATH: PFAD ANHAND SVG-PFADDATENLISTE MALEN Rem ================================================= Public Sub SUBPltPath(LM1() As Single, n1 As Long, PData As String, z() As Single) Rem Rem SUBPltPolygon plottet einen Pfad anhand eines SVG-Pfadzeichenkette PData. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Es wird mit dem Pen gemalt. Rem Rem Im Gegensatz zum SVG-Path füllt SUBPltPath nie! Das muss extra mit SUBPltFill gemacht werden. Rem Hierfür braucht SUBPltFill einen Anfangspunkt. Rem Rem Die Syntax der Pfadzeichenkette entspricht der des Data-Attributes des SVG-Pfadelements. Rem Rem Kurzbeschreibung: Rem Rem M x y Moveto (x,y) Rem Z Close Path Rem L x y Lineto (x,y) Rem H x Horizontal Lineto x Rem V y Vertical Lineto y Rem C x1 y1 x2 y2 x y Cubic Bézier Curveto (x,y), Kontrollpunkte (x1,y1), (x2,y2) Rem S x2 y2 x y Smooth Cubic Bézier Curveto. (x1,y1) ist der vorhergehende (x2,y2) gespiegelt. Rem Q x1 y1 x y Quadratic Bézier Curveto (x,y), Kontrollpunkt (x1,y1) Rem T x y SmooTh Quadratic Bézier Curveto (x,y), (x1,y1) ist der vorige (x1,y1) gespiegelt. Rem A r1 r2 az f1 f2 x y Arcto (x,y), Ellipsenhalbachsen rx, ry, Rotationswinkel Große Halbachse-X- Rem Achse az, f1 und f2 sind 2 Flags (Large-Arc-Flag und Sweep Flag), die aus 4 Rem möglichen Lösungem eine Lösungen aus wählen. Rem Rem Bei Großbuchstaben werden Absolutkoordinaten, bei Kleinbuchstaben Relativkoordinaten erwartet. Rem Rem Die SVG-Pfadbefehle ist ausführlich in der SVG-Dokumentation beschrieben. Rem Rem Implementierter Stand: SVG 1.0 20010904. Rem Rem Im Gegensatz zu den anderen Subroutinen der Plotlib behandelt SUBPltPath Rem Fehler. Hierzu werden an den Fehlertent SVGPathErrorText (SVG-Subsystem!) laufend Mitteilungen angehängt. Rem Dim i As Long Dim IsInit As Boolean ' True: Es wurde schon irgendwas gemalt und Z kann ausgeführt werden Dim ArgV() As Double ' Allg. Argumentenvektor Dim P1(1 To 2) As Double ' Allg. Punkte Dim P2(1 To 2) As Double Dim p3(1 To 2) As Double Dim p4(1 To 2) As Double Dim R1 As Double ' Ellipsenhalbmesser Dim R2 As Double Dim az As Double ' Ellipsenwinkel (Azimut) Dim f1 As Double ' Ellipsenflags Dim f2 As Double Dim SData As String Dim ActCommand As String Dim tmpString As String Dim tmpChar As String Dim TList() As String Dim TPointer As Long Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichvalue Dim zf(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Füllvalue If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub SVGPathErrorText = "" ' Ausführliches Fehlerprotokoll löschen. Wenn = "", dann fehlerfrei. IsInit = False HF.Text2.Text = "Vektorplot: Pfadinterpretation " & PData & " ..." HF.Text2.Refresh Rem FARBEN ERMITTELN Call VIMAGEValueCopy(z, zs) Rem TEXTKETTE VORBEREITEN SData = VPAPreText(PData) ' wandelt bestimmte Sonderzeichen SData = Replace(SData, vbCrLf, " ") ' Steuerzeichen und allemöglichen White/Gray Spaces in SP SData = Replace(SData, vbLf, " ") SData = Replace(SData, vbCr, " ") SData = Replace(SData, vbTab, " ") SData = Replace(SData, Chr(0), " ") SData = Replace(SData, ",", " ") SData = Replace(SData, "~", " ") tmpString = SData SData = "" For i = 1 To Len(tmpString) ' Alle Buchstaben separieren tmpChar = Mid(tmpString, i, 1) If Asc(tmpChar) < 65 Then SData = SData & tmpChar Else SData = SData & tmpChar & " " End If Next i For i = 1 To 10 ' Mehrfachleerzeichen wegmachen SData = Replace(SData, " ", " ") Next i For i = 1 To 10 ' Mehrfachleerzeichen wegmachen SData = Replace(SData, " ", " ") Next i SData = RTrim(LTrim(SData)) ' Führende/angehängte Leerzeichen wegmachen Rem LEERE KETTE?? If SData = "" Then SVGPathErrorText = SVGPathErrorText & " [POS000-E.NUL]: Zeichenkette leer" & vbCrLf GoTo LabPltPathExit End If Rem TEXTKETTE IN TOKEN TRENNEN TList = Split(SData, " ") ReDim Preserve TList(0 To UBound(TList) + 1) ' TList um eins verlängern For i = UBound(TList) To 1 Step -1 TList(i) = TList(i - 1) Next i ' Jetzt ist TList einsbasiert: Es steht Token 1 in Tlist(1) TList(0) = "" TPointer = 0 Rem TOKENART ERMITTELN LabPltPathNext: ' Beginn der grossen Kommandoschleife ' Nächstes Token holen TPointer = TPointer + 1 If TPointer > UBound(TList) Then GoTo LabPltPathExit ' Tokenliste zu Ende If TList(TPointer) = "" Then GoTo LabPltPathNext ' Leeres Token Rem KOMMANDO INTERPRETIEREN Select Case TList(TPointer) Rem M -- MOVETO Case "M", "m": ' Relative Moveto HF.Text2.Text = "Vektorplot: Pfadkommando Moveto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei M(m)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 2 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei M(m)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 2) * 2 Step 2 If ActCommand = "M" Then PLCCursor(1) = ArgV(i) PLCCursor(2) = ArgV(i + 1) Else PLCCursor(1) = PLCCursor(1) + ArgV(i) PLCCursor(2) = PLCCursor(2) + ArgV(i + 1) End If IsInit = True PLCStartPoint(1) = PLCCursor(1) ' Closepath führt immer zum vorausgegangenen Moveto-Startpunkt PLCStartPoint(2) = PLCCursor(2) PLCStartPointII(1) = PLCCursor(1) PLCStartPointII(2) = PLCCursor(2) PLCCursorII(1) = PLCCursor(1) PLCCursorII(2) = PLCCursor(2) Next i Rem Z -- CLOSEPATH Case "Z", "z": ' Closepath HF.Text2.Text = "Vektorplot: Pfadkommando CloZepath" HF.Text2.Refresh ActCommand = TList(TPointer) If IsInit = True Then Call SUBPltLine(LM1, n1, PLCCursor, PLCStartPoint, zs) Else SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.INZ]: Z-Kommando ohne Vorkommando nicht ausführbar" & vbCrLf End If Rem L -- LINETO Case "L", "l": ' Relative lineto HF.Text2.Text = "Vektorplot: Pfadkommando Lineto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei L(l)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 2 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei L(l)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 2) * 2 Step 2 ' VisualBasic rundet nach einer so elenden Geradezahlregel, was bei bei 0.5000 stehenden ' und mit 1.0000 inkrementierte Pixeladressen die Rundung 2 2 4 4 6 6 8 8 ... bewirkt. ' Wir addieren ein RandomEpsilon und dann klappts ... If ActCommand = "L" Then P1(1) = ArgV(i) + VIMAGERandomEpsilon(1) P1(2) = ArgV(i + 1) + VIMAGERandomEpsilon(2) Else P1(1) = ArgV(i) + PLCCursor(1) + VIMAGERandomEpsilon(3) P1(2) = ArgV(i + 1) + PLCCursor(2) + VIMAGERandomEpsilon(4) End If Call SUBPltLine(LM1, n1, PLCCursor, P1, zs) IsInit = True PLCCursor(1) = P1(1) PLCCursor(2) = P1(2) PLCCursorII(1) = P1(1) PLCCursorII(2) = P1(2) Next i Rem H HORIZONTAL LINETO Case "H", "h": ' Horizontal Lineto HF.Text2.Text = "Vektorplot: Pfadkommando Horizontal Lineto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei H(h)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 1 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei H(h)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 1) * 1 Step 1 If ActCommand = "H" Then P1(1) = ArgV(i) + VIMAGERandomEpsilon(5) P1(2) = PLCCursor(2) + VIMAGERandomEpsilon(6) Else P1(1) = ArgV(i) + PLCCursor(1) + VIMAGERandomEpsilon(7) P1(2) = PLCCursor(2) + VIMAGERandomEpsilon(8) End If Call SUBPltLine(LM1, n1, PLCCursor, P1, zs) IsInit = True PLCCursor(1) = P1(1) PLCCursor(2) = P1(2) PLCCursorII(1) = P1(1) PLCCursorII(2) = P1(2) Next i Rem V VERTICAL LINETO Case "V", "v": ' Vertical Lineto HF.Text2.Text = "Vektorplot: Pfadkommando Vertical Lineto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei H(h)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 1 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei H(h)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 1) * 1 Step 1 If ActCommand = "V" Then P1(1) = PLCCursor(1) + VIMAGERandomEpsilon(9) P1(2) = ArgV(i) + VIMAGERandomEpsilon(10) Else P1(1) = PLCCursor(1) + VIMAGERandomEpsilon(11) P1(2) = ArgV(i) + PLCCursor(2) + VIMAGERandomEpsilon(12) End If Call SUBPltLine(LM1, n1, PLCCursor, P1, zs) IsInit = True PLCCursor(1) = P1(1) PLCCursor(2) = P1(2) PLCCursorII(1) = P1(1) PLCCursorII(2) = P1(2) Next i Rem C -- BÉZIER CURVETO Case "C", "c": ' Curveto HF.Text2.Text = "Vektorplot: Pfadkommando Bézier Curveto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei C(c)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 6 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei C(c)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 6) * 6 Step 6 If ActCommand = "C" Then P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = ArgV(i) P2(2) = ArgV(i + 1) p3(1) = ArgV(i + 2) p3(2) = ArgV(i + 3) p4(1) = ArgV(i + 4) p4(2) = ArgV(i + 5) Else P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + ArgV(i) P2(2) = PLCCursor(2) + ArgV(i + 1) p3(1) = PLCCursor(1) + ArgV(i + 2) p3(2) = PLCCursor(2) + ArgV(i + 3) p4(1) = PLCCursor(1) + ArgV(i + 4) p4(2) = PLCCursor(2) + ArgV(i + 5) End If Call SUBPltBezier(LM1, n1, P1, P2, p3, p4, zs) IsInit = True PLCCursor(1) = p4(1) PLCCursor(2) = p4(2) PLCCursorII(1) = p3(1) PLCCursorII(2) = p3(2) Next i Rem S -- SMOOTH BÉZIER CURVETO Case "S", "s": ' Smooth Cubic Bezier Curveto HF.Text2.Text = "Vektorplot: Pfadkommando Smooth Bézier Curveto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei S(s)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 4 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei S(s)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 4) * 4 Step 4 If ActCommand = "S" Then P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + (PLCCursor(1) - PLCCursorII(1)) P2(2) = PLCCursor(2) + (PLCCursor(2) - PLCCursorII(2)) p3(1) = ArgV(i) p3(2) = ArgV(i + 1) p4(1) = ArgV(i + 2) p4(2) = ArgV(i + 3) Else P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + (PLCCursor(1) - PLCCursorII(1)) P2(2) = PLCCursor(2) + (PLCCursor(2) - PLCCursorII(2)) p3(1) = PLCCursor(1) + ArgV(i) p3(2) = PLCCursor(2) + ArgV(i + 1) p4(1) = PLCCursor(1) + ArgV(i + 2) p4(2) = PLCCursor(2) + ArgV(i + 3) End If Call SUBPltBezier(LM1, n1, P1, P2, p3, p4, zs) IsInit = True PLCCursor(1) = p4(1) PLCCursor(2) = p4(2) PLCCursorII(1) = p3(1) PLCCursorII(2) = p3(2) Next i Rem Q -- QUADRATIC BÉZIER CURVETO Case "Q", "q": ' Quadratic Bezier Curveto HF.Text2.Text = "Vektorplot: Pfadkommando Quadratic Bézier Curveto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei Q(q)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 4 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei Q(q)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 4) * 4 Step 4 If ActCommand = "Q" Then P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = ArgV(i) P2(2) = ArgV(i + 1) p3(1) = ArgV(i + 2) p3(2) = ArgV(i + 3) Else P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + ArgV(i) P2(2) = PLCCursor(2) + ArgV(i + 1) p3(1) = PLCCursor(1) + ArgV(i + 2) p3(2) = PLCCursor(2) + ArgV(i + 3) End If Call SUBPltQBezier(LM1, n1, P1, P2, p3, zs) IsInit = True PLCCursor(1) = p3(1) PLCCursor(2) = p3(2) PLCCursorII(1) = P2(1) PLCCursorII(2) = P2(2) Next i Rem T -- THE SMOOTH QUADRATIC BÉZIER CURVETO Case "T", "t": ' SmooTh Quadratic Bezier Curveto HF.Text2.Text = "Vektorplot: Pfadkommando SmooTh Quadratic Bézier Curveto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei T(t)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 2 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei T(t)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 2) * 2 Step 2 If ActCommand = "T" Then P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + (PLCCursor(1) - PLCCursorII(1)) P2(2) = PLCCursor(2) + (PLCCursor(2) - PLCCursorII(2)) p3(1) = ArgV(i) p3(2) = ArgV(i + 1) Else P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) P2(1) = PLCCursor(1) + (PLCCursor(1) - PLCCursorII(1)) P2(2) = PLCCursor(2) + (PLCCursor(2) - PLCCursorII(2)) p3(1) = PLCCursor(1) + ArgV(i) p3(2) = PLCCursor(2) + ArgV(i + 1) End If Call SUBPltQBezier(LM1, n1, P1, P2, p3, zs) IsInit = True PLCCursor(1) = p3(1) PLCCursor(2) = p3(2) PLCCursorII(1) = P2(1) PLCCursorII(2) = P2(2) Next i Rem A -- ELLIPTIC ARCTO Case "A", "a": ' Elliptic Arcto HF.Text2.Text = "Vektorplot: Pfadkommando Arcto" HF.Text2.Refresh ActCommand = TList(TPointer) Call SUBPltGetPathParameter(TList, TPointer, ArgV) ' Zahlenargumente holen If ArgV(0) <> 0 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.EOS]: Zeichenkettenende bei S(s)-Kommando" & vbCrLf GoTo LabPltPathExit End If If UBound(ArgV) < 7 Then SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.ARG]: Zu wenig Argumente bei S(s)-Kommando" & vbCrLf GoTo LabPltPathNext End If For i = 1 To (UBound(ArgV) \ 7) * 7 Step 7 If ActCommand = "A" Then P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) R1 = ArgV(i) R2 = ArgV(i + 1) az = ArgV(i + 2) f1 = ArgV(i + 3) f2 = ArgV(i + 4) P2(1) = ArgV(i + 5) P2(2) = ArgV(i + 6) Else P1(1) = PLCCursor(1) P1(2) = PLCCursor(2) R1 = ArgV(i) R2 = ArgV(i + 1) az = ArgV(i + 2) f1 = ArgV(i + 3) f2 = ArgV(i + 4) P2(1) = PLCCursor(1) + ArgV(i + 5) P2(2) = PLCCursor(2) + ArgV(i + 6) End If Call SUBPltArc(LM1, n1, P1, R1, R2, az, f1, f2, P2, zs) IsInit = True PLCCursor(1) = P2(1) PLCCursor(2) = P2(2) PLCCursorII(1) = P2(1) PLCCursorII(2) = P2(2) Next i Rem ? -- UNKNOWN Case Else: SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer, "000") & "-E.UNK]: Kommando »" & TList(TPointer) & "« unbekannt" & vbCrLf End Select GoTo LabPltPathNext LabPltPathExit: If SVGPathErrorText <> "" Then fixErrCode = 88 HF.Text2.Text = "Vektorplot: Pfadinterpretation fertig. Es ist ein (sind mehrere) Fehler aufgetreten." Else HF.Text2.Text = "Vektorplot: Pfadinterpretation erfolgreich abgeschlossen." End If HF.Text2.Refresh End Sub Private Sub SUBPltGetPathParameter(TList() As String, TPointer As Long, ArgV() As Double) Rem Rem Interne Sub für SUBPltPath, die alle ab der Position TPointer+1 in der Tokenliste Rem vorhandenen Zahlen ermittelt und in den Argumentenvektor ArgV überträgt. Rem Rem TPointer wird weitergestellt. Rem Rem ArgV wird nullbasiert redimensioniert. Element 0 wird auf 0 (Erfolgsfall) oder -1 Rem (Position hinter Topkenlistenende) gesetzt. Rem ' SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer + 1, "000") & "-E.EOS]: Zeichenkette zu Ende" & vbCrLf ' SVGPathErrorText = SVGPathErrorText & " [POS" & Format(TPointer + 1, "000") & "-E.NUM]: »" & TList(TPointer) & "« ist keine Zahl" & vbCrLf ReDim ArgV(0 To 0) ArgV(0) = 0 If TPointer >= UBound(TList) Or TPointer < LBound(TList) Then ' Auch Gleich!! d. h. ein *Inkrement muss er noch abkönnen ArgV(0) = -1 ' Wenn Tokenlistenende Exit Sub End If While 1 = 1 If UBound(TList) < TPointer + 1 Then Exit Sub ' Abbruch wenn Kette zu Ende If IsNumeric(TList(TPointer + 1)) = False Then Exit Sub ' Abbruch wenn Token keine Zahl TPointer = TPointer + 1 ' Pointer weiterstellen ReDim Preserve ArgV(0 To (UBound(ArgV) + 1)) ' Argumentvektor verlängern ArgV(UBound(ArgV)) = VIMAGEVal(TList(TPointer)) ' Übernehmen Wend End Sub Rem Rem BEFEHL FILL: KONTUR FÜLLEN Rem ========================== Public Sub SUBPltFill(LM1() As Single, n1 As Long, P1() As Double, fbv0() As Single, Z1() As Single) Rem Rem SUBPltFill füllt eine Fläche ab Position (p1(1),p1(2)) bis zum Randgrauwert- Rem vektor fbv0 mit Grauwertvektor z1. Rem Rem LM1() ist ein Single-Feld(x,y,Band) mit dem Bild, N1 die Bildspeichernummer Rem Rem Aus Speicherplatzgründen erstmal nur mit 16-Bit-Bildadressen implementiert. Rem Rem !!! Das Programm nutzt nicht den Driver, sondern greift direkt auf den Bildspeicher zu! Rem Stacktiefe: 1 Mio belegen 5 MB Speicher. Kürzere erzeugen früher Stäcküberlauf, längere brauchen mehr Speicher. Dim KoordList() As Integer ' Koordinatenstack. !NUR 16-BIT! Daher Fehler-48-anfällig. Dim DirList() As Byte ' Richtungsstack. Zeigt Richtung an, in der der KoordList-Punkt erreicht wurde. Dim ListIndex As Long ' Listenzeiger, svw. Stackpointer. Dim Band As Long Dim w As Long Rem Sonstige Variablen Dim q1(1 To 2) As Double ' p1() in Bildkoordinaten Dim ActDir As Long ' Aktuelle Suchrichtung: 0=Ost, 1=Süd, 2=West, 3=Nord; Interpoetation modulo 4 Dim Cursor(1 To 2) As Integer ' Aktueller Punkt Dim FillCounter As Long ' Zähler für statistische Zwecke Dim TimeOutCounter As Long ' Timeoutzähler Dim OldTimeoutCounter As Long ' Duplikat Dim zf(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Füllfarbe fixAbortFlag = False ' Die Routine reagiert auf fixAbortflag/Stopsignal Rem Plot-Subsystem initialisieren If PLGIsInitialized = False Then Call SUBPltInit Rem Fehler, wenn Koordinaten nicht in Short Integer passen If (RMHD(n1).ImgXXXX > 32750) Or (RMHD(n1).ImgYYYY > 32750) Then GoTo LabPltImageToLarge Rem Farbe holen Call VIMAGEValueCopy(Z1, zf) Rem Koordinaten in Bildkoord Select Case PLTCoordMode Case 0: ' Bildkoord q1(1) = P1(1) q1(2) = P1(2) Case 1: ' Geokoord-->Bildkoord Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) Case 2: ' Kartenkoord-->Bildkoord Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) Case Else: ' Standard: Geokoord Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), q1(1), q1(2)) End Select If PLGSkelettFlag = True Then Call SUBPltPhysSkelettText(LM1, q1, Chr(8), PLGSkelettValue) ' Punkt Exit Sub End If Rem Initialisieren ReDim KoordList(1 To 2, 0 To VIMAGE_FILL_MAX_STACK_DEEPTH) ' Pro einer Million Stacktiefe ReDim DirList(0 To VIMAGE_FILL_MAX_STACK_DEEPTH) ' verbrät er 5 Megabyte ListIndex = 1 ActDir = 1 Cursor(1) = CInt(q1(1)) Cursor(2) = CInt(q1(2)) Rem Initialpunkt ausserhalb Bild? If (Cursor(1) < LBound(LM1, 1) Or _ Cursor(1) > UBound(LM1, 1) Or _ Cursor(2) < LBound(LM1, 2) Or _ Cursor(2) > UBound(LM1, 2)) Then GoTo LabPltIsAlreadyFilled End If Rem Bereits fertig? For w = 1 To UBound(LM1, 3) If LM1(Cursor(1), Cursor(2), w) <> fbv0(w) Then GoTo LabPltFill1 Next w GoTo LabPltIsAlreadyFilled LabPltFill1: HF.Text2.Text = "Vektorplot: Fläche füllen ... " HF.Text2.Refresh Rem Eigentlicher Füllalgorithmus. Floodfill in einem Arrangement von Christian Gruner, Berlin TimeOutCounter = 0 FillCounter = 0 ' Statistik Do While ListIndex >= 1 ' ERSTENS: Solange ackern, bis die Liste (wieder) leer ist. Do While ActDir < VIMAGE_FILL_DIR_LIMIT ' ZWEITENS: Solange ackern, bis alle Richtungen abgearbeitet sind ... ' Grenzwert 5 oder 6 führt zu Fehlern! 7 und 8 geht auch ... sicherheitshalber 9. Do While SUBPltFill_IsFilled(LM1, n1, Cursor, fbv0, zf, TimeOutCounter) = False ' Timeout (von SUBPltFill_IsFilled inkrementiert) testen If TimeOutCounter > VIMAGE_FILL_TIMEOUT Then GoTo LabPltFillTimeOut ' DRITTENS Solange ackern wie es noch leere Punkte gibt ... Call SUBPltPhysFastPixel(LM1, Cursor, zf) 'For Band = 1 To UBound(LM1, 3) ' !!! Direkt ohne Driver füllen ' LM1(Cursor(1), Cursor(2), Band) = zf(Band) ' !!! Direkt ohne Driver füllen 'Next Band ' !!! Direkt ohne Driver füllen FillCounter = FillCounter + 1 KoordList(1, ListIndex) = Cursor(1) ' Punkt in Stack eintragen KoordList(2, ListIndex) = Cursor(2) DirList(ListIndex) = CByte(ActDir Mod 4) If ListIndex = VIMAGE_FILL_MAX_STACK_DEEPTH Then GoTo LabPltFillOverflow ListIndex = ListIndex + 1 Select Case ActDir Mod 4 Case 0: Cursor(1) = Cursor(1) + 1 ' Nach O weiterstellen Case 1: Cursor(2) = Cursor(2) - 1 ' Nach S weiterstellen Case 2: Cursor(1) = Cursor(1) - 1 ' Nach W weiterstellen Case 3: Cursor(2) = Cursor(2) + 1 ' Nach N weiterstellen End Select Loop ' Jetzt ist er in der aktuellen Richtung an einen gereits gefüllten Punkt, an einen Randpunkt oder an den Bildrand gekommen Select Case ActDir Mod 4 Case 0: Cursor(1) = Cursor(1) - 1 ' Nach O zurückstellen Case 1: Cursor(2) = Cursor(2) + 1 ' Nach S zurückstellen Case 2: Cursor(1) = Cursor(1) + 1 ' Nach W zurückstellen Case 3: Cursor(2) = Cursor(2) - 1 ' Nach N zurückstellen End Select ActDir = ActDir + 1 ' Nächste Richtung Select Case ActDir Mod 4 Case 0: Cursor(1) = Cursor(1) + 1 ' Nach O weiterstellen Case 1: Cursor(2) = Cursor(2) - 1 ' Nach S weiterstellen Case 2: Cursor(1) = Cursor(1) - 1 ' Nach W weiterstellen Case 3: Cursor(2) = Cursor(2) + 1 ' Nach N weiterstellen End Select Rem Fortschrittskontrolle; alle 100000 Zyklen Textausgabe, alle 1 MIO im Test Bild 0 Anzeigen (was nicht zwingend Rem das Bild sein muss, in das geplottet wird, aber egal). If TimeOutCounter \ 100000 <> OldTimeoutCounter \ 100000 Then HF.Text2.Text = "Vektorplot: Flächenfüllung ... aktuelle Stacktiefe: " _ & Format(ListIndex, "###,###,###,##0") & "/" _ & Format(VIMAGE_FILL_MAX_STACK_DEEPTH, "###,###,###,##0") & _ ". Punkt/Zyklus/Timeout: " & Format(FillCounter, "###,###,###,##0") & _ "/" & Format(TimeOutCounter, "###,###,###,##0") & _ "/" & Format(VIMAGE_FILL_TIMEOUT, "###,###,###,##0") & _ " " HF.Text2.Refresh DoEvents If fixAbortFlag = True Then GoTo LabPltFillAborted If TimeOutCounter \ 1000000 <> OldTimeoutCounter \ 1000000 Then ' Nur für Test: Visualisieren If VIMAGETest = True Then Call PICShow(0) End If End If End If OldTimeoutCounter = TimeOutCounter Loop ' Jetzt hat er alle Richtungen probiert ListIndex = ListIndex - 1 Cursor(1) = KoordList(1, ListIndex) Cursor(2) = KoordList(2, ListIndex) ActDir = DirList(ListIndex) Loop ' Jetzt ist der Stack leer. Rem Fertig HF.Text2.Text = "Vektorplot: Fläche füllen fertig." HF.Text2.Refresh ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub Rem Rem Fehlerbehandlungen Rem ------------------ LabPltImageToLarge: HF.Text2.Text = "Vektorplot: Bild zu groß. Flächenfüllen geht nur für Bilder bis 32750*32750" HF.Text2.Refresh fixErrCode = 48 ' "Short-Integer-Parameterfehler" ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub LabPltIsAlreadyFilled: HF.Text2.Text = "Vektorplot: Anfangspunkt der zu füllenden Fläche ist bereits Randpunkt oder ausserhalb Bild." HF.Text2.Refresh fixErrCode = 97 ' "Parameterfehler" ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub LabPltFillOverflow: HF.Text2.Text = "Vektorplot: Stacküberlauf beim Fläche füllen -- Stackpointer>" & VIMAGE_FILL_MAX_STACK_DEEPTH & ". Abhilfe: Fläche in kleinere Teilflächen gliedern." HF.Text2.Refresh fixErrCode = 50 ' "Zu wenig interner Speicher" ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub LabPltFillAborted: HF.Text2.Text = "Vektorplot: Flächenfüll-Abbruch durch Bedienereingriff." HF.Text2.Refresh fixErrCode = 90 ' "Abbruch durch Interrupt" fixAbortFlag = False ' Gleich wieder löschen, sonst Endlosschleife ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub LabPltFillTimeOut: HF.Text2.Text = "Vektorplot: Flächenfüll-Abbruch infolge TimeOut." HF.Text2.Refresh fixErrCode = 89 ' "TimeOut" ReDim KoordList(1 To 1) ReDim DirList(1 To 1) Exit Sub End Sub Rem Rem LOKALES UNTERPROGRAMM SUBPltFill_IsFilled Rem ----------------------------------------- Private Function SUBPltFill_IsFilled(LM1() As Single, n1 As Long, Cursor() As Integer, Z0() As Single, Z1() As Single, Timeout As Long) As Boolean Rem Rem Die Function gibt FALSE zurück, wenn der Grauwertvektor im Cursorpunkt LM1(Cursor(1), Cursor(2)) Rem ungleich dem Randgrauwertvektor z0 oder dem Füllgrauwertvektor z1() ist, sonst TRUE. Rem Rem Zusätzlich inkrementiert die Funktion einen Timeoutzähler Timeout. Rem Dies hilft, unschönes Hängenbleiben zu vermeiden. Rem Dim v As Byte Dim w As Byte Dim IdFlag1 As Boolean Dim IdFlag2 As Boolean ' Timeout inkrementieren Timeout = Timeout + 1 ' Wenn Ausserhalb Bild immer gefüllt ... SUBPltFill_IsFilled = True If Cursor(1) < 1 Then Exit Function ' Am W-Rand immer gefüllt If Cursor(1) > RMHD(n1).ImgXXXX Then Exit Function ' Am O-Rand immer gefüllt If Cursor(2) < 1 Then Exit Function ' Am S-Rand immer gefüllt If Cursor(2) > RMHD(n1).ImgYYYY Then Exit Function ' Am N-Rand immer gefüllt ' Grauwert ist Randgrauwert ?? IdFlag1 = True For w = 1 To UBound(LM1, 3) If LM1(Cursor(1), Cursor(2), w) <> Z0(w) Then IdFlag1 = False Next w ' Grauwert ist Füllgrauwert ?? IdFlag2 = True For w = 1 To UBound(LM1, 3) If LM1(Cursor(1), Cursor(2), w) <> Z1(w) Then IdFlag2 = False Next w ' Wenn Punkt entweder Rand- oder aber Füllfarbe hat, so ist er gefüllt ... SUBPltFill_IsFilled = False If IdFlag1 = True Or IdFlag2 = True Then SUBPltFill_IsFilled = True End Function Rem Rem BEFEHL SIGN: ZEICHEN MALEN Rem ========================== Public Sub SUBPltPixelSign(LM1() As Single, n1 As Long, p() As Double, Code As Long) Rem Rem SUBPltSig plottet ein einfaches Pixelsymbol Code code auf (p(1),p(2)). Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Geschrieben wird mit dem globalen Grauwert PLTTextValue. Rem Rem Es wird mit dem Pixel gemalt. Rem Dim i As Long Dim j As Long Dim wx As Double Dim wy As Double Dim i1 As Long Dim j1 As Long Dim SI As Long Dim sj As Long Dim PP(1 To 2) As Double Dim actstring As String Dim actchar As String If PLGIsInitialized = False Then Call SUBPltInit Select Case PLTCoordMode Case 0: ' Bildkoordinaten i1 = CLng(p(1)): j1 = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), wx, wy) i1 = CLng(wx) j1 = CLng(wy) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), p(1), p(2), wx, wy) i1 = CLng(wx) j1 = CLng(wy) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), wx, wy) i1 = CLng(wx) j1 = CLng(wy) End Select If Code < 0 Then Code = 0 If Code > 255 Then Code = 255 For j = -5 To 5 actstring = PLGFont(Code, 10 - (j + 5)) actstring = Left(actstring & " ", 11) For i = -5 To 5 actchar = Mid(actstring, i + 5 + 1, 1) If actchar = "#" Then PP(1) = i1 + i PP(2) = j1 + j If PP(1) >= -15 And PP(2) >= -15 And PP(1) <= RMHD(n1).ImgXXXX + 16 And PP(2) <= RMHD(n1).ImgYYYY Then Call SUBPltPhysPixel(LM1, PP, PLTTextValue) End If End If Next i Next j PLGPlotCounter = PLGPlotCounter + 1 End Sub Rem Rem BEFEHL TEXT: TEXT SCHREIBEN Rem =========================== Public Sub SUBPltPixelText(LM1() As Single, n1 As Long, p() As Double, ByVal Text As String) Rem Rem SUBPltPixelText plottet einen einfachen Pixeltext text auf (p(1),p(2)). Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Geschrieben wird mit dem globalen Grauwert PLTTextValue, Rem in der globalen Schriftgrösse PLTTextSize (1 bis 10), Rem mit dem globalen Schriftmodus PLTTextMode (0=normal, 1=fett) Rem und mit der globalen Schriftversetzung PLTTextShift(1), PLTTextShift(2). Rem Rem Normalschrift wird mit dem Pixel, Fettschrift mit dem FatPixel gemalt. Rem Fettung und Schriftgrösse sind also nicht voneinander abhängig. Größere Schriften Rem fette man »zu Fuß« per PLTTextMode. Rem Dim i As Long Dim j As Long Dim ppi As Long Dim ppj As Long ' Aktueller Zeichenmittelpunkt Dim PP(1 To 2) As Double ' Aktueller Zeichenpunkt Dim wx As Double ' Work-Coord Dim wy As Double Dim tx As Double ' Für Vergrößerung Dim ty As Double Dim StartX As Long Dim StartY As Long Dim zeichenposition As Long ' Für Tabulator Dim g As Long ' Zeichenzähler Dim z As String ' Aktuelles Einzelzeichen Dim Code As Long ' ASCII-Code des aktuellen Zeichens Dim actstring As String ' Aktueller String aus Fontfeld Dim actchar ' Aktuelles Char aus Fontfeld Dim SI As Long Dim sj As Long ' Aktuelles Schreibpixel If PLGIsInitialized = False Then Call SUBPltInit End If If Len(Text) = 0 Then Exit Sub Text = VPAPreText(Text) If PLTTextSize = 0 Then PLTTextSize = 1 ' irgendeiner hackt hier manchmal rein StartX = p(1) StartY = p(2) Select Case PLTCoordMode Case 0: ' Bildkoordinaten ppi = CLng(p(1)): ppj = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), wx, wy) ppi = CLng(wx) ppj = CLng(wy) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), p(1), p(2), wx, wy) ppi = CLng(wx) ppj = CLng(wy) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), wx, wy) ppi = CLng(wx) ppj = CLng(wy) End Select ppi = ppi + PLTTextShift(1) '- 10 * PLTTextSize ' Empirische Korrektur, unten hab ich nochn Denkfehler ... ppj = ppj + PLTTextShift(2) StartX = ppi StartY = ppj For g = 1 To Len(Text) z = (Mid(Text, g, 1)) For Code = 1 To 255 ' Klar müsste das auch mit asc gehen, aber asc geht nicht ... If z = Chr(Code) Then Exit For Next Code Select Case Code Case Asc(" ") ' Leerzeichen ppi = ppi + 10 * PLTTextSize Case Asc(vbCr) ' Wagenrücklauf und Zeilenvorschub=Zeilenumbruch ppi = StartX ppj = ppj - 10 * PLTTextSize Case Asc(vbLf) ' Gar nix Case Asc(vbTab) ' Tabulator zeichenposition = (ppi - StartX) / (10 * PLTTextSize) zeichenposition = ((zeichenposition + 8) \ 8) * 8 ppi = StartX + zeichenposition * (10 * PLTTextSize) Case Else For j = -5 * PLTTextSize To 5 * PLTTextSize ty = (CDbl(j) / PLTTextSize) + 5 actstring = PLGFont(Code, 10 - (CInt(ty + 0.000001))) actstring = Left(actstring & " ", 11) For i = -5 * PLTTextSize To 5 * PLTTextSize tx = (CDbl(i) / PLTTextSize) + 5 + 1 actchar = Mid(actstring, CInt(tx + 0.0000001), 1) If actchar = "#" Then PP(1) = ppi + i PP(2) = ppj + j If PP(1) >= -15 And PP(2) >= -15 And PP(1) <= RMHD(n1).ImgXXXX + 16 And PP(2) <= RMHD(n1).ImgYYYY Then If PLTTextMode = 0 Then Call SUBPltPhysPixel(LM1, PP, PLTTextValue) Else Call SUBPltPhysFatPixel(LM1, PP, PLTTextValue) End If End If End If Next i Next j ppi = ppi + 10 * PLTTextSize End Select Next g PLGPlotCounter = PLGPlotCounter + 1 End Sub Rem Rem BEFEHL BRUSH: PUNKT MIT PINSEL MALEN Rem ==================================== Public Sub SUBPltBrush(LM1() As Single, n1 As Long, p() As Double, z() As Single) Rem Rem SUBPltPoint plottet eine Punkt (p(1),p(2)) mit Grauwert z. Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer. Rem Rem Brush entspricht Point, malt aber nicht mit der Pen-Zeichenspitze, sondern mit der Rem Brush-Zeichenspitze. Hierbei werden die Brushparameter BRUSHMODE, BRUSHSIZE, Rem BRUSHSTRENGTH und BRUSHOPACITY berücksichtigt. Rem Rem SUBPltBrush dient weniger dem konstruierenden Zeichnen, Rem als dem interaktiven retuschieren. Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim s(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double If PLGIsInitialized = False Then Call SUBPltInit If PLTBrushSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten s(1) = CLng(p(1)): s(2) = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Geo(RMHD(n1), p(1), p(2), wx, wy) Call FIXCoordGeo2Img(RMHD(n1), wx, wy, s(1), s(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) End Select ' Prüfung, ob Parameter im Fenster erfolgt in Phys. Call SUBPltPhysBrush(LM1, s, z) End Sub Rem Rem BEFEHL COPYBRUSH: PUNKT MIT KOPIERPINSEL MALEN Rem ============================================== Public Sub SUBPltCopyBrush(LM1() As Single, n1 As Long, P1() As Double, P0() As Double) Rem Rem SUBPltCopyBrush plottet einen Punkt (p1(1),p1(2)) mit dem Grauwert, der von Rem (p0(1),p0(2)) gelesen wird. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer. Rem Rem Copybrush arbeitet wie Brush mit der Brush-Zeichenspitze. Hierbei werden Rem im gegensatz zur Pen-Zeichenspitze die Brushparameter BRUSHMODE, BRUSHSIZE, Rem BRUSHSTRENGTH und BRUSHOPACITY berücksichtigt. Rem Rem SUBCopyBrush dient, wie alle Brushs weniger dem konstruierenden Zeichnen, Rem als dem interaktiven retuschieren. Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim lc(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double If PLGIsInitialized = False Then Call SUBPltInit If PLTBrushSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(P1(1)): sc(2) = CLng(P1(2)) lc(1) = CLng(P0(1)): lc(2) = CLng(P0(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordGeo2Img(RMHD(n1), P0(1), P0(2), lc(1), lc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordMap2Img(RMHD(n1), P0(1), P0(2), lc(1), lc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordGeo2Img(RMHD(n1), P0(1), P0(2), lc(1), lc(2)) End Select ' Prüfung, ob Koord im Bild erfolgt in Phys Call SUBPltPhysCopyBrush(LM1, sc, lc) End Sub Rem Rem BEFEHL COPYBRUSH: PUNKT MIT BILDKOPIERPINSEL MALEN Rem ================================================== Public Sub SUBPltImageCopyBrush(lm0() As Single, n0 As Long, LM1() As Single, n1 As Long, P0() As Double, P1() As Double) Rem Rem SUBPltCopyBrush überträgt einen Punkt (p1(1),p1(2)) aus einem Bild LM1, n1, auf einen anderen Rem Punkt (p0(1),p0(2)) eines anderen Bildes. Rem Rem Es ist also ein CopyBrush zwischen zwei Bildspeichern. Rem Rem LM0() ist ein Single-Feld mit dem Bild, n0 die Bildspeichernummer, ebenso LM0() und n0. Rem Rem Wie alle Brushs arbeitet auch der ImageCopyBrush mit der Brush-Zeichenspitze. Hierbei werden Rem im Gegensatz zur Pen-Zeichenspitze die Brushparameter BRUSHMODE, BRUSHSIZE, Rem BRUSHSTRENGTH und BRUSHOPACITY berücksichtigt. Rem Rem ACHTUNG: Der SUBCopyImageBrush ist nicht per Plotbefehl über VPA ansprechbar. Rem Rem 14.07.2006 Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim lc(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double If PLGIsInitialized = False Then Call SUBPltInit If PLTBrushSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(P1(1)): sc(2) = CLng(P1(2)) lc(1) = CLng(P0(1)): lc(2) = CLng(P0(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordGeo2Img(RMHD(n0), P0(1), P0(2), lc(1), lc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordMap2Img(RMHD(n0), P0(1), P0(2), lc(1), lc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), P1(1), P1(2), sc(1), sc(2)) Call FIXCoordGeo2Img(RMHD(n0), P0(1), P0(2), lc(1), lc(2)) End Select ' Prüfung, ob Koord im Bild erfolgt in Phys Call SUBPltPhysImageCopyBrush(lm0, LM1, lc, sc) End Sub Rem Rem BEFEHL FILTERBRUSH: PUNKT FILTERN Rem ================================= Public Sub SUBPltFilterBrush(LM1() As Single, n1 As Long, p() As Double) Rem Rem SUBPltFilterBrush plottet einen Punkt (p1(1),p1(2)) mit dem Grauwert, der aus Rem einer 5*5-Umgebung des Punktes (gewichtet mit 5*5-Gaußfilter) gelesen wird. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer. Rem Rem Filterbrush arbeitet nicht mit der Pen-, sondern mit der Brush-Zeichenspitze. Rem Hierbei die Brushparameter BRUSHMODE, BRUSHSIZE, BRUSHSTRENGTH und BRUSHOPACITY Rem berücksichtigt. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBFilterBrush dient, wie alle Brushs weniger dem konstruierenden Zeichnen, Rem als dem interaktiven retuschieren. Rem Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim s(1 To 2) As Double ' Schreib-Bildkoord Dim wx As Double Dim wy As Double Dim Matrix(1 To 1, 1 To 1) As Single Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub Select Case PLTCoordMode Case 0: ' Bildkoordinaten s(1) = CLng(p(1)): s(2) = CLng(p(2)) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Geo(RMHD(n1), p(1), p(2), wx, wy) Call FIXCoordGeo2Img(RMHD(n1), wx, wy, s(1), s(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), p(1), p(2), s(1), s(2)) End Select Rem Matrix erzeugen Matrix(1, 1) = 1 ' wird z. Zt. noch ignoriert, der Driver macht immer Gauß 5*5 Rem Driverruf If s(1) >= -15 And s(1) < RMHD(0).ImgXXXX + 16 And _ s(2) >= -15 And s(2) < RMHD(0).ImgYYYY + 16 Then Call SUBPltPhysFilterBrush(LM1, s) End If End Sub Rem Rem BEFEHL SIGNATURE -- PUNKTSIGNATUR EINSETZEN (ALTE DISSAMPENDE VARIANTE) Rem ======================================================================= Public Sub SUBPltPointSign(LM1() As Single, n1 As Long, LM2() As Single, n2 As Long, p() As Double) Rem Rem VERALTET. MAN NUTZE NUN DAS BESSERE SUBPltPointSignResample! Rem Rem URSPRUNGSCODE IN SUBAriFreistellenPro !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Rem Rem DAHER ÄNDERUNGEN IMMER PRIMÄR DORT AUSFÜHREN. Rem Rem WICHTIGSTER UNTERSCHIED: ER SCANNT NICHT DAS ZIELBILD SONDERN DAS SIGNATURBILD. Rem Rem PltPointSign zeichnte eine Vordergrundsignatur aus Bild LM2() auf Position p() Rem in ein Hintergrundbild LM1() Rem Rem Dabei wird ein Freistellungssaum erzeugt. Dieser hat die Breite SIGSkirts (0 bis 20), die Rem Schärfe SIGFilterPercent (25++ bis 100) und den Grauwertabstand (Vordergrund über Hintergrund) Rem SIGDeltaPercent (0 bis 100). Rem Rem Exemplarische Anwendung: Signaturenplatte mit schwarze, roten, grünen Signaturen. Rem Rem ++ Der Freistellungssaum ist unscharf, SIGSkirts ist eine mittlere Breite. Dies ist auch der Grund, warum Rem SIGFilterPercent nicht unter 25 liegen sollten: Ein z. B. nur 10%iger Saum mit einer mittleren Breite von Rem 10 Pixeln müsste vielleicht 50 Pixel breit sein -- das würde sehr ungünstig. Rem Dim k As Long Dim l As Long Dim m As Long Dim n As Long Dim i As Long Dim j As Long Dim r As Double Dim s As Double Dim FilterPercent As Long Dim DeltaPercent As Long Dim Skirts As Long Dim coord(0 To 2) As Double Dim ziel(0 To MAX_NUMBER_OF_CHANNELS) As Single Dim IsToWrite As Boolean ' Grauwerte aller Art Dim pseudovordergrund As Single ' verbreiterter, sw generalisierter FG Dim pseudohintergrund As Single ' sw generaliserter BG Dim protosignatur As Single ' masliert den FG Dim istdelta As Single ' Differenz Pseudo-BG -- PseudoFG Dim solldelta As Single ' Gegebener Mindestabstand FG über BG Dim rohabsenkung As Single ' Soviel muss abgesenkt werden, damit def FG solldelta über den Bg kommt Dim absenkung As Single Dim absenkfaktor As Single Dim maske As Single ' Freistellungsmaske Dim Alpha As Single ' Alphakanal. Ohne den werden Anti-Aliasingpixel im FG zu weißem Staub Dim vollvordergrund As Single ' FG, das, was nicht im Alphakanal steht Dim hintergrund As Single Dim hintergrundabgesenkt As Single Dim vordergrund As Single Dim ch As Long Dim maxch As Long Dim ismulti As Boolean Dim o As Long Dim w As Long k = LBound(LM2, 1) l = LBound(LM2, 2) m = UBound(LM2, 1) n = UBound(LM2, 2) o = UBound(LM2, 3) Dim FilterGröße As Long Dim tmppercent As Single Dim tmpFlag As Boolean Rem PARAMETER PRÄPROZESSIEREN FilterPercent = SIGFilterPercent DeltaPercent = SIGDeltaPercent Skirts = SIGSkirts If Skirts > 20 Then Skirts = 20 Call VIMAGEClip(FilterPercent, 0, 100) Call VIMAGEClip(DeltaPercent, 0, 100) solldelta = CSng(DeltaPercent / 100) * 255 ' Delta Soll Rem VORAB: IN DIE SKIRTsTabs EINTRAGEN, WIE DIE KASKADEN PARAMETRIERT WERDEN Dim skirtsATab(1 To 20) As Long ' Skirtsanteil auf H-V-Kaskade Dim skirtsBTab(1 To 20) As Long ' Skirtsanteil auf Diagonalkaskaden skirtsATab(1) = 3: skirtsBTab(1) = 1 ' 3*3-Kasten macht 1 skirtsATab(2) = 5: skirtsBTab(2) = 1 ' 5*5-Kasten macht 2 skirtsATab(3) = 3: skirtsBTab(3) = 3 ' 3*3-Kasten macht 1 plus 3*3-Diagonale à 2 1+2=3 skirtsATab(4) = 5: skirtsBTab(4) = 3 ' 5*5-Kasten macht 2 plus 3*3-Diagonale à 2 skirtsATab(5) = 7: skirtsBTab(5) = 3 ' 7*7-Kasten macht 3 plus 3*3-Diagonale à 2 skirtsATab(6) = 5: skirtsBTab(6) = 5 ' 5*5-Kasten macht 2 plus 5*5-Diagonale à 4 skirtsATab(7) = 7: skirtsBTab(7) = 5 ' 7*7-Kasten macht 3 plus 5*5-Diagonale à 4 skirtsATab(8) = 9: skirtsBTab(8) = 5 ' 9*9-Kasten macht 4 plus 5*5-Diagonale à 4 skirtsATab(9) = 7: skirtsBTab(9) = 7 ' 7*7-Kasten macht 3 plus 7*7-Diagonale à 6 skirtsATab(10) = 9: skirtsBTab(10) = 7 ' 9*9-Kasten macht 4 plus 7*7-Diagonale à 6 skirtsATab(11) = 11: skirtsBTab(11) = 7 ' 11er-Kasten macht 5 plus 7*7-Diagonale à 6 skirtsATab(12) = 9: skirtsBTab(12) = 9 ' 9er-Kasten macht 4 plus 9*9-Diagonale à 8 skirtsATab(13) = 11: skirtsBTab(13) = 9 ' 11er-Kasten macht 5 plus 9*9-Diagonale à 8 skirtsATab(14) = 13: skirtsBTab(14) = 9 ' 13er-Kasten macht 6 plus 9*9-Diagonale à 8 skirtsATab(15) = 11: skirtsBTab(15) = 11 ' 11er-Kasten macht 5 plus 11erDiagonale à 10 skirtsATab(16) = 13: skirtsBTab(16) = 11 ' 13er-Kasten macht 6 plus 11erDiagonale à 10 skirtsATab(17) = 15: skirtsBTab(17) = 11 skirtsATab(18) = 13: skirtsBTab(18) = 13 skirtsATab(19) = 15: skirtsBTab(19) = 13 skirtsATab(20) = 17: skirtsBTab(20) = 13 Rem VORAB: FILTERMATRIX FÜLLEN For i = 1 To 33 For j = 1 To 33 FI(i, j) = 1 Next j Next i Rem ZIELBILD INITIALISIEREN Rem ... entfällt bei der Plotlibvariante Rem ******************** BEGINN HINTERGRUNDPROZESS Rem DER HINTERGRUNDPROZESS ERZEUGT DEN PSEUDOHINTERGRUND IN RM30: Rem ER WIRD NUR DURCHLAUFEN, WENN ANHAND BILDNAMEN UND -ABMESSUNGEN Rem PLAUSIBEL IST, DASS DER PSEUDOHINTERGRUND NICHT BEREITS VORHER ERZEUGT WURDE. Rem HIER DER PLAUSIBILITÄTSTEST: If SIGBgrFileName <> RMFn(n1) Or _ RMFn(30) <> RMFn(n1) Or _ LBound(RM30, 1) > LBound(LM1, 1) Or UBound(RM30, 1) < UBound(LM1, 1) Or _ LBound(RM30, 2) > LBound(LM1, 2) Or UBound(RM30, 2) < UBound(LM1, 2) Then Rem 1. HINTERGRUND MONOCHROMATISEREN -->:: "PSEUDOHINTERGRUND" RM30 Rem Protohintergrund: svw. ein monochromatischer Hintergrund HF.Text1.Text = "BGR PASS" Call SUBRestAussenrand(LM1, n1, 1, 0, 16) ' Außenrandergänzung If fixErrCode = 90 Then GoTo abortend23 Call SUBChrMax2MONO(LM1, n1, RM30, 30) If fixErrCode = 90 Then GoTo abortend23 RMFn(30) = "" RMFn(30) = RMFn(n1) SIGBgrFileName = RMFn(n1) End If Rem ******************** BEGINN VORDERGRUNDPROZESS Rem DER VORDERGRUNDPROZESS ERZEUGT ALPHA IN RM20:, VOLLFARBE IN RM26: Rem PROTOSIGNATUR IN RM29:, PSEUDOVORDERGRUND IN RM 28: UND MASKE IN RM27: Rem ER WIRD NUR DURCHLAUFEN, WENN ANHAND BILDNAMEN UND -ABMESSUNGEN Rem PLAUSIBEL IST, DASS DIESE BILDER NICHT BEREITS VORHER ERZEUGT WURDEN. Rem HIER DER PLAUSIBILITÄTSTEST: If SIGFgrFileName <> RMFn(n2) Or _ RMFn(20) <> RMFn(n2) Or _ LBound(RM20, 1) > LBound(LM2, 1) Or UBound(RM20, 1) < UBound(LM2, 1) Or _ LBound(RM20, 2) > LBound(LM2, 2) Or UBound(RM20, 2) < UBound(LM2, 2) Or _ RMFn(26) <> RMFn(n2) Or _ LBound(RM26, 1) > LBound(LM2, 1) Or UBound(RM26, 1) < UBound(LM2, 1) Or _ LBound(RM26, 2) > LBound(LM2, 2) Or UBound(RM26, 2) < UBound(LM2, 2) Or _ RMFn(27) <> RMFn(n2) Or _ LBound(RM27, 1) > LBound(LM2, 1) Or UBound(RM27, 1) < UBound(LM2, 1) Or _ LBound(RM27, 2) > LBound(LM2, 2) Or UBound(RM27, 2) < UBound(LM2, 2) Or _ RMFn(28) <> RMFn(n2) Or _ LBound(RM28, 1) > LBound(LM2, 1) Or UBound(RM28, 1) < UBound(LM2, 1) Or _ LBound(RM28, 2) > LBound(LM2, 2) Or UBound(RM28, 2) < UBound(LM2, 2) Or _ RMFn(29) <> RMFn(n2) Or _ LBound(RM29, 1) > LBound(LM2, 1) Or UBound(RM29, 1) < UBound(LM2, 1) Or _ LBound(RM29, 2) > LBound(LM2, 2) Or UBound(RM29, 2) < UBound(LM2, 2) Then Rem 2. ALPHA-SEPARATION (RM20: (ALPHABILD), RM26: (VOLLFARBBILD)) Rem Spaltet den Vordergrund in einen Vollfarbvordergrund auf und in einen Rem immer fest in RM20 stehenden Alphakanal auf. Rem Muss vorab erfolgen, denn die Alphaseparartion braucht die Bilder RM29:, RM30:, RM31: Rem Merke: Vollfarbe x Alpha = Vordergrund HF.Text1.Text = "ALPHA PASS" Call SUBAriAlphaSeparation(LM2, n2, RM26, 26) ' Call DIPCopy(LM2, N2, RM26, 26) If fixErrCode = 90 Then GoTo abortend23 RMFn(20) = RMFn(n2) RMFn(26) = RMFn(n2) Rem 3. VORDERGRUND MONOCHROMATISEREN -->:: "PROTOSIGNATUR" (RM29:) HF.Text1.Text = "MONO PASS" Call SUBRestAussenrand(LM2, n2, 1, 0, 16) ' Außenrandergänzung If fixErrCode = 90 Then GoTo abortend23 Call SUBChrMax2MONO(LM2, n2, RM29, 29) If fixErrCode = 90 Then GoTo abortend23 RMFn(29) = RMFn(n2) Rem 4. VORDERGRUND EINFACH VERBREITERN -->:: "ZWISCHENBILD" -- EINSTWEILEN RM28: HF.Text1.Text = "1ST FILTER BLOCK" If Skirts > 20 Then Skirts = 20 If Skirts > 0 Then Call SUBFilRangordnung(RM29, 29, RM31, 31, skirtsATab(Skirts), "Maximum Horizontal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsATab(Skirts), "Maximum Vertical") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsBTab(Skirts), "Maximum Diagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsBTab(Skirts), "Maximum Antidiagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 End If If Skirts = 0 Then Call DIPCopy(RM29, 29, RM28, 28) End If RMFn(28) = "" Rem 7. PROTOSIGNATUR ETWAS VERDÜNNEN DAMIT DER ALIASINGBEREICH HINTERGRUNDEINMISCHBAR WIRD HF.Text1.Text = "2ND FILTER BLOCK" ' Dies nur hier und nicht in SUBARIFreistellenPro auskommentiert. !!!!!!!! ' Call SUBFilRangordnung(RM29, 29, RM31, 31, 3, "Minimum Horizontal") ' Call SUBFilRangordnung(RM31, 31, RM29, 29, 3, "Minimum Vertical") Rem 8. ZWISCHENBILD BINÄRISIEREN UND TIEFPASSFILTERN -->:: "FREISTELLUNGSMASKE" -- RM27: HF.Text1.Text = "MASK PASS" Call SUBRadBinarysize(RM28, 28, RM27, 27, 0.5, 1) RMHD(27).RadWLev = 0 RMHD(27).RadBLev = 1 FilterGröße = 2 * Skirts * ((100 - FilterPercent) / 100) FilterGröße = FilterGröße \ 2 FilterGröße = FilterGröße * 2 + 1 ' immer ungerade If FilterGröße > 33 Then FilterGröße = 33 ' Bei skirts 20 und 100 Filterpercent wirds bissl runtergesetzt. If FilterGröße >= 3 Then Call DIPFirFilter(RM27, 27, RM31, 31, FI(), 1, FilterGröße, CSng(1 / FilterGröße), 0) If fixErrCode = 90 Then GoTo abortend23 Call DIPFirFilter(RM31, 31, RM27, 27, FI(), FilterGröße, 1, CSng(1 / FilterGröße), 0) If fixErrCode = 90 Then GoTo abortend23 End If RMFn(27) = RMFn(n2) Rem 9. ZWISCHENBILD EIN ZWEITES MAL VERBREITERN -->:: "PSEUDOVORDERGRUND" -- RM28: HF.Text1.Text = "3RD FILTER BLOCK" If Skirts > 0 Then Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsATab(Skirts), "Maximum Horizontal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsATab(Skirts), "Maximum Vertical") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsBTab(Skirts), "Maximum Diagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsBTab(Skirts), "Maximum Antidiagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 End If RMFn(28) = RMFn(n2) Rem 10. PROTOSIGNATUR ETWAS VERDÜNNEN DAMIT DER ALIASINGBEREICH HINTERGRUNDEINMISCHBAR WIRD HF.Text1.Text = "4TH FILTER BLOCK" Call SUBFilRangordnung(RM29, 29, RM31, 31, 3, "Minimum Horizontal") Call SUBFilRangordnung(RM31, 31, RM29, 29, 3, "Minimum Vertical") SIGFgrFileName = RMFn(n2) End If Rem ******************** ENDE VORDERGRUNDPROZESS Rem JETZT STEHEN IN Rem RM20: (FG) DER ALPHAKANAL Rem RM26: (FG) DER VORDERGRUND ALS VOLLFARBVORDERGRUND NACH DER ALPHASEPARATION Rem RM27: (FG) DIE FREISTELLUNGSMASKE -- verbreitert, unscharf, wenn Zeichnung, dann 255 Rem RM28: (FG) DER PSEUDOVORDERGRUND -- doppelt verbreitert, mit dem Durchschnittsgrauwert des Vordergrundes Rem RM29: (FG) DIE PROTOSIGNATUR -- die entscheidet, was Vordergrund ist Rem RM30: (BG) DER PSEUDOHINTERGRUND -- mit dem Durchschnittsgrauwert des Hintergrundes Rem BG=Backgroundgeometrie ... LM1 = LM1, LM3, RM30: Rem FG=Foregroundgeometrie ... LM2 = LM2, RM20:, RM26:, RM27:, RM28:, RM29: If VIMAGETest = False Then Call DIPFree(RM31, 31) Rem 11. HAUPTPROZESS -- GROSSE SCHLEIFE Rem ******************** BEGINN HAUOPTPROZESS HF.Text1.Text = "OP PASS" HF.ProgressBar1.max = n / 20 For j = l To n For i = k To m Call FIXCoordImg2Geo(RMHD(n2), CDbl(i), CDbl(j), g, h) ' von Hintergrundgeometrie in g = g + p(1) h = h + p(2) Call FIXCoordGeo2Img(RMHD(n1), g, h, r, s) ' ... Vordergrundgeometrie If i >= LBound(LM1, 1) And i <= UBound(LM1, 1) And _ j >= LBound(LM1, 2) And j <= UBound(LM1, 2) Then ' Pixelschleife nur wenn in Hintergundgeometrie ' QUELLPIXEL HOLEN (nur wenn sie existieren) ' ... aus der Hintergrundgeometrie If r >= LBound(RM30, 1) And r <= UBound(RM30, 1) And _ s >= LBound(RM30, 2) And s <= UBound(RM30, 2) Then pseudohintergrund = RM30(r, s, 1) Else pseudohintergrund = 0 End If ' ... aus der Vordergrundgeometrie vordergrund = LM2(i, j, 1) Alpha = RM20(i, j, 1) maske = RM27(i, j, 1) pseudovordergrund = RM28(i, j, 1) protosignatur = RM29(i, j, 1) Rem STÄRKE DER BENÖTIGTEN HINTERGRUNDABSENKUNG BERECHNEN istdelta = pseudovordergrund - pseudohintergrund absenkung = solldelta - istdelta If absenkung < 0 Then absenkung = 0 ' absenkung ist die Absenkung im Grauwerten If pseudohintergrund > 0.1 Then ' absenkfaktor ist eine Zahl 0 (keine Freistellung) ... 1 (volle Freistellung) absenkfaktor = absenkung / pseudohintergrund ' auf Wertebereich 0 ... 1 bringen Else absenkfaktor = 0 ' (bei weißem Hintergrund kann man ja gar nicht absenken] End If If absenkfaktor > 1 Then absenkfaktor = 1 Rem HINTERGRUNDABSENKUNG BEI HELLEM VORDERRUND VERRINGERN Rem Sonst sehen helle Vordergründe schnell aus "wie hearausgeschossen" Rem ... das gibts beim Punktsignaturenstempel nicht ... 'aufhellfaktor = pseudovordergrund / 255 'If aufhellfaktor > 1 Then aufhellfaktor = 1 'If aufhellfaktor < 0 Then aufhellfaktor = 0 'absenkfaktor = absenkfaktor * aufhellfaktor Rem FREISTELLUNGS-RECHNUNG IsToWrite = False For w = 1 To o If w <= UBound(RM26, 3) Then vollvordergrund = RM26(i, j, w) Else vollvordergrund = 0 End If If r >= LBound(LM1, 1) And r <= UBound(LM1, 1) And _ s >= LBound(LM1, 2) And s <= UBound(LM1, 2) And _ w >= LBound(LM1, 3) And w <= UBound(LM1, 3) Then If protosignatur > 0.5 Then ziel(w) = vollvordergrund * Alpha Else hintergrund = LM1(r, s, w) hintergrundabgesenkt = hintergrund * (1 - (absenkfaktor * maske)) ziel(w) = vollvordergrund * Alpha + hintergrundabgesenkt * (1 - Alpha) End If If ziel(w) < 0 Then ziel(w) = 0 If ziel(w) > 255 Then ziel(w) = 255 If ziel(w) <> LM1(r, s, w) Then IsToWrite = True End If Next w If IsToWrite = True Then coord(1) = r coord(2) = s Call SUBPltPhysPixel(LM1, coord(), ziel()) End If End If Next i If DIPAbort(j, "Punktsignaturstempel") = True Then If VIMAGETest = False Then ' ReDim RM26(1 To 1, 1 To 1, 1 To 1) ' ReDim RM27(1 To 1, 1 To 1, 1 To 1) ' ReDim RM28(1 To 1, 1 To 1, 1 To 1) ' ReDim RM29(1 To 1, 1 To 1, 1 To 1) ' ReDim RM30(1 To 1, 1 To 1, 1 To 1) ReDim RM31(1 To 1, 1 To 1, 1 To 1) ' RMIsInUse(26) = False ' RMIsInUse(27) = False ' RMIsInUse(28) = False ' RMIsInUse(29) = False ' RMIsInUse(30) = False RMIsInUse(31) = False End If Exit Sub End If Next j HF.ProgressBar1.max = 1 PLGPlotCounter = PLGPlotCounter + 1 Rem ******************** ENDE HAUPTPROZESS abortend23: If VIMAGETest = False Then 'ReDim RM26(1 To 1, 1 To 1, 1 To 1) 'ReDim RM27(1 To 1, 1 To 1, 1 To 1) 'ReDim RM28(1 To 1, 1 To 1, 1 To 1) 'ReDim RM29(1 To 1, 1 To 1, 1 To 1) 'ReDim RM30(1 To 1, 1 To 1, 1 To 1) ReDim RM31(1 To 1, 1 To 1, 1 To 1) 'RMIsInUse(26) = False 'RMIsInUse(27) = False 'RMIsInUse(28) = False 'RMIsInUse(29) = False 'RMIsInUse(30) = False RMIsInUse(31) = False End If End Sub Rem Rem BEFEHL SIGNATURE -- PUNKTSIGNATUR EINSETZEN Rem =========================================== Public Sub SUBPltPointSignResample(LM1() As Single, n1 As Long, LM2() As Single, n2 As Long, p() As Double) Rem Rem PltPointSignResample zeichnte eine Vordergrundsignatur aus Bild LM2() auf Position p() Rem in ein Hintergrundbild LM1() Rem Rem Dabei wird ein Freistellungssaum erzeugt. Dieser hat die Breite SIGSkirts (0 bis 20), die Rem Schärfe SIGFilterPercent (25++ bis 100) und den Grauwertabstand (Vordergrund über Hintergrund) Rem SIGDeltaPercent (0 bis 100). Weiterhin gestatter er eine Zeichenskalierung um SIGScalePercent zwischen 50 und 200 %. Rem Rem ++ Der Freistellungssaum ist unscharf, SIGSkirts ist eine mittlere Breite. Dies ist auch der Grund, warum Rem SIGFilterPercent nicht unter 25 liegen sollten: Ein z. B. nur 10%iger Saum mit einer mittleren Breite von Rem 10 Pixeln müsste vielleicht 50 Pixel breit sein -- das würde sehr ungünstig. Rem Rem PROGRAMMGESCHICHTE Rem Rem - FREISTELLUNGSCODE AUS SUBAriFreistellenPro. Rem Rem - NUN VERALTETE VORGÄNGERVERSION: SUBPltPointSign. Rem Rem Prinzipieller Unterschied zu SUBPltPointSign: Er scannt nicht das Zielbild, Rem sondern das Quellbild. Auf diese Art können Ziel- und Quellauflösungen Rem abweichend sein. Ausserdem ist so die Zeichenskalierung möglich. Rem Rem Koordinaten aller Art Dim k0 As Long ' Startadresse FG-Bild Img Dim l0 As Long Dim k8 As Long ' Endadresse FG-Bild Img Dim l8 As Long Dim kz As Long ' Mittelpunkt FG-Bild Img Dim lz As Long Dim i0 As Long ' Startadresse BG-Bild Img Dim j0 As Long Dim i8 As Long ' Endadresse BG-Bild Img Dim j8 As Long Dim ip As Long ' Mauskoordinate = Mittelpunkt BG-Bild Img Dim jp As Long Dim i0d As Long ' FG Img Distanz Mitte-Startadresse Dim j0d As Long Dim i8d As Long ' FG Img Distanz Mitte-Endadresse Dim j8d As Long Dim g0 As Double ' Startadresse Geo Dim h0 As Double Dim g8 As Double ' Endadresse Geo Dim h8 As Double Dim g0d As Double ' Geo Distanz Mitte-Startadresse Dim h0d As Double Dim g8d As Double ' Geo Distanz Mitte-Endadresse Dim h8d As Double Dim i As Long Dim j As Long Dim k As Long Dim l As Long Dim r As Double Dim s As Double Dim T As Double Dim u As Double Dim x As Double Dim y As Double Dim FilterPercent As Long Dim DeltaPercent As Long Dim Skirts As Long Dim ScaleFactor As Double Dim coord(0 To 2) As Double Dim ziel(0 To MAX_NUMBER_OF_CHANNELS) As Single Dim IsToWrite As Boolean Dim q As DoubleCoordinate ' Grauwerte aller Art Dim pseudovordergrund As Single ' verbreiterter, sw generalisierter FG Dim pseudohintergrund As Single ' sw generaliserter BG Dim protosignatur As Single ' masliert den FG Dim istdelta As Single ' Differenz Pseudo-BG -- PseudoFG Dim solldelta As Single ' Gegebener Mindestabstand FG über BG Dim rohabsenkung As Single ' Soviel muss abgesenkt werden, damit def FG solldelta über den Bg kommt Dim absenkung As Single Dim absenkfaktor As Single Dim maske As Single ' Freistellungsmaske Dim Alpha As Single ' Alphakanal. Ohne den werden Anti-Aliasingpixel im FG zu weißem Staub Dim vollvordergrund As Single ' FG, das, was nicht im Alphakanal steht Dim hintergrund As Single Dim hintergrundabgesenkt As Single Dim vordergrund As Single Dim ch As Long Dim maxch As Long Dim ismulti As Boolean Dim o As Long Dim w As Long o = UBound(LM1, 3) w = UBound(LM2, 3) If o <> w Then Call MsgBox("Warnung: Signatur und Hintergrundbild haben abweichende Bandzahlen (" & o & " und " & w & "). Das könnte nicht korrekt funktionieren.", , "Signaturen setzen: Warnung") End If Call FIXCoordGetPixelSize(RMHD(n1), r, s) Call FIXCoordGetPixelSize(RMHD(n2), T, u) If Abs(r / T) < 0.25 Or Abs(r / T) > 4 Or Abs(s / u) < 0.25 Or Abs(s / u) > 4 Then Call MsgBox("Pixelgrößenverhältnis Signatur/Hintergrundbild (x: " & r / T & "/y: " & s / u & ") < 0,25 oder > 4. Das ergibt keine gute Qualität, darum Abbruch.", , "Signaturen setzen: Warnung") End If Dim FilterGröße As Long Dim tmppercent As Single Dim tmpFlag As Boolean Dim n As Long Rem PARAMETER PRÄPROZESSIEREN FilterPercent = SIGFilterPercent DeltaPercent = SIGDeltaPercent Skirts = SIGSkirts If Skirts > 20 Then Skirts = 20 Call VIMAGEClip(FilterPercent, 0, 100) Call VIMAGEClip(DeltaPercent, 0, 100) solldelta = CSng(DeltaPercent / 100) * 255 ' Delta Soll ScaleFactor = CDbl(SIGScalePercent) / 100 Call VIMAGEClip(ScaleFactor, 0.5, 2#) ' Über vierfach vergrößern lässt die Qualität nach. Über vierfach verkleinern wirds gestalterisch kritisch. Rem VORAB: FILTERMATRIX Dim f5(1 To 5, 1 To 5) As Single If f5(1, 1) <> 1 Then f5(1, 1) = 1: f5(1, 2) = 4: f5(1, 3) = 6: f5(1, 4) = 4: f5(1, 5) = 1 f5(2, 1) = 4: f5(2, 2) = 16: f5(2, 3) = 24: f5(2, 4) = 16: f5(2, 5) = 4 f5(3, 1) = 6: f5(3, 2) = 24: f5(3, 3) = 36: f5(3, 4) = 24: f5(3, 5) = 6 f5(4, 1) = 4: f5(4, 2) = 16: f5(4, 3) = 24: f5(4, 4) = 16: f5(4, 5) = 4 f5(5, 1) = 1: f5(5, 2) = 4: f5(5, 3) = 6: f5(5, 4) = 4: f5(5, 5) = 1 End If Rem VORAB: IN DIE SKIRTsTabs EINTRAGEN, WIE DIE KASKADEN PARAMETRIERT WERDEN Dim skirtsATab(1 To 20) As Long ' Skirtsanteil auf H-V-Kaskade Dim skirtsBTab(1 To 20) As Long ' Skirtsanteil auf Diagonalkaskaden skirtsATab(1) = 3: skirtsBTab(1) = 1 ' 3*3-Kasten macht 1 skirtsATab(2) = 5: skirtsBTab(2) = 1 ' 5*5-Kasten macht 2 skirtsATab(3) = 3: skirtsBTab(3) = 3 ' 3*3-Kasten macht 1 plus 3*3-Diagonale à 2 1+2=3 skirtsATab(4) = 5: skirtsBTab(4) = 3 ' 5*5-Kasten macht 2 plus 3*3-Diagonale à 2 skirtsATab(5) = 7: skirtsBTab(5) = 3 ' 7*7-Kasten macht 3 plus 3*3-Diagonale à 2 skirtsATab(6) = 5: skirtsBTab(6) = 5 ' 5*5-Kasten macht 2 plus 5*5-Diagonale à 4 skirtsATab(7) = 7: skirtsBTab(7) = 5 ' 7*7-Kasten macht 3 plus 5*5-Diagonale à 4 skirtsATab(8) = 9: skirtsBTab(8) = 5 ' 9*9-Kasten macht 4 plus 5*5-Diagonale à 4 skirtsATab(9) = 7: skirtsBTab(9) = 7 ' 7*7-Kasten macht 3 plus 7*7-Diagonale à 6 skirtsATab(10) = 9: skirtsBTab(10) = 7 ' 9*9-Kasten macht 4 plus 7*7-Diagonale à 6 skirtsATab(11) = 11: skirtsBTab(11) = 7 ' 11er-Kasten macht 5 plus 7*7-Diagonale à 6 skirtsATab(12) = 9: skirtsBTab(12) = 9 ' 9er-Kasten macht 4 plus 9*9-Diagonale à 8 skirtsATab(13) = 11: skirtsBTab(13) = 9 ' 11er-Kasten macht 5 plus 9*9-Diagonale à 8 skirtsATab(14) = 13: skirtsBTab(14) = 9 ' 13er-Kasten macht 6 plus 9*9-Diagonale à 8 skirtsATab(15) = 11: skirtsBTab(15) = 11 ' 11er-Kasten macht 5 plus 11erDiagonale à 10 skirtsATab(16) = 13: skirtsBTab(16) = 11 ' 13er-Kasten macht 6 plus 11erDiagonale à 10 skirtsATab(17) = 15: skirtsBTab(17) = 11 skirtsATab(18) = 13: skirtsBTab(18) = 13 skirtsATab(19) = 15: skirtsBTab(19) = 13 skirtsATab(20) = 17: skirtsBTab(20) = 13 Rem VORAB: FILTERMATRIX FÜLLEN For i = 1 To 33 For j = 1 To 33 FI(i, j) = 1 Next j Next i Rem ZIELBILD INITIALISIEREN Rem ... entfällt bei der Plotlibvariante Rem ******************** BEGINN HINTERGRUNDPROZESS Rem DER HINTERGRUNDPROZESS ERZEUGT DEN PSEUDOHINTERGRUND IN RM30: Rem ER WIRD NUR DURCHLAUFEN, WENN ANHAND BILDNAMEN UND -ABMESSUNGEN Rem PLAUSIBEL IST, DASS DER PSEUDOHINTERGRUND NICHT BEREITS VORHER ERZEUGT WURDE. Rem HIER DER PLAUSIBILITÄTSTEST: If SIGBgrFileName <> RMFn(n1) Or _ RMFn(30) <> RMFn(n1) Or _ LBound(RM30, 1) > LBound(LM1, 1) Or UBound(RM30, 1) < UBound(LM1, 1) Or _ LBound(RM30, 2) > LBound(LM1, 2) Or UBound(RM30, 2) < UBound(LM1, 2) Then Rem 1. HINTERGRUND MONOCHROMATISEREN -->:: "PSEUDOHINTERGRUND" RM30 Rem Protohintergrund: svw. ein monochromatischer Hintergrund HF.Text1.Text = "BGR PASS" HF.Text1.Refresh Call SUBRestAussenrand(LM1, n1, 1, 0, 16) ' Außenrandergänzung If fixErrCode = 90 Then GoTo abortend23 Call SUBChrMax2MONO(LM1, n1, RM30, 30) If fixErrCode = 90 Then GoTo abortend23 RMFn(30) = "" RMFn(30) = RMFn(n1) SIGBgrFileName = RMFn(n1) End If Rem ******************** BEGINN VORDERGRUNDPROZESS Rem DER VORDERGRUNDPROZESS ERZEUGT ALPHA IN RM20:, VOLLFARBE IN RM26: Rem PROTOSIGNATUR IN RM29:, PSEUDOVORDERGRUND IN RM 28: UND MASKE IN RM27: Rem ER WIRD NUR DURCHLAUFEN, WENN ANHAND BILDNAMEN UND -ABMESSUNGEN Rem PLAUSIBEL IST, DASS DIESE BILDER NICHT BEREITS VORHER ERZEUGT WURDEN. Rem HIER DER PLAUSIBILITÄTSTEST: If SIGFgrFileName <> RMFn(n2) Or _ RMFn(20) <> RMFn(n2) Or _ LBound(RM20, 1) > LBound(LM2, 1) Or UBound(RM20, 1) < UBound(LM2, 1) Or _ LBound(RM20, 2) > LBound(LM2, 2) Or UBound(RM20, 2) < UBound(LM2, 2) Or _ RMFn(26) <> RMFn(n2) Or _ LBound(RM26, 1) > LBound(LM2, 1) Or UBound(RM26, 1) < UBound(LM2, 1) Or _ LBound(RM26, 2) > LBound(LM2, 2) Or UBound(RM26, 2) < UBound(LM2, 2) Or _ RMFn(27) <> RMFn(n2) Or _ LBound(RM27, 1) > LBound(LM2, 1) Or UBound(RM27, 1) < UBound(LM2, 1) Or _ LBound(RM27, 2) > LBound(LM2, 2) Or UBound(RM27, 2) < UBound(LM2, 2) Or _ RMFn(28) <> RMFn(n2) Or _ LBound(RM28, 1) > LBound(LM2, 1) Or UBound(RM28, 1) < UBound(LM2, 1) Or _ LBound(RM28, 2) > LBound(LM2, 2) Or UBound(RM28, 2) < UBound(LM2, 2) Or _ RMFn(29) <> RMFn(n2) Or _ LBound(RM29, 1) > LBound(LM2, 1) Or UBound(RM29, 1) < UBound(LM2, 1) Or _ LBound(RM29, 2) > LBound(LM2, 2) Or UBound(RM29, 2) < UBound(LM2, 2) Then Rem 2. ALPHA-SEPARATION (RM20: (ALPHABILD), RM26: (VOLLFARBBILD)) Rem Spaltet den Vordergrund in einen Vollfarbvordergrund auf und in einen Rem immer fest in RM20 stehenden Alphakanal auf. Rem Muss vorab erfolgen, denn die Alphaseparartion braucht die Bilder RM29:, RM30:, RM31: Rem Merke: Vollfarbe x Alpha = Vordergrund HF.Text1.Text = "ALPHA PASS" HF.Text1.Refresh Call SUBRestAussenrand(LM2, n2, 0, 0, 16) If fixErrCode = 90 Then GoTo abortend23 Call SUBAriAlphaSeparation(LM2, n2, RM26, 26) If fixErrCode = 90 Then GoTo abortend23 RMFn(20) = RMFn(n2) RMFn(26) = RMFn(n2) Rem 3. VORDERGRUND MONOCHROMATISEREN --> "PROTOSIGNATUR" RM29: HF.Text1.Text = "MONO PASS" HF.Text1.Refresh Call SUBRestAussenrand(LM2, n2, 1, 0, 16) ' Außenrandergänzung If fixErrCode = 90 Then GoTo abortend23 Call SUBChrMax2MONO(LM2, n2, RM29, 29) If fixErrCode = 90 Then GoTo abortend23 RMFn(29) = RMFn(n2) Rem 4. VORDERGRUND EINFACH VERBREITERN --> "ZWISCHENBILD" -- EINSTWEILEN RM28: HF.Text1.Text = "1ST FILTER BLOCK" HF.Text1.Refresh If Skirts > 20 Then Skirts = 20 If Skirts > 0 Then Call SUBFilRangordnung(RM29, 29, RM31, 31, skirtsATab(Skirts), "Maximum Horizontal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsATab(Skirts), "Maximum Vertical") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsBTab(Skirts), "Maximum Diagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsBTab(Skirts), "Maximum Antidiagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 End If If Skirts = 0 Then Call DIPCopy(RM29, 29, RM28, 28) End If RMFn(28) = "" Rem 7. PROTOSIGNATUR ETWAS VERDÜNNEN DAMIT DER ALIASINGBEREICH HINTERGRUNDEINMISCHBAR WIRD HF.Text1.Text = "2ND FILTER BLOCK" ' Dies nur hier und nicht in SUBARIFreistellenPro auskommentiert. !!!!!!!! ' Call SUBFilRangordnung(RM29, 29, RM31, 31, 3, "Minimum Horizontal") ' Call SUBFilRangordnung(RM31, 31, RM29, 29, 3, "Minimum Vertical") Rem 8. ZWISCHENBILD BINÄRISIEREN UND TIEFPASSFILTERN -->:: "FREISTELLUNGSMASKE" -- RM27: HF.Text1.Text = "MASK PASS" Call SUBRadBinarysize(RM28, 28, RM27, 27, 0.5, 1) If fixErrCode = 90 Then GoTo abortend23 RMHD(27).RadWLev = 0 RMHD(27).RadBLev = 1 FilterGröße = 2 * Skirts * ((100 - FilterPercent) / 100) FilterGröße = FilterGröße \ 2 FilterGröße = FilterGröße * 2 + 1 ' immer ungerade If FilterGröße > 33 Then FilterGröße = 33 ' Bei skirts 20 und 100 Filterpercent wirds bissl runtergesetzt. If FilterGröße >= 3 Then Call DIPFirFilter(RM27, 27, RM31, 31, FI(), 1, FilterGröße, CSng(1 / FilterGröße), 0) If fixErrCode = 90 Then GoTo abortend23 Call DIPFirFilter(RM31, 31, RM27, 27, FI(), FilterGröße, 1, CSng(1 / FilterGröße), 0) If fixErrCode = 90 Then GoTo abortend23 End If RMFn(27) = RMFn(n2) Rem 9. ZWISCHENBILD EIN ZWEITES MAL VERBREITERN -->:: "PSEUDOVORDERGRUND" -- RM28: HF.Text1.Text = "3RD FILTER BLOCK" If Skirts > 0 Then Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsATab(Skirts), "Maximum Horizontal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsATab(Skirts), "Maximum Vertical") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM28, 28, RM31, 31, skirtsBTab(Skirts), "Maximum Diagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM28, 28, skirtsBTab(Skirts), "Maximum Antidiagonal") ' Die wird gefettet If fixErrCode = 90 Then GoTo abortend23 End If RMFn(28) = RMFn(n2) Rem 10. PROTOSIGNATUR ETWAS VERDÜNNEN DAMIT DER ALIASINGBEREICH HINTERGRUNDEINMISCHBAR WIRD HF.Text1.Text = "4TH FILTER BLOCK" Call SUBFilRangordnung(RM29, 29, RM31, 31, 3, "Minimum Horizontal") If fixErrCode = 90 Then GoTo abortend23 Call SUBFilRangordnung(RM31, 31, RM29, 29, 3, "Minimum Vertical") If fixErrCode = 90 Then GoTo abortend23 SIGFgrFileName = RMFn(n2) End If Rem ******************** ENDE VORDERGRUNDPROZESS Rem JETZT STEHEN IN Rem RM20: (FG) DER ALPHAKANAL Rem RM26: (FG) DER VORDERGRUND ALS VOLLFARBVORDERGRUND NACH DER ALPHASEPARATION Rem RM27: (FG) DIE FREISTELLUNGSMASKE -- verbreitert, unscharf, wenn Zeichnung, dann 255 Rem RM28: (FG) DER PSEUDOVORDERGRUND -- doppelt verbreitert, mit dem Durchschnittsgrauwert des Vordergrundes Rem RM29: (FG) DIE PROTOSIGNATUR -- die entscheidet, was Vordergrund ist Rem RM30: (BG) DER PSEUDOHINTERGRUND -- mit dem Durchschnittsgrauwert des Hintergrundes Rem BG=Backgroundgeometrie ... LM1 = LM1, LM3, RM30: Rem FG=Foregroundgeometrie ... LM2 = LM2, RM20:, RM26:, RM27:, RM28:, RM29: If VIMAGETest = False Then Call DIPFree(RM31, 31) Rem 11. HAUPTPROZESS -- GROSSE SCHLEIFE Rem ******************** BEGINN HAUPTPROZESS HF.Text1.Text = "OPERATION ..." HF.Text1.Refresh ReDim PV00(1 To o) ' Lese-Pixelvektor: Bandanzahl einstellen Rem FG-Bild-Ecken in Geokoordinaten Call FIXCoordImg2Geo(RMHD(n2), 1 - 12, 1 - 12, g0, h0) Call FIXCoordImg2Geo(RMHD(n2), RMHD(n2).ImgXXXX + 12, RMHD(n2).ImgYYYY + 12, g8, h8) Rem Distanzen FG-Bild-Mitte - FG-Bild-Ecken in Geokoordinaten g0d = g0 h0d = h0 g8d = g8 h8d = h8 Rem Skalieren g0d = g0d * ScaleFactor h0d = h0d * ScaleFactor g8d = g8d * ScaleFactor h8d = h8d * ScaleFactor Rem Die BG-Bild-Ecken sind die FG-Bild-Ecken plus Mausposition. (Alles in Geokoordinaten) g0d = g0d + p(1) h0d = h0d + p(2) g8d = g8d + p(1) h8d = h8d + p(2) Rem Umrechnung der BG-Bildecken von Geokoordinaten in Imagekoordinaten Call FIXCoordGeo2Img(RMHD(n1), g0d, h0d, r, s) i0 = CLng(r) j0 = CLng(s) Call FIXCoordGeo2Img(RMHD(n1), g8d, h8d, r, s) i8 = CLng(r) j8 = CLng(s) HF.Text1.Text = "OP PASS" HF.Text1.Refresh n = j8 - j0 HF.ProgressBar1.max = n / 20 For j = j0 To j8 n = j - j0 For i = i0 To i8 If i >= LBound(LM1, 1) + 4 And i <= UBound(LM1, 1) - 4 And _ j >= LBound(LM1, 2) + 4 And j <= UBound(LM1, 2) - 4 Then ' Pixelschleife nur wenn in Hintergundgeometrie ' QUELLPIXEL HOLEN (nur wenn sie existieren) ' ... aus der Hintergrundgeometrie pseudohintergrund = RM30(i, j, 1) ' ... Vordergrundposition berechnen Call FIXCoordImg2Geo(RMHD(n1), CDbl(i), CDbl(j), r, s) r = r - p(1) s = s - p(2) s = s / ScaleFactor r = r / ScaleFactor Call FIXCoordGeo2Img(RMHD(n2), r, s, x, y) ' ... aus der Vordergrundgeometrie If x >= LBound(LM2, 1) + 4 And x <= UBound(LM2, 1) - 4 And _ y >= LBound(LM2, 2) + 4 And y <= UBound(LM2, 2) - 4 Then ' Pixelschleife nur wenn in Vordergrundgeometrie q.x = x: q.y = y Call SUBGeoPixelResample(RM20, 20, PV00, 0, q, 2) ' ! Modell muss immer (5 x) dasselbe sein (sonst rechnet er jedesmal neue Lagrange-Koeffizienten, das dauert ewig!) Alpha = PV00(1) q.x = x: q.y = y Call SUBGeoPixelResample(RM27, 27, PV00, 0, q, 2) maske = PV00(1) q.x = x: q.y = y Call SUBGeoPixelResample(RM28, 28, PV00, 0, q, 2) pseudovordergrund = PV00(1) q.x = x: q.y = y Call SUBGeoPixelResample(RM29, 29, PV00, 0, q, 2) protosignatur = PV00(1) End If Rem STÄRKE DER BENÖTIGTEN HINTERGRUNDABSENKUNG BERECHNEN istdelta = pseudovordergrund - pseudohintergrund absenkung = solldelta - istdelta If absenkung < 0 Then absenkung = 0 ' absenkung ist die Absenkung im Grauwerten If pseudohintergrund > 0.5 Then ' 0.1 Then ' absenkfaktor ist eine Zahl 0 (keine Freistellung) ... 1 (volle Freistellung) absenkfaktor = absenkung / pseudohintergrund ' auf Wertebereich 0 ... 1 bringen Else absenkfaktor = 0 ' (bei weißem Hintergrund kann man ja gar nicht absenken] End If If absenkfaktor > 1 Then absenkfaktor = 1 Rem FREISTELLUNGS-RECHNUNG IsToWrite = False For w = 1 To o If w <= UBound(RM26, 3) Then If x >= LBound(LM2, 1) + 4 And x <= UBound(LM2, 1) - 4 And _ y >= LBound(LM2, 2) + 4 And y <= UBound(LM2, 2) - 4 Then ' nur wenn in Vordergrundgeometrie q.x = x q.y = y Call SUBGeoPixelResample(RM26, 26, PV00, 0, q, 2) ' ! Modell muss immer (5 x) dasselbe sein (sonst rechnet er jedesmal neue Lagrange-Koeffizienten, das dauert ewig!) vollvordergrund = PV00(w) Else vollvordergrund = 0 End If 'vollvordergrund = RM26(ifg, jfg, w) Else vollvordergrund = 0 End If If i >= LBound(LM1, 1) And i <= UBound(LM1, 1) And _ j >= LBound(LM1, 2) And j <= UBound(LM1, 2) And _ w >= LBound(LM1, 3) And w <= UBound(LM1, 3) Then If protosignatur > 0.5 Then ' Innnerhalb Signatur ziel(w) = vollvordergrund * Alpha Else ' Im Freistellungssaum hintergrund = LM1(i, j, w) hintergrundabgesenkt = hintergrund * (1 - (absenkfaktor * maske)) ' hintergrundabgesenkt = hintergrund * (1 - maske) ziel(w) = (vollvordergrund * Alpha) + hintergrundabgesenkt * (1 - Alpha) End If If ziel(w) < 0 Then ziel(w) = 0 If ziel(w) > 255 Then ziel(w) = 255 If ziel(w) <> LM1(i, j, w) Then IsToWrite = True End If Next w If IsToWrite = True Then coord(1) = i coord(2) = j Call SUBPltPhysPixel(LM1, coord(), ziel()) End If End If Next i n = j - j0 If DIPAbort(n, "Punktsignaturstempel") = True Then GoTo abortend23 Next j HF.ProgressBar1.Value = 1 PLGPlotCounter = PLGPlotCounter + 1 Rem ******************** ENDE HAUPTPROZESS abortend23: If VIMAGETest = False Then 'ReDim RM26(1 To 1, 1 To 1, 1 To 1) 'ReDim RM27(1 To 1, 1 To 1, 1 To 1) 'ReDim RM28(1 To 1, 1 To 1, 1 To 1) 'ReDim RM29(1 To 1, 1 To 1, 1 To 1) 'ReDim RM30(1 To 1, 1 To 1, 1 To 1) ReDim RM31(1 To 1, 1 To 1, 1 To 1) 'RMIsInUse(26) = False 'RMIsInUse(27) = False 'RMIsInUse(28) = False 'RMIsInUse(29) = False 'RMIsInUse(30) = False RMIsInUse(31) = False If fixErrCode = 90 Then HF.Text2.Text = "Funktion abgebrochen" HF.Text2.Refresh End If End Sub Rem Rem CROSSBEFEHLE: PASSKREUZCHEN MALEN UND WIEDER LÖSCHEN Rem ====================================================== Rem Die Crossbefehle dienen dem Malen und Wiederlöschen von bis zu 20 Paßpunkten. Rem Es gibt hierzu die 5 Unterprogramme CROSSOPEN, CROSSSET, CLOSSCLEAR, CLOSSCLOSE und CROSSABORT. Public Sub SUBPltCrossOpen(LM1() As Single, n1 As Long, Buffer() As Single) Rem Rem SUBPltCrossOpen bereitet das Kreuzchenmalen vor. Es wird ein Kreuzchensicherungspuffer Rem Buffer eingerichtet. Dieser muß im rufenden Hauptprogramm als undimensioniertes Single-Feld Rem vereinbart sein. Rem Rem Anmerkung: In der VPA-Syntax wird der Puffer durch eine Kanalnummer (1 oder 2) angesprochen. Rem Rem Aufbau des Kreuzchensicherungspuffers: Rem 1. Dimension: Punktnummer 1 bis MAX_NUMBER_OF_PASSPOINTS (Max 1000, die Passpunktnummer hat maximal 3 Stellen) Rem 2. Dimension: Bilddaten, Spalte (-1,0 bis 40). Auf Spalte -1 stehen Steuerdaten. Rem 3. Dimension: Bilddaten, Zeile (0 bis 10) Rem 4. Dimension: Bilddaten, Band (1 bis n, redimensionierbar) Rem Rem Buffer(Punktnummer, 0, 1,1): -7999=Punkt unbenutzt, 0=Punkt gültig Rem Buffer(Punktnummer, 0, 2,1): -7999=Punkt unbenutzt, <>-7999=X-Bildkoordinate Rem Buffer(Punktnummer, 0, 3,1): -7999=Punkt unbenutzt, <>-7999=Y-Bildkoordinate Rem Rem Überschlag Hauptspeicherverbrauch: Maximale Größe der 2 Puffer pro Band: Rem MAX_NUMBER_OF_PASSPOINTS Punkte * 41 Spalten * 10 Zeilen * 2 Puffer * 4 Byte * 4 Bänder = 656000 Byte, also ... Rem Rem 20 Passpunkte 0,26 MByte Rem 100 Passpunkte 1,21 MByte Rem 200 Passpunkte 2,43 MByte (Generierung Stand 2005) Rem 400 Passpunkte 4,86 MByte (Geht sicherlich problemlos zu generieren) Rem 800 Passpunkte 9,72 MByte (Stand 2008; Solide konzipiert, a) Gleichungssysteme gut lösbar, wenn auch hohe Rechenzeit, b) bei 8 Bändern 18 MByte Speicher c) Zahlen bis 999 klappen auch.) Rem 1200 Passpunkte 14,58 MByte (Stand 2020. Dank der Ligaturen 10 11 12 mit drei Stellen gut beschriftbar. Recht langsam. Rem 4000 Passpunkte 52,480 MByte (Konzipiertzes absolutes Maximum. a) Gleichungssysteme nicht mehr sicher lösbar, b) Bei 8 Bändern sinds schon 104 MByte, c) Zahlendarstellung "X00" statt 4000) Rem Dim i As Long ReDim Buffer(1 To MAX_NUMBER_OF_PASSPOINTS, -1 To 40, 0 To 10, 1 To UBound(LM1, 3)) For i = 1 To MAX_NUMBER_OF_PASSPOINTS Buffer(i, -1, 1, 1) = -7999 ' Flagfeld: -7999 = Punkt ist leer, sonst 0=Punkt gültig Buffer(i, -1, 2, 1) = -7999 ' X-Feld: -7999 = Punkt ist Leer, sonst X Buffer(i, -1, 3, 1) = -7999 ' Y-Feld: -7999 = Punkt ist Leer, sonst Y Next i End Sub Public Sub SUBPltCrossSet(LM1() As Single, n1 As Long, P1() As Double, k1 As Long, Buffer() As Single) Rem Rem SUBPltCrossSet malt ein Kreuzchen auf Punkt (p1(1),p1(2)), Nummer k1 (1 bis VIMAGE_MAX_NUMBER_OF_PASSPOINTS). Rem Rem Die draunterliegenden Bilddaten werden in den Puffer Buffer gesichert. Rem Das Kreuzchensystem muss mit SUBPltCrossOpen vorbereitet sein. Rem Dim x1 As Double Dim y1 As Double Dim sid As Double Dim sjd As Double Dim SI As Long ' Schreib-Bildkoordinaten Dim sj As Long Dim wx As Double ' Work-Koordinaten (Zwischen-Geokoordinaten) Dim wy As Double Dim i As Long ' Laufende Indizees Dim j As Long Dim w As Long Dim i2 As Long ' Aktuelle Indizees Dim j2 As Long Dim t01 As Long 'Sicherungszellen für Globals Dim t02 As Long Dim t03 As Long Dim t04(1 To MAX_NUMBER_OF_CHANNELS) As Single Dim Einer1 As Long Dim Zehner1 As Long Dim Hunderter1 As Long Dim Einer2 As String Dim Zehner2 As String Dim Hunderter2 As String Dim Text1 As String Dim Text2 As String Dim Pos(1 To 2) As Double ' Plotposition Dim Code As Byte Dim tmpTextMode As Long If UBound(Buffer, 1) <> MAX_NUMBER_OF_PASSPOINTS Then Exit Sub ' Parameter prüfen ... If UBound(Buffer, 2) <> 40 Then Exit Sub ' dimen- If UBound(Buffer, 3) <> 10 Then Exit Sub ' sionie- If UBound(Buffer, 4) <> UBound(LM1, 3) Then Exit Sub ' rung If k1 < 1 Or k1 > MAX_NUMBER_OF_PASSPOINTS Then Exit Sub ' Unzulässige Punktnummer (weicher Abbruch) If k1 > 4299 Then Exit Sub ' Unzulässige Punktnummer (harter Abbruch) ' If Buffer(k1, 0, 1, 1) <> -7999 Then Exit Sub ' Punkt bereits gefüllt ' If Buffer(k1, 0, 2, 1) <> -7999 Then Exit Sub ' Punkt bereits gefüllt ' If Buffer(k1, 0, 3, 1) <> -7999 Then Exit Sub ' Punkt bereits gefüllt x1 = P1(1) y1 = P1(2) Select Case PLTCoordMode Case 0: ' Bildkoordinaten sid = CDbl(x1): sjd = CDbl(y1) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), x1, y1, wx, wy) sid = wx sjd = wy Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), x1, y1, wx, wy) sid = wx sjd = wy Case Else: Call FIXCoordGeo2Img(RMHD(n1), x1, y1, wx, wy) sid = wx sjd = wy End Select Rem Abbruch, wenn Bildkoordinaten zu groß If Abs(sid) < 2000000000# Then SI = CLng(sid) Else Exit Sub End If If Abs(sjd) < 2000000000# Then sj = CLng(sjd) Else Exit Sub End If For w = 1 To UBound(LM1, 3) For j = sj - 5 To sj + 5 ' Bildpunkte in Puffer retten For i = SI - 5 To SI + 5 + 30 If i > -16 And i < RMHD(n1).ImgXXXX + 16 And j > -16 And j < RMHD(n1).ImgYYYY + 16 Then i2 = i - SI + 5 ' Punkte stehen um 5 versetzt im Puffer j2 = j - sj + 5 ' Punkte stehen um 5 versetzt im Puffer Buffer(k1, i2, j2, w) = LM1(i, j, w) End If Next i Next j Next w Buffer(k1, -1, 1, 1) = 0 ' Puffer als belegt kennzeichnen und Buffer(k1, -1, 2, 1) = CSng(SI) ' Koordinate merken Buffer(k1, -1, 3, 1) = CSng(sj) ' Text konvertieren Einer1 = k1 Mod 10 Zehner1 = (k1 \ 10) Mod 10 Hunderter1 = (k1 \ 100) 'Mod 10 -- kein Modulo. Ohne den Modula läufter hinter der 9 in :;<=>?@ABCDEFG ... rein ... Einer2 = Chr(Einer1 + 48) Zehner2 = Chr(Zehner1 + 48) Hunderter2 = Chr(Hunderter1 + 48) ' Hunderter >9 werden zu :;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ -- was notfalls bis 4299 (="Z99") reicht. ' Vornullenunterdrückung If k1 < 10 Then Zehner2 = "" If k1 < 100 Then Hunderter2 = "" ' Hunderter : ; < zu Ligaturen 10 11 12 umkodieren If Hunderter2 = ":" Then Hunderter2 = Chr(20) ' Code 20 = Ligatur 10 If Hunderter2 = ";" Then Hunderter2 = Chr(21) ' Code 21 = Ligatur 11 If Hunderter2 = "<" Then Hunderter2 = Chr(22) ' Code 22 = Ligatur 12 ' Passpunkt-Mire dranmalen Text1 = Chr(18) & Hunderter2 & Zehner2 & Einer2 ' 18 ist die Passpunkt-Testmire ' Globals retten t01 = PLTTextSize t02 = PLTTextShift(1) t03 = PLTTextShift(2) Call VIMAGEValueCopy(PLTTextValue, t04) ' Globals einstellen PLTTextSize = 1 PLTTextShift(1) = 0 PLTTextShift(2) = 0 Pos(1) = x1 Pos(2) = y1 ' Mit Hintergrundwert fettes (3*3-Pixel-) Kreuz malen tmpTextMode = PLTTextMode For i = 1 To UBound(PLTTextValue) PLTTextValue(i) = RMHD(n1).RadWLev Next i Call SUBPltSet("TEXTMODE", 1) Call SUBPltPixelText(LM1, n1, Pos, Text1) ' Mit Vordergrundwert normales (1*1-Pixel-) Kreuz malen For i = 1 To UBound(PLTTextValue) PLTTextValue(i) = RMHD(n1).RadBLev Next i Call SUBPltSet("TEXTMODE", 0) Call SUBPltPixelText(LM1, n1, Pos, Text1) Call SUBPltSet("TEXTMODE", tmpTextMode) ' Globals wiederherstellen PLTTextSize = t01 PLTTextShift(1) = t02 PLTTextShift(2) = t03 Call VIMAGEValueCopy(t04, PLTTextValue) End Sub Public Sub SUBPltCrossClear(LM1() As Single, n1 As Long, k1 As Long, Buffer() As Single) Rem Rem SUBPltCrossClear löscht ein Kreuzchen auf Punkt Nummer k1. Rem Die Bilddaten werden aus dem Puffer Buffer wiederhergestellt. Rem Das Kreuzchensystem muss mit SUBPltCrossOpen vorbereitet sein und der Rem Punkt muß mit SUBPltCrossSet eingetragen worden sein. Rem Dim SI As Long ' Schreib-Bildkoordinaten Dim sj As Long Dim i As Long ' Laufende Indizees Dim j As Long Dim w As Long If UBound(Buffer, 1) <> MAX_NUMBER_OF_PASSPOINTS Then Exit Sub ' Parameter prüfen ... If UBound(Buffer, 2) <> 40 Then Exit Sub ' falsch dimen- If UBound(Buffer, 3) <> 10 Then Exit Sub ' sioniert If UBound(Buffer, 4) <> UBound(LM1, 3) Then Exit Sub If k1 < 1 Or k1 > MAX_NUMBER_OF_PASSPOINTS Then Exit Sub ' falsche Punktnummer If Buffer(k1, -1, 1, 1) = -7999 Then Exit Sub ' Punkt leer If Buffer(k1, -1, 2, 1) = -7999 Then Exit Sub ' Punkt leer If Buffer(k1, -1, 3, 1) = -7999 Then Exit Sub ' Punkt leer SI = Buffer(k1, -1, 2, 1) ' Koordinate holen sj = Buffer(k1, -1, 3, 1) For w = 1 To UBound(LM1, 3) For j = sj - 5 To sj + 5 ' Bildpunkte aus Puffer wieder reinmalen For i = SI - 5 To SI + 5 + 30 If i > -16 And i < RMHD(n1).ImgXXXX + 16 And j > -16 And j < RMHD(n1).ImgYYYY + 16 Then LM1(i, j, w) = Buffer(k1, i - SI + 5, j - sj + 5, w) End If Next i Next j Next w Buffer(k1, -1, 1, 1) = -7999 ' Puffer als frei kennzeichnen Buffer(k1, -1, 2, 1) = -7999 ' Puffer als frei kennzeichnen Buffer(k1, -1, 3, 1) = -7999 ' Puffer als frei kennzeichnen End Sub Public Sub SUBPltCrossClose(LM1() As Single, n1 As Long, Buffer() As Single) Rem Rem SUBPltCrossClose beendet die Kreuzchenmalerei. Alle gemalten Kreuzchen werden Rem mit Hilfe der Alt-Bilddaten im Puffer Buffer wieder entfernt. Rem Dim i As Long If UBound(Buffer, 1) <> MAX_NUMBER_OF_PASSPOINTS Then Exit Sub ' Parameter prüfen ... If UBound(Buffer, 2) <> 40 Then Exit Sub ' falsch dimen- If UBound(Buffer, 3) <> 10 Then Exit Sub ' sioniert For i = MAX_NUMBER_OF_PASSPOINTS To 1 Step -1 ' Rückwärts, damit evtl. später gesicherte höhere nicht ' ältere niedrigere überschreiben. If Buffer(i, -1, 1, 1) <> -7999 Then ' Flagfeld: -7999 = Punkt ist leer Call SUBPltCrossClear(LM1, n1, i, Buffer) End If Next i ReDim Buffer(0 To 1, 0 To 1, 0 To 1, 0 To 1) ' Speicher freigeben End Sub Public Sub SUBPltCrossAbort(LM1() As Single, n1 As Long, Buffer() As Single) Rem Rem SUBPltCrossAbort beendet die Kreuzchenmalerei. Die gemalten Kreuzchen Rem bleiben »auf ewig« erhalten, der Rettungspuffer Buffer wird gelöscht und freigegeben. Rem Dim i As Long ReDim Buffer(0 To 1, 0 To 1, 0 To 1, 0 To 1) ' Speicher freigeben End Sub Rem Rem BEFEHL IMAGENEW: BILD NEU ALLEGEN Rem ================================= Rem Das macht nicht die Plotlib, sondern die Fixlib. Rem Rem BEFEHL IMAGESET: PARAMETER IM BILDKOPF SETZEN Rem ============================================= Rem Das macht nicht die Plotlib, sondern die Fixlib. Rem Rem BEFEHL INIT: INITIALISIERUNG Rem ============================ Rem Steht ganz oben Rem Rem BEFEHL SET: HINTERGRUNDPARAMETER SETZEN Rem ======================================= Public Sub SUBPltSet(s1 As String, Vpara As Variant) Rem Rem SUBPltSetMode setzt die Variable mit dem Namen s1 auf den Wert Vpara. Rem Vpara kann eine Zahl oder ein Feld sein. Rem Die ersten 32 Zeichen sind signifikant. Rem Dim para() As Variant Dim i As Long Rem Zahl oder Feld --> Feld If IsArray(Vpara) = False Then ' Zahl ReDim para(1 To 1) para(1) = Vpara Else ' Feld ReDim para(1 To UBound(Vpara)) For i = 1 To UBound(Vpara) para(i) = CDbl(Vpara(i)) Next i End If Rem Variablen übernehmen Select Case Left(UCase(s1) & "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", 32) Case "BRUSHMODE~~~~~~~~~~~~~~~~~~~~~~~": If PLTBrushMode <> CLng(para(1)) Then PLTBrushMode = CLng(para(1)) If PLTBrushMode < 0 Then PLTBrushMode = 0 If PLTBrushMode > 1 Then PLTBrushMode = 1 PLXBrushIsChanged = True ' neu generieren! End If Case "BRUSHOPACITY~~~~~~~~~~~~~~~~~~~~": If PLTBrushOpacity <> CLng(para(1)) Then PLTBrushOpacity = CLng(para(1)) If PLTBrushOpacity < 1 Then PLTBrushOpacity = 1 If PLTBrushOpacity > 100 Then PLTBrushOpacity = 100 PLXBrushIsChanged = True ' neu generieren! End If Case "BRUSHSIZE~~~~~~~~~~~~~~~~~~~~~~~": If PLTBrushSize <> CLng(para(1)) Then PLTBrushSize = CLng(para(1)) If PLTBrushSize < 0 Then PLTBrushSize = 0 If PLTBrushSize > MAX_BRUSH_SIZE Then PLTBrushSize = MAX_BRUSH_SIZE If PLTBrushSize > 400 Then PLTBrushSize = 400 ' ca. 400*400*2*2*3 = ca. 2 MByte für Pen und Brush. Mehr wird erstmal Hart verboten. PLXBrushIsChanged = True ' neu generieren! End If Case "BRUSHSTRENGTH~~~~~~~~~~~~~~~~~~~": If PLTBrushStrength <> CLng(para(1)) Then PLTBrushStrength = CLng(para(1)) If PLTBrushStrength < 0 Then PLTBrushStrength = 0 If PLTBrushStrength > 100 Then PLTBrushStrength = 100 PLXBrushIsChanged = True ' neu generieren! End If Case "COORDMODE~~~~~~~~~~~~~~~~~~~~~~~": ' MOD PLTCoordMode = CLng(para(1)) If PLTCoordMode < 0 Then PLTCoordMode = 0 If PLTCoordMode > 2 Then PLTCoordMode = 2 Case "PENSIZE~~~~~~~~~~~~~~~~~~~~~~~~~": If PLTPenSize <> CLng(para(1)) Then PLTPenSize = CLng(para(1)) If PLTPenSize < 0 Then PLTPenSize = 0 If PLTPenSize > MAX_PEN_SIZE Then PLTPenSize = MAX_PEN_SIZE If PLTPenSize > 400 Then PLTPenSize = 400 ' ca. 400*400*2*2*3 = ca. 2 MByte für Pen und Brush. Mehr wird erstmal Hart verboten. PLXPenIsChanged = True ' Neu generieren! End If Case "PENSIZEAUX~~~~~~~~~~~~~~~~~~~~~~": If PLTPenSizeAux <> CLng(para(1)) Then PLTPenSizeAux = CLng(para(1)) If PLTPenSizeAux < 0 Then PLTPenSizeAux = 0 If PLTPenSizeAux > PLTPenSize Then PLTPenSizeAux = PLTPenSize If PLTPenSizeAux > 400 Then PLTPenSize = 400 ' ca. 400*400*2*2*3 = ca. 2 MByte für Pen und Brush. Mehr wird erstmal Hart verboten. PLXPenIsChanged = True ' Neu generieren! End If Case "TEXTMODE~~~~~~~~~~~~~~~~~~~~~~~~": PLTTextMode = CLng(para(1)) If PLTTextMode < 0 Then PLTTextMode = 0 If PLTTextMode > 1 Then PLTTextMode = 1 Case "TEXTSHIFT~~~~~~~~~~~~~~~~~~~~~~~": If IsArray(para) Then If UBound(para) >= 2 Then PLTTextShift(1) = CLng(para(1)) PLTTextShift(2) = CLng(para(2)) End If End If Case "TEXTSIZE~~~~~~~~~~~~~~~~~~~~~~~~": PLTTextSize = CLng(para(1)) If PLTTextSize < 1 Then PLTTextSize = 1 If PLTTextSize > 10 Then PLTTextSize = 10 Case "TEXTVALUE~~~~~~~~~~~~~~~~~~~~~~~": For i = 1 To VIMAGEMin(UBound(para), MAX_NUMBER_OF_CHANNELS) PLTTextValue(i) = para(i) Next i Case "STRAIN~~~~~~~~~~~~~~~~~~~~~~~~~~": PLTStrain = CLng(para(1)) If PLTStrain < 20 Then PLTStrain = 20 If PLTStrain > 80 Then PLTStrain = 80 Case Else: Call MsgBox("Nichtdefinierter Variablenname bei Plotbefehl SET: " & s1, , "Plotlib") End Select End Sub Rem Rem BEFEHL INIT: INITIALISIEREN Rem =========================== Public Sub SUBPltInit() Rem Gesamtes Plotsubsystem definiert zurücksetzen. Dim i As Long Dim x As Long Dim T As String x = 10 ' Das tabelliert schöner Rem Quasi noch Deklarationen Dim Zerofeld(1 To MAX_NUMBER_OF_CHANNELS) As Double For i = 1 To MAX_NUMBER_OF_CHANNELS Zerofeld(i) = 0 Next i Dim Fullfeld(1 To MAX_NUMBER_OF_CHANNELS) As Double For i = 1 To MAX_NUMBER_OF_CHANNELS Fullfeld(i) = 255 Next i Dim Nullfeld(1 To 1) As Double Nullfeld(1) = 0 Dim Einsfeld(1 To 1) As Double Einsfeld(1) = 1 Dim Workfeld(1 To 2) As Double Workfeld(1) = 0 Workfeld(2) = 0 Rem Laufbereich. Nur einmalig durchlaufen PLGIsInitialized = True Rem Counter auf 0 PLGPlotCounter = 0 Rem Undo-Subsystem initialisieren Call SUBPltUndoClose Call SUBPltUndoOpen(RM00()) Rem Den SET mit Anfangswerten füllen Call SUBPltSet("BRUSHMODE", 1) ' 1=Pinselform kreisförmig Call SUBPltSet("BRUSHSIZE", 1) ' 1=Pinselbreite 1 Call SUBPltSet("BRUSHSTRENGTH", 100) ' 100=Pinselhärte 100 % Call SUBPltSet("BRUSHOPACITY", 100) ' 100=Pinseldeckfähigkeit 100 % Call SUBPltSet("COORDMODE", 1) ' 1=Geokoord Call SUBPltSet("PENSIZE", 1) ' 1=Stiftbreite 1 Call SUBPltSet("PENSIZEAUX", 0) ' 0=Stiftbreite 0 Call SUBPltSet("STRAIN", 50) ' 50=mittlerer Freiheitsgrad Call SUBPltSet("TEXTMODE", 0) ' Text normal, nicht fett Workfeld(1) = 5: Workfeld(2) = 5 Call SUBPltSet("TEXTSHIFT", Workfeld) ' 5,5=Textversetzung 5,5 Call SUBPltSet("TEXTSIZE", 1) ' Textgrösse 1 Call SUBPltSet("TEXTVALUE", Fullfeld) ' 32 mal Vollton Rem Aufbau der Zeichen Call SUBPltInitFont ' Steht in VDPLTINI Rem Helptext T = "" T = T & vbCrLf T = T & "DOKUMENTATION VECTOR PLOT ASSEMBLER VPA" & vbCrLf T = T & "=======================================" & vbCrLf T = T & vbCrLf T = T & "Zugleich Dokumentation der Plotlib" & vbCrLf T = T & vbCrLf T = T & "(VPA ... svw. Vector Plot Assembler. VPA hat mit RTA, dem " & vbCrLf T = T & "Reduced Transliteration Assembler nichts zu tun. VPA ist eine Syntax, " & vbCrLf T = T & "die vektorgraphische Zeichnungen beschreibt, RTA ist eine Programmiersprache.)" & vbCrLf T = T & vbCrLf T = T & vbCrLf T = T & "Mit VPA-Plotbefehlen können Zeichnungen einfach und präzise erstellt" & vbCrLf T = T & "werden." & vbCrLf T = T & vbCrLf T = T & "Jeder VPA-Plotbefehl besteht aus einem Befehlsnamen dem Parameter folgen" & vbCrLf T = T & "können. Beispiel:" & vbCrLf T = T & vbCrLf T = T & " LINE 100,150 200,250 255" & vbCrLf T = T & vbCrLf T = T & "Zusätzlich zu den reinen Zeichenbefehlen gibt es einige Sonderbefehle z. B." & vbCrLf T = T & "zum Anlegen von Bildern oder zum Zeichnen von Passkreuzen." & vbCrLf T = T & vbCrLf T = T & vbCrLf T = T & "1. ARTEN VON PARAMETERN" & vbCrLf T = T & "-----------------------" & vbCrLf T = T & vbCrLf T = T & "Die Befehle haben vier verschiedene Arten von Parametern:" & vbCrLf T = T & vbCrLf T = T & " ZAHLEN p sind grundsätzlich gewöhnliche Dezimalzahlen." & vbCrLf T = T & " Dezimaltrennzeichen ist dabei der Punkt. Beispiel:" & vbCrLf T = T & vbCrLf T = T & " 3.1415926535" & vbCrLf T = T & vbCrLf T = T & " VEKTOREN p() sind mehrere durch Komma getrennte Zahlen, z. B. für" & vbCrLf T = T & " Koordinaten oder Farben. Zwischenleerzeichen sind verboten." & vbCrLf T = T & " Beispiel:" & vbCrLf T = T & vbCrLf T = T & " 0,128,127.5,255,0" & vbCrLf T = T & vbCrLf T = T & " Vektor »,« ist äquivalent zu »-9999« und bedeutet Leer. So lässt" & vbCrLf T = T & " sich z. B. die Füllfarbe »nicht füllen« angeben. " & vbCrLf T = T & vbCrLf T = T & " ZEICHENKETTEN »p« werden in Doppelhochkomma eingeschlossen." & vbCrLf T = T & vbCrLf T = T & " Die Zeichen NUL, TAB, CR, LF, SP, " & Chr(34) & ", ', <, >, \ und ~ kann " & vbCrLf T = T & " man auch als <0>, <9>, <10>, <13>, <32>, <34>, <39>, <60>, <62>, <92> und" & vbCrLf T = T & " <126> schreiben. Das Leerzeichen kann auch als ~ notiert werden. Beispiel: " & vbCrLf T = T & vbCrLf T = T & " " & Chr(34) & "Maßstab:<9>1 : 25000" & Chr(34) & vbCrLf T = T & vbCrLf T = T & " FREIE PARAMETER p* sind auch Zahlen, Vektoren oder Zeichenketten, der" & vbCrLf T = T & " tatsächliche Typ ergibt sich aber erst aus dem Sinnzusammenhang." & vbCrLf T = T & vbCrLf T = T & vbCrLf T = T & "2. VERZEICHNIS DER PLOTBEFEHLE" & vbCrLf T = T & "------------------------------" & vbCrLf T = T & vbCrLf T = T & "PIXEL " & vbTab & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Wirklich nur ein Pixel auf (p(1),p(2)) mit Grauwert z() zeichnen." & vbCrLf T = T & vbCrLf T = T & "FATPIXEL" & vbTab & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Eine kleine 3*3-Pixelmatrix auf (p(1),p(2)) mit Grauwert z() zeichnen." & vbCrLf T = T & vbCrLf T = T & "POINT " & vbTab & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Punkt mit Stift auf (p(1),p(2)) mit Grauwert z() zeichnen." & vbCrLf T = T & vbCrLf T = T & "LINE " & vbTab & vbTab & "p() " & vbTab & "q() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Line mit (gewöhnlichem) Stift von (p(1),p(2)) nach (q(1),q(2)) mit Grauwert z()" & vbCrLf T = T & " zeichnen." & vbCrLf T = T & vbCrLf T = T & "LINEAUX " & vbTab & "p() " & vbTab & "q() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Line mit Aux-Stift von (p(1),p(2)) nach (q(1),q(2)) mit Grauwert z() zeichnen." & vbCrLf T = T & vbCrLf T = T & "LINEDOUBLE " & vbTab & "p() " & vbTab & "q() " & vbTab & "y()" & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Doppelline von (p(1),p(2)) nach (q(1),q(2)) mit Grauwerten y() und z() zeichnen." & vbCrLf T = T & " Die Stiftgröße ist die Linienbreite und die Aux-Stiftgröße die Innenraumbreite." & vbCrLf T = T & vbCrLf T = T & "LINEDOUBLEAPP " & vbTab & "p() " & vbTab & "q() " & vbTab & "y()" & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Doppellinie von (p(1),p(2)) nach (q(1),q(2)) mit Grauwerten y() und z() zeichnen." & vbCrLf T = T & " Dabei anhängend arbeiten, d. h. wenn p() identisch mit vorherigem q() und der " & vbCrLf T = T & " Anfangspunkt der vorherigen Linie bekannt ist, Linienanschluss an vorherige Linie" & vbCrLf T = T & " öffnen." & vbCrLf T = T & vbCrLf T = T & "BEZIER " & vbTab & vbTab & "p() " & vbTab & "q() " & vbTab & "r() " & vbTab & "s() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Gewöhnliche (kubische) Bezierkurve mit Stift von (p(1),p(2)) nach (s(1),s(2)) mit" & vbCrLf T = T & " Grauwert z() zeichnen, dabei sind die Punkte (q(1),q(2)) und (r(1),r(2))" & vbCrLf T = T & " Kontrollpunkte, die die Tangenten an p und s fstlegen." & vbCrLf T = T & vbCrLf T = T & "QBEZIER" & vbTab & vbTab & "p() " & vbTab & "q() " & vbTab & "r() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Quadratische Bezierkurve mit Stift von (p(1),p(2)) nach (r(1),r(2)) mit Grauwert" & vbCrLf T = T & " z() zeichnen, dabei ist Punkt (q(1),q(2)) Kontrollpunkt, der die Tangenten" & vbCrLf T = T & " an p und s festlegt." & vbCrLf T = T & vbCrLf T = T & "ARC " & vbTab & vbTab & "p() " & vbTab & "r " & vbTab & "s " & vbTab & "a " & vbTab & "f1 " & vbTab & "f2 " & vbTab & "q()" & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Ellipsenbogen mit Stift von (p(1),p(2)) nach (q(1),q(2)) mit Grauwert z() " & vbCrLf T = T & " zeichnen. Die Parameter r, s, a, f1 und f2 entstammen dem A-Befehl " & vbCrLf T = T & " des SVG-Path-Elements:" & vbCrLf T = T & " r ... 1. Halbachse der Ellipse," & vbCrLf T = T & " s ... 2. Halbachse der Ellipse," & vbCrLf T = T & " a ... Winkel zwischen 1. Halbachse und X-Achse des Koordinatensystems," & vbCrLf T = T & " f1 ... Large-Arc-Flag, wenn 1 verbindet der längere Bogen die Punkte," & vbCrLf T = T & " f2 ... Sweep-Flag, wählt eine der beiden Ellipsen, die die Punkt verbinden." & vbCrLf T = T & vbCrLf T = T & "CIRCLE " & vbTab & vbTab & "m() " & vbTab & "r " & vbTab & "zs()" & vbTab & "zf()" & vbCrLf T = T & vbCrLf T = T & " Kreis mit Stift um Mittelpunkt (m(1),m(2)) und Radius r mit Grauwert zs() zeichnen" & vbCrLf T = T & " zeichnen und mit dem Grauwert zf() füllen. Sollen Kreisumfang oder -fläche nicht " & vbCrLf T = T & " geplottet werden, so kann die mit dem Leergrauwert ».« (=-9999) angewiesen werden." & vbCrLf T = T & vbCrLf T = T & "ELLIPSE " & vbTab & "m() " & vbTab & "h1" & vbTab & "h2" & vbTab & "zs()" & vbTab & "zf()" & vbCrLf T = T & vbCrLf T = T & " Ellipse Stift um Mittelpunkt (m(1),m(2)) und Halbachsen h1, h2 zeichnen." & vbCrLf T = T & " Die Ellipse wird mit dem Grauwert zs() gezeichnet und mit dem Grauwert zf() " & vbCrLf T = T & " gefüllt. Sollen Ellipsenumfang oder -fläche nicht geplottet werden, so kann dies " & vbCrLf T = T & " durch Angabe des Leergrauwertes ».« (=-9999) angewiesen werden." & vbCrLf T = T & vbCrLf T = T & "RECT " & vbTab & vbTab & "p() " & vbTab & "q() " & vbTab & "zs()" & vbTab & "zf()" & vbCrLf T = T & vbCrLf T = T & " Rechteck mit Stift durch die Eckpunkte (p(1),p(2)) und (q(1),q(2)) mit Grauwert " & vbCrLf T = T & " zs() zeichnen und mit dem Grauwert zf() füllen. Soll Umfang oder Flächenfüllung " & vbCrLf T = T & " nicht geplottet werden, so kann die mit dem Leergrauwert ».« (=-9999) angewiesen " & vbCrLf T = T & " werden." & vbCrLf T = T & vbCrLf T = T & "POLYLINE" & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Polylinie über die Punkte (p(1),p(2)), (p(3),p(4)) ... (p(n-1),q(n)) mit" & vbCrLf T = T & " Grauwert z() zeichnen. " & vbCrLf T = T & vbCrLf T = T & "POLYLINEDOUBLE" & vbTab & "p() " & vbTab & "y()" & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Doppelpolylinie über die Punkte (p(1),p(2)), (p(3),p(4)) ... (p(n-1),q(n)) mit" & vbCrLf T = T & " Stift und Aux-Stift und den Grauwerten y() und z() zeichnen. " & vbCrLf T = T & vbCrLf T = T & "POLYGON " & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Polygon über die Punkte (p(1),p(2)), (p(3),p(4)) ... (p(n-1),q(n)), (P(1),p(2))" & vbCrLf T = T & " mit Grauwert z() zeichnen. POLYGONE werden im Gegensatz zu SVG nie gefüllt." & vbCrLf T = T & " Das erledige man erforderlichenfalls mit FILL." & vbCrLf T = T & vbCrLf T = T & "POLYGONDOUBLE " & vbTab & "p() " & vbTab & "y()" & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Doppelliniges Polygon über die Punkte (p(1),p(2)), (p(3),p(4)) ... (p(n-1),q(n)), " & vbCrLf T = T & " (P(1),p(2)) mit Stift und Aux-Stift und den Grauwerten y() und z() zeichnen. Wird " & vbCrLf T = T & " nie gefüllt, das erledige man erforderlichenfalls mit FILL." & vbCrLf T = T & vbCrLf T = T & "PATH " & vbTab & vbTab & "»pc« " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Pfad entsprechend Pfadcodeliste »pc« mit Stift und Grauwert z() zeichnen." & vbCrLf T = T & " Dieser Befehl dient der Unterstützung des SVG-Formates. »pc« ist ein String, " & vbCrLf T = T & " der dem Data-Attribut des SVG-Elementes path entspricht. Beispiel hierfür:" & vbCrLf T = T & vbCrLf T = T & " " & Chr(34) & "M 200,300 L 220,300 220,350 200,250 Z" & Chr(34) & vbCrLf T = T & vbCrLf T = T & " Pfade werden im Gegensatz zu SVG nie gefüllt. Dies erledige man separat " & vbCrLf T = T & " mit einem FILL-Ruf. " & vbCrLf T = T & vbCrLf T = T & "FILL " & vbTab & vbTab & "p() " & vbTab & "zb() " & vbTab & "zf()" & vbCrLf T = T & vbCrLf T = T & " Fläche ab Punkt (p(1),p(2)) bis Randgrauwert zb() mit Füllgrauwert zf()" & vbCrLf T = T & " zeichnen. Es wird eine geschlossene Randkontur mit zb() erwartet, ist" & vbCrLf T = T & " diese nicht geschlossen, so wird das ganze Bild gefüllt!" & vbCrLf T = T & vbCrLf T = T & "PIXELSIGN " & vbTab & "p() " & vbTab & "cod" & vbCrLf T = T & vbCrLf T = T & " Skizzenzeichen ASCII-Code cod mit Stift auf Position (p(1),p(2)) zeichnen" & vbCrLf T = T & " Der Plot erfolgt mit globalem Grauwert TEXTVALUE. Es wird mit dem Pixel " & vbCrLf T = T & " gezeichnet." & vbCrLf T = T & vbCrLf T = T & "PIXELTEXT " & vbTab & "p() " & vbTab & "»string«" & vbCrLf T = T & vbCrLf T = T & " Skizzentext »string« mit Stift ab Position (p(1),p(2)) zeichnen. Der Plot" & vbCrLf T = T & " erfolgt mit globalem Grauwert TEXTVALUE, einer Textversetzung TEXTSHIFT," & vbCrLf T = T & " einer Schriftgröße TEXTSIZE und einem Modus TEXTMODE. (s. Befehl SET). " & vbCrLf T = T & " Es wird mit Pixel bzw. Fettpixel gezeichnet." & vbCrLf T = T & vbCrLf T = T & "BRUSH " & vbTab & vbTab & "p() " & vbTab & "z()" & vbCrLf T = T & vbCrLf T = T & " Punkt mit Pinsel auf (p(1),p(2)) mit Grauwert z() zeichnen." & vbCrLf T = T & vbCrLf T = T & "COPYBRUSH " & vbTab & "p1() " & vbTab & "p0()" & vbCrLf T = T & vbCrLf T = T & " Punkt mit Pinsel auf (p1(1),p1(2)) zeichnen. Die Grauwerte des Punktes" & vbCrLf T = T & " werden von (p0(1),p0(2)) gelesen." & vbCrLf T = T & vbCrLf T = T & "FILTERBRUSH " & vbTab & "p() " & vbCrLf T = T & vbCrLf T = T & " Punkt (p(1),p(2)) mit Pinsel weichzeichnen. Die Punktgrauwerte werden mit" & vbCrLf T = T & " 5*5-Tiefpassfilter behandelt." & vbCrLf T = T & vbCrLf T = T & "POINTSIGN " & vbTab & "p() " & vbCrLf T = T & vbCrLf T = T & " Punktsignatur aus Sekundäroperand auf Position (p(1),p(2)) zeichnen." & vbCrLf T = T & " Es erfolgt intelligente Freistellung der Punktsignatur mit Saumbreite BRUSHSIZE" & vbCrLf T = T & " (max. 20), mit Transparenz BRUSHOPACITY und Schärfe BRUSHSTRENGTH." & vbCrLf T = T & vbCrLf T = T & "CROSSOPEN " & vbTab & "channel" & vbCrLf T = T & "CROSSSET " & vbTab & "p()" & vbTab & "n " & vbTab & "channel" & vbCrLf T = T & "CROSSCLEAR" & vbTab & "n " & vbTab & "channel" & vbCrLf T = T & "CROSSCLOSE" & vbTab & "channel" & vbCrLf T = T & "CROSSABORT" & vbTab & "channel" & vbCrLf T = T & vbCrLf T = T & " Passkreuzsystem vorbereiten, Passkreuz zeichnen, Passkreuz löschen, " & vbCrLf T = T & " Passkreuzsystem schließen und dabei alle Passkreuze löschen, Passkreuz-" & vbCrLf T = T & " system ohne Löschungen schließen. Das Passkreuzsystem sorgt dafür, dass" & vbCrLf T = T & " Passkreuze nicht nur gesetzt, sondern auch gelöscht werden können." & vbCrLf T = T & " Passkreuze werden immer schwarz/weiß gezeichnet. Es bedeuten:" & vbCrLf T = T & vbCrLf T = T & " p() " & vbTab & "Passkreuzposition" & vbCrLf T = T & " n " & vbTab & "Passkreuznummer (1 ... " & MAX_NUMBER_OF_PASSPOINTS & ")" & vbCrLf T = T & " channel " & vbTab & "eine Kanalnummer (1 oder 2)" & vbCrLf T = T & vbCrLf T = T & "IMAGENEW " & vbTab & "x " & vbTab & "y " & vbTab & "z " & vbTab & "»radtype«" & vbCrLf T = T & "IMAGESET " & vbTab & "»name«" & vbTab & "v* " & vbCrLf T = T & vbCrLf T = T & " IMAGENEW erzeugt ein neues Bild der Größe x*y, z Bänder, Farbmodell »radtype« " & vbCrLf T = T & " (RGB, CMYK, MONO). IMAGESET setzt den Bildkopfparameter »name« auf Wert v." & vbCrLf T = T & vbCrLf T = T & " x " & vbTab & "Bildspaltenzahl" & vbCrLf T = T & " y " & vbTab & "Bildzeilenzahl" & vbCrLf T = T & " z " & vbTab & "Bildkanalzahl" & vbCrLf T = T & " »radtype« " & vbTab & "Bildradiotyp=Farbmodell (MONO, RGB, CMYK, XY)" & vbCrLf T = T & " »name« " & vbTab & "Name eines Fixbild-Kopfparameters, z. B. IMGDTYP, GEOSWPX, GEOSWPY," & vbCrLf T = T & " " & vbTab & "GEONEPX, GEONEPY, GEONUNI, GEOSCAX, GEOSCAY, RADMODE," & vbCrLf T = T & " " & vbTab & "RADWLEV, RADBLEV und einige mehr - immer 7 Zeichen lang." & vbCrLf T = T & " " & vbTab & "Siehe hierzu die Fixlib-Dokumentation." & vbCrLf T = T & " v* " & vbTab & "Wert, auf den der angegebene Parameter gesetzt wird." & vbCrLf T = T & vbCrLf T = T & "INIT" & vbCrLf T = T & vbCrLf T = T & " Initialisieren" & vbCrLf T = T & vbCrLf T = T & "SET" & vbTab & "»name«" & vbTab & "wert" & vbCrLf T = T & vbCrLf T = T & " Setzt globale Parameter des SET mit dem Namen »name« auf den Wert wert." & vbCrLf T = T & " Beispiel: SET PENSIZE 10 setzt den Stiftdurchmesser PENSIZE auf 10 Pixel" & vbCrLf T = T & vbCrLf T = T & "SHOW" & vbCrLf T = T & vbCrLf T = T & " Bild visualisieren" & vbCrLf T = T & vbCrLf T = T & "STOP" & vbTab & "»message«" & vbCrLf T = T & vbCrLf T = T & " Plot mit Mitteilung »message« unterbrechen" & vbCrLf T = T & vbCrLf T = T & "REM" & vbTab & "»kommentar«" & vbCrLf T = T & " " & vbCrLf T = T & " Kommentar" & vbCrLf T = T & " " & vbCrLf T = T & "3. GLOBALE PARAMETER DES SET" & vbCrLf T = T & "----------------------------" & vbCrLf T = T & vbCrLf T = T & " Globalen Parameter stehen im Hintergrund bereit und werden durch den" & vbCrLf T = T & " den Befehl SET gesetzt." & vbCrLf T = T & vbCrLf T = T & " BRUSHMODE " & vbTab & "Pinselmodus. 0=quadratisch, 1=rund." & vbCrLf T = T & " BRUSHOPACITY " & vbTab & "Pinseldeckung. 1 ... 100" & vbCrLf T = T & " BRUSHSIZE " & vbTab & "Pinselgrösse. 0 ... " & MAX_BRUSH_SIZE & " (generierungsabhängig)" & vbCrLf T = T & " BRUSHSTRENGTH " & vbTab & "Pinselhärte. 1 ... 100" & vbCrLf T = T & " COORDMODE " & vbTab & "Koordinatenmodus. 0=Image-, 1=Geo-, 2=Kartenkoord." & vbCrLf T = T & " PENSIZE " & vbTab & "Stiftgrösse. 0 ... " & MAX_PEN_SIZE & " (generierungsabhängig)" & vbCrLf T = T & " PENSIZEAUX " & vbTab & "Aux-Stiftgrösse. 0 ... " & MAX_PEN_SIZE & " (generierungsabhängig)" & vbCrLf T = T & " STRAIN " & vbTab & "Standardspannung von Bézierkurven (20 ... 80)" & vbCrLf T = T & " TEXTMODE " & vbTab & "Textstärke. 0=normal, 1*1, 1=fett, 3*3." & vbCrLf T = T & " TEXTSHIFT " & vbTab & "Textschriftgrösse. 1 ... 10." & vbCrLf T = T & " TEXTSIZE " & vbTab & "Textverschiebung (2 Elemente: x/y)" & vbCrLf T = T & " TEXTVALUE " & vbTab & "Grauwert für TEXT und SIGN (Ein Zahlenfeld)." & vbCrLf T = T & vbCrLf T = T & vbCrLf T = T & "4. DIE ZEICHENSPITZEN" & vbCrLf T = T & "---------------------" & vbCrLf T = T & vbCrLf T = T & " Es gibt acht Zeichenspitzen: das Pixel, das Fettpixel, den Stift (Pen) mit der " & vbCrLf T = T & " Untervarietät Aux-Stift sowie den Pinsel (Brush) mit den drei Untervarietäten " & vbCrLf T = T & " Kopierpinsel (Copybrush), Bildkopierpinsel (Imagecopybrush) und Filterpinsel " & vbCrLf T = T & " (Filterbrush). Der Imagecopybrush kann allerdings nicht über VPA angesteuert werden. " & vbCrLf T = T & vbCrLf T = T & " Die meisten Befehle zeichnen mit dem Stift. Dieser kennt nur einen Parameter," & vbCrLf T = T & " den Stiftdurchmesser PENSIZE und ist immer rund." & vbCrLf T = T & vbCrLf T = T & " Zusätzlich zum Stift gibt es den (dünneren) Aux-Stift mit der Größe PENSIZEAUX. " & vbCrLf T = T & " Mit dieser werden die Innenlinien der Doppelllinien gezeichnet." & vbCrLf T = T & vbCrLf T = T & " Speziell für interaktives Retuschieren gibt es den Pinsel, der komfortabler" & vbCrLf T = T & " ist." & vbCrLf T = T & vbCrLf T = T & " Mit dem Pinsel gezeichnete Punkte variieren in Abhängigkeit von Pinselmodus" & vbCrLf T = T & " Pinselgrösse, Pinselhärte und Pinseldeckfähigkeit. Die entsprechen Parameter" & vbCrLf T = T & " BRUSHMODE, BRUSHSIZE, BRUSHSTRENGTH und BRUSHOPACITY werden mit dem Befehl SET" & vbCrLf T = T & " eingestellt. Das gilt auch für Kopierpinsel und Filterpinsel. " & vbCrLf T = T & vbCrLf T = T & " Das Pixel zeichnet genau ein Pixel. Das Fettpixel zeichnet ein kleines 3*3-Pixel-" & vbCrLf T = T & " Quadrat. Mit Pixel/Fettpixel zeichen die Befehle PIXEL, FATPIXEL, SIGN und TEXT." & vbCrLf T = T & vbCrLf T = T & vbCrLf T = T & "5. SONDERCODES FÜR TEXT UND SIGN" & vbCrLf T = T & "--------------------------------" & vbCrLf T = T & vbCrLf T = T & " Die Ascii-Codes unter 32 können in SIGN und TEXT folgende kleine Sonder-" & vbCrLf T = T & " zeichen plotten:" & vbCrLf T = T & vbCrLf T = T & " 0 ... Leerzeichen" & vbCrLf T = T & " 1 ... Kleiner Punkt" & vbCrLf T = T & " 2 ... Mittlerer Punkt" & vbCrLf T = T & " 3 ... Großer Punkt" & vbCrLf T = T & " 4 ... Passkreuz" & vbCrLf T = T & " 5 ... Andreaskreuz" & vbCrLf T = T & " 6 ... Kreis" & vbCrLf T = T & " 7 ... Quadrat" & vbCrLf T = T & " 8 ... Kreis mit Punkt" & vbCrLf T = T & " " & vbCrLf T = T & " 16 ... Raute" & vbCrLf T = T & " 17 ... Dreieck" & vbCrLf T = T & " 18 ... Passpunkt-Mire" & vbCrLf T = T & " 19 ... Passpunkt-Mire (fett/Hintergrund)" & vbCrLf T = T & " 20 ... Ligatur »10«" & vbCrLf T = T & " 21 ... Ligatur »11«" & vbCrLf T = T & " 22 ... Ligatur »12«" & vbCrLf T = T & vbCrLf T = T & "Stand: 31.01.2020" & vbCrLf T = T & vbCrLf T = T & "[Ende der Dokumentation Vector Plot Assembler VPA. ]" & vbCrLf PLGHelpText = T End Sub Rem Rem Z W I S C H E N S C H I C H T Rem ============================= Rem Sog. Common-Routinen, diese stehen zwischen dem Driver und der oberen Schicht. Rem Rem COMMON LINE: LINIE MALEN Rem ======================== Public Sub SUBPltCommonLine(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, z() As Single, Optional IsRaw As Boolean, Optional IsAux As Boolean) Rem Rem SUBPltCommonLine plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) mit dem Pen. Rem Der Grauwert der Linie ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltCommonLine ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag wird das Linienskelett gezeichnet. Rem Dim sx As Double ' Schreib-Rohkoord Dim sy As Double Dim wx As Double Dim wy As Double Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim oc(1 To 2) As Double ' Old Schreib-Bildkoord Dim wc(1 To 2) As Double ' Arbeits-Bildkoord Dim i As Long Dim c As Long Dim length As Double Dim steps As Double Dim incx As Double ' Inkremente Dim incy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe Dim incz() As Single Dim PIXX As Double Dim PIXY As Double Dim pixsize As Double Dim pixmiddle As Double If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub sx = P1(1) ' Start-X sy = P1(2) ' Start-Y If sx > 2000000000 Then sx = 2000000000 If sy > 2000000000 Then sy = 2000000000 If sx < -2000000000 Then sx = -2000000000 If sy < -2000000000 Then sy = -2000000000 Rem Grauwert übernehmen Call VIMAGEValueCopy(z, zs) ReDim incz(1 To UBound(zs)) Rem Schrittweite auf length berechnen Select Case PLTCoordMode Case 0: pixsize = 1 Case 1: Call FIXCoordGetPixelSize(RMHD(n1), PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist Case 2: Call FIXCoordGetParameters(RMHD(n1), , , , , , , , , PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist End Select If pixsize = 0 Then pixsize = 0.0000001 ' Nulldivisor length = Sqr((P1(1) - P2(1)) ^ 2 + (P1(2) - P2(2)) ^ 2) ' Länge der Linie im Geomaß steps = length / pixsize ' Pixelanzahl auf der Linie im Pixelmaß steps = steps * 5 ' zur Sicherheit Punkte etwas dichter If steps = 0 Then steps = 1 Rem Inkremente setzen If steps = 0 Then steps = 0.0000001 If steps > 1000000 Then steps = 1000000 incx = (P2(1) - P1(1)) / steps incy = (P2(2) - P1(2)) / steps For c = 1 To UBound(incz) ' incz(c) = (z2(c) - z1(c)) / steps ' Alter Code als es noch 2 z gab ... incz(c) = 0 ' Jetzt so Next c Rem Linie initialisieren Select Case PLTCoordMode Case 0: ' Bildkoordinaten oc(1) = CLng(sx): oc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, oc(1), oc(2)) Case 2: ' Kartenkoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, oc(1), oc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, oc(1), oc(2)) End Select If PLGSkelettFlag = True Then If IsMissing(IsRaw) = False Then If IsRaw = False Then Call SUBPltPhysSkelettText(LM1, oc, Chr(4), PLGSkelettValue) End If End If End If Rem Linie generieren For i = 0 To steps ' Linie Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select If PLGSkelettFlag = False Then If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' wenn ungültig sind si/sj -9999 If i = 0 Then Call SUBPltPhysPen(LM1, sc, zs, False, IsAux) ' Init-Punkt malen Else Call SUBPltPhysPen(LM1, sc, zs, True, IsAux) ' Draw-Punkt malen End If If oc(1) <> sc(1) And oc(2) <> sc(2) Then ' Wenn Diagonalversatz (Achternachbarschaft!) dann wc(1) = sc(1): wc(2) = oc(2) ' Punkt so setzen, Call SUBPltPhysPixel(LM1, wc, zs) ' dass Vierernachbarchaft gewährleistet End If End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) ' Skelettpixel End If oc(1) = sc(1) oc(2) = sc(2) sx = sx + incx sy = sy + incy Next i If PLGSkelettFlag = True Then If IsMissing(IsRaw) = False Then If IsRaw = False Then Call SUBPltPhysSkelettText(LM1, sc, Chr(4), PLGSkelettValue) End If End If End If End Sub Rem Rem D R I V E R R O U T I N E N -- U N T E R E S C H I C H T D E S Z E I C H N E N S Rem ========================================================================================== Rem Rem Die Driverroutinen realisieren den tatsächlichen Zugriff auf die Bilddaten. Rem Rem Hierzu werden sogenannte Schreibspitzen bereitgestellt. Diese kapseln einen gewissen Rem Zeichenkomfort; ausserdem werden überschriebene Bildpunkte in einem Undo-Speicher Rem gerettet und können so wiederhergestellt werden. Rem Rem Schreibspitzen (aus Anwendersicht) ... Rem Rem Das Pixel, welches wirklich nur ein Pixel ist; Rem Das Fatpixel, welches eine kleine 3*3-Pixelmatrix ist; Rem Der Stift oder Pen, welcher mit einer undurchsichtigen scharf begrenzten Kreisscheibe schreibt; Rem Der Pinsel oder Brush, der mit einer Kreisscheibe oder einem Quadrat schreibt; diese können auch Rem unscharf oder teilweise durchsichtig sein. Rem Rem Aus Programmsicht ... Rem Rem ... gibt es noch weitere Schreibspitzen, insgesamt ... Rem Rem Das HardPixel ist ein direkte Bildspeicherzugriff ohne Driver. Dabei erfolgt keine Rem Rückgängig-Sicherung. Achtung, das muss dan vom Programmierer selbst Rem organisiert werden. Die Crossbefehle arbeiten hart. Rem Das Pixel ist das Pixel. Ab hier stets weich, d. h. mit Driver, d. h. es erfolgt Rem Rückgängigsicherung. Rem Das FastPixel schreibt ebenfalls ein einziges Pixel, dies aber besonders schnell. Rem Der FatPixel ist das FatPixel (die 3*3-Pixelmatrix), Rem Die SkelLine malt eine Linie mit der Linienstärke 1, Rem Das SkelSign malt ein Zeichen pixelsweise, Rem Der Pen schreibt einen Kreis der Größe PENSIZE. Er hat zwei „Sub-Zeichenspitzen“, Rem den InitPen, dieser malt eine Kreisfläche und den DrawPen, dieser malt Rem nur einen Kreisumfang. Indem ein erster Punkt einer Linie mit dem InitPen, Rem alle weiteren Punkte der Linie aber mit dem DrawPen geschrieben werden, Rem lässt sich Speicher und Rechenzeit sparen. Rem Gleichzeitig werden mit dem Pen noch zwei weitere Zeichenspitzen mit der Rem Größe PENSIZEAUX generiert, der InitPenAux und der DrawPenAux, Rem diese dienen dem Pendouble. Rem Der Pendouble (Projekt für Doppelllinien, es wird zweimal mit dem Pen gezeichnet, Rem einmal mit PENSIZE, einmal mit PENSIZEAUX.) Rem Der Brush schreibt eine Form (Kreis oder Quadrat) mit einer gewissen Größe Unschärfe und Rem Durchsichtigkeit entsprechen den vier Set-parametern BRUSHMODE, BRUSHSIZE, Rem BRUSHOPACITY und BRUSHSTRENGTH. Rem Der Copybrush ist wie der Brush parametriert, er schreibt aber nicht mit festem Grauwert, Rem sondern er liest und schreibt ins Bild um eine gewisse Strecke versetzt. Rem (Kopierpinselfunktion für Retuschen) Rem Der Imagecopy- ähnelt Brush und Copybrush, überträgt aber Grauwerte lagetreu aus dem Rem brush Sekundäroperanden in das Zielbild. Rem Der Filterbrush ist wie der Brush parametriert, schreibt aber nicht mit festem Grauwert, sondern Rem macht Grauwert mit 5*5-Gaußfilter unschärfer. Rem Das Punktsign welches seine Zeichenspitze selbst (intelligent freistellend) organisiert. Rem Rem Rem NEUE STIFTSPITZE GENERIEREN Rem --------------------------- Public Sub SUBPltPhysGenerateNewPen() Rem Rem SUBPltPhysNewPen erzeugt einen neuen Pen anhand der Rem Plotglobalen PENSIZE und PENSIZEAUX. Rem Rem Pen erzeugen heisst svw. 4 neue PenCodeListen zu erzeugen. Rem Rem Es gibt 2 Pencodelisten, eine für den ersten Punkt (die Init-List) Rem und eine für folgende Punkte auf Linien (die Draw-List). Die Draw-List Rem malt hohle Kreise, so geht es schneller. Die Stiftgröße ist PENSIZE. Zwei Rem weitere (zusätzliche, Aux-) Listen werden mit der Stiftgröße PENSIZEAUX gebildet. Rem Rem Die vier Listen sind (f,t)-Felder, wobei t alle Punkte, die der Pen in Rem der Umgebung eines Zeichenpunktes beschreiben soll indiziert. Rem Der 1. Index f läuft von 1 bis 2, f=1=x-Verschiebung, Rem f=2=y-Verschiebung. Rem Rem Bildspeicherbenutzung: Rem Rem RM26: Stiftspitze voll Rem RM27: Stiftspitze hohl Rem Dim i As Long Dim j As Long Dim tstS As String Dim Counter As Double Dim SizeHalbeA As Long Dim SizeHalbeB As Long Dim P0(1 To 2) As Double ' Base Dim P1(1 To 2) As Double Dim P2(1 To 2) As Double Dim p8(1 To 2) As Double Dim q0(1 To 2) As Double ' Aux Dim q1(1 To 2) As Double Dim q2(1 To 2) As Double Dim Q8(1 To 2) As Double Dim z(1 To 1) As Single Dim R1 As Double ' Base Radius Dim s1 As Double ' Aux Radius Dim WMiddle As Long ' Fenstermitte Dim WMiddleAux As Long ' Fenstermitte Dim tmpPenInitCodeList() As Integer Dim tmpPenDrawCodeList() As Integer Dim tmpPenIAuxCodeList() As Integer Dim tmpPenDAuxCodeList() As Integer Dim PenInitCodeListPointer As Long ' Zeiger in die PenInitCodeList Dim PenDrawCodeListPointer As Long ' Zeiger in die PenDrawCodeList Dim PenIAuxCodeListPointer As Long ' Zeiger in die PenIAuxCodeList Dim PenDAuxCodeListPointer As Long ' Zeiger in die PenDAuxCodeList Dim tmpPenSize As Double Dim tmpUndoIsActive As Boolean Dim tmpCoordMode As Long Dim tmpBoolean As Double Rem Abbrechen? 'If PLXPenGenerationIsInProc = True Then Exit Sub 'PLXPenGenerationIsInProc = True Rem VORBEREITEN Rem 1. Bei PENSIZE 0 Stift ganz ausschalten If PLTPenSize = 0 Then ' Bei Pensize 0 Stift ausschalten ReDim PLXPenInitCodeList(1 To 2, 0 To 0) ReDim PLXPenDrawCodeList(1 To 2, 0 To 0) ReDim PLXPenIAuxCodeList(1 To 2, 0 To 0) ' Wenn PENSIZE=0, dann ist auch PENSIZEAUX 0 ReDim PLXPenDAuxCodeList(1 To 2, 0 To 0) HF.Text2.Text = "Plotdriver: Stiftgröße 0 = Stift ausgeschaltet" HF.Text2.Refresh Exit Sub End If Rem 2. Stiftgrößen hart auf 400 begrenzen If PLTPenSize > 400 Then PLTPenSize = 400 WMiddle = PLTPenSize If PLTPenSizeAux > 400 Then PLTPenSizeAux = 400 WMiddleAux = PLTPenSizeAux Rem 3. Arbeitsbildspeicher reservieren RMIsInUse(26) = True Call FIXHdrInit(RMHD(26), 2 * WMiddle, 2 * WMiddle, 1, 1, "FIXPOINT") RMFn(26) = "" Call FIXMatClear(RMHD(26), RM26(), VIMAGENullValue, HF.Text2, HF.ProgressBar1) RMHD(26).RadWLev = 0 RMHD(26).RadBLev = 100 RMIsInUse(27) = True Call FIXHdrInit(RMHD(27), 2 * WMiddle, 2 * WMiddle, 1, 1, "FIXPOINT") RMFn(27) = "" Call FIXMatClear(RMHD(27), RM27(), VIMAGENullValue, HF.Text2, HF.ProgressBar1) RMHD(27).RadWLev = 0 RMHD(27).RadBLev = 100 Rem 4. Div. Größen berechnen Rem Größe der Urform ermitteln; Urform ist ein Kreis mit Radius Rem WMiddle/2 mittig in einem Bild mit der Seitenlänge 2*WMiddle (bzw.WMiddleAux) P0(1) = WMiddle ' für Base Pass P0(2) = WMiddle P1(1) = WMiddle + 1 P1(2) = WMiddle P2(1) = WMiddle P2(2) = WMiddle + 1 p8(1) = WMiddle + 1 p8(2) = WMiddle + 1 R1 = WMiddle * 0.5 q0(1) = WMiddleAux ' für Aux Pass q0(2) = WMiddleAux q1(1) = WMiddleAux + 1 q1(2) = WMiddleAux q2(1) = WMiddleAux q2(2) = WMiddleAux + 1 Q8(1) = WMiddleAux + 1 Q8(2) = WMiddleAux + 1 s1 = WMiddleAux * 0.5 z(1) = 100 Rem 5. Circle braucht rudimentären Codelisten ReDim PLXPenInitCodeList(1 To 2, 0 To 1) ' GenerateNewPen braucht eine rudimentäre CodeList PLXPenInitCodeList(1, 1) = 0 PLXPenInitCodeList(2, 1) = 0 ReDim PLXPenDrawCodeList(1 To 2, 0 To 1) ' GenerateNewPen braucht eine rudimentäre CodeList PLXPenDrawCodeList(1, 1) = 0 PLXPenDrawCodeList(2, 1) = 0 Rem BASE PASS: DIE BEIDEN GEWÖHNLICHEN LISTEN GENERIEREN PLXPenIsChanged = False ' verhindern, daß der Pen GenerateNewPen ruft Rem 1. Zwei Urformen Base malen Select Case PLTPenSize Case 1: ' Size 1 zu Fuß RM26(P0(1), P0(2), 1) = z(1) RM27(P0(1), P0(2), 1) = z(1) Case 2: ' Size 2 zu Fuß RM26(P0(1), P0(2), 1) = z(1) RM27(P0(1), P0(2), 1) = z(1) RM26(P1(1), P1(2), 1) = z(1) RM27(P1(1), P1(2), 1) = z(1) RM26(P2(1), P2(2), 1) = z(1) RM27(P2(1), P2(2), 1) = z(1) RM26(p8(1), p8(2), 1) = z(1) RM27(p8(1), p8(2), 1) = z(1) Case Else: ' Size>2: Kreise malen tmpCoordMode = PLTCoordMode ' retten tmpUndoIsActive = PUNIsActive PLXPenIsChanged = False PUNIsActive = False ' temporär Undo aus (sonst rettet er den Pen und macht ihn bei undo neu) PLTCoordMode = 0 ' temporär setzen Call SUBPltCircle(RM26, 26, P0, R1, z, z) ' Vollkreis für den Initpen Call SUBPltCircle(RM27, 27, P0, R1, z, VIMAGEEmptyValue) ' Hohlkreis für den DrawPen Call SUBPltCircle(RM27, 27, P0, R1 - 0.25, z, VIMAGEEmptyValue) ' etwas kleinerer Hohklkreis für den DrawPen 'Call PICShow(26) ' TEST 'Call MsgBox("26 gen base") 'Call PICShow(27) 'Call MsgBox("27 gen base") PLTCoordMode = tmpCoordMode ' wiederherstellen PUNIsActive = tmpUndoIsActive End Select Rem 2. Die beiden Base Pen in die Codelisten »einsammeln« PenInitCodeListPointer = 1 ReDim tmpPenInitCodeList(1 To 2, 0 To 160000) ' Achtung: das beschränkt maximale PENSIZEs auf 400! For i = 1 To 2 * WMiddle For j = 1 To 2 * WMiddle If (RM26(i, j, 1) <> 0) Then tmpPenInitCodeList(1, PenInitCodeListPointer) = i - (WMiddle) tmpPenInitCodeList(2, PenInitCodeListPointer) = j - (WMiddle) PenInitCodeListPointer = PenInitCodeListPointer + 1 End If Next j Next i PenDrawCodeListPointer = 1 ReDim tmpPenDrawCodeList(1 To 2, 0 To 160000) For i = 1 To 2 * WMiddle For j = 1 To 2 * WMiddle If (RM27(i, j, 1) <> 0) Then tmpPenDrawCodeList(1, PenDrawCodeListPointer) = i - (WMiddle) tmpPenDrawCodeList(2, PenDrawCodeListPointer) = j - (WMiddle) PenDrawCodeListPointer = PenDrawCodeListPointer + 1 End If Next j Next i Rem AUX PASS: DIE BEIDEN AUX-LISTEN GENERIEREN Rem Bildspeicher neu initialisieren RMIsInUse(26) = True Call FIXHdrInit(RMHD(26), 2 * WMiddleAux, 2 * WMiddleAux, 1, 1, "FIXPOINT") RMFn(26) = "" Call FIXMatClear(RMHD(26), RM26(), VIMAGENullValue, HF.Text2, HF.ProgressBar1) RMHD(26).RadWLev = 0 RMHD(26).RadBLev = 100 RMIsInUse(27) = True Call FIXHdrInit(RMHD(27), 2 * WMiddleAux, 2 * WMiddleAux, 1, 1, "FIXPOINT") RMFn(27) = "" Call FIXMatClear(RMHD(27), RM27(), VIMAGENullValue, HF.Text2, HF.ProgressBar1) RMHD(27).RadWLev = 0 RMHD(27).RadBLev = 100 PLXPenIsChanged = False ' verhindern, daß der Pen GenerateNewPen ruft Rem 1. Urform Aux in Arbeitsbildspeicher malen Select Case PLTPenSizeAux Case 1: ' Size 1 zu Fuß RM26(q0(1), q0(2), 1) = z(1) RM27(q0(1), q0(2), 1) = z(1) Case 2: ' Size 2 zu Fuß RM26(q0(1), q0(2), 1) = z(1) RM27(q0(1), q0(2), 1) = z(1) RM26(q1(1), q1(2), 1) = z(1) RM27(q1(1), q1(2), 1) = z(1) RM26(q2(1), q2(2), 1) = z(1) RM27(q2(1), q2(2), 1) = z(1) RM26(Q8(1), Q8(2), 1) = z(1) RM27(Q8(1), Q8(2), 1) = z(1) Case Else: ' Size>2: Kreise malen tmpCoordMode = PLTCoordMode ' retten tmpUndoIsActive = PUNIsActive PLXPenIsChanged = False PUNIsActive = False ' temporär Undo aus (sonst rettet er den Pen und macht ihn bei undo neu) PLTCoordMode = 0 ' temporär setzen Call SUBPltCircle(RM26, 26, q0, s1, z, z) ' Vollkreis für den Initpen Call SUBPltCircle(RM27, 27, q0, s1, z, VIMAGEEmptyValue) ' Hohlkreis für den DrawPen Call SUBPltCircle(RM27, 27, q0, s1 - 0.25, z, VIMAGEEmptyValue) ' etwas kleinerer Hohklkreis für den DrawPen 'Call PICShow(26) ' TEST 'Call MsgBox("26 gen aux") 'Call PICShow(27) 'Call MsgBox("27 gen aux") PLTCoordMode = tmpCoordMode ' wiederherstellen PUNIsActive = tmpUndoIsActive End Select Rem 2. Die beiden Aux Pen die Codelisten »einsammeln« PenIAuxCodeListPointer = 1 ReDim tmpPenIAuxCodeList(1 To 2, 0 To 160000) ' Achtung: das beschränkt maximale PENSIZEAUXs auf 400! For i = 1 To 2 * WMiddleAux For j = 1 To 2 * WMiddleAux If (RM26(i, j, 1) <> 0) Then tmpPenIAuxCodeList(1, PenIAuxCodeListPointer) = i - (WMiddleAux) tmpPenIAuxCodeList(2, PenIAuxCodeListPointer) = j - (WMiddleAux) PenIAuxCodeListPointer = PenIAuxCodeListPointer + 1 End If Next j Next i PenDAuxCodeListPointer = 1 ReDim tmpPenDAuxCodeList(1 To 2, 0 To 160000) For i = 1 To 2 * WMiddleAux For j = 1 To 2 * WMiddleAux If (RM27(i, j, 1) <> 0) Then tmpPenDAuxCodeList(1, PenDAuxCodeListPointer) = i - (WMiddleAux) tmpPenDAuxCodeList(2, PenDAuxCodeListPointer) = j - (WMiddleAux) PenDAuxCodeListPointer = PenDAuxCodeListPointer + 1 End If Next j Next i Rem ENDE Rem Temporärlisten kürzen und global umkopieren ReDim Preserve tmpPenInitCodeList(1 To 2, 0 To PenInitCodeListPointer) ReDim Preserve tmpPenDrawCodeList(1 To 2, 0 To PenDrawCodeListPointer) ReDim Preserve tmpPenIAuxCodeList(1 To 2, 0 To PenIAuxCodeListPointer) ReDim Preserve tmpPenDAuxCodeList(1 To 2, 0 To PenDAuxCodeListPointer) PLXPenInitCodeList = tmpPenInitCodeList PLXPenDrawCodeList = tmpPenDrawCodeList PLXPenIAuxCodeList = tmpPenIAuxCodeList PLXPenDAuxCodeList = tmpPenDAuxCodeList Rem 2. Arbeitsbildspeicher wiederfreigeben If VIMAGETest = False Then Call DIPFree(RM26(), 26) Call DIPFree(RM27(), 27) End If HF.Text2.Text = "Plotdriver: Stiftspitze mit " & PenInitCodeListPointer & "/" & PenDrawCodeListPointer & " (Aux: " & PenIAuxCodeListPointer & "/" & PenDAuxCodeListPointer & ") Punkten neu generiert ..." HF.Text2.Refresh PLXPenGenerationIsInProc = False End Sub Rem Rem NEUE PINSELSPITZE GENERIEREN Rem ---------------------------- Public Sub SUBPltPhysGenerateNewBrush() Rem Rem SUBPltPhysNewBrush erzeugt einen neuen Brush anhand der Rem 4 Plotglobals BRUSHSIZE, BRUSHMODE, BRUSHSTRENGTH, BRUSHOPACITY. Rem Rem Brush erzeugen heisst svw. eine neue Brushcodelist erzeugen. Rem Rem Die BrushCodeList PLXBrushCodeList ist ein (f,t)-Feld, wobei t Rem alle Punkte, die der Brush in der Umgebung eines Zeichenpunktes beschreiben Rem soll indiziert. Der 1. Index f läuft von 1 bis 3, f=1=x-Verschiebung, Rem f=2=y-Verschiebung, f=3=Transparenz (0 bis 100). Rem Rem Benutzte Arbeitsbildspeicher: Rem Rem 25, 26, 27, 28 Rem Rem PhysGenerateNewBrush nutzt den Pen und darf deshalb die Rem von PhysGenerateNewPen benutzten 4 Bildspeicher 26, 27 Rem nicht während der Pen-Rufe benutzen. Rem Dim i As Long Dim j As Long Dim valu As Single Dim tstS As String Dim Counter As Double Dim SizeHalbeA As Long Dim SizeHalbeB As Long Dim P0(1 To 2) As Double Dim P1(1 To 2) As Double Dim P2(1 To 2) As Double Dim R1 As Double Dim z(1 To 1) As Single Dim BrushFIRFilterA(1 To 3, 1 To 3) As Single ' Das ist ein 1/8-starker 3*3-Gaußfilter BrushFIRFilterA(1, 1) = 1 / 128 BrushFIRFilterA(2, 1) = 2 / 128 BrushFIRFilterA(3, 1) = 1 / 128 BrushFIRFilterA(1, 2) = 2 / 128 BrushFIRFilterA(2, 2) = 116 / 128 BrushFIRFilterA(3, 2) = 2 / 128 BrushFIRFilterA(1, 3) = 1 / 128 BrushFIRFilterA(2, 3) = 2 / 128 BrushFIRFilterA(3, 3) = 1 / 128 Dim BrushFIRFilterV(1 To 3, 1 To 3) As Single ' Das ist ein 1/4-starker 3*3-Gaußfilter BrushFIRFilterV(1, 1) = 1 / 64 BrushFIRFilterV(2, 1) = 2 / 64 BrushFIRFilterV(3, 1) = 1 / 64 BrushFIRFilterV(1, 2) = 2 / 64 BrushFIRFilterV(2, 2) = 52 / 64 BrushFIRFilterV(3, 2) = 2 / 64 BrushFIRFilterV(1, 3) = 1 / 64 BrushFIRFilterV(2, 3) = 2 / 64 BrushFIRFilterV(3, 3) = 1 / 64 Dim BrushFIRFilterH(1 To 3, 1 To 3) As Single ' Das ist ein 1/2-starker 3*3-Gaußfilter BrushFIRFilterH(1, 1) = 1 / 32 BrushFIRFilterH(2, 1) = 2 / 32 BrushFIRFilterH(3, 1) = 1 / 32 BrushFIRFilterH(1, 2) = 2 / 32 BrushFIRFilterH(2, 2) = 20 / 32 BrushFIRFilterH(3, 2) = 2 / 32 BrushFIRFilterH(1, 3) = 1 / 32 BrushFIRFilterH(2, 3) = 2 / 32 BrushFIRFilterH(3, 3) = 1 / 32 Dim BrushFIRFilter(1 To 3, 1 To 3) As Single ' Das ist ein 100-%-starker 3*3-Gaußfilter BrushFIRFilter(1, 1) = 1 / 16 BrushFIRFilter(2, 1) = 2 / 16 BrushFIRFilter(3, 1) = 1 / 16 BrushFIRFilter(1, 2) = 2 / 16 BrushFIRFilter(2, 2) = 4 / 16 BrushFIRFilter(3, 2) = 2 / 16 BrushFIRFilter(1, 3) = 1 / 16 BrushFIRFilter(2, 3) = 2 / 16 BrushFIRFilter(3, 3) = 1 / 16 Dim BrushFIRFilter2(1 To 1, 1 To 5) As Single ' Das ist ein 200-%-starker 3*3-Gaußfilter, kaskadiert BrushFIRFilter2(1, 1) = 1 / 16 BrushFIRFilter2(1, 2) = 4 / 16 BrushFIRFilter2(1, 3) = 6 / 16 BrushFIRFilter2(1, 4) = 4 / 16 BrushFIRFilter2(1, 5) = 1 / 16 Dim BrushFIRFilter4(1 To 1, 1 To 9) As Single ' Das ist ein 400-%-starker 3*3-Gaußfilter, kaskadiert BrushFIRFilter4(1, 1) = 1 / 256 BrushFIRFilter4(1, 2) = 8 / 256 BrushFIRFilter4(1, 3) = 28 / 256 BrushFIRFilter4(1, 4) = 56 / 256 BrushFIRFilter4(1, 5) = 70 / 256 BrushFIRFilter4(1, 6) = 56 / 256 BrushFIRFilter4(1, 7) = 28 / 256 BrushFIRFilter4(1, 8) = 8 / 256 BrushFIRFilter4(1, 9) = 1 / 256 Dim BrushCodeListPointer As Long ' Zeiger in die PLXBrushCodeList Dim WMiddle As Long ' Fenstermitte Dim tmpPenSize As Long Dim tmpBrushSize As Double Dim tmpUndoIsActive As Boolean Dim tmpCoordMode As Long Rem Abbrechen? If PLXBrushGenerationIsInProc = True Then Exit Sub PLXBrushGenerationIsInProc = True Rem Bei Brushsize 0 Stift ausschalten If PLTBrushSize = 0 Then ReDim PLXBrushCodeList(1 To 3, 0 To 0) ReDim PLXBrushCodeList(1 To 3, 0 To 0) HF.Text2.Text = "Plotdriver: Pinselgröße 0 = Pinsel ausgeschaltet" HF.Text2.Refresh Exit Sub End If Rem Arbeitsbildspeicher reservieren If PLTBrushSize > 400 Then PLTBrushSize = 400 WMiddle = PLTBrushSize * 2 RMIsInUse(25) = True Call FIXHdrInit(RMHD(25), 2 * WMiddle, 2 * WMiddle, 1, 1, "FIXPOINT") RMFn(25) = "" Call FIXMatClear(RMHD(25), RM25(), VIMAGENullValue, HF.Text2, HF.ProgressBar1) Call SUBRestAussenrand(RM25(), 25, 0, 0, 16) RMHD(25).RadWLev = 0 RMHD(25).RadBLev = 100 Rem Für spätere Unschärfefilterung evtl. verkleinern tmpBrushSize = PLTBrushSize If PLTBrushSize > MAX_BRUSH_SIZE Then tmpBrushSize = MAX_BRUSH_SIZE tmpBrushSize = tmpBrushSize tmpBrushSize = tmpBrushSize + tmpBrushSize * (PLTBrushStrength / 100) tmpBrushSize = tmpBrushSize / 2 Rem Größe der Urform ermitteln SizeHalbeA = CInt(tmpBrushSize - 0.2) \ 2 ' z. B. 3 -> 2.8 -> 1.4 -> 1 4 -> 3.8 -> 1.9 -> 2 SizeHalbeB = Fix(tmpBrushSize - 0.2) \ 2 ' z. B. 3 -> 2.8 -> 1.4 -> 1 4 -> 3.8 -> 1.9 -> 1 P0(1) = WMiddle P0(2) = WMiddle P1(1) = WMiddle - SizeHalbeA P1(2) = WMiddle - SizeHalbeA P2(1) = WMiddle + SizeHalbeB P2(2) = WMiddle + SizeHalbeB R1 = SizeHalbeB z(1) = 100 ' Gleich Prozente Rem Urform in Arbeitsbildspeicher malen tmpCoordMode = PLTCoordMode ' retten tmpPenSize = PLTPenSize tmpUndoIsActive = PUNIsActive PUNIsActive = False PLTCoordMode = 0 ' temporär auf Bildkoord setzen Call SUBPltSet("PENSIZE", 1) ' Und Stiftgröße 1 PLXBrushIsChanged = False Select Case PLTBrushMode Case 0: Call SUBPltRect(RM25, 25, P1, P2, z, z) ' Rechteck Case 1: Call SUBPltCircle(RM25, 25, P0, R1, z, z) ' Kreis End Select Rem Erst jetzt (nach SUBPLtPect/Circle) dürfen die Bilder 26 und 27 genutzt werden. Call DIPCopy(RM25, 25, RM26, 26) PUNIsActive = tmpUndoIsActive ' wiederherstellen PLTCoordMode = tmpCoordMode Call SUBPltSet("PENSIZE", tmpPenSize) Rem Brush erforderlichenfalls unschärfer machen Rem Counter ist die Anzahl an 100-%-3*3-Gauß-Filtern Counter = (PLTBrushSize - 1) * 2 ' 2 3*3-Gaußfilter sind bei Brushgröße 3*3 100% ... Counter = Counter * (100 - PLTBrushStrength) / 100 While Counter >= 8 ' N-mal zweimalvierfachstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0") Call DIPFirFilterKask(RM26, 26, RM27, 27, BrushFIRFilter4(), 9, 1, 0, 1, True) Call DIPFirFilterKask(RM27, 27, RM26, 26, BrushFIRFilter4(), 9, 1, 0, 1, True) Counter = Counter - 8 Wend If Counter >= 4 Then ' Evtl. noch einmal Vierfachstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilterKask(RM27, 27, RM26, 26, BrushFIRFilter4(), 9, 1, 0, 1, True) Counter = Counter - 4 End If If Counter >= 2 Then ' Evtl. noch einmal doppelstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilterKask(RM27, 27, RM26, 26, BrushFIRFilter2(), 5, 1, 0, 1, True) Counter = Counter - 2 End If If Counter >= 1 Then ' Evtl. noch einmal normalstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilter(RM27, 27, RM26, 26, BrushFIRFilter(), 3, 3, 1, 0) Counter = Counter - 1 End If If Counter >= 0.5 Then ' Evtl. noch einmal halbstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0.0") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilter(RM27, 27, RM26, 26, BrushFIRFilterH(), 3, 3, 1, 0) Counter = Counter - 0.5 End If If Counter >= 0.25 Then ' Evtl. noch ein viertelstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0.00") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilter(RM27, 27, RM26, 26, BrushFIRFilterV(), 3, 3, 1, 0) Counter = Counter - 0.25 End If If Counter >= 0.125 Then ' Evtl. noch ein viertelstarker Filter HF.Text1 = "BRUSH GEN " & Format(Counter, "#0.000") Call DIPCopy(RM26, 26, RM27, 27) Call DIPFirFilter(RM27, 27, RM26, 26, BrushFIRFilterA(), 3, 3, 1, 0) Counter = Counter - 0.25 End If HF.Text1.Text = "" Rem Brush erforderlichenfalls in der Deckung herabsetzen Call DIPCopy(RM26, 26, RM27, 27) Call DIPMultiplikation(RM27, 27, RM28, 28, (PLTBrushOpacity / 100)) Rem Für Test 'Call PICShow(26) If VIMAGETest = True Then Call DIPCopy(RM26, 26, RM13, 13) End If Rem PLXBrushCodeList dimensionieren Rem Weils mit Redim Preserve zu langsam ist, vorab BrushcodeList-Länge bestimmen BrushCodeListPointer = 1 For i = 1 To 2 * WMiddle For j = 1 To 2 * WMiddle If (RM26(i, j, 1) <> 0) Then BrushCodeListPointer = BrushCodeListPointer + 1 End If Next j Next i ReDim PLXBrushCodeList(1 To 3, 0 To BrushCodeListPointer - 1) Rem Punkte einsammeln BrushCodeListPointer = 1 For i = 1 To 2 * WMiddle For j = 1 To 2 * WMiddle If (RM26(i, j, 1) <> 0) Then PLXBrushCodeList(1, BrushCodeListPointer) = i - WMiddle PLXBrushCodeList(2, BrushCodeListPointer) = j - WMiddle valu = RM28(i, j, 1) * 100 If valu > 32767 Then valu = 32767 If valu < -32768 Then valu = -32768 PLXBrushCodeList(3, BrushCodeListPointer) = valu BrushCodeListPointer = BrushCodeListPointer + 1 End If Next j Next i Rem Arbeitsbildspeicher wiederfreigeben If VIMAGETest = False Then Call DIPFree(RM25(), 25) Call DIPFree(RM26(), 26) Call DIPFree(RM27(), 27) Call DIPFree(RM28(), 28) End If HF.Text2.Text = "Plotdriver: Pinselspitze mit " & BrushCodeListPointer & " Punkten neu generiert ..." HF.Text2.Refresh PLXBrushGenerationIsInProc = False End Sub Rem Rem EINEN EINZELNEN PUNKT DIREKT MALEN Rem ---------------------------------- Public Sub SUBPltPhysPixel(Bild() As Single, p() As Double, Value() As Single) Rem Rem SUBPLTPhysPixel zeichnet einen einzigen Punkt. Rem Dim Band As Long If p(1) > -16 And p(2) > -16 And p(1) < UBound(Bild, 1) And p(2) < UBound(Bild, 2) Then ' Wenn im Bild If PUNIsActive And PUNPointer < PUNPageLength Then ' Wenn Plot-Undo aktiv und möglich ' Sicherung auf Plot-Undo-Seite PUNPage und reinmalen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1): PUNPage(2, PUNPointer) = p(2) For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(p(1), p(2), Band) ' retten Bild(p(1), p(2), Band) = Value(Band) ' überschreiben Next Band Else ' Nur reinmalen For Band = 1 To UBound(Bild, 3) Bild(p(1), p(2), Band) = Value(Band) Next Band End If End If End Sub Rem Rem EINEN EINZELNEN PUNKT SCHNELL MALEN Rem ----------------------------------- Public Sub SUBPltPhysFastPixel(Bild() As Single, p() As Integer, Value() As Single) Rem Rem SUBPLTPhysFastPixel zeichnet einen einzigen Punkt. Rem Rem Unterschied zu SUBPltPhysPixel: Rem Rem Es erfolgt kein Fenstertest und die Koordinaten sind Integer. Rem Speziell fürs Füllen geschrieben. Rem Dim Band As Long If PUNIsActive And PUNPointer < PUNPageLength Then ' Sicherung auf Plot-Undo-Seite PUNPage und reinmalen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = CSng(p(1)): PUNPage(2, PUNPointer) = CSng(p(2)) For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(p(1), p(2), Band) ' retten Bild(p(1), p(2), Band) = Value(Band) ' überschreiben Next Band Else ' Nur reinmalen For Band = 1 To UBound(Bild, 3) Bild(p(1), p(2), Band) = Value(Band) Next Band End If End Sub Rem Rem EINE KLEINE 3x3-PIXELMATRIX MALEN Rem --------------------------------- Public Sub SUBPltPhysFatPixel(Bild() As Single, p() As Double, Value() As Single) Rem Rem SUBPLTPhysFatPoint zeichnet einen 3*3-Punkt. Rem Rem Ein Rudiment. Ineffektiv, aber dafür gibt es ja auch Pen und Brush ... Rem Dim Band As Long If p(1) > -15 And p(2) > -15 And p(1) < UBound(Bild, 1) - 1 And p(2) < UBound(Bild, 2) - 1 Then If PUNIsActive And PUNPointer < (PUNPageLength - 9 + 1) Then ' Koordinaten in PUNPage eintragen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) - 1: PUNPage(2, PUNPointer) = p(2) - 1 PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) - 1: PUNPage(2, PUNPointer) = p(2) PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) - 1: PUNPage(2, PUNPointer) = p(2) + 1 PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1): PUNPage(2, PUNPointer) = p(2) - 1 PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1): PUNPage(2, PUNPointer) = p(2) PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1): PUNPage(2, PUNPointer) = p(2) + 1 PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) + 1: PUNPage(2, PUNPointer) = p(2) - 1 PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) + 1: PUNPage(2, PUNPointer) = p(2) PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = p(1) + 1: PUNPage(2, PUNPointer) = p(2) + 1 ' Grauwerte in PUNPage eintragen und im Bild überschreiben For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer - 8) = Bild(p(1) - 1, p(2) - 1, Band) ' retten PUNPage(Band + 2, PUNPointer - 7) = Bild(p(1) - 1, p(2), Band) ' retten PUNPage(Band + 2, PUNPointer - 6) = Bild(p(1) - 1, p(2) + 1, Band) ' retten PUNPage(Band + 2, PUNPointer - 5) = Bild(p(1), p(2) - 1, Band) ' retten PUNPage(Band + 2, PUNPointer - 4) = Bild(p(1), p(2), Band) ' retten PUNPage(Band + 2, PUNPointer - 3) = Bild(p(1), p(2) + 1, Band) ' retten PUNPage(Band + 2, PUNPointer - 2) = Bild(p(1) + 1, p(2) - 1, Band) ' retten PUNPage(Band + 2, PUNPointer - 1) = Bild(p(1) + 1, p(2), Band) ' retten PUNPage(Band + 2, PUNPointer - 0) = Bild(p(1) + 1, p(2) + 1, Band) ' retten Bild(p(1) - 1, p(2) - 1, Band) = Value(Band) Bild(p(1) - 1, p(2), Band) = Value(Band) Bild(p(1) - 1, p(2) + 1, Band) = Value(Band) Bild(p(1), p(2) - 1, Band) = Value(Band) Bild(p(1), p(2), Band) = Value(Band) Bild(p(1), p(2) + 1, Band) = Value(Band) Bild(p(1) + 1, p(2) - 1, Band) = Value(Band) Bild(p(1) + 1, p(2), Band) = Value(Band) Bild(p(1) + 1, p(2) + 1, Band) = Value(Band) Next Band Else For Band = 1 To UBound(Bild, 3) Bild(p(1) - 1, p(2) - 1, Band) = Value(Band) Bild(p(1) - 1, p(2), Band) = Value(Band) Bild(p(1) - 1, p(2) + 1, Band) = Value(Band) Bild(p(1), p(2) - 1, Band) = Value(Band) Bild(p(1), p(2), Band) = Value(Band) Bild(p(1), p(2) + 1, Band) = Value(Band) Bild(p(1) + 1, p(2) - 1, Band) = Value(Band) Bild(p(1) + 1, p(2), Band) = Value(Band) Bild(p(1) + 1, p(2) + 1, Band) = Value(Band) Next Band End If End If End Sub Rem Rem EINE 1 PIXEL STARKE LINIE MALEN Rem ------------------------------- Public Sub SUBPltPhysSkelettLine(LM1() As Single, P1() As Double, P2() As Double, z() As Single) Rem Rem SUBPhysLine plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) mit dem Pen. Rem Der Grauwert der Linie ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Dim sx As Double ' Schreib-Rohkoord Dim sy As Double Dim wx As Double Dim wy As Double Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim oc(1 To 2) As Double ' Old Schreib-Bildkoord Dim wc(1 To 2) As Double ' Arbeits-Bildkoord Dim i As Long Dim c As Long Dim l1 As Long Dim length As Double Dim steps As Double Dim incx As Double ' Inkremente Dim incy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe Dim PIXX As Double Dim PIXY As Double Dim pixsize As Double Dim pixmiddle As Double If PLGIsInitialized = False Then Call SUBPltInit sx = P1(1) ' Start-X sy = P1(2) ' Start-Y Rem Grauwert übernehmen Call VIMAGEValueCopy(z, zs) Rem Schrittweite auf length berechnen pixsize = 1 length = Sqr((P1(1) - P2(1)) ^ 2 + (P1(2) - P2(2)) ^ 2) ' Länge der Linie im Geomaß steps = length / pixsize ' Pixelanzahl auf der Linie im Pixelmaß steps = steps * 5 ' zur Sicherheit Punkte etwas dichter If steps = 0 Then steps = 1 Rem Inkremente setzen incx = (P2(1) - P1(1)) / steps incy = (P2(2) - P1(2)) / steps Rem Linie initialisieren oc(1) = CLng(sx): oc(2) = CLng(sy) Rem Linie generieren For i = 0 To steps ' Linie sc(1) = CLng(sx): sc(2) = CLng(sy) If sc(1) > -15 And sc(2) > -15 And sc(1) < UBound(LM1, 1) And sc(2) < UBound(LM1, 2) Then ' wenn ungültig sind si/sj -9999 Call SUBPltPhysPixel(LM1, sc, zs) 'If oc(1) <> sc(1) And oc(2) <> sc(2) Then ' Wenn Diagonalversatz (Achternachbarschaft!) dann ' wc(1) = sc(1): wc(2) = oc(2) ' Punkt so setzen, ' Call SUBPltPhysPixel(LM1, wc, zs) ' dass Vierernachbarchaft gewährleistet 'End If End If oc(1) = sc(1) oc(2) = sc(2) sx = sx + incx sy = sy + incy Next i End Sub Rem Rem EIN KLEINES ZEICHEN MALEN Rem ------------------------- Rem Rem BEFEHL TEXT: TEXT SCHREIBEN Rem =========================== Public Sub SUBPltPhysSkelettText(LM1() As Single, p() As Double, ByVal Text As String, z() As Single) Rem Rem SUBPltPhysSkelettText plottet einen einfachen Pixeltext text auf (p(1),p(2)) in der Farbe z(). Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem Im gegensatz zu den logischen PixelSign und PixelText wird das Set ignoriert. Rem Dim i As Long Dim j As Long Dim ppi As Long Dim ppj As Long ' Aktueller Zeichenmittelpunkt Dim PP(1 To 2) As Double ' Aktueller Zeichenpunkt Dim wx As Double ' Work-Coord Dim wy As Double Dim tx As Double ' Für Vergrößerung Dim ty As Double Dim StartX As Long Dim StartY As Long Dim zeichenposition As Long ' Für Tabulator Dim g As Long ' Zeichenzähler Dim zchar As String ' Aktuelles Einzelzeichen Dim Code As Long ' ASCII-Code des aktuellen Zeichens Dim actstring As String ' Aktueller String aus Fontfeld Dim actchar ' Aktuelles Char aus Fontfeld Dim SI As Long Dim sj As Long ' Aktuelles Schreibpixel If PLGIsInitialized = False Then Call SUBPltInit End If If Len(Text) = 0 Then Exit Sub Text = VPAPreText(Text) If PLTTextSize = 0 Then PLTTextSize = 1 ' irgendeiner hackt hier manchmal rein StartX = p(1) StartY = p(2) ppi = CLng(p(1)): ppj = CLng(p(2)) StartX = ppi StartY = ppj For g = 1 To Len(Text) zchar = (Mid(Text, g, 1)) For Code = 1 To 255 ' Klar müsste das auch mit asc gehen, aber asc geht nicht ... If zchar = Chr(Code) Then Exit For Next Code Select Case Code Case Asc(" ") ' Leerzeichen ppi = ppi + 10 Case Asc(vbCr) ' Wagenrücklauf und Zeilenvorschub=Zeilenumbruch ppi = StartX ppj = ppj - 10 Case Asc(vbLf) ' Gar nix Case Asc(vbTab) ' Tabulator zeichenposition = (ppi - StartX) / 10 zeichenposition = ((zeichenposition + 8) \ 8) * 8 ppi = StartX + zeichenposition * 10 Case Else For j = -5 To 5 ty = CDbl(j) + 5 actstring = PLGFont(Code, 10 - (CInt(ty + 0.000001))) actstring = Left(actstring & " ", 11) For i = -5 To 5 tx = CDbl(i) + 5 + 1 actchar = Mid(actstring, CInt(tx + 0.0000001), 1) If actchar = "#" Then PP(1) = ppi + i PP(2) = ppj + j If PP(1) >= -15 And PP(2) >= -15 And PP(1) < UBound(LM1, 1) And PP(2) < UBound(LM1, 2) Then Call SUBPltPhysPixel(LM1, PP, z) End If End If Next i Next j ppi = ppi + 10 End Select Next g End Sub Rem Rem BEFEHL LINE: LINIE MALEN Rem ======================== Public Sub SUBPltPhysLine(LM1() As Single, n1 As Long, P1() As Double, P2() As Double, z() As Single, Optional IsRaw As Boolean) Rem Rem SUBPltLine plottet eine Linie von (P1(1),P1(2)) nach (P2(1),P2(2)) mit dem Pen. Rem Der Grauwert der Linie ist z. Rem Rem LM1() ist ein Single-Feld mit dem Bild, N1 die Bildspeichernummer Rem Rem SUBPltLine ist skelettsensitiv, d. h. bei wahrem PLGSkelettFlag wird das Linienskelett gezeichnet. Rem Dim sx As Double ' Schreib-Rohkoord Dim sy As Double Dim wx As Double Dim wy As Double Dim SI As Long ' Schreib-Bildkoord Dim sj As Long Dim sc(1 To 2) As Double ' Schreib-Bildkoord Dim oc(1 To 2) As Double ' Old Schreib-Bildkoord Dim wc(1 To 2) As Double ' Arbeits-Bildkoord Dim i As Long Dim c As Long Dim length As Double Dim steps As Double Dim incx As Double ' Inkremente Dim incy As Double Dim zs(1 To MAX_NUMBER_OF_CHANNELS) As Single ' Strichfarbe Dim incz() As Single Dim PIXX As Double Dim PIXY As Double Dim pixsize As Double Dim pixmiddle As Double If PLGIsInitialized = False Then Call SUBPltInit If PLTPenSize = 0 Then Exit Sub sx = P1(1) ' Start-X sy = P1(2) ' Start-Y If sx > 2000000000 Then sx = 2000000000 If sy > 2000000000 Then sy = 2000000000 If sx < -2000000000 Then sx = -2000000000 If sy < -2000000000 Then sy = -2000000000 Rem Grauwert übernehmen Call VIMAGEValueCopy(z, zs) ReDim incz(1 To UBound(zs)) Rem Schrittweite auf length berechnen Select Case PLTCoordMode Case 0: pixsize = 1 Case 1: Call FIXCoordGetPixelSize(RMHD(n1), PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist Case 2: Call FIXCoordGetParameters(RMHD(n1), , , , , , , , , PIXX, PIXY) pixsize = PIXX If PIXY < PIXX Then pixsize = PIXY ' pixx oder pixy: was kleiner ist End Select If pixsize = 0 Then pixsize = 0.0000001 ' Nulldivisor length = Sqr((P1(1) - P2(1)) ^ 2 + (P1(2) - P2(2)) ^ 2) ' Länge der Linie im Geomaß steps = length / pixsize ' Pixelanzahl auf der Linie im Pixelmaß steps = steps * 5 ' zur Sicherheit Punkte etwas dichter If steps = 0 Then steps = 1 Rem Inkremente setzen If steps = 0 Then steps = 0.0000001 If steps > 1000000 Then steps = 1000000 incx = (P2(1) - P1(1)) / steps incy = (P2(2) - P1(2)) / steps For c = 1 To UBound(incz) ' incz(c) = (z2(c) - z1(c)) / steps ' Alter Code als es noch 2 z gab ... incz(c) = 0 ' Jetzt so Next c Rem Linie initialisieren Select Case PLTCoordMode Case 0: ' Bildkoordinaten oc(1) = CLng(sx): oc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, oc(1), oc(2)) Case 2: ' Kartenkoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, oc(1), oc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, oc(1), oc(2)) End Select If PLGSkelettFlag = True Then If IsMissing(IsRaw) = False Then If IsRaw = False Then Call SUBPltPhysSkelettText(LM1, oc, Chr(4), PLGSkelettValue) End If End If End If Rem Linie generieren For i = 0 To steps ' Linie Select Case PLTCoordMode Case 0: ' Bildkoordinaten sc(1) = CLng(sx): sc(2) = CLng(sy) Case 1: ' Geokoordinaten-->Bildkoordinaten Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case 2: ' Kartenkoordinaten-->Geokoordinaten-->Bildkoordinaten Call FIXCoordMap2Img(RMHD(n1), sx, sy, sc(1), sc(2)) Case Else: Call FIXCoordGeo2Img(RMHD(n1), sx, sy, sc(1), sc(2)) End Select If PLGSkelettFlag = False Then If sc(1) > -15 And sc(2) > -15 And sc(1) < RMHD(n1).ImgXXXX + 16 And sc(2) < RMHD(n1).ImgYYYY + 16 Then ' wenn ungültig sind si/sj -9999 If i = 0 Then Call SUBPltPhysPen(LM1, sc, zs) ' Init-Punkt malen Else Call SUBPltPhysPen(LM1, sc, zs, True) ' Draw-Punkt malen End If If oc(1) <> sc(1) And oc(2) <> sc(2) Then ' Wenn Diagonalversatz (Achternachbarschaft!) dann wc(1) = sc(1): wc(2) = oc(2) ' Punkt so setzen, Call SUBPltPhysPixel(LM1, wc, zs) ' dass Vierernachbarchaft gewährleistet End If End If Else Call SUBPltPhysPixel(LM1, sc, PLGSkelettValue) ' Skelettpixel End If oc(1) = sc(1) oc(2) = sc(2) sx = sx + incx sy = sy + incy Next i If PLGSkelettFlag = True Then If IsMissing(IsRaw) = False Then If IsRaw = False Then Call SUBPltPhysSkelettText(LM1, sc, Chr(4), PLGSkelettValue) End If End If End If End Sub Rem Rem EINEN PUNKT MIT DEM STIFT MALEN Rem -------------------------------- Public Sub SUBPltPhysPen(Bild() As Single, p() As Double, Value() As Single, Optional IsDrawMode As Boolean, Optional AuxMode As Boolean) Rem Rem SUBPLTPhysPen kapselt den Penzugriff. Rem Rem Der Penzugriff malt eine Kreisscheibe mit dem Durchmesser PENSIZE oder PENSIZEAUX. Rem Rem PENSIZE und PENSIZEAUX befinden sich im Set, bei Änderung müssen mit Rem SUBPltPhysGenerateNewPen die vier PenCodeListen neu kompiliert werden. Rem Rem Es werden folgende Zeichenspitzen benutzt - IsDrawMode: AuxMode: s: Liste: Rem False * False * init InitCodeList Rem * = Standard True False * draw DrawCodeList Rem False * True iaux IAuxCodeList Rem True True daux DAuxCodeList Rem Rem PENSIZE und PENSIZEAUX bitte nur mit dem Befehl SET ändern. Rem Dim Band As Long Dim Pixel As Single Dim T As Long Dim x As Long Dim y As Long Dim s As String Rem Pen, sofern er geändert wurde neu erzeugen If PLXPenIsChanged = True Then Call SUBPltPhysGenerateNewPen PLXPenIsChanged = False End If Rem Fallunterscheidung If IsMissing(IsDrawMode) = True Or IsDrawMode = False Then If IsMissing(AuxMode) = True Or AuxMode = False Then s = "init" Else s = "iaux" End If Else If IsMissing(AuxMode) = True Or AuxMode = False Then s = "draw" Else s = "daux" End If End If Rem Jetzt kommt das eigentliche Malen Select Case s: Rem MALEN MIT DEM INITPEN (=KREISFLÄCHE), BASE Case "init": For T = 1 To UBound(PLXPenInitCodeList, 2) x = p(1) + PLXPenInitCodeList(1, T) y = p(2) + PLXPenInitCodeList(2, T) If x > -16 And y > -16 And x < UBound(Bild, 1) And y < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x: PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) Bild(x, y, Band) = Value(Band) Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Bild(x, y, Band) = Value(Band) Next Band End If End If Next T Rem MALEN MIT DEM DRAWPEN (=KREISUMFANG), BASE Case "draw": For T = 1 To UBound(PLXPenDrawCodeList, 2) x = p(1) + PLXPenDrawCodeList(1, T) y = p(2) + PLXPenDrawCodeList(2, T) If x > -16 And y > -16 And x < UBound(Bild, 1) And y < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x: PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) Bild(x, y, Band) = Value(Band) Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Bild(x, y, Band) = Value(Band) Next Band End If End If Next T Rem MALEN MIT DEM INITPEN (=KREISFLÄCHE), AUX Case "iaux": For T = 1 To UBound(PLXPenIAuxCodeList, 2) x = p(1) + PLXPenIAuxCodeList(1, T) y = p(2) + PLXPenIAuxCodeList(2, T) If x > -16 And y > -16 And x < UBound(Bild, 1) And y < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x: PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) Bild(x, y, Band) = Value(Band) Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Bild(x, y, Band) = Value(Band) Next Band End If End If Next T Rem MALEN MIT DEM DRAWPEN (=KREISUMFANG), AUX Case "daux": For T = 1 To UBound(PLXPenDAuxCodeList, 2) x = p(1) + PLXPenDAuxCodeList(1, T) y = p(2) + PLXPenDAuxCodeList(2, T) If x > -16 And y > -16 And x < UBound(Bild, 1) And y < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x: PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) Bild(x, y, Band) = Value(Band) Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Bild(x, y, Band) = Value(Band) Next Band End If End If Next T End Select End Sub Rem Rem EINEN PUNKT MIT DEM PINSEL MALEN Rem -------------------------------- Public Sub SUBPltPhysBrush(Bild() As Single, p() As Double, Value() As Single) Rem Rem SUBPLTPhysBrush kapselt den Brushzugriff. Rem Rem Der Brushzugriff ist ein Punktzugriff mit einen bestimmtem Modus (Quadrat oder Kreis), Rem einer bestimmten Pinselgrösse, -härte, und -deckfähigkeit. Rem Rem Diese Parameter befinden sich auf den BRUSH-Globals im Set, sie werden von Rem SUBPltPhysGenerateNewBrush in eine sog. BrushCodeList »kompiliert«. Es muss also Rem nach jeder Änderung der Brush-Globals neu »kompiliert« werden, ansonsten nimmt er den alten Rem Brush. Rem Dim s As String Dim Band As Long Dim Pixel As Single Dim T As Long Dim x As Long Dim y As Long Dim fg As Single ' Fore Ground Dim bg As Single ' Back Ground If PLXBrushIsInProc = True Then Exit Sub PLXBrushIsInProc = True Rem Brush, sofern er geändert wurde neu erzeugen If PLXBrushIsChanged = True Then Call SUBPltPhysGenerateNewBrush PLXBrushIsChanged = False End If Rem Jetzt kommt das eigentliche Malen For T = 1 To UBound(PLXBrushCodeList, 2) x = p(1) + PLXBrushCodeList(1, T) y = p(2) + PLXBrushCodeList(2, T) fg = PLXBrushCodeList(3, T) / 10000 bg = 1 - fg If x > -16 And y > -16 And x < UBound(Bild, 1) And y < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x: PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) Pixel = Bild(x, y, Band) * bg + Value(Band) * fg Bild(x, y, Band) = Pixel Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Pixel = Bild(x, y, Band) * bg + Value(Band) * fg Bild(x, y, Band) = Pixel Next Band End If End If Next T PLXBrushIsInProc = False End Sub Rem Rem EINEN PUNKT MIT DEM KOPIERPINSEL MALEN Rem -------------------------------------- Public Sub SUBPltPhysCopyBrush(Bild() As Single, P1() As Double, P0() As Double) Rem Rem SUBPLTPhysBrush kapselt den Kopierpinsel. Rem Rem Es werden Grauwerte mit einem Pinsel (Brush) auf p1 geschrieben. Diese werden Rem von Position p0 gelesen. Rem Der CopyBrush hat wie der Brush eine bestimmte Pinselform (Modus), -grösse, -härte, und -deckfähigkeit. Rem Rem Diese Parameter befinden sich auf den BRUSH-Globals im Set, sie werden von Rem SUBPltPhysGenerateNewBrush in eine sog. BrushCodeList »kompiliert«. Es muss also Rem nach jeder Änderung der Brush-Globals neu »kompiliert« werden, ansonsten nimmt er Rem den alten Brush. Rem Dim Band As Long Dim Pixel As Single Dim T As Long Dim xs As Long ' Schreibkoordinaten Dim ys As Long Dim xl As Long ' Lesekoordinaten Dim yl As Long Dim fg As Single ' Fore Ground Dim bg As Single ' Back Ground Rem Brush, sofern er geändert wurde neu erzeugen If PLXBrushIsChanged = True Then Call SUBPltPhysGenerateNewBrush PLXBrushIsChanged = False End If Rem Jetzt kommt das eigentliche Malen mit dem Kopierpinsel For T = 1 To UBound(PLXBrushCodeList, 2) xs = P1(1) + PLXBrushCodeList(1, T) ys = P1(2) + PLXBrushCodeList(2, T) xl = P0(1) + PLXBrushCodeList(1, T) yl = P0(2) + PLXBrushCodeList(2, T) fg = PLXBrushCodeList(3, T) / 10000 bg = 1 - fg If xs > -16 And ys > -16 And xs < UBound(Bild, 1) And ys < UBound(Bild, 2) And _ xl > -16 And yl > -16 And xl < UBound(Bild, 1) And yl < UBound(Bild, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = xs: PUNPage(2, PUNPointer) = ys For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(xs, ys, Band) Pixel = Bild(xs, ys, Band) * bg + Bild(xl, yl, Band) * fg Bild(xs, ys, Band) = Pixel Next Band Else ' Oder ohne Undoliste malen For Band = 1 To UBound(Bild, 3) Pixel = Bild(xs, ys, Band) * bg + Bild(xl, yl, Band) * fg Bild(xs, ys, Band) = Pixel Next Band End If End If Next T End Sub Rem Rem EINEN PUNKT MIT DEM BILDKOPIERPINSEL MALEN Rem ------------------------------------------ Public Sub SUBPltPhysImageCopyBrush(Bildl() As Single, Bilds() As Single, P0() As Double, P1() As Double) Rem Rem SUBPLTPhysImageBrush kapselt den Bildkopierpinsel. Rem Rem Es werden Grauwerte mit einem Pinsel (Brush) auf p1 in Bilds geschrieben. Diese werden Rem von Position p0 in Bildl gelesen. Rem Rem Der ImageCopyBrush hat wie der Brush eine bestimmte Pinselform (Modus), -grösse, -härte, und -deckfähigkeit. Rem Rem Diese Parameter befinden sich auf den BRUSH-Globals im Set, sie werden von Rem SUBPltPhysGenerateNewBrush in eine sog. BrushCodeList »kompiliert«. Es muss also Rem nach jeder Änderung der Brush-Globals neu »kompiliert« werden. Ansonsten nimmt er Rem den alten Brush. Rem Dim Band As Long Dim MaxBand As Long Dim Pixel As Single Dim T As Long Dim xs As Long ' Schreibkoordinaten Dim ys As Long Dim xl As Long ' Lesekoordinaten Dim yl As Long Dim fg As Single ' Fore Ground Dim bg As Single ' Back Ground Rem Brush, sofern er geändert wurde neu erzeugen If PLXBrushIsChanged = True Then Call SUBPltPhysGenerateNewBrush PLXBrushIsChanged = False End If Rem Maxband ermitteln MaxBand = UBound(Bildl, 3) If MaxBand < UBound(Bilds, 3) Then MaxBand = UBound(Bilds, 3) Rem Jetzt kommt das eigentliche Malen mit dem Bildkopierpinsel For T = 1 To UBound(PLXBrushCodeList, 2) xs = P1(1) + PLXBrushCodeList(1, T) ys = P1(2) + PLXBrushCodeList(2, T) xl = P0(1) + PLXBrushCodeList(1, T) yl = P0(2) + PLXBrushCodeList(2, T) fg = PLXBrushCodeList(3, T) / 10000 bg = 1 - fg If xs > -16 And ys > -16 And xs < UBound(Bilds, 1) And ys < UBound(Bilds, 2) And _ xl > -16 And yl > -16 And xl < UBound(Bildl, 1) And yl < UBound(Bildl, 2) Then If PUNIsActive And PUNPointer < PUNPageLength Then ' In Undoliste rein und malen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = xs: PUNPage(2, PUNPointer) = ys For Band = 1 To MaxBand PUNPage(Band + 2, PUNPointer) = Bilds(xs, ys, Band) Pixel = Bilds(xs, ys, Band) * bg + Bildl(xl, yl, Band) * fg Bilds(xs, ys, Band) = Pixel Next Band Else ' Oder ohne Undoliste malen For Band = 1 To MaxBand Pixel = Bilds(xs, ys, Band) * bg + Bildl(xl, yl, Band) * fg Bilds(xs, ys, Band) = Pixel Next Band End If End If Next T End Sub Rem Rem EINEN PUNKT MIT DEM FILTERPINSEL MALEN Rem -------------------------------------- Public Sub SUBPltPhysFilterBrush(Bild() As Single, p() As Double) Rem Rem SUBPLTPhysFilterBrush kapselt den Weichzeichnerzugriff. Punkt p() wird nicht Rem mit gegebenem grauwert beschrieben, sondern aus seiner 5*5-Umgebung per Rem Gaußfilter zusammengesetzt. Rem Dim T As Long ' lfd. Parameter Dim i As Long Dim j As Long Dim Band As Long Dim w As Long Dim x As Long ' Koord aus Brushcodelist Dim y As Long Dim g As Long Dim fg As Single ' Fore Ground Dim bg As Single ' Back Ground Dim ac(1 To MAX_NUMBER_OF_CHANNELS) ' Akkumulator Dim ma(-2 To 2, -2 To 2) As Single ' Matrix Dim Pixel As Single ' Schreibgrauwert Static isinproc As Boolean If isinproc = True Then Exit Sub isinproc = True Rem Filter füllen If ma(0, 0) <> 36 / 256 Then ma(-2, -2) = 1 / 256 ma(-2, -1) = 4 / 256 ma(-2, 0) = 6 / 256 ma(-2, 1) = 4 / 256 ma(-2, 2) = 1 / 256 ma(-1, -2) = 4 / 256 ma(-1, -1) = 16 / 256 ma(-1, 0) = 24 / 256 ma(-1, 1) = 16 / 256 ma(-1, 2) = 4 / 256 ma(0, -2) = 6 / 256 ma(0, -1) = 24 / 256 ma(0, 0) = 36 / 256 ma(0, 1) = 24 / 256 ma(0, 2) = 6 / 256 ma(1, -2) = 4 / 256 ma(1, -1) = 16 / 256 ma(1, 0) = 24 / 256 ma(1, 1) = 16 / 256 ma(1, 2) = 4 / 256 ma(2, -2) = 1 / 256 ma(2, -1) = 4 / 256 ma(2, 0) = 6 / 256 ma(2, 1) = 4 / 256 ma(2, 2) = 1 / 256 End If ' If ma(0, 0) <> 36 Then ' Das ist der Schafrzeichner ... ' ma(-2, -2) = 1 / 64 ' ma(-2, -1) = -2 / 64 ' ma(-2, 0) = -6 / 64 ' ma(-2, 1) = -2 / 64 ' ma(-2, 2) = 1 / 64 ' ma(-1, -2) = -2 / 64 ' ma(-1, -1) = 4 / 64 ' ma(-1, 0) = 12 / 64 ' ma(-1, 1) = 4 / 64 ' ma(-1, 2) = -2 / 64 ' ma(0, -2) = -6 / 64 ' ma(0, -1) = 12 / 64 ' ma(0, 0) = 36 / 64 ' ma(0, 1) = 12 / 64 ' ma(0, 2) = -6 / 64 ' ma(1, -2) = -2 / 64 ' ma(1, -1) = 4 / 64 ' ma(1, 0) = 12 / 64 ' ma(1, 1) = 4 / 64 ' ma(1, 2) = -2 / 64 ' ma(2, -2) = 1 / 64 ' ma(2, -1) = -2 / 64 ' ma(2, 0) = -6 / 64 ' ma(2, 1) = -2 / 64 ' ma(2, 2) = 1 / 64 ' End If Rem Brush, sofern er geändert wurde neu erzeugen If PLXBrushIsChanged = True Then Call SUBPltPhysGenerateNewBrush PLXBrushIsChanged = False End If Rem Akkumulatorpixel anfangslöschen For w = 1 To MAX_NUMBER_OF_CHANNELS ac(w) = 0 Next w Rem Filterschleife g = Abs(UBound(ma, 1)) + 1 ' Filterradius-Abstand von Bildgrenze halten For T = 1 To UBound(PLXBrushCodeList, 2) ' Brushvorarbeit x = p(1) + PLXBrushCodeList(1, T) y = p(2) + PLXBrushCodeList(2, T) fg = PLXBrushCodeList(3, T) / 10000 bg = 1 - fg ' Jetzt die grosse Brush-Schleife If x > -16 + g And y > -16 + g And x < UBound(Bild, 1) - g And y < UBound(Bild, 2) - g Then ' Wenn im Bild ' Filtern = Schreibwertvektor in ac erzeugen For Band = 1 To UBound(Bild, 3) ac(Band) = 0 For i = LBound(ma, 1) To UBound(ma, 1) For j = LBound(ma, 2) To UBound(ma, 2) ac(Band) = ac(Band) + Bild(x + i, y + j, Band) * ma(i, j) Next j Next i Next Band If PUNIsActive And PUNPointer < PUNPageLength Then ' Wenn Plot-Undo aktiv und möglich ' Sicherung auf Plot-Undo-Seite PUNPage und reinmalen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = x PUNPage(2, PUNPointer) = y For Band = 1 To UBound(Bild, 3) PUNPage(Band + 2, PUNPointer) = Bild(x, y, Band) ' retten Pixel = Bild(x, y, Band) * bg + ac(Band) * fg Bild(x, y, Band) = Pixel ' überschreiben Next Band Else ' oder nur reinmalen For Band = 1 To UBound(Bild, 3) Pixel = Bild(x, y, Band) * bg + ac(Band) * fg Bild(x, y, Band) = Pixel Next Band End If End If Next T ' Nächster Punkt aus der Brushcodelist isinproc = False End Sub Rem Rem U N D O - R O U T I N E N -- V E R W A L T E N D E N R Ü C K G Ä N G I G P U F F E R Rem ============================================================================================ Rem Rem Hierzu gibt es die PUN-Variablen im PUN-Subsystem in VDGLOBAL Rem Rem PRINZIP: Es gibt eine »große« Undo-Liste, die PUNPage. Rem PUNPage ist ein zweidimensionales Feld. Rem 1. Dimension = Bänder + 2. Rem Hier kommen pro Punktveränderung rein: x-Adrersse, y-Adressen und der Pixelvektor (=Grauwerte aller Bänder). Rem 2. Dimension = ... einige Millionen ... pro Punktveränderung ein Eintrag. Rem Die 2. Dimension bezeigert ein Pointer, der PUNPointer. Rem Beim Punkte Malen werden die alten Grauwerte in der PUNPage gerettet und der PUNPointer weitergestellt. Rem Beim Undo wird der PUNPointer zrückgestellt und die Grauwerte werden anhand der Einträge wiederhergestellt. Rem Rem Ausserdem können in der PUNPage spezielle Marken gesetzt werden. Rem Bei gewöhnlichem Undo wird bis zu einer Marke rückgängig gemacht, es gibt auch ein Rem Voll-Undo, das macht alles rückgängig. Rem SUBPltUndoOpen -- Undo öffnen Rem ============================= Rem Public Sub SUBPltUndoOpen(Bild() As Single) Rem Rem Das Programm öffnet das Plot-Undo-Subsystem PUN. Rem Dim n As Long If PUNIsActive = True Then Exit Sub On Error GoTo ErL: GoTo ErC: ErL: Exit Sub ErC: n = UBound(Bild, 3) n = n + 2 ' x, y ReDim PUNPage(n, 1 To PUNPageLength) PUNPointer = 0 PUNIsActive = True End Sub Rem SUBPltUndoClose -- PUN schliessen Rem ================================= Public Sub SUBPltUndoClose() Rem Rem Das Programm schliesst das Plot-Undo-Subsustem PUN. Rem ReDim PUNPage(1 To 1, 1 To 1) PUNPointer = 0 PUNIsActive = False End Sub Rem Rem SUBPltUndoSetLabel -- Eine Marke in der Plot-Undo-Seite setzen Rem ============================================================== Public Sub SUBPltUndoSetLabel() Rem Rem Das Programm setzt in der PUNPage eine Marke. Nachfolgendes Rem Rückgängigmachen mit PUNUndelete macht Löschungen bis zu dieser Marke Rem rückgängig. Rem Rem Eine Marke ummfasst 3 PUNPage-Einträge: -9999, CursorII-Position, Cursorposition Rem Rem Sie sieht in der PUNPage also wie folgt aus: Rem Rem Pointer 1 2 3 4 5 ... Rem Rem 117 x117 y117 R-117 G-117 B-117 Rem 118 x118 y118 R-118 G-118 B-118 Rem 119 CurX-II CurY-II Rem 120 CurX CurY Rem 121 -9999 1 Rem 122 x122 y122 R-122 G-122 B-122 Rem 123 x123 y123 R-123 G-123 B-123 Rem Rem If PUNIsActive = False Then Exit Sub If PUNPointer >= PUNPageLength - 4 Then Exit Sub End If ' Cursor merken PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = PLCCursor(1) PUNPage(2, PUNPointer) = PLCCursor(2) ' Cursor II merken PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = PLCCursorII(1) PUNPage(2, PUNPointer) = PLCCursorII(2) ' Label setzen PUNPointer = PUNPointer + 1 PUNPage(1, PUNPointer) = -9999 PUNPage(2, PUNPointer) = 1 ' Dass kann künftig evtl. als eine Markenpriorität ausgewertet werden. End Sub Rem Rem SUBPltUndoUndelete -- Alle Änderungen bis vorherige Marke löschen Rem ================================================================= Public Sub SUBPltUndoUndelete() Rem Rem Das Programm macht die letzten Eintragungen bis zur nächst vorangegangenen Rem Marke rückgängig. Rem Dim w As Long ' Bandnummer ' EXIT WENN PUN NICHT AKTIV If PUNIsActive = False Then Exit Sub ' AM ANFANG NICHT WEITER ZURÜCK If PUNPointer < 1 Then Exit Sub ' (EVENTUELL SOEBEN ERST GESETZTE) MARKE DIREKT UNTER DEM POINTER IGNORIEREN If PUNPointer >= 3 Then If PUNPage(1, PUNPointer) = -9999 Then PUNPointer = PUNPointer - 3 End If End If ' GROSSE RÜCKGÄNGIG-SCHLEIFE While 1 = 1 ' Schon an Anfang: If PUNPointer < 1 Then Exit Sub End If ' Schon an einer Marke If PUNPointer >= 3 Then If PUNPage(1, PUNPointer) = -9999 Then Rem PUNPage(1, PUNPointer) = 0 PUNPointer = PUNPointer - 1 PLCCursorII(1) = PUNPage(1, PUNPointer) ' CursorII auskellern PLCCursorII(2) = PUNPage(2, PUNPointer) PUNPointer = PUNPointer - 1 PLCCursor(1) = PUNPage(1, PUNPointer) ' Cursor auskellern PLCCursor(2) = PUNPage(2, PUNPointer) PUNPointer = PUNPointer - 1 PUNPointer = PUNPointer + 3 ' Aber die Marke muss gesezt bleiben Exit Sub End If End If ' Punkt Undo For w = 1 To UBound(RM00, 3) RM00(PUNPage(1, PUNPointer), PUNPage(2, PUNPointer), w) = PUNPage(w + 2, PUNPointer) Next w PUNPointer = PUNPointer - 1 Wend End Sub Rem Rem SUBPltUndoUndeleteAll -- Alles rückgängig machen Rem ================================================ Public Sub SUBPltUndoUndeleteAll() Rem Rem Das Programm macht alle Eintragungen Rem rückgängig, also auch über alle Marken hinweg. Rem Dim w As Long ' Bandnummer If PUNIsActive = False Then Exit Sub While 1 = 1 ' Schon an Anfang: If PUNPointer < 1 Then Exit Sub End If ' Wenn Marke: a) In Seitenmitte überspringen, b) Am Seitenanfang Exit If PUNPage(1, PUNPointer) = -9999 Then PUNPage(1, PUNPointer) = 0 If PUNPointer < 4 Then PUNPointer = 0 Exit Sub Else PUNPointer = PUNPointer - 3 End If End If ' Punkt Undo For w = 1 To UBound(RM00, 3) RM00(PUNPage(1, PUNPointer), PUNPage(2, PUNPointer), w) = PUNPage(w + 2, PUNPointer) Next w PUNPointer = PUNPointer - 1 Wend End Sub