Personal Computer World 2002 March/PCWMAR02.iso/software/turbocad/v8trial/TurboCADv8ProfessionalNoReg.exe/Data.Cab/F41127_modContour.bas

BASIC Source File | 2001-10-16 | 9.5 KB | 314 lines

Attribute VB_Name = "modContour"
'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2001                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'

Option Explicit

'USGS DLG files have unix newline characters: Chr(10)
'VB's Line Input statement can only deal with Chr(13)-Chr(10) combinations
Function UnixLineInput(result As String) As Boolean
    On Error Resume Next

    result = ""
    If EOF(1) Then
        UnixLineInput = False
        Exit Function
    End If

    Dim c As String
    Do While True
        If EOF(1) Then Exit Do
        c = Input(1, #1)
        If c = Chr(10) Then Exit Do
        result = result & c
    Loop
    UnixLineInput = True
End Function


'Read contour line info from a USGS DLG file (optional format)
Sub ConvertContourDlgFile(ByVal fname As String, ByVal sheet As Excel.Worksheet)

    'For specifications, see: http://rockyweb.cr.usgs.gov/nmpstds/dlgstds.html
    'Part 2, Appendix 2-B lists file format records
    'Part 3 lists attribute codes (we use 21-25 to get contour elevation data)

    On Error Resume Next
    Dim i, nnodes, nareas, maxline As Integer
    Dim row, col As Long
    Dim line As String

    row = 1
    Open fname For Input As #1

    'Skip to first category line
    For i = 1 To 15
        If Not UnixLineInput(line) Then GoTo Finished
    Next

    'Get category parameters
    nnodes = CInt(Mid(line, 31, 6))
    nareas = CInt(Mid(line, 47, 6))
    maxline = CInt(Mid(line, 57, 6))

    'Skip nodes
    For i = 1 To nnodes
        Do While Left(line, 1) <> "N"
            If Not UnixLineInput(line) Then GoTo Finished
        Loop

        'Consume N record
        If Not UnixLineInput(line) Then GoTo Finished
    Next

    'Skip areas
    For i = 1 To nareas
        Do While Left(line, 1) <> "A"
            If Not UnixLineInput(line) Then GoTo Finished
        Loop

        'Consume A record
        If Not UnixLineInput(line) Then GoTo Finished
    Next

    'Read lines
    Dim idline, ncoords, maxcoords, natts, nchars, nrecs, j, k, l, m As Integer
    Dim col1, col2 As Integer
    Dim xarr() As Single
    Dim yarr() As Single
    Dim att1, att2 As Integer
    Dim elev As Single
    Dim hasElev As Boolean

    'Get a bunch of memory for our coordinate values
    maxcoords = 500
    ReDim xarr(maxcoords)
    ReDim yarr(maxcoords)

    For i = 1 To maxline
        Do While Left(line, 1) <> "L"
            If Not UnixLineInput(line) Then GoTo Finished
        Loop

        'Get line record parameters
        idline = CInt(Mid(line, 2, 5))
        ncoords = CInt(Mid(line, 43, 6))
        natts = CInt(Mid(line, 49, 6))
        nchars = CInt(Mid(line, 55, 6))

        'Consume L record
        If Not UnixLineInput(line) Then GoTo Finished

        'Get coordinates
        If ncoords > maxcoords Then
            maxcoords = ncoords
            ReDim xarr(maxcoords)
            ReDim yarr(maxcoords)
        End If
        k = 1 'coordinate number
        nrecs = (ncoords + 2) \ 3
        For j = 1 To nrecs
            col1 = 1
            col2 = 13
            l = 1 'coordinate index in record
            Do While k <= ncoords And l <= 3
                xarr(k) = CSng(Mid(line, col1, 12))
                yarr(k) = CSng(Mid(line, col2, 12))
                k = k + 1
                l = l + 1
                col1 = col1 + 24
                col2 = col2 + 24
            Loop
            UnixLineInput line
        Next

        'Get contour elevation attributes
        elev = 0
        hasElev = False
        k = 1 'attribute number
        nrecs = (natts + 5) \ 6
        For j = 1 To nrecs
            col1 = 1
            col2 = 7
            l = 1 'attribute index in record
            Do While k <= natts And l <= 6
                att1 = CInt(Mid(line, col1, 6))
                att2 = CInt(Mid(line, col2, 6))

                'Look for contour elevation attribute
                If att1 >= 21 And att1 <= 25 Then
                    Select Case att1
                    Case 21:
                        '10000 feet or more
                        elev = CSng(att2) + 10000
                    Case 22:
                        '0 to 9999 feet
                        elev = CSng(att2)
                    Case 23:
                        'below datum
                        elev = -CSng(att2)
                    Case 24:
                        'meters
                        elev = CSng(att2) / 0.3048
                    Case 25:
                        'meters below datum
                        elev = -CSng(att2) / 0.3048
                    End Select
                    hasElev = True
                End If
                k = k + 1
                l = l + 1
                col1 = col1 + 12
                col2 = col2 + 12
            Loop
            UnixLineInput line
        Next

        'Put contour into worksheet
        If hasElev Then
            nrecs = (ncoords + 99) \ 100
            k = 0
            For j = 1 To nrecs

                'How many coordinates in this row?
                m = ncoords - k
                If m > 100 Then m = 100

                With sheet.Cells
                    .Item(row, 1) = idline
                    .Item(row, 2) = k
                    .Item(row, 3) = m
                    .Item(row, 4) = elev
                    For l = 1 To m
                        .Item(row, l * 2 + 3) = xarr(k)
                        .Item(row, l * 2 + 4) = yarr(k)
                        k = k + 1
                    Next
                End With
            Next
        End If
    Next

Finished:
    Close #1
End Sub

Sub ConvertContours()
    'Data we're using is part of USGS's "Lake Tahoe Data Clearinghouse" model project
    'Sample file emer_hypso.dlg contains hypsography (contour) data for Emerald Bay 7.5' series
    'This and other DLG files are available for download at: http://tahoe.usgs.gov/tahoe/DLG.html

    On Error GoTo ConvertError
    Dim xlapp As New Excel.Application
    Dim xlbook As Excel.Workbook

    Set xlbook = xlapp.Workbooks.Add()
    ConvertContourDlgFile "J:\Samples\New\Excel\emer_hypso.dlg", xlbook.ActiveSheet
    xlbook.SaveAs "J:\Samples\New\Excel\contours.xls"

Cleanup:
    'Release Excel stuff
    Set xlbook = Nothing
    Set xlapp = Nothing
    Exit Sub

ConvertError:
    MsgBox "Error " & Err.Description
    GoTo Cleanup
End Sub

Sub ImportContours()
    On Error GoTo ImportError

    Dim xlapp As New Excel.Application

    'Test to see if Excel was initialized
    If xlapp Is Nothing Then
        MsgBox "Could not create Excel application object"
        Exit Sub
    End If

    Dim grs As IMSIGX.Graphics
    Dim gr As IMSIGX.Graphic
    Dim xlbook As Excel.Workbook

    'Open a workbook
    Set xlbook = xlapp.Workbooks.Open("J:\Samples\New\Excel\Contours.xls")
    If Not xlbook Is Nothing Then

        'Target to add graphics to
        Set grs = ActiveDrawing.Graphics

        Dim r As Long
        Dim coord As Long
        Dim id As Long
        Dim ncoords As Long
        Dim lastId As Long
        Dim x As Double
        Dim y As Double
        Dim z As Double

        'Format of worksheet
        'In each row:
        'Col 1:  id of contour line
        'Col 2:  starting coordinate index for this row
        'Col 3:  number of x-y coordinate pairs in this row
        'Col 4:  contour elevation (in feet)
        'Col 5, 7, etc.:  x coordinate (UTM, meters)
        'Col 6, 8, etc.:  y coordinate

        lastId = -1
        With xlbook.ActiveSheet.Cells
            For r = 1 To 65536

                'If no id, we're done
                If .Item(r, 1) = "" Then
                    Exit For
                End If

                id = .Item(r, 1)
                Debug.Print "id: " & id

                'New id: generate new polyline
                If id <> lastId Then
                    Set gr = grs.Add
                    lastId = id
                End If

                'Get number of coordinates and elevation
                ncoords = .Item(r, 3)
                z = .Item(r, 4)

                For coord = 1 To ncoords

                    'Get x-y coordinates and create polyline vertex
                    x = .Item(r, 2 * coord + 3)
                    y = .Item(r, 2 * coord + 4)
                    gr.Vertices.Add x, y, z
                Next
            Next
        End With
    End If

Cleanup:
    'Release TurboCAD stuff
    Set gr = Nothing
    Set grs = Nothing

    'Release Excel stuff
    Set xlbook = Nothing
    Set xlapp = Nothing
    Exit Sub

ImportError:
    MsgBox "Error " & Err.Description
    GoTo Cleanup
End Sub