VERSION 5.00 Begin VB.Form frmGraphicView BorderStyle = 3 'Fixed Dialog Caption = "GraphicView" ClientHeight = 10485 ClientLeft = 45 ClientTop = 435 ClientWidth = 17085 ControlBox = 0 'False Icon = "frmGraphicView.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 10485 ScaleMode = 0 'User ScaleWidth = 17085 StartUpPosition = 2 'CenterScreen Begin VB.Frame Frame3 Height = 855 Left = 600 TabIndex = 34 Top = 9480 Width = 8895 Begin VB.CommandButton cmdVerwijderDWP Caption = "Verwijder dwarsprofiel" Enabled = 0 'False Height = 495 Left = 6480 TabIndex = 39 Top = 240 Visible = 0 'False Width = 2295 End Begin VB.CommandButton cmdUpdateHuplijn Caption = "Update hulplijn" Height = 495 Left = 3600 TabIndex = 38 Top = 240 Width = 2295 End Begin VB.TextBox txtOffsetZmax Alignment = 1 'Right Justify Height = 285 Left = 2520 TabIndex = 35 Text = "-0.5" Top = 320 Width = 495 End Begin VB.Label Label10 AutoSize = -1 'True Caption = "m" Height = 195 Left = 3120 TabIndex = 37 Top = 340 Width = 120 End Begin VB.Label Label9 AutoSize = -1 'True Caption = "Offset hulplijn t.o.v. maximale Z" Height = 195 Left = 120 TabIndex = 36 Top = 340 Width = 2190 End End Begin VB.Frame Frame2 Height = 2895 Left = 9600 TabIndex = 15 Top = 3120 Width = 7335 Begin VB.HScrollBar scrollSchaal Height = 255 Left = 120 Max = 100 Min = 1 TabIndex = 26 Top = 600 Value = 20 Width = 7095 End Begin VB.CommandButton cmdOK Caption = "OK >>" Height = 495 Left = 5280 TabIndex = 19 Top = 1320 Width = 1815 End Begin VB.CommandButton cmdVorrige Caption = "<< Vorige" Height = 495 Left = 120 TabIndex = 18 Top = 1320 Width = 1815 End Begin VB.CommandButton cmdVolgende Caption = "Volgende >>" Height = 495 Left = 2040 TabIndex = 17 Top = 1320 Width = 1815 End Begin VB.CommandButton cmdEnd Caption = "Stop" Height = 495 Left = 5280 TabIndex = 16 Top = 2280 Width = 1815 End Begin VB.Label Label8 AutoSize = -1 'True Caption = "Set schaalfactor ( Z=f*L)" Height = 195 Left = 120 TabIndex = 33 Top = 240 Width = 1725 End Begin VB.Label lblSchaalfactor AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1320 TabIndex = 32 Top = 960 Width = 75 End Begin VB.Label Label7 AutoSize = -1 'True Caption = "Schaalfactor (f):" Height = 195 Left = 120 TabIndex = 31 Top = 960 Width = 1125 End Begin VB.Line Line1 X1 = 120 X2 = 7200 Y1 = 1995 Y2 = 1995 End End Begin VB.Frame Frame1 Caption = "Array eigenschappen" Height = 2895 Left = 9600 TabIndex = 6 Top = 120 Width = 7335 Begin VB.Label lblMinZ AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1560 TabIndex = 25 Top = 2520 Width = 75 End Begin VB.Label lblMaxZ AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1560 TabIndex = 24 Top = 2160 Width = 75 End Begin VB.Label Label5 AutoSize = -1 'True Caption = "Minimale Z:" Height = 195 Left = 120 TabIndex = 23 Top = 2520 Width = 810 End Begin VB.Label Label4 AutoSize = -1 'True Caption = "Maximale Z:" Height = 195 Left = 120 TabIndex = 22 Top = 2160 Width = 855 End Begin VB.Label lblLengteProfiel AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1560 TabIndex = 21 Top = 1800 Width = 75 End Begin VB.Label Label3 AutoSize = -1 'True Caption = "Lengte profiel:" Height = 195 Left = 120 TabIndex = 20 Top = 1800 Width = 1005 End Begin VB.Label Label12 AutoSize = -1 'True Caption = "Rijen:" Height = 195 Left = 120 TabIndex = 14 Top = 1080 Width = 405 End Begin VB.Label Label14 AutoSize = -1 'True Caption = "Kolommen:" Height = 195 Left = 120 TabIndex = 13 Top = 1440 Width = 780 End Begin VB.Label lblRijen AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1575 TabIndex = 12 Top = 1080 Width = 75 End Begin VB.Label lblKolommen AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1575 TabIndex = 11 Top = 1440 Width = 75 End Begin VB.Label Label11 AutoSize = -1 'True Caption = "Aantal profielen:" Height = 195 Left = 120 TabIndex = 10 Top = 360 Width = 1140 End Begin VB.Label lblAantalProfielen AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1575 TabIndex = 9 Top = 360 Width = 75 End Begin VB.Label lblActiefProfiel AutoSize = -1 'True Caption = "-" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 195 Left = 1575 TabIndex = 8 Top = 720 Width = 75 End Begin VB.Label Label13 AutoSize = -1 'True Caption = "Geselecteerd profiel:" Height = 195 Left = 120 TabIndex = 7 Top = 720 Width = 1455 End End Begin VB.PictureBox picXY AutoRedraw = -1 'True BackColor = &H80000005& ForeColor = &H00FF0000& Height = 3900 Left = 9720 MousePointer = 2 'Cross ScaleHeight = 3840 ScaleMode = 0 'User ScaleWidth = 3960 TabIndex = 1 Top = 6240 Width = 4020 End Begin VB.PictureBox picDwarsprofiel AutoRedraw = -1 'True BackColor = &H80000005& ForeColor = &H00C00000& Height = 8800 Left = 600 MousePointer = 2 'Cross ScaleHeight = 8745 ScaleWidth = 8745 TabIndex = 0 Top = 120 Width = 8800 Begin VB.Line lineBottom BorderColor = &H00808080& BorderStyle = 3 'Dot X1 = 240 X2 = 1080 Y1 = 1920 Y2 = 1920 End Begin VB.Line lineTop BorderColor = &H00808080& BorderStyle = 3 'Dot X1 = 240 X2 = 1080 Y1 = 1680 Y2 = 1680 End End Begin VB.Label lblLengte Alignment = 1 'Right Justify Caption = "-" Height = 255 Left = 8880 TabIndex = 30 Top = 9000 Width = 495 End Begin VB.Label Label6 Alignment = 1 'Right Justify Caption = "0" Height = 255 Left = 600 TabIndex = 29 Top = 9000 Width = 495 End Begin VB.Label lblZmin Alignment = 1 'Right Justify Caption = "-" Height = 255 Left = 0 TabIndex = 28 Top = 8640 Width = 495 End Begin VB.Label lblZmax Alignment = 1 'Right Justify Caption = "-" Height = 255 Left = 0 TabIndex = 27 Top = 120 Width = 495 End Begin VB.Label Label16 Alignment = 2 'Center AutoSize = -1 'True Caption = "L [m]" Height = 195 Left = 4320 TabIndex = 5 Top = 9120 Width = 360 End Begin VB.Label Label15 AutoSize = -1 'True Caption = "Z [m]" Height = 195 Left = 120 TabIndex = 4 Top = 3960 Width = 360 End Begin VB.Label Label2 AutoSize = -1 'True Caption = "Y" Height = 195 Left = 9600 TabIndex = 3 Top = 8040 Width = 105 End Begin VB.Label Label1 AutoSize = -1 'True Caption = "X" Height = 195 Left = 11520 TabIndex = 2 Top = 10200 Width = 105 End End Attribute VB_Name = "frmGraphicView" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub cmdEnd_Click() 'Declareer locale variabelen Dim i i = MsgBox("Weet u zeker dat u wilt stoppen? Wijzigingen worden niet opgeslagen!", vbYesNo, "Let op!") If i = vbYes Then 'Stop het programma End End If End Sub Private Sub cmdOk_Click() 'Declareer locale variabelen Dim i, p As Long Dim tellerZeven As Long 'Vul de array met code -1 => Onbekende punten For tellerZeven = 1 To aantalProfielen arrayKnooppunten(tellerZeven, 1) = arrayProfielen(tellerZeven, 1) 'Profielnaam For tellerAcht = 2 To 37 arrayKnooppunten(tellerZeven, tellerAcht) = -1 Next tellerAcht Next tellerZeven 'Sluit de graphic view en open de pl view Unload frmGraphicView frmPL.Show End Sub Private Sub cmdStop_Click() 'Stop het programma End End Sub Private Sub cmdUpdateHuplijn_Click() 'Teken het profiel opnieuw Call tekenProfielen(geselecteerdProfiel) End Sub Private Sub cmdVerwijderDWP_Click() Dim tempArray() 'Tijdelijke array om de punten in bij te houden Dim tempArray2() 'Tijdelijke array om de subcodes in bij te houden Dim tellerEen, tellerTwee, tellerDrie As Long Dim i i = MsgBox("Weet u zeker dat u het dwarsprofiel wilt verwijderen", vbYesNo, "Let op!") If i = vbNo Then 'verlaat de sub routine het programma Exit Sub End If 'Maak de tijdelijke array aan ReDim tempArray(aantalProfielen - 1, totaalAantalKolommen) ReDim tempArray2(aantalProfielen - 1, totaalAantalKolommenPuntCodes) 'Verhoog het aantal verwijderde profielen aantalVerwijderdeProfielen = aantalVerwijderdeProfielen + 1 ReDim Preserve verwijderdeProfielen(1, aantalVerwijderdeProfielen) 'Bewaar het verwijderde profiel in de arrayVerwijderdeProfielen verwijderdeProfielen(1, aantalVerwijderdeProfielen) = arrayProfielen(geselecteerdProfiel, 1) 'kopieer alle data tot aan het geselecteerde profiel vanuit de arrayProfielen 'naar de tijdelijke array 'Controleer eerst of het niet het eerste profiel is If geselecteerdProfiel <> 1 Then For tellerEen = 1 To geselecteerdProfiel - 1 'Array met profielen For tellerTwee = 1 To totaalAantalKolommen tempArray(tellerEen, tellerTwee) = arrayProfielen(tellerEen, tellerTwee) Next tellerTwee 'Array met puntcodes For tellerDrie = 1 To totaalAantalKolommenPuntCodes tempArray2(tellerEen, tellerDrie) = arrayPuntCode(tellerEen, tellerDrie) Next tellerDrie Next tellerEen End If 'kopieer alle data na het geselecteerde profiel vanuit de arrayProfielen 'naar de tijdelijke array 'Controleer eerst of het niet het laatste profiel is If geselecteerdProfiel <> aantalProfielen Then For tellerEen = geselecteerdProfiel + 1 To aantalProfielen 'Array met profielen For tellerTwee = 1 To totaalAantalKolommen tempArray(tellerEen - 1, tellerTwee) = arrayProfielen(tellerEen, tellerTwee) Next tellerTwee 'Array met puntcodes For tellerDrie = 1 To totaalAantalKolommenPuntCodes tempArray2(tellerEen - 1, tellerDrie) = arrayPuntCode(tellerEen, tellerDrie) Next tellerDrie Next tellerEen End If 'Verminder het aantal profielen met 1 aantalProfielen = aantalProfielen - 1 'Maak de arrayprofielen opnieuw aan uitgaande van de nieuwe dimensies ReDim arrayProfielen(aantalProfielen, totaalAantalKolommen) ReDim arrayPuntCode(aantalProfielen, totaalAantalKolommenPuntCodes) 'Kopieër de data vanuit de tempArray in de arrayProfielen For tellerEen = 1 To aantalProfielen 'Array met profielen For tellerTwee = 1 To totaalAantalKolommen arrayProfielen(tellerEen, tellerTwee) = tempArray(tellerEen, tellerTwee) Next tellerTwee 'Array met puntcodes For tellerDrie = 1 To totaalAantalKolommenPuntCodes arrayPuntCode(tellerEen, tellerDrie) = tempArray2(tellerEen, tellerDrie) Next tellerDrie Next tellerEen 'Teken het opvolgende profiel van het verwijderde profiel If geselecteerdProfiel = aantalProfielen + 1 Then geselecteerdProfiel = 1 End If If aantalProfielen <> 0 Then Call tekenProfielen(geselecteerdProfiel) Else 'Toon waarschuwing i = MsgBox("Er zijn geen profielen meer over. Verdere uitvoering RRD-Edit niet mogelijk", vbCritical, "Fout!") 'Stop het programma End End If End Sub Private Sub cmdVolgende_Click() 'Blokkeer de command knoppen cmdVolgende.Enabled = False cmdVorrige.Enabled = False 'Hoog het nummer van het geselecteerde profiel op geselecteerdProfiel = geselecteerdProfiel + 1 'Zorg er voor dat er nooit een profile buiten de array gekozen kan worden If geselecteerdProfiel > aantalProfielen Then geselecteerdProfiel = 1 'Teken het nieuwe profiel Call tekenProfielen(geselecteerdProfiel) 'Bij het laatse profiel, dan zorgen dat weer bij nummer 1 begonnen wordt 'If aantalProfielen = geselecteerdProfiel Then geselecteerdProfiel = 0 'De Blokkeer de command knoppen cmdVolgende.Enabled = True cmdVorrige.Enabled = True End Sub Private Sub cmdVorrige_Click() 'Blokkeer de command knoppen cmdVolgende.Enabled = False cmdVorrige.Enabled = False 'Verminder het nummer van het geselecteerde profiel If geselecteerdProfiel = 1 Then geselecteerdProfiel = aantalProfielen Else geselecteerdProfiel = geselecteerdProfiel - 1 End If 'Teken het nieuwe profiel Call tekenProfielen(geselecteerdProfiel) 'De Blokkeer de command knoppen cmdVolgende.Enabled = True cmdVorrige.Enabled = True End Sub Private Sub Form_Load() 'Declareer lokale constanten Const defaultOffsetmax = -0.5 'Set error handler 'On Error GoTo errorHandler MousePointer = 11 'Toon de default waarde voor de offsetmax txtOffsetZmax.Text = defaultOffsetmax 'Toon de bestandsnaam in het form caption frmGraphicView.Caption = "GraphicView: " + inputBestand 'Toon het aantal ingelezen profielen lblAantalProfielen.Caption = aantalProfielen 'Verkrijg default schaalfactor schaalFactor = scrollSchaal.Value / 100 'Lees het profielenbestand in Call leesBestand 'Lees het bestand in met de slootparameters Call leesBestandSloot 'Teken het eerste profiel Call tekenProfielen(1) 'Geef de waarde 1 mee met het 1e profiel geselecteerdProfiel = 1 MousePointer = 0 Unload frmLaden 'Voorkom dat de errorHandler onnodig wordt uitgevoerd Exit Sub 'Trap errorHandler: 'Toon waarschuwing i = MsgBox("fout in het invoerbestand, restart het programma", vbCritical, "Fout!") 'Stop het programma End 'sluit bestand Close #1 'Verander de muispointer MousePointer = 0 End Sub Sub tekenProfielen(profielNummer As Long) 'Deze routine tekent de profielen en het bovenaanzicht 'Declareer lokale variabelen Dim minX, maxX, minY, maxY, minZ, maxZ, newX, oldX, newY, oldY, newZ, oldZ, schaal, lengteProfiel, oudeLengteProfiel As Double Dim tellerEen, tellerTwee, aantalPunten As Long Dim leesVariabeleX, leesVariabeleY, leesVariabeleZ 'Wis de plot areas picDwarsprofiel.Cls picXY.Cls 'Geselecteerd profiel tellerEen = profielNummer 'Toon geselecteerd profielnaam lblActiefProfiel.Caption = arrayProfielen(tellerEen, 1) & " (" & tellerEen & "/" & aantalProfielen & ")" 'Lees de benodige array regel door voor het tekenen van het profiel en vaststellen van de schaal For tellerTwee = 2 To totaalAantalKolommen If tellerTwee = 2 Then maxX = arrayProfielen(tellerEen, tellerTwee) minX = maxX maxY = arrayProfielen(tellerEen, tellerTwee + 1) minY = maxY maxZ = arrayProfielen(tellerEen, tellerTwee + 2) minZ = maxZ 'Bewaar de startcoördinaten van het geselecteerde profiel startX = maxX startY = maxY startZ = maxZ Else leesVariabeleX = arrayProfielen(tellerEen, tellerTwee) 'Controleer of er nog een waarde aanwezig is, zoniet verlaat dan de For Loop If leesVariabeleX = "" Then aantalPunten = (tellerTwee - 2) / 3 Exit For End If leesVariabeleY = arrayProfielen(tellerEen, tellerTwee + 1) leesVariabeleZ = arrayProfielen(tellerEen, tellerTwee + 2) 'Controleer of de ingelezen variabele de limiet is van het gebied If leesVariabeleX > maxX Then maxX = leesVariabeleX If leesVariabeleX < minX Then minX = leesVariabeleX If leesVariabeleY > maxY Then maxY = leesVariabeleY If leesVariabeleY < minY Then minY = leesVariabeleY If leesVariabeleZ > maxZ Then maxZ = leesVariabeleZ If leesVariabeleZ < minZ Then minZ = leesVariabeleZ End If 'Verhoog de teller met 2 om weer op de positie van een X-coördinaat terug te keren tellerTwee = tellerTwee + 2 Next tellerTwee 'Controleer of het aantalpunten niet gelijk is aan nul If aantalPunten = 0 Then aantalPunten = (tellerTwee - 2) / 3 End If 'Set schaal If (maxY - minY) >= (maxX - minX) Then schaal = (maxY - minY) + (maxY - minY) * 0.5 Else schaal = (maxX - minX) + (maxX - minX) * 0.5 End If 'Set window scales picXY.ScaleLeft = minX - 0.5 * ((maxX - minX) * 0.5) picXY.ScaleTop = -1 * maxY - 0.5 * ((maxY - minY) * 0.5) picXY.ScaleHeight = schaal picXY.ScaleWidth = schaal 'Lees de eerste coördinaten en teken punt oldX = (arrayProfielen(tellerEen, 2)) oldY = (arrayProfielen(tellerEen, 3)) picXY.Circle (oldX, -oldY), schaal / 100, vbRed 'Teken de meetposities For tellerTwee = 5 To (aantalPunten * 3) newX = (arrayProfielen(tellerEen, tellerTwee)) newY = (arrayProfielen(tellerEen, tellerTwee + 1)) 'teken lijn en punten picXY.Line (oldX, -oldY)-(newX, -newY) picXY.Circle (newX, -newY), schaal / 100, vbRed lengteProfiel = lengteProfiel + Sqr((newX - oldX) ^ 2 + (newY - oldY) ^ 2) oldX = newX oldY = newY 'Bewaar telkens de laatstecoördinaten van het geselecteerde profiel endX = newX endY = newY 'Verhoog de teller met 2 om weer op de positie van een X-coördinaat terug te keren tellerTwee = tellerTwee + 2 Next tellerTwee 'Set he bereik van de scrollbar scrollSchaal.Max = 100 scrollSchaal.Min = ((maxZ - minZ) / lengteProfiel) * 100 'Set schaal voor dwarsporiel picDwarsprofiel.ScaleWidth = lengteProfiel + lengteProfiel * 0.1 picDwarsprofiel.ScaleHeight = schaalFactor * -lengteProfiel '(-(maxZ - minZ) - (maxZ - minZ) * 0.1) picDwarsprofiel.ScaleLeft = 0 - 0.5 * lengteProfiel * 0.1 picDwarsprofiel.ScaleTop = (((maxZ - minZ) / 2) + minZ) + schaalFactor * 0.5 * lengteProfiel '(maxZ - minZ) '(maxZ + 0.5 * (maxZ - minZ) * 0.1) 'Toon de afmetingen van het dwarsprofiel grid lblZmax.Caption = Format(picDwarsprofiel.ScaleTop, "###0.00") lblZmin.Caption = Format((picDwarsprofiel.ScaleTop + picDwarsprofiel.ScaleHeight), "###0.00") lblLengte.Caption = Format(lengteProfiel, "###0.00") lblSchaalfactor.Caption = schaalFactor 'Toon de lengte van het profiel en de max en min Z lblLengteProfiel.Caption = Format(lengteProfiel, "###0.00") & " m" lblMaxZ.Caption = Format(maxZ, "###0.00") & " m" lblMinZ.Caption = Format(minZ, "###0.00") & " m" 'Bewaar de schaal in de variabele schaal schaal = lengteProfiel 'Lees de startposities oldX = (arrayProfielen(tellerEen, 2)) oldY = (arrayProfielen(tellerEen, 3)) oldZ = (arrayProfielen(tellerEen, 4)) 'Teken het eerste punt in picDwarsprofiel.Circle (0, oldZ), schaal / 250, vbRed 'Initialiseer de eerste waar op 0 oudeLengteProfiel = 0 lengteProfiel = 0 'Teken het dwarsprofiel For tellerTwee = 5 To (aantalPunten * 3) newX = (arrayProfielen(tellerEen, tellerTwee)) newY = (arrayProfielen(tellerEen, tellerTwee + 1)) newZ = (arrayProfielen(tellerEen, tellerTwee + 2)) lengteProfiel = lengteProfiel + Sqr((newX - oldX) ^ 2 + (newY - oldY) ^ 2) picDwarsprofiel.Line (oudeLengteProfiel, oldZ)-(lengteProfiel, newZ), vbBlack picDwarsprofiel.Circle (lengteProfiel, newZ), schaal / 250, vbRed oldX = newX oldY = newY oldZ = newZ oudeLengteProfiel = lengteProfiel 'Bewaar de eind waarde van Z endZ = oldZ 'Verhoog de teller met 2 om weer op de positie van een X-coördinaat terug te keren tellerTwee = tellerTwee + 2 Next tellerTwee 'Bewaar het aantal punten in een globale variabele puntenGeselecteerdProfiel = aantalPunten 'Roep de subProcedure op om de hulplijnen te tekenen Call tekenHulplijn(maxZ) End Sub Sub tekenHulplijn(maximaleZ) 'Declareer lokalevariabelen Dim offsetMaxZ As Double 'Set trap 'On Error GoTo errorHandler 'lees de offset waarde in offsetMaxZ = txtOffsetZmax.Text 'Teken de top en bottom lijnen (hoogste punt + offset) lineTop.X1 = picDwarsprofiel.ScaleLeft lineTop.X2 = picDwarsprofiel.ScaleWidth lineTop.Y1 = maximaleZ lineTop.Y2 = maximaleZ lineBottom.X1 = picDwarsprofiel.ScaleLeft lineBottom.X2 = picDwarsprofiel.ScaleWidth lineBottom.Y1 = maximaleZ + offsetMaxZ lineBottom.Y2 = maximaleZ + offsetMaxZ 'Voorkom dat de errorHandler onnodig wordt uitgevoerd Exit Sub errorHandler: offsetMaxZ = -0.5 'Teken de top en bottom lijnen (hoogste punt + offset) lineTop.X1 = picDwarsprofiel.ScaleLeft lineTop.X2 = picDwarsprofiel.ScaleWidth lineTop.Y1 = maxZ lineTop.Y2 = maxZ lineBottom.X1 = picDwarsprofiel.ScaleLeft lineBottom.X2 = picDwarsprofiel.ScaleWidth lineBottom.Y1 = maxZ + offsetMaxZ lineBottom.Y2 = maxZ + offsetMaxZ 'Toon waarschuwing i = MsgBox("De offset waarde is geen getal. Kan de waarden niet veranderen", vbCritical, "Fout!") End Sub Sub leesBestandSloot() Dim leesregel As String 'Leesregel uit tekstbestand Dim totaalAantalRegels 'Aantal regels in het ingelezen bestand Dim tempArray() As String Dim tellerEen As Long 'Deze routine leest het bestand met de slootgeometrie in 'Verander de muispointer MousePointer = 11 'Set error trap 'On Error GoTo errorHandler 'Open bestand Open inputBestandSloot For Input As #1 totaalAantalRegels = 0 'Bepaal de lengte van het bestand Do While Not EOF(1) Line Input #1, leesregel totaalAantalRegels = totaalAantalRegels + 1 Loop Close #1 'Controleer of het aantral igelezen regels klopt met het aantal profielen If (totaalAantalRegels - 1) <> aantalProfielen Then 'Toon waarschuwing i = MsgBox("fout in het invoerbestand, restart het programma", vbCritical, "Fout!") 'Stop het programma End End If ReDim arrayProfielenSloot(totaalAantalRegels, aantalKolommenProfielenSloot) totaalAantalRegels = 0 'Open bestand Open inputBestandSloot For Input As #1 'Lees de Header regel Line Input #1, leesregel Do While Not EOF(1) Line Input #1, leesregel tempArray() = Split(leesregel, ";") totaalAantalRegels = totaalAantalRegels + 1 For tellerEen = 0 To aantalKolommenProfielenSloot - 1 arrayProfielenSloot(totaalAantalRegels, tellerEen + 1) = tempArray(tellerEen) Next tellerEen Loop Close #1 'Voorkom dat de errorHandler zonder reden wordt uitgevoerd Exit Sub 'Trap errorHandler: 'Toon waarschuwing i = MsgBox("fout in het invoerbestand, restart het programma", vbCritical, "Fout!") 'Stop het programma End 'sluit bestand Close #1 'Verander de muispointer MousePointer = 0 End Sub Sub leesBestand() 'Deze sub routine leest het geselecteerde bestand en bewaart de gegevens in een dynamische array 'Declareren locale variabelen Dim X, Y, Z, huidigProfiel, omschrijving, puntnummer, xStartRaw, yStartRaw, xEndRaw, yEndRaw, xRawOld, xRawNew, yRawOld, yRawNew, dX, dY, kaarthoek Dim xOld, yOld Dim xLees, yLees, xEdit, yEdit, RC1, RC2, b1, b2, xn, yn, puntCode, subPuntCode Dim profielnaam As String Dim i As Integer Dim helpArrayProfielen(), helpArrayPuntCode() 'Tijdelijke array Dim tellerEen, tellerTwee, tellerDrie, tellerVier, tellerVijf, tellerZes, tellerZeven, tellerAcht As Long Dim helpAantalKolommen, aantalKolommen, helpAantalKolommenPuntCodes As Long Dim aantalKolommenPuntCodes As Long Const PI = 3.14159265358979 'Verander de muispointer MousePointer = 11 'Set error trap 'On Error GoTo errorHandler 'Open bestand Open inputBestand For Input As #1 'Lees de 1e regel uit het bestand Input #1, puntCode, subPuntCode, X, Y, Z, profielnaam 'Verhoog het aantalprofielen met 1 aantalProfielen = aantalProfielen + 1 'ReDefine de dynamic Array en behoud de vulling er van ReDim Preserve rawArrayProfielen(aantalProfielen, 4) 'ReDefine de dynamic Array voor de puntCode's en behoud inhoud daarvan ReDim Preserve arrayPuntCode(aantalProfielen, 3) 'Vul de array's met de nieuwe waarden rawArrayProfielen(aantalProfielen, 1) = profielnaam If Z <> -9999# Then rawArrayProfielen(aantalProfielen, 2) = Round(X, 3) rawArrayProfielen(aantalProfielen, 3) = Round(Y, 3) rawArrayProfielen(aantalProfielen, 4) = Round(Z, 3) arrayPuntCode(aantalProfielen, 1) = profielnaam arrayPuntCode(aantalProfielen, 2) = puntCode arrayPuntCode(aantalProfielen, 3) = subPuntCode 'Geef het aantalKolommen de waarde mee aantalKolommen = 4 aantalKolommenPuntCodes = 3 Else 'Geef het aantalKolommen de waarde mee aantalKolommen = 1 aantalKolommenPuntCodes = 1 End If 'Bewaar de ingelezen X en Y waarden in de oude X en Y coördinaten xOld = Round(X, 3) yOld = Round(Y, 3) 'Bewaar de profielnaam in huidigprofiel huidigProfiel = profielnaam 'Doorloop het gehele bestand Do While Not EOF(1) 'Lees de regel uit het bestand Input #1, puntCode, subPuntCode, X, Y, Z, profielnaam 'Rond de waarde af X = Round(X, 3) Y = Round(Y, 3) Z = Round(Z, 3) 'Controleer welk profiel ingelezen is If (profielnaam = huidigProfiel) Or (profielnaam = "") Then 'COntroleer of het nieuw ingelezen punt niet gelijk is aan het vorige punt. 'Als dit het geval is dan ingelezen punt niet opnemen in array If (X = xOld) And (Y = yOld) Then 'Controleer of er een puntcode is, niet gelijk aan 99, als dit zo is dan 'bij het voorgaande, gelijke punt, invullen If (puntCode <> 99) Or (subPuntCode <> 999) Then arrayPuntCode(aantalProfielen, aantalKolommenPuntCodes - 3) = puntCode arrayPuntCode(aantalProfielen, aantalKolommenPuntCodes - 2) = subPuntCode End If 'Toon waarschwuing 'i = MsgBox("Profiel " & profielnaam & " bevat een dubbel punt." & Chr$(13) & "xOld = " & xOld & " = xNew " & X & Chr$(13) & "yOld = " & yOld & " = yNew = " & Y & Chr$(13) & "Het punt wordt niet meegenomen in de database", vbCritical, "Melding") ElseIf (Z <> -9999#) Then 'Verhoog het aantalKolommen voor de positie in de array aantalKolommen = aantalKolommen + 3 aantalKolommenPuntCodes = aantalKolommenPuntCodes + 2 'Controleer of het aantalkolommen groter wordt dan de array ,reed is If aantalKolommen > helpAantalKolommen Then 'ReDefine de dynamic Array en behoud de vulling er van ReDim Preserve rawArrayProfielen(aantalProfielen, aantalKolommen) End If 'Controleer of het aantalkolommen groter wordt dan de array If aantalKolommenPuntCodes > helpAantalKolommenPuntCodes Then 'ReDefine de dynamic Array en behoud de vulling er van ReDim Preserve arrayPuntCode(aantalProfielen, aantalKolommenPuntCodes) End If 'Vul de array met de nieuwe waarden rawArrayProfielen(aantalProfielen, (aantalKolommen - 2)) = Round(X, 3) rawArrayProfielen(aantalProfielen, (aantalKolommen - 1)) = Round(Y, 3) rawArrayProfielen(aantalProfielen, aantalKolommen) = Round(Z, 3) arrayPuntCode(aantalProfielen, aantalKolommenPuntCodes - 1) = puntCode arrayPuntCode(aantalProfielen, aantalKolommenPuntCodes) = subPuntCode 'Bewaar de ingelezen X en Y waarden in de oude X en Y coördinaten xOld = X yOld = Y End If Else 'Bewaar de actuele breedte van de arrayAantalKolommen als deze de grootste breedte bevat If aantalKolommen > helpAantalKolommen Then helpAantalKolommen = aantalKolommen End If 'Bewaar de actuele breedte van de aantalkolommenPuntCodes als deze de grootste breedte bevat If aantalKolommenPuntCodes > helpAantalKolommenPuntCodes Then helpAantalKolommenPuntCodes = aantalKolommenPuntCodes End If 'Define tijdelijke array's ReDim helpArrayProfielen(aantalProfielen, helpAantalKolommen) ReDim helpArrayPuntCode(aantalProfielen, helpAantalKolommenPuntCodes) 'Kopieer arrayProfielen in de tijdelijke helpArrayProfielen For tellerEen = 1 To aantalProfielen For tellerTwee = 1 To helpAantalKolommen helpArrayProfielen(tellerEen, tellerTwee) = rawArrayProfielen(tellerEen, tellerTwee) Next tellerTwee Next tellerEen 'Kopieer arrayPuntCode in de tijdelijke helpArrayPuntCode For tellerEen = 1 To aantalProfielen For tellerTwee = 1 To helpAantalKolommenPuntCodes helpArrayPuntCode(tellerEen, tellerTwee) = arrayPuntCode(tellerEen, tellerTwee) Next tellerTwee Next tellerEen 'Verhoog het aantalprofielen met 1 aantalProfielen = aantalProfielen + 1 'ReDefine de dynamic Array's ReDim rawArrayProfielen(aantalProfielen, helpAantalKolommen) ReDim arrayPuntCode(aantalProfielen, helpAantalKolommenPuntCodes) 'Kopieer de tijdelijke helpArrayProfielen in rawArrayProfielen For tellerEen = 1 To aantalProfielen - 1 For tellerTwee = 1 To helpAantalKolommen rawArrayProfielen(tellerEen, tellerTwee) = helpArrayProfielen(tellerEen, tellerTwee) Next tellerTwee Next tellerEen 'Kopieer de tijdelijke helpAantalkolommenPuntcodes in aantalKolommenPuntcodes For tellerEen = 1 To aantalProfielen - 1 For tellerTwee = 1 To helpAantalKolommenPuntCodes arrayPuntCode(tellerEen, tellerTwee) = helpArrayPuntCode(tellerEen, tellerTwee) Next tellerTwee Next tellerEen 'Vul de array's met de nieuwe waarden rawArrayProfielen(aantalProfielen, 1) = profielnaam If Z <> -9999# Then rawArrayProfielen(aantalProfielen, 2) = Round(X, 3) rawArrayProfielen(aantalProfielen, 3) = Round(Y, 3) rawArrayProfielen(aantalProfielen, 4) = Round(Z, 3) arrayPuntCode(aantalProfielen, 1) = profielnaam arrayPuntCode(aantalProfielen, 2) = puntCode arrayPuntCode(aantalProfielen, 3) = subPuntCode 'Geef het aantalKolommen de waarde mee aantalKolommen = 4 aantalKolommenPuntCodes = 3 Else 'Geef het aantalKolommen de waarde mee aantalKolommen = 1 aantalKolommenPuntCodes = 1 End If 'Bewaar de ingelezen X en Y waarden in de oude X en Y coördinaten xOld = Round(X, 3) yOld = Round(Y, 3) huidigProfiel = profielnaam End If Loop 'Als één profiel in het bestand staat, dan is het aantalkolommen het gebruikte kolommen If helpAantalKolommen = 0 Then helpAantalKolommen = aantalKolommen helpAantalKolommenPuntCodes = aantalKolommenPuntCodes End If 'Bewaar het totaal aantal kolommen totaalAantalKolommen = helpAantalKolommen totaalAantalKolommenPuntCodes = helpAantalKolommenPuntCodes 'Set de grootte van de Array ReDim arrayProfielen(aantalProfielen, totaalAantalKolommen) 'Kopieer de rawArrayProfielen in arrayProfielen 'Deze module staat hier omdat namelijk eerst de kaarthoek etc. berekend werd For tellerDrie = 1 To aantalProfielen For tellerVier = 1 To totaalAantalKolommen 'Bewaar het eerste punt, deze is ongewijzigd arrayProfielen(tellerDrie, tellerVier) = rawArrayProfielen(tellerDrie, tellerVier) Next tellerVier Next tellerDrie 'Als er maar één profiel in het bestand staat, dan disable de for en back knoppen If aantalProfielen = 1 Then cmdVolgende.Enabled = False cmdVorrige.Enabled = False End If 'Maak de arrayGeologischeProfielen aan ReDim arrayGeologischProfiel(aantalProfielen) 'sluit bestand Close #1 'Verander de muispointer MousePointer = 0 'Maak de knooppunten array aan voor de knoppunten en de process log ReDim arrayKnooppunten(aantalProfielen, 37) ReDim arrayProcessLog(aantalProfielen, aantalKolommenArrayProcessLog) 'Vul de arrayProcessLog met de profielnamen en de waarde FALSE voor de taludhellingen aanpassing For tellerEen = 1 To aantalProfielen arrayProcessLog(tellerEen, 1) = arrayProfielen(tellerEen, 1) arrayProcessLog(tellerEen, 4) = "FALSE" Next tellerEen 'Toon de array eigenschappen lblRijen.Caption = aantalProfielen lblKolommen.Caption = totaalAantalKolommen lblAantalProfielen.Caption = aantalProfielen 'Voorkom dat de errorHandler zonder reden wordt uitgevoerd Exit Sub 'Trap errorHandler: 'Toon waarschuwing i = MsgBox("fout in het invoerbestand, restart het programma", vbCritical, "Fout!") 'Stop het programma End 'sluit bestand Close #1 'Verander de muispointer MousePointer = 0 End Sub Private Sub picDwarsprofiel_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'Toon de X, Y coördinaat in de tooltip picDwarsprofiel.ToolTipText = "L = " & Format(X, "###0.00") & "m, Z = " & Format(Y, "###0.00") & "m" End Sub Private Sub picXY_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'Toon de X, Y coördinaat in de tooltip picXY.ToolTipText = "X = " & Format(X, "###0.00") & "m, Y = " & Format(-1 * Y, "###0.00") & "m" End Sub Private Sub scrollSchaal_Change() 'Verkijg de schaalfactor uit de scrollbar value schaalFactor = scrollSchaal.Value / 100 'Teken het profiel opnieuw bij verandering van de schaal tekenProfielen (geselecteerdProfiel) End Sub