home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2002 March / PCWMAR02.iso / software / turbocad / v8trial / TurboCADv8ProfessionalNoReg.exe / Data.Cab / F41245_ImportFromExcelspreadSheet.bas < prev    next >
Encoding:
BASIC Source File  |  2001-10-16  |  3.5 KB  |  100 lines
  1. Attribute VB_Name = "ImportFromExcelspreadSheet"
  2. '******************************************************************'
  3. '*                                                                *'
  4. '*                      TurboCAD for Windows                      *'
  5. '*                   Copyright (c) 1993 - 2001                    *'
  6. '*             International Microcomputer Software, Inc.         *'
  7. '*                            (IMSI)                              *'
  8. '*                      All rights reserved.                      *'
  9. '*                                                                *'
  10. '******************************************************************'
  11.  
  12. Global appWorld As Excel.Application
  13. Global wbWorld As Excel.Workbook
  14. Global Path As String
  15. Global W As Excel.Worksheet
  16. Global XCur As Double
  17. Global YCur As Double
  18. Global ZCur As Double
  19. Global ActDr As Drawing
  20. Global Grs As Graphics
  21. Global Gr As Graphic
  22.  
  23. Sub Run_Import()
  24. MsgBox "Remember you should define correct path to the sample excel file !"
  25. ' define path to TurboCADv6.xls sample excel file
  26.     Path = "d:\Temp\TurboCADv6.xls"
  27.     Set ActDr = ActiveDrawing
  28.     Set Grs = ActDr.Graphics
  29.     Call Setup
  30.     Call Import
  31.     Call CleanUp
  32.     ActDr.Views(0).Refresh
  33.     Set Grs = Nothing
  34.     Set ActDr = Nothing
  35. End Sub
  36. Private Sub Setup()
  37.     ' IMPORTANT: If your machine does not have Excel 97 installed,
  38.     ' you must change the reference to the Excel 95 Object Library.
  39.     ' Then, in the Declarations section above, change the variable
  40.     ' declaration "wbWorld as Workbook" to "shtWorld As Worksheet."
  41.     ' Then change all references to "wbWorld" to "shtWorld."
  42.  
  43.     On Error Resume Next 'ignore errors
  44.     Set appWorld = CreateObject("Excel.Application") 'run it
  45.     Err.Clear   ' Clear Err object in case error occurred.
  46.     On Error GoTo 0 'Resume normal error processing
  47.     Set wbWorld = appWorld.Workbooks.Open(Path)
  48.     Set W = wbWorld.Worksheets("Coordinates")
  49. End Sub
  50.  
  51. ' Set the objects to Nothing.
  52. Private Sub CleanUp()
  53.     ' This should force an unload of Microsoft Excel,
  54.     ' providing no other applications or users have it loaded.
  55.     wbWorld.Close False
  56.     appWorld.Quit
  57.     Set appWorld = Nothing
  58.     Set wbWorld = Nothing
  59. End Sub
  60.  
  61. Private Sub Import()
  62.     Dim rngFeatureList As Excel.Range
  63.     Dim intFirstBlankCell As Integer
  64.     Dim loop1 As Integer
  65.     Dim intColumOfFeature As Integer
  66.     
  67.  ' we use column 1 (x coordinates) to define how many records (x, y, z ) we have in SpreadSheet
  68.     intColumOfFeature = 1
  69.    ' Assign the column to an object.
  70.     Set rngRankedList = W.Columns(intColumOfFeature)
  71.     
  72.     ' See if it's an empty list.
  73.     If (rngRankedList.Cells(1, 1) = "") Then
  74.         intFirstBlankCell = 0
  75.     Else
  76.         ' Search the row for the first blank cell.
  77.         intFirstBlankCell = rngRankedList.Find("").Row
  78.     End If
  79.  
  80.     ' row1 we have reserved for column header (X, Y, Z)
  81.     'load first item to define start point
  82.     XCur = W.Cells(2, 1)
  83.     YCur = W.Cells(2, 2)
  84.     ZCur = W.Cells(2, 3)
  85.     
  86.     Set Gr = Grs.AddLineMultiline(XCur, YCur, ZCur)
  87. ' you can add curve instead multiline or other graphic you would like
  88. '    Set Gr = Grs.AddCurveBezier(XCur, YCur, ZCur)
  89.     
  90.     For loop1 = 3 To intFirstBlankCell - 1
  91.         XCur = W.Cells(loop1, 1)
  92.         YCur = W.Cells(loop1, 2)
  93.         ZCur = W.Cells(loop1, 3)
  94.         Gr.Vertices.Add XCur, YCur, ZCur
  95.     Next
  96. ' if you would like to have closed multiline decoment next string
  97. '    Gr.Close
  98.  
  99. End Sub
  100.