'gpx/tcx to gcode converter
'cbf May 2026
Option Explicit
Public flh As Single    'first layer height
Public ew As Single     'extrusion width
Public fd As Single     'filament diameter
Public x1               'filament scaler
Public Aroad_scaler As Single
Public prn_def(11)
Public olle(3, 3)
Public nlle(3, 3)
Public loaded As Boolean
Public zlayers As Long
Public geofile As Variant
Public prog$
Public def_loaded As Boolean
Public DataWidth As Long
Public DataHeight As Long
Public strata() As Variant
Public ftype As String
Public datatype As String
Public binsmax As Long
Public central As Long
Public lonrng As Long
Public latrng As Long

Sub gpx_conv()

 Call namesheets

 With Worksheets(1)
  .Select
  .Cells.Clear
  .Range("A1").Activate
 End With
 
 Call Clear_Charts

 prog$ = "gpx_conv14"
 datatype = "gpx"   '"tcx"
 def_loaded = False

 central = 100
 flh = 0.36
 ew = 0.61   'extrusion width (mm)
 fd = 1.75   'filament diameter (mm)
 x1 = 1
 Aroad_scaler = 1.5
 
 'latitude rescale
 nlle(1, 1) = 185                        'max
 nlle(1, 2) = 100                        'min
 nlle(1, 3) = nlle(1, 1) - nlle(1, 2)    'range

 'longtitude rescale
 nlle(2, 1) = 185
 nlle(2, 2) = 100
 nlle(2, 3) = nlle(2, 1) - nlle(2, 2)

 'elevation rescale
 nlle(3, 1) = 70
 nlle(3, 2) = 0
 nlle(3, 3) = nlle(3, 1) - nlle(3, 2)

 Select Case datatype
  Case "gpx"
   ftype = "GPS files (*.gpx), *.gpx"
  Case "tcx"
   ftype = "TCX files (*.tcx), *.tcx"
 End Select

 UserForm1.Show
 'Call gpx
End Sub

Public Function gpx(Mydata)
 'global flh, ew, fd, x1, Aroad_scaler, nlle(), olle()
 Dim a As Long
 Dim b As Long
 Dim c As Long
 Dim cl As Variant
 Dim dat(0 To 12) As Variant
 Dim e(1 To 4) As Single
 Dim r As Single
 Dim spd_unit As Single
 Dim tmp As Long, tmp1 As Long, tmp2 As Long
 Dim all() As Variant
 Dim formtype(1 To 1) As Variant
 Dim strData() As String
 'Dim datatype As String
 'Dim ftype As String
 Dim offset As Long
 Dim t1 As Single

 t1 = Timer

 datatype = "gpx"   '"tcx"
 Select Case datatype
  Case "gpx"
   formtype(1) = Array("<trkseg>", "lat=", "lon=", "<ele>", "<time>", "<gpxtpx:hr>", "</trkpt>", "<trkpt") 'gpx
   ftype = "GPS files (*.gpx), *.gpx"
  Case "tcx"
   formtype(1) = Array("<Track>", "<LatitudeDegrees>", "<LongitudeDegrees>", "<AltitudeMeters>", "<Time>", "<HeartRateBpm><Value>", "<Trackpoint>")  'tcx
   ftype = "TCX files (*.tcx), *.tcx"
 End Select

 r = 6371       'radius of earth - 3958.756in ml, 6371 in km
 spd_unit = 1   '0.621371 in mph, 1 in kph
 
 For a = 0 To UBound(dat): dat(a) = 0: Next a
 
 Select Case datatype
  Case "gpx": strData() = Split(Mydata, formtype(1)(7)) 'gpx
  Case "tcx": strData() = Split(Mydata, formtype(1)(6)) 'tcx
 End Select
 
 a = 0
 Do While InStr(strData(a), formtype(1)(0)) = 0
  a = a + 1
 Loop
 a = a + 1
 b = 0
 Do
  cl = Trim$(strData(a))
  If Len(cl) = 0 Then Exit Do
   
   Select Case datatype
    Case "gpx": offset = 1
    Case "tcx": offset = 0
   End Select
   tmp1 = InStr(1, cl, formtype(1)(1)): If tmp1 Then dat(1) = Val(Mid$(cl, tmp1 + (Len(formtype(1)(1)) + offset)))
   tmp2 = InStr(1, cl, formtype(1)(2)): If tmp2 Then dat(2) = Val(Mid$(cl, tmp2 + (Len(formtype(1)(2)) + offset)))
   If tmp1 <> 0 And tmp2 <> 0 Then
    If ((b + 1) Mod 2) <> 0 Then e(1) = dat(1): e(2) = dat(2) Else e(3) = dat(1): e(4) = dat(2)
    If (b + 1) > 1 Then
     With WorksheetFunction
      On Error Resume Next
       dat(6) = .Acos(Cos(.Radians(90 - e(1))) * Cos(.Radians(90 - e(3))) + Sin(.Radians(90 - e(1))) * Sin(.Radians(90 - e(3))) * Cos(.Radians(e(2) - e(4)))) * r 'distance
      On Error GoTo 0
     End With
    End If
   End If
   
   If InStr(1, cl, formtype(1)(3)) Then
    dat(3) = Val(Mid$(cl, InStr(1, cl, formtype(1)(3)) + Len(formtype(1)(3))))
    dat(7) = deltaE(b, dat(3))  'elevation delta
   End If
   
   tmp = InStr(1, cl, formtype(1)(4))
   Select Case datatype
    Case "gpx": offset = 1
    Case "tcx": offset = (tmp + Len(formtype(1)(4))) + 1
   End Select
   If tmp Then dat(4) = Mid$(cl, tmp + Len(formtype(1)(4)), InStr(offset, cl, "T") - (InStr(cl, formtype(1)(4)) + Len(formtype(1)(4)))) 'date
   If InStr(1, cl, formtype(1)(4)) Then
    dat(5) = Mid$(cl, InStr(offset, cl, "T") + 1, InStr(cl, "Z") - (InStr(offset, cl, "T") + 1)) 'time
    dat(8) = deltaT(b, dat(5))   'time delta
   End If
  
   tmp = InStr(1, cl, formtype(1)(5))
   If tmp Then dat(12) = Val(Mid$(cl, tmp + (Len(formtype(1)(5)) + 0))) 'heartrate
  
   b = b + 1
   dat(0) = b
   On Error Resume Next
    dat(9) = (((((dat(6) * 9300) * (60 / (dat(8) * 86400)))) / 60) / 1.60934) * 0.621371    'speed
    dat(10) = (dat(7) / (dat(6) * 1000)) * 100                                              'gradient
   On Error GoTo 0
   dat(11) = Watts(dat(9), dat(10))
   ReDim Preserve all(0 To UBound(dat), 1 To b)
   For c = 0 To UBound(dat): all(c, b) = dat(c): Next c
  
  a = a + 1
 Loop Until a >= UBound(strData)
 
 Call summaries(all)
 
 If Data_Extent(1) Then
  Call map3d(7, DataHeight, 3, 2, 4)
  Call chartXYarray(1, 7, DataHeight, 3, 2, "XYScatter")
 End If
 
 Debug.Print Timer - t1
 
End Function

Public Function deltaT(b As Long, dat As Variant) As Single

 Static g(1 To 2) As Variant
   
   If InStr(1, dat, ".") <> 0 Then
    dat = Mid$(dat, 1, InStr(1, dat, ".") - 1)
   End If
   
   If (b + 1) < 3 Then
    If ((b + 1) Mod 2) <> 0 Then
     g(1) = dat
    Else
     g(2) = dat: deltaT = TimeValue(g(2)) - TimeValue(g(1)): g(1) = g(2)
    End If
   Else
    deltaT = TimeValue(dat) - TimeValue(g(1)): g(1) = dat
   End If

End Function

Public Function deltaE(b As Long, dat As Variant) As Single

 Static f(1 To 2) As Variant

   If (b + 1) < 3 Then
    If ((b + 1) Mod 2) <> 0 Then
     f(1) = dat
    Else
     f(2) = dat: deltaE = f(2) - f(1): f(1) = f(2)
    End If
   Else
    deltaE = dat - f(1): f(1) = dat
   End If

End Function

Public Function summaries(all)

 Dim a As Long
 Dim titles() As Variant
 Dim lastrow As Long
 Dim sumrange As Range
 Dim climbht As Range
 Dim climbdist As Range
 Dim myrange As Range
 Dim sumdata() As Variant

  'Worksheets(1).Select
  'Cells.Clear
  'Range("A1").Activate
  
  With Application
   
   titles = Array("#", "lat", "lon", "ele", "date", "time", "dDst", "dHt", "dTm", "spd", "slope%", "watts", "hr", "ascent")
   Cells(1, 1).Resize(1, UBound(titles) + 1) = titles
   
   titles = Array("Max", "Min", "Delta", "Ave", "Sum")
   Cells(2, 1).Resize(UBound(titles) + 1, 1) = .Transpose(titles)
  
   Cells(7, 1).Resize(UBound(all, 2), UBound(all, 1) + 1) = .Transpose(all)
   lastrow = Cells(Rows.Count, "A").End(xlUp).Row
   
   'summaries
   
   For a = 2 To UBound(all, 1) + 1
    ReDim sumdata(2 To 6)
    Set sumrange = Range(Cells(7, a), Cells(lastrow, a))
    sumdata(2) = .max(sumrange) 'Cells(2, a)
    sumdata(3) = .Min(sumrange) 'Cells(3, a)
    Select Case a
     Case 1 To 4, 8, Is > 9
      sumdata(5) = .Average(sumrange)   'Cells(5, a)
    End Select
    Select Case a
     Case 2 To 6, 8, 11 To 13
      sumdata(4) = sumdata(2) - sumdata(3) 'Cells(2, a) - Cells(3, a)   'delta Cells(4, a)
     Case 7, 9
      sumdata(6) = .Sum(sumrange)   'Cells(6, a)
    End Select
    Cells(2, a).Resize(UBound(sumdata) - 1, 1) = .Transpose(sumdata)
   Next a
   
   'climb data
   Set climbht = Range(Cells(7, 8), Cells(lastrow, 8))
   Set climbdist = Range(Cells(7, 7), Cells(lastrow, 7))
   Cells(2, 14) = .SumIf(climbht, ">0", climbht)    'ascent
   Cells(3, 14) = .SumIf(climbht, "<0", climbht)    'descent
   Cells(2, 15) = .SumIf(climbht, ">0", climbdist)  'ascent dist
   Cells(3, 15) = .SumIf(climbht, "<0", climbdist)  'descent dist
   Cells(4, 15) = .SumIf(climbht, "0", climbdist)   'flat dist
   titles = Array("up", "down", "flat")
   Cells(2, 16).Resize(UBound(titles) + 1, 1) = .Transpose(titles)

  End With
  
  'formatting
  Set myrange = Union(Range(Cells(2, 6), Cells(4, 6)), Cells(6, 9))
  myrange.NumberFormat = "hh:mm:ss"
  Range(Cells(2, 5), Cells(3, 5)).NumberFormat = "dd/mm/yyyy"

  Set sumrange = Nothing
  Set climbht = Nothing
  Set climbdist = Nothing
  Set myrange = Nothing

End Function

Public Function Watts(dat9 As Variant, dat10 As Variant) As Single
 
 Dim w(0 To 3) As Single
 
 On Error Resume Next
  w(0) = ((dat9 * 1000) / 3600)                'm/s
  w(1) = 0.004 * 70 * w(0)
  w(2) = 0.5 * 0.2284 * w(0) * (w(0) ^ 2) * 1.226
  w(3) = 9.8 * (dat10 / 100) * 70 * w(0)
  Watts = (w(1) + w(2) + w(3)) * 0.95          'Effective Watts
 On Error GoTo 0

End Function

Public Function layers() As Long
'create layer map
'global:flh - filament height

Dim arr As Range
Dim lastrow As Long
Dim endrow As Long
Dim a As Long
Dim b As Long
Dim max As Long
Dim inc()
Dim tmp()

'latitude rescale
'nlle(1, 1) = 185                        'max
'nlle(1, 2) = 100                        'min
'nlle(1, 3) = nlle(1, 1) - nlle(1, 2)    'range

'longtitude rescale
'nlle(2, 1) = 185
'nlle(2, 2) = 100
'nlle(2, 3) = nlle(2, 1) - nlle(2, 2)

'elevation rescale
'nlle(3, 1) = 70
'nlle(3, 2) = 0
'nlle(3, 3) = nlle(3, 1) - nlle(3, 2)

With Worksheets(1)                                  'read lat, lon, ele and pass to range
 Set arr = .Range(.Cells(7, 2), .Cells(DataHeight, 4)) 'copy to array
End With
 
strata() = arr
endrow = (DataHeight - 6)

'find min, max and range per column
For a = 1 To 3
 ReDim tmp(1 To endrow)
 For b = 1 To endrow:  tmp(b) = strata(b, a): Next b
 With Application
  olle(a, 1) = .max(tmp)
  olle(a, 2) = .Min(tmp)
  olle(a, 3) = (olle(a, 1) - olle(a, 2))    'range
 End With
 For b = 1 To endrow
  strata(b, a) = Rescale(strata(b, a), olle(a, 2), olle(a, 3), nlle(a, 3), nlle(a, 2))
 Next b
Next a
 
 ReDim Preserve strata(1 To endrow, 1 To (olle(3, 1) + 3))
 
 For a = 1 To endrow
  ReDim inc(1 To 1, 1 To olle(3, 1))                                'define array for numbers
  max = strata(a, 3)                                                'max height per line
  If max > 0 Then
   For b = 1 To max: inc(1, b) = (b * flh): Next b                  'fill array with numbers from 1 to Max
   If max < olle(3, 1) Then
    For b = max + 1 To olle(3, 1): inc(1, b) = -(b * flh): Next b   'part zero's
   End If
  Else
   For b = 1 To olle(3, 1): inc(1, b) = -(b * flh): Next b          'all zero's
  End If
  For b = 1 To olle(3, 1): strata(a, (3 + b)) = inc(1, b): Next b
 Next a
 
 With Worksheets(2)
  .Cells.Clear
  .Cells(1, 1).Resize(UBound(strata), UBound(strata, 2)) = strata
  Dim rng As Range
  Set rng = .Range(.Cells(1, 1), .Cells(UBound(strata), UBound(strata, 2)))
  rng.FormatConditions.Delete
  With rng.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:="0")
   .Interior.Color = RGB(0, 255, 0)
  End With
  
 End With

layers = nlle(3, 1)

Set arr = Nothing

End Function

Public Function gcode(height As Long)
'create the gcode from the map array data
'input: height - map array data columns
'global: flh, ew, fd, x1, strata()

 Dim data_gcode() As Variant
 Dim arr As Range
 Dim a As Long
 Dim b As Long
 Dim c As Long
 Dim lastrow As Long
 Dim gcoded(4) As String
 'Dim fx As Single
 'Dim fy As Single
 Dim dx As Single
 Dim dy As Single
 Dim length As Single
 Dim Aroad As Single
 Dim evt As Single
 Dim flag As Boolean
 Dim flagcount As Long
 Dim lastx As Single
 Dim lasty As Single
 Dim zed As Variant
 Dim response As Variant

 Const PI = 3.124
 Aroad = ((ew - flh) * flh + PI * (flh / 2) ^ 2) * Aroad_scaler          'area of deposited filament (mm2)

 With Worksheets(3)
  .Cells.Clear

  c = 0                                                         'gcode line count
  evt = 0                                                       'Evalue total
  flag = False
  For a = 4 To (height + 3)                                     'map array column
   If c > 1000000# Then
    response = MsgBox("Rows>1e6 process ended!", vbOKOnly)
    Exit Function
   End If
   For b = 1 To UBound(strata)                                         'map array row
    c = c + 1

    GoSub datareader
   
    If Sgn(strata(b, a)) <= 0 Then
     flag = False '-1                                           'E0 line
    Else
     If flagcount > 0 Then                                      'fast move without extrusion
      GoSub sprint
      GoSub datareader
     End If
     flagcount = 0: flag = True '1                              'line with E value > 0
    End If
    
    If b > 1 Then
     'fx = strata(b - 1, 1): fy = strata(b - 1, 2)
     dx = Abs(strata(b - 1, 1) - strata(b, 1)): dy = Abs(strata(b - 1, 2) - strata(b, 2))
     length = Sqr((dx ^ 2) + (dy ^ 2))
     If flag = False Then
      flagcount = flagcount + 1
      lastx = strata(b, 1): lasty = strata(b, 2)                'xy values of last E0 in block
     Else
      If gcoded(4) = "." Then
       'Evalue = Aroad * length * 4 / (PI * fd ^ 2 * x1)
       evt = (Aroad * length * 4 / (PI * fd ^ 2 * x1)) + evt
       gcoded(4) = "E" & Format(evt, "##0.0##")
      End If
     End If
    Else
     gcoded(4) = "E0"
     If c <> 1 Then
      Erase gcoded
      gcoded(0) = "G0"
      gcoded(1) = "F1500"
     End If
    End If
   
    If flag = True Then
     .Cells(c, 1).Resize(1, UBound(gcoded) + 1) = gcoded
    End If

   Next b
  Next a

  Set arr = .Range(.Cells(1, 1), .Cells(c, 5))                  'copy to array
 End With
 
 data_gcode() = arr
 Call savefile(data_gcode())
 Call savelayer1(data_gcode())

 Set arr = Nothing

Exit Function

datareader:
 gcoded(0) = "G1"
 gcoded(2) = "Y" & Format(strata(b, 1), "###.0##")
 gcoded(1) = "X" & Format(strata(b, 2), "###.0##")
 gcoded(3) = "Z" & Format(Abs(strata(b, a)), "##0.0##")
 gcoded(4) = "."
 
 If zed <> Abs(strata(b, a)) Then zed = Abs(strata(b, a)): zlayers = zlayers + 1

Return

sprint:
 With Worksheets(3)
  Erase gcoded
  gcoded(0) = "G0"
  gcoded(1) = "F7200"
  gcoded(3) = "Y" & Format(lastx, "###.0##")
  gcoded(2) = "X" & Format(lasty, "###.0##")
  If flagcount >= 1 Then
   c = (c - (flagcount - 2))
   .Cells(c - 2, 1).Resize(1, UBound(gcoded) + 1) = gcoded
   Erase gcoded
   gcoded(0) = "G0"
   gcoded(1) = "F1500"
   .Cells(c - 1, 1).Resize(1, UBound(gcoded) + 1) = gcoded
  Else
   Erase gcoded
   gcoded(0) = "G0"
   gcoded(1) = "F1500"
  End If
 End With

Return

End Function

Public Function savefile(data)

 Dim fs
 Dim oFile
 Dim a As Long
 Dim b As Long
 Dim lastrow As Long
 Dim stringPath As String
 Dim settings() As Variant
 Dim arr As Range
 Dim tmp

 stringPath = "C:\Users\xpie2\Documents\excel\gpx\" & prog$ & ".txt"
 
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set oFile = fs.CreateTextFile(stringPath, True)

 With Worksheets(4)                                     'setup gcode
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
  Set arr = .Range(.Cells(1, 1), .Cells(lastrow, 1))    'copy to array
 End With
 settings() = arr
 For a = 1 To UBound(settings)
  oFile.Write settings(a, 1) & vbCrLf
 Next a
 
 For a = 1 To UBound(data)                              '3d print data
  If Trim(data(a, 1)) <> "" Then
   tmp = ""
   For b = 1 To UBound(data, 2)
    tmp = tmp & data(a, b) & " "
   Next b
   tmp = tmp & vbCrLf
   oFile.Write tmp
  End If
 Next a

 With Worksheets(5)                                     'reset gcode
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
  Set arr = .Range(.Cells(1, 1), .Cells(lastrow, 1))    'copy to array
 End With
 settings() = arr
 For a = 1 To UBound(settings)
  oFile.Write settings(a, 1) & vbCrLf
 Next a
 
 oFile.Close
 
 Set oFile = Nothing
 Set fs = Nothing
 Set arr = Nothing

End Function

Public Function speedup_on()
'turn on speedup options
 With Application
  .Calculation = xlCalculationManual
  .ScreenUpdating = False
  .DisplayStatusBar = False
  .EnableEvents = False
 End With
 ActiveSheet.DisplayPageBreaks = False
End Function

Public Function speedup_off()
 'turn off speedup options
 Calculate
 With Application
  .Calculation = xlCalculationAutomatic
  .ScreenUpdating = True
  .DisplayStatusBar = True
  .EnableEvents = True
 End With
 ActiveSheet.DisplayPageBreaks = True
End Function

Public Function Data_Extent(wsht) As Boolean
'find the extent of the data
'i/p: wsht
'o/p: Data_Extent
'global: DataWidth, DataHeight

 Dim response As Variant
 
 With Worksheets(wsht)
  
  If WorksheetFunction.CountA(.Cells) > 0 Then
   DataHeight = (.Cells.Find(what:="*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)
  End If
  If (DataHeight) < 1 Then
   response = MsgBox("Height Error!", vbOKOnly, "Format Check")
   If response = vbOK Then
    Data_Extent = False
    Exit Function
   End If
  End If

  'Search for any entry, by searching backwards by Columns.
  If WorksheetFunction.CountA(.Cells) > 0 Then
   DataWidth = (.Cells.Find(what:="*", After:=.Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column)
  End If
  If (DataWidth) < 1 Then
   response = MsgBox("Width Error!", vbOKOnly, "Format Check")
   If response = vbOK Then
    Data_Extent = False
    Exit Function
   End If
  End If
  
 End With
 
 Data_Extent = True
 
End Function

Public Function chart3darray(wsht As Long, array_x, array_y, array_z, title$)
    
    'chart from array data
    Dim a As Long
    Dim chtO As ChartObject
    Dim ws As Worksheet
    
    Set ws = Worksheets(wsht)
 
    With ws.Range("O5:U25")
     Set chtO = ws.ChartObjects.Add(.Left, .Top, .Width, .height)
     chtO.Name = title$
    End With
    
    With chtO.Chart
     .HasTitle = True
     With .ChartTitle
      .Characters.Text = Trim$(title$)
      .Font.Bold = True
      .Font.Size = 10
     End With
    
     For a = 1 To UBound(array_y)
      With .SeriesCollection.NewSeries
       .XValues = array_x
       .Values = Application.Index(array_z, 0, a)
       .Name = array_y(a)
      End With
     Next a
     .ChartType = xlSurface
    End With

End Function

Public Function axis_values(comin As Long, comax As Long) As Variant
 
 Dim a As Long
 Dim b As Long
 Dim tmp() As Long
 ReDim tmp(1 To ((comax - comin) + 1))
 
 b = 0
 For a = comin To comax
  b = b + 1: tmp(b) = a
 Next a
 
 axis_values = tmp()

End Function

Public Function map3d(Rowstart As Long, Rowend As Long, xcolumn As Long, ycolumn As Long, data_col As Long)
 
 Dim xcora() As Long
 Dim ycora() As Long
 Dim xco(1 To 2) As Long
 Dim yco(1 To 2) As Long
 Dim map() As Long
 Dim xmap() As Variant
 Dim ymap() As Variant
 Dim bin() As Variant
 Dim a As Long
 Dim xco_m(2) As Single
 Dim yco_m(2) As Single
 Dim bin_m(2) As Single
 Dim xmap_rescale As Long
 Dim ymap_rescale As Long
  
  'latitude rescale
 'nlle(1, 1) = 185                        'max
 'nlle(1, 2) = 100                        'min
 'nlle(1, 3) = nlle(1, 1) - nlle(1, 2)    'range

 'longtitude rescale
 'nlle(2, 1) = 185
 'nlle(2, 2) = 100
 'nlle(2, 3) = nlle(2, 1) - nlle(2, 2)

 'elevation rescale
 'nlle(3, 1) = 70
 'nlle(3, 2) = 0
 'nlle(3, 3) = nlle(3, 1) - nlle(3, 2)
 
 'extent of x/y/bin values
 xmap = Range(Cells(Rowstart, xcolumn), Cells(Rowend, xcolumn))
 ymap = Range(Cells(Rowstart, ycolumn), Cells(Rowend, ycolumn))
 bin = Range(Cells(Rowstart, data_col), Cells(Rowend, data_col))
  
 With Application
  xco_m(0) = .Min(xmap)
  xco_m(1) = .max(xmap)
  xco_m(2) = (xco_m(1) - xco_m(0))
  xco(1) = Rescale(xco_m(0), xco_m(0), xco_m(2), nlle(1, 3), nlle(1, 2))
  xco(2) = Rescale(xco_m(1), xco_m(0), xco_m(2), nlle(1, 3), nlle(1, 2))
  
  yco_m(0) = .Min(ymap)
  yco_m(1) = .max(ymap)
  yco_m(2) = (yco_m(1) - yco_m(0))
  yco(1) = Rescale(yco_m(0), yco_m(0), yco_m(2), nlle(2, 3), nlle(2, 2))
  yco(2) = Rescale(yco_m(1), yco_m(0), yco_m(2), nlle(2, 3), nlle(2, 2))

  ReDim map(xco(1) To xco(2), yco(1) To yco(2))
    
  bin_m(0) = .Min(bin)
  bin_m(1) = .max(bin)
  bin_m(2) = (bin_m(1) - bin_m(0))
  binsmax = bin_m(1)
  For a = 1 To UBound(xmap)
   On Error Resume Next
    xmap_rescale = Rescale(xmap(a, 1), xco_m(0), xco_m(2), nlle(1, 3), nlle(1, 2))
    ymap_rescale = Rescale(ymap(a, 1), yco_m(0), yco_m(2), nlle(2, 3), nlle(2, 2))
    map(xmap_rescale, ymap_rescale) = Rescale(bin(a, 1), bin_m(0), bin_m(2), nlle(3, 3), nlle(3, 2))
   On Error GoTo 0
  Next a
    
 End With
    
 xcora = axis_values(xco(1), xco(2))
 ycora = axis_values(yco(1), yco(2))
    
 Call chart3darray(1, xcora, ycora, map, "3dmap")

End Function

Public Function chartXYarray(wsht As Long, Rowstart As Long, Rowend As Long, xcolumn As Long, ycolumn As Long, title$)
    
    'chart from array data
    Dim chtO As ChartObject
    Dim ws As Worksheet
    Dim xmap As Variant
    Dim ymap As Variant
    
    Set ws = Worksheets(wsht)
    
    With ws
     xmap = .Range(.Cells(Rowstart, xcolumn), .Cells(Rowend, xcolumn))
     ymap = .Range(.Cells(Rowstart, ycolumn), .Cells(Rowend, ycolumn))
    End With
    
    With ws.Range("W5:AC25")
     Set chtO = ws.ChartObjects.Add(.Left, .Top, .Width, .height)
     chtO.Name = title$
    End With
    
    With chtO.Chart
     .HasTitle = True
     With .ChartTitle
      .Characters.Text = Trim$(title$)
      .Font.Bold = True
      .Font.Size = 10
     End With
    
      With .SeriesCollection.NewSeries
       .XValues = xmap
       .Values = ymap
      End With
     .ChartType = xlXYScatter
    End With

End Function

Public Function Clear_Charts()

 If ActiveSheet.ChartObjects.Count > 0 Then
   On Error Resume Next
    ActiveSheet.ChartObjects.Delete  'ensure only one chart is used for all data
   On Error GoTo 0
  End If

End Function

Public Function Rescale(value, max, rng, nrng, nmin) As Single

 Rescale = (value - max) / rng * nrng + nmin
 
 'nrng/rng*(value-min)+nmin

End Function

Public Function namesheets()
 
 Dim Index As Long
 Dim sheetlist As Variant
 sheetlist = Array("rawdata", "strata", "gc_map", "gc_Init", "gc_reset")
 
 Dim wb As Workbook
 Dim ws As Worksheet '
 
 Set wb = ThisWorkbook
 
 Index = -1
 For Each ws In wb.Sheets
    Index = Index + 1
    If ws.Name = sheetlist(Index) Then
        'skip
    Else
        If Len(sheetlist(Index)) > 0 Then
            wb.Sheets(Index + 1).Name = sheetlist(Index)
        End If
    End If
 Next ws
 
End Function

Public Function savelayer1(data)

 Dim fs
 Dim oFile
 Dim a As Long
 Dim b As Long
 Dim lastrow As Long
 Dim stringPath As String
 Dim settings() As Variant
 Dim arr As Range
 Dim tmp
 Dim test As String

 stringPath = "C:\Users\xpie2\Documents\excel\gpx\" & prog$ & "l1.txt"
 
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set oFile = fs.CreateTextFile(stringPath, True)

 With Worksheets(4)                                     'setup gcode
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
  Set arr = .Range(.Cells(1, 1), .Cells(lastrow, 1))    'copy to array
 End With
 settings() = arr
 For a = 1 To UBound(settings)
  oFile.Write settings(a, 1) & vbCrLf
 Next a
 
 For a = 1 To UBound(data)                              '3d print data
  If Trim(data(a, 1)) <> "" Then
   test = "Z" & Trim(CStr(flh))
   If InStr(Trim(data(a, 4)), test) <> 0 Then
    tmp = ""
    For b = 1 To UBound(data, 2)
     tmp = tmp & data(a, b) & " "
    Next b
    tmp = tmp & vbCrLf
    oFile.Write tmp
   End If
  End If
 Next a

 With Worksheets(5)                                     'reset gcode
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
  Set arr = .Range(.Cells(1, 1), .Cells(lastrow, 1))    'copy to array
 End With
 settings() = arr
 For a = 1 To UBound(settings)
  oFile.Write settings(a, 1) & vbCrLf
 Next a
 
 oFile.Close
 
 Set oFile = Nothing
 Set fs = Nothing
 Set arr = Nothing
End Function