'CitizenMapmaker.txt (Visual Basic source code for CitizenMapmaker.exe)
' Beta version 0.2 of CitizenMapmaker.exe</a></b>
' version 0.1 by Mike McCullough
' version 0.2 enhancements mostly by Mal Winslett

Option Explicit
Public ix_g As Long
Public fatalErr As Boolean
Public extra_parsed_chars As Boolean

Sub build_Svg()
Dim viewBoxCoordinates As String, startSvg As String

viewBoxCoordinates = LatLonEnvy

startSvg = "<?xml version= '1.0' encoding = 'UTF-8' standalone='yes'?>" & vbCrLf
startSvg = startSvg & "<svg xml:space='preserve' width='"

If Len(mainmap.width) < 1 Then
    mainmap.width = "5in"
End If
startSvg = startSvg & mainmap.width & "' height='"

If Len(mainmap.height) < 1 Then
    mainmap.height = "4in"
End If
startSvg = startSvg & mainmap.height & "' viewBox='"
startSvg = startSvg & viewBoxCoordinates & "'>" & vbCrLf
 Print #2, startSvg
End Sub
Sub endSvg()
'Print #2, "z' />" & vbCrLf
 Print #2, "</g>"
 Print #2, "</svg>"
End Sub
Function LatLonEnvy()
Dim max As Integer, hLon As Double
Dim hLat As Double, hWidth As Double
Dim hHeight As Double, i As Integer
max = UBound(mapLayers)
For i = 0 To max Step 1
    If mapLayers(i).Lat > hLat Then
        hLat = mapLayers(i).Lat
    End If
    If mapLayers(i).Lon < hLon Then
        hLon = mapLayers(i).Lon
    End If
'    If mapLayers(i).height > hHeight Then
    If Val(mapLayers(i).height) > hHeight Then
        hHeight = mapLayers(i).height
    End If
'    If mapLayers(i).width > hWidth Then
    If Val(mapLayers(i).width) > hWidth Then
        hWidth = mapLayers(i).width
    End If
Next
LatLonEnvy = hLon & " " & -hLat & " " & hWidth & " " & hHeight
End Function
Sub set_files(x As Integer)
If x = 1 Then
    mapLayers(current_layer).shortName = ParseFileName
        If Right(DirSourceLbl.Text, 1) = "\" Then
        mapLayers(current_layer).source_path = DirSourceLbl.Text
        Else
        mapLayers(current_layer).source_path = DirSourceLbl.Text & "\"
        End If
    mapLayers(current_layer).m_sourceFile = mapLayers(current_layer).source_path & mapLayers(current_layer).shortName & ".dat"
    mapLayers(current_layer).a_sourceFile = mapLayers(current_layer).source_path & mapLayers(current_layer).shortName & "a.dat"

Else
    If UCase(Right(FileTargetLbl.Text, 4)) = ".SVG" Then
        mainmap.targetfilename = FileTargetLbl.Text
    Else
        mainmap.targetfilename = FileTargetLbl.Text & ".svg"
    End If
    If Right(DirTargetLbl.Text, 1) = "\" Then
      mainmap.targetpath = DirTargetLbl.Text
    Else
      mainmap.targetpath = DirTargetLbl.Text & "\"
    End If
End If
End Sub


Function BuildG(layer As Integer)
Dim gItem As String
If Len(mapLayers(layer).fillClr) < 1 Then
    mapLayers(layer).fillClr = "rgb(255,255,192)"
End If
If Len(mapLayers(layer).visible) < 1 Then
    mapLayers(layer).visible = "visible"
End If
If Len(mapLayers(layer).pathStrokeClr) < 1 Then
    mapLayers(layer).pathStrokeClr = "black"
End If
If mapLayers(layer).pathStrokeWidth = 0 Then
    mapLayers(layer).pathStrokeWidth = "0.0005"
End If
If Len(mapLayers(layer).class) < 1 Then
    mapLayers(layer).class = mapLayers(layer).shortName
End If
gItem = "<g id='" & mapLayers(layer).shortName
gItem = gItem & "' style='fill:" & mapLayers(layer).fillClr
gItem = gItem & ";visibility:" & mapLayers(layer).visible
gItem = gItem & ";stroke:" & mapLayers(layer).pathStrokeClr
gItem = gItem & ";stroke-width:" & mapLayers(layer).pathStrokeWidth
gItem = gItem & "' class='" & mapLayers(layer).class & "'>"
Print #2, gItem

End Function
Public Function parse_att()
Dim ix As Integer, i As Integer, LineScan As String
Dim LineScan_Trim As String, tempchar As String * 1
Dim curr_file_numb As Integer
Dim openForms As Integer, upper As Integer, file_exists As String
ix = 0
i = 0

On Error Resume Next
file_exists = Dir$(mapLayers(current_layer).a_sourceFile)
If file_exists = "" Then
    Update_Msgs ("No attribute file found.")
    Exit Function
End If
Open mapLayers(current_layer).a_sourceFile For Input As #7
Do While Not EOF(7)
            LineScan = ""
            tempchar = ""
                       
            While tempchar <> Chr(10)
                LineScan = LineScan + tempchar
                tempchar = Input(1, #7)
                 If tempchar = Chr(34) Then
                tempchar = ""
                End If
            Wend
'read in 6 lines increment index
LineScan_Trim = Trim(LineScan)
LineScan = LineScan_Trim
If LineScan = "" Then
    LineScan = "0"
End If
'state equiv areas use id + 4 fields rest apparently use id + 5 fields
Select Case i
    Case 0
        matrix(current_layer, ix).id = LineScan
    Case 1
        matrix(current_layer, ix).one = LineScan
    Case 2
        matrix(current_layer, ix).two = LineScan
    Case 3
        matrix(current_layer, ix).three = LineScan
    Case 4
        matrix(current_layer, ix).four = LineScan
        If mapLayers(current_layer).field_5_fix = 1 Then
        i = 6
        End If
    Case 5
        matrix(current_layer, ix).five = LineScan
        openForms = DoEvents
        
    Case 6
End Select
If i > 5 Then
    ix = ix + 1
    upper = UBound(matrix, 2) + 1
    ReDim Preserve matrix(4, upper)
    i = 0
    Else
    i = i + 1
End If
Loop
mapLayers(current_layer).rec_count = ix
'rec_count could be used to create a progress bar, total # of records
Close #7
End Function
Function ChkFileSelect(chkOpt As Integer)
'error check on file input
If chkOpt = 1 Then
    If Len(FileSourceLbl.Text) < 1 Then
    MsgBox "Please select a file to convert as a layer."
    ChkFileSelect = "1"
    End If
Else
    If Len(FileTargetLbl.Text) < 1 Then
    MsgBox "Please enter a name for the output file."
    ChkFileSelect = "1"
    End If
End If
End Function
Public Static Function ParseFileName()
Dim filename As String, pos As String
Dim raw_year As Integer, map_caption As String
Dim s_map_state As String, s_map_year As String
Dim FIPS As Integer, hold_chars As String
Dim short_name As String, s_file As String
Dim first_char As String
filename = FileSourceLbl.Text
'this is messy, still messy after layers ugh
If UCase(Right(filename, 4)) = ".DAT" Then
    If UCase(Right(filename, 5)) = "A.DAT" Then
       pos = InStr(filename, "a.dat")
       short_name = Left(filename, pos - 1)
       s_file = short_name & ".dat"
       ParseFileName = short_name
      Update_Msgs ("Using " & s_file)
    Else
      pos = InStr(filename, ".dat")
      short_name = Left(filename, pos - 1)
      s_file = short_name & ".dat"
      ParseFileName = short_name
      Update_Msgs ("Using " & s_file)
    End If
Else
'change this message to a var for filetypes accepted
'better would be to inspect whatever file is selected
'and see if we can make heads or tails of it then reject it
    Update_Msgs ("Citizen Mapmaker only accepts .dat files currently")
    fatalErr = True
    Exit Function
End If

map_caption = titleLookup(short_name)
   If s_map_year = "" Then
        raw_year = Right(short_name, 2)
            If raw_year > 70 Then
                    s_map_year = "19" & raw_year
            Else
            s_map_year = "200" & raw_year
            End If
End If
If extra_parsed_chars = 0 Then
    hold_chars = Left(short_name, 4)
    FIPS = CInt(Right(hold_chars, 2))
    s_map_state = fipsLookUp(FIPS)
Else
   'process those 3 files here
   first_char = Left(short_name, 4)
        If first_char = "cmsa" Then
            hold_chars = Left(short_name, 6)
        Else
            'cm_sa and pm_sa
            hold_chars = Left(short_name, 7)
        End If
    FIPS = Right(hold_chars, 2)
    s_map_state = fipsLookUp(FIPS)
End If

mapLayers(current_layer).title = map_caption
mapLayers(current_layer).year = s_map_year
mapLayers(current_layer).state = s_map_state
extra_parsed_chars = 0
End Function

Public Sub Update_msg_wo(Message)
'Adds text to the Message Box without a linefeed and will reset it to 0 length
'after 255 chars: any longer and the msgbox will flicker as its updated
Dim openForms As Integer
If Len(MsgOut.Text) > 255 Then
MsgOut.Text = Message
Else
MsgOut.Text = MsgOut.Text & Message
openForms = DoEvents
'MsgOut.SelStart = Len(MsgOut.Text)
End If
End Sub
Public Sub Update_Msgs(Message)
'add message with a hard return
MsgOut.Text = MsgOut.Text & Message & vbCrLf
  MsgOut.Refresh
  MsgOut.SelStart = Len(MsgOut.Text)
End Sub
Private Sub menu_about_Click()
MsgBox ("Citizen Mapmaker, SVG Utility to convert Census Files. Copyright 2003 CCI. Visit www.citizencomputing.org for more information.")
End Sub
Private Sub cmdAddLayer_Click()
Dim result As Integer
If current_layer = 4 Then
    Update_Msgs ("Citizen MapMaker only supports 4 layers currently")
    Exit Sub
Else
result = ChkFileSelect(1)
                If result = 1 Then
                    Exit Sub
                End If
set_files (1)
parse_att
current_layer = current_layer + 1
FileSourceLbl.Text = ""
Update_Msgs ("Added Layer " & current_layer)
ReDim Preserve mapLayers(current_layer)
End If
If current_layer > 0 Then
cmdMakeMap.visible = True
End If
End Sub
Private Sub CmdOptions_Click()
If Len(mapLayers(0).a_sourceFile) < 1 Then
    If Len(FileSourceLbl.Text) < 1 Then
        MsgBox ("Please select a source file first and click add layer.")
        End If
Else
        Opt_Frm.Show
    
End If
End Sub
Private Sub menu_directions_Click()
MsgBox ("Select input file and output file, click makemap. View in browser with Adobe's SVG Viewer")
End Sub
Private Sub DirTargetLbl_Change()
  DirTargetLbl = DirTarget.Path
End Sub
Private Sub Form_Load()
  DriveSourceLbl = DriveSource.Drive
  DriveTargetLbl = DriveTarget.Drive
  DirSourceLbl = DirSource.Path
  DirTargetLbl = DirTarget.Path
  FileSourceLbl = GetSourceFile.filename
  current_layer = 0
  ReDim mapLayers(current_layer)
  ReDim matrix(4, 1)
End Sub
Private Sub DriveSource_Change()
  DriveSourceLbl = DriveSource.Drive
  DirSourceLbl = DriveSource.Drive
  DirSource.Path = DriveSource.Drive
End Sub
Private Sub DirSource_Change()
  GetSourceFile.Path = DirSource.Path
  DirSourceLbl = DirSource.Path
End Sub
Private Sub DriveTarget_Change()
    DriveTargetLbl = DriveTarget.Drive
    DirTarget.Path = DriveTarget.Drive
End Sub
Private Sub DirTarget_Change()
  DirTargetLbl = DirTarget.Path
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim intCount As Integer
While Forms.Count > 1
'// Find first form besides "me" to unload
intCount = 0
While Forms(intCount).Caption = Me.Caption
intCount = intCount + 1
Wend
Unload Forms(intCount)
Wend
Unload Me
End
End Sub
Private Sub GetSourceFile_Click()
    FileSourceLbl = GetSourceFile.filename
End Sub
Function ItemReview(m_line As String)
Dim lon_center As Double
Dim lat_center As Double
Dim m_write As String
Dim i As Integer
Dim id_fld As String
If m_line = Int(m_line) Then
ix_g = m_line
    If ix_g = -99999 Then
         'avoid subscript range errors: double check
    Else
        'should this be check  old_ix_g if == then set the id?
        Select Case mapLayers(mainmap.currLayer).idField
            Case 0
            id_fld = matrix(mainmap.currLayer, ix_g).id
            Case 1
            id_fld = matrix(mainmap.currLayer, ix_g).one
            Case 2
            id_fld = matrix(mainmap.currLayer, ix_g).two
            Case 3
            id_fld = matrix(mainmap.currLayer, ix_g).three
            Case 4
            id_fld = matrix(mainmap.currLayer, ix_g).four
            Case 5
            id_fld = matrix(mainmap.currLayer, ix_g).five
        End Select
    End If
    If Len(id_fld) < 1 Then
        If ix_g <> "-99999" Then
        id_fld = matrix(mainmap.currLayer, ix_g).two
        End If
    End If
    If m_line > 1 Or m_line = -99999 Then
        Input #1, lon_center, lat_center
        If ix_g <> "-99999" Then
        matrix(mainmap.currLayer, ix_g).c_lon = lon_center
        matrix(mainmap.currLayer, ix_g).c_lat = lat_center
        ' centroid coordinates stored but not used; could be activated
        End If
         m_write = "z' />" & vbCrLf
     If m_line = -99999 Then
     m_write = m_write & "<path d='M "
     
     Else
     'hardcoded matrix(ix_g).two needs to change to user selection
     'best bet would be to build this statement prior ;access as variable
     ':Need to add style to path statements for label/color uses later
     m_write = m_write & "<path id='" & id_fld & "' d='M "
      End If
     Else
       If m_line = 1 Then
          Input #1, lon_center, lat_center
          matrix(mainmap.currLayer, ix_g).c_lon = lon_center
          matrix(mainmap.currLayer, ix_g).c_lat = lat_center
          ' centroid coordinates stored but not used; could be activated
          Print #2, "<path id='" & id_fld & "' d='M"
       End If
    End If
Else
' should this be a user option?
        m_write = Format(m_line, "##.####")
'        m_write = Format(m_line, "##.###") 'OK detail
'        m_write = Format(m_line, "##.##") 'boundaries getting choppy but OK large view
           If m_write > 0 Then
           m_write = -m_write
           End If
         
End If
 ItemReview = m_write
End Function
Function getviewBoxCoordinates(i As Integer)
'i is layerCnt from makeMapcmd
 Dim x As Integer, openForms As Integer
Dim txtLon As String, numLon As Double
numLon = 0
Dim highLon As Double, lowLon As Double
Dim lowestLon As Double, highestLon As Double
Dim m_line As Double
highestLon = -999
lowestLon = 0

Dim txtLat As String, numLat As Double
numLat = 0
Dim highestLat As Double, lowestLat As Double
highestLat = 0
lowestLat = 999

  Update_msg_wo ("Working *")
 x = 0
 Do While Not EOF(1)
      Input #1, m_line
    
      If m_line = Int(m_line) Or m_line = -99999 Then
      Else
       If Val(m_line) < 0 Then ' this is longitude
        numLon = CDbl(m_line)
         If numLon > highestLon Then
          highestLon = numLon
         End If
         If numLon < lowestLon Then
          lowestLon = numLon
         End If
    
       Else  ' this is latititude
        numLat = CDbl(m_line)
         If numLat > highestLat Then
            highestLat = numLat
         End If
         If numLat < lowestLat Then
            lowestLat = numLat
         End If
       End If
      End If
    
     x = x + 1
     'Update messages to show progress, doevents added to avoid
     'the GUI not being repainted or being unresponsive
     If x > 250 Then
        Update_msg_wo ("*")
        x = 0
        openForms = DoEvents
     End If
 Loop
Dim vb_x As Double
Dim vb_y As Double
Dim lowLat As Double
   vb_x = lowestLon
   highLon = highestLon
   vb_y = highestLat
   lowLat = lowestLat
 Dim vb_width As Double
 Dim vb_height As Double
 
 vb_width = Abs(vb_x - highLon)
 vb_height = vb_y - lowLat
 vb_x = Format(vb_x, "##.####")
 vb_y = Format(vb_y, "##.####")
 vb_width = Format(vb_width, "##.####")
 vb_height = Format(vb_height, "##.####")
 'getviewBoxCoordinates = vb_x & " " & -vb_y & " " & vb_width & " " & vb_height
 mapLayers(i).Lon = vb_x
 mapLayers(i).Lat = vb_y
 mapLayers(i).width = vb_width
 mapLayers(i).height = vb_height
 
 Close #1
End Function
Private Sub cmdMakeMap_Click()
Dim Short_File As String, result As Boolean
Dim viewBoxCoordinates, m_line, m_item
Dim StatusCount As Integer
Dim layerCnt As Integer
Dim i As Integer, ind As Integer
If Len(mapLayers(0).m_sourceFile) < 1 Then
    Update_Msgs ("Please select a file to convert.")
    Exit Sub
End If
set_files (0)
'ix_g is the attribute id number, hits problems with -99999,
'saw that UTM files use 0; could be problems there
'resets the index_global to key the correct index for matrix/att_rec
If ix_g > 1 Then
    ix_g = 0
End If

layerCnt = UBound(mapLayers) - 1
Update_Msgs ("Generating SVG File")
'loop through each layer to getViewBox then compare before printing
For i = 0 To layerCnt Step 1
    Open mapLayers(i).m_sourceFile For Input Access Read As #1
    getviewBoxCoordinates (i)
Next
'improve the filecheck procedure, variable renaming causes it to fail
Open mainmap.targetpath & mainmap.targetfilename For Output As #2
build_Svg
For ind = 0 To layerCnt Step 1
    mainmap.currLayer = ind
    
    BuildG (ind)
    Open mapLayers(ind).m_sourceFile For Input Access Read As #1
    Do While Not EOF(1)
      Input #1, m_line
        m_item = ItemReview((m_line))
        Print #2, m_item; Spc(1);
        'Feeble attempt at outputing current coordinates to MsgBox
              If StatusCount = "40" Then
              Update_msg_wo (m_item)
              StatusCount = 0
              Print #2, ""
              'adds line breaks to the SVG Code output, PFE(text editor) truncates really
                'long lines of text ;maybe others do too.
              End If
        StatusCount = StatusCount + 1
     Loop
     Print #2, "z' />"
     Update_Msgs (" Layer " & layerCnt & " generated. ")
     Close #1
 Next
 endSvg
 Close #2
 Update_Msgs ("SVG Map has been created and saved. View it by loading into your browser.")
 'this wipes the slate but needs a reinit process afterwards.
 ReDim matrix(4, 1)
 ReDim mapLayers(0)
'MFM 3/19/03 temporarily removing
' reinit
  
End Sub
Private Sub btnExit_Click()
'  The End
Form_Unload (0)
End Sub