home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / DXFWriter_20312811162006.psc / DXFWriter / cDXF.cls < prev    next >
Text File  |  2006-11-16  |  7KB  |  212 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cDXF"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = True
  14. '----------------------------------------------------------
  15. '     ⌐ 2006, Athanasios Gardos
  16. 'e-mail: gardos@hol.gr
  17. 'You may freely use, modify and distribute this source code
  18. '
  19. 'Last update: November 16, 2006
  20. 'Please visit:
  21. '     http://business.hol.gr/gardos/
  22. ' or
  23. '     http://avax.invisionzone.com/
  24. 'for development tools and more source code
  25. '-----------------------------------------------------------
  26.  
  27. Option Explicit
  28.  
  29. Private oHeader As cHeader
  30. Private m_Entities As cDrawing
  31. Private m_Blocks() As cDrawing
  32. Private m_FontCharSet As Long
  33.  
  34. Public Function SetLayers(LayerNames() As String, LayerFlags() As Integer, LayerColorIndex() As Integer, LayerLineTypeName() As String) As Boolean
  35.     SetLayers = oHeader.SetLayers(LayerNames(), LayerFlags(), LayerColorIndex(), LayerLineTypeName())
  36. End Function
  37.  
  38. Public Function GetLayers(LayerNames() As String, LayerFlags() As Integer, LayerColorIndex() As Integer, LayerLineTypeName() As String) As Long
  39.     GetLayers = oHeader.GetLayers(LayerNames(), LayerFlags(), LayerColorIndex(), LayerLineTypeName())
  40. End Function
  41.  
  42. Public Function SetFonts(Fonts() As String, FontCharSet As Long) As Boolean
  43.     SetFonts = oHeader.SetFonts(Fonts())
  44.     m_FontCharSet = FontCharSet
  45. End Function
  46.  
  47. Public Function GetFonts(Fonts() As String, FontCharSet As Long) As Long
  48.     GetFonts = oHeader.GetFonts(Fonts())
  49.     FontCharSet = m_FontCharSet
  50. End Function
  51.  
  52. Public Function SetLineTypes(LineTypes() As String) As Boolean
  53.     SetLineTypes = oHeader.SetLineTypes(LineTypes())
  54. End Function
  55.  
  56. Public Function GetLineTypes(LineTypes() As String) As Long
  57.     GetLineTypes = oHeader.GetLineTypes(LineTypes())
  58. End Function
  59.  
  60. Public Property Let LineTypeScale(ByVal v As Double)
  61.     If v <= 0 Then v = 1
  62.     oHeader.LineTypeScale = v
  63. End Property
  64.  
  65. Public Property Get LineTypeScale() As Double
  66.     LineTypeScale = oHeader.LineTypeScale
  67. End Property
  68.  
  69. Public Function InsertEntities(Entities As cDrawing) As Boolean
  70.     If (Entities Is Nothing) Then Exit Function
  71.     Set m_Entities = Entities
  72.     InsertEntities = True
  73. End Function
  74.     
  75. Public Function InsertBlocks(Blocks() As cDrawing) As Boolean
  76.     Dim lMax As Long, lCnt As Long
  77.     Dim xMin As Double, yMin As Double, zMin As Double
  78.     Dim xMax As Double, yMax As Double, zMax As Double
  79.     On Local Error Resume Next
  80.     lMax = UBound(Blocks)
  81.     If lMax = 0 Then Exit Function
  82.     ReDim m_Blocks(lMax) As cDrawing
  83.     For lCnt = 1 To lMax
  84.         If Not (Blocks(lCnt) Is Nothing) Then
  85.            Set m_Blocks(lCnt) = Blocks(lCnt)
  86.            InsertBlocks = True
  87.         End If
  88.     Next lCnt
  89.     Call oGlobals.SetBlocks(Blocks())
  90. End Function
  91.     
  92. Private Sub InitHeader()
  93.     Dim xMin As Double, yMin As Double, zMin As Double
  94.     Dim xMax As Double, yMax As Double, zMax As Double
  95.     Call m_Entities.GetBorder(xMin, yMin, zMin, xMax, yMax, zMax)
  96.     oHeader.EXTMIN_x = xMin
  97.     oHeader.EXTMIN_y = yMin
  98.     oHeader.EXTMIN_z = zMin
  99.     oHeader.EXTMAX_x = xMax
  100.     oHeader.EXTMAX_y = yMax
  101.     oHeader.EXTMAX_z = zMax
  102. End Sub
  103.  
  104. Private Sub InsertDemo()
  105.     Dim dx As Double
  106.     Dim oLine As cLine
  107.     Dim oText As cText
  108.     If fDemoMode = True Then
  109.        Set oLine = New cLine
  110.        Set oText = New cText
  111.        oLine.x1 = oHeader.EXTMIN_x
  112.        oLine.y1 = oHeader.EXTMIN_y
  113.        oLine.z1 = oHeader.EXTMIN_z
  114.        oLine.x2 = oHeader.EXTMAX_x
  115.        oLine.y2 = oHeader.EXTMIN_y
  116.        oLine.z2 = oHeader.EXTMAX_z
  117.        oLine.ColorIndex = 1
  118.        Call m_Entities.InsertLine(oLine)
  119.        dx = oHeader.EXTMAX_x - oHeader.EXTMIN_x
  120.        oText.Text = D_DemoMSG
  121.        oText.Height = dx / Len(D_DemoMSG)
  122.        oText.x = oHeader.EXTMIN_x
  123.        oText.y = oHeader.EXTMIN_y - 1.1 * oText.Height
  124.        oText.z = oHeader.EXTMIN_z
  125.        oText.ColorIndex = 1
  126.        Call m_Entities.InsertText(oText)
  127.        Set oLine = Nothing
  128.        Set oText = Nothing
  129.     End If
  130. End Sub
  131.  
  132. Public Function Save(sDXFFile As String) As Boolean
  133.     Dim iFr As Integer
  134.     Dim oStr As cAddString
  135.     Dim lMax As Long, lCnt As Long
  136.     If sDXFFile = "" Then Exit Function
  137.     If (m_Entities Is Nothing) Then Exit Function
  138.     Set oStr = New cAddString
  139.     oStr.BeginAdd
  140.     '------------ Header ---------------
  141.     Call InitHeader
  142.     oStr.AddString oHeader.DxfHeader
  143.     '------------ Tables ---------------
  144.     oStr.AddString oHeader.DxfTables
  145.     '------------ Blocks ---------------
  146.     On Local Error Resume Next
  147.     lMax = UBound(m_Blocks)
  148.     If lMax <> 0 Then
  149.        oStr.Add2Strings "  0", vbCrLf
  150.        oStr.Add2Strings "SECTION", vbCrLf
  151.        oStr.Add2Strings "  2", vbCrLf
  152.        oStr.Add2Strings "BLOCKS", vbCrLf
  153.        For lCnt = 1 To lMax
  154.            If Not m_Blocks(lCnt) Is Nothing Then
  155.               oStr.Add2Strings "  0", vbCrLf
  156.               oStr.Add2Strings "BLOCK", vbCrLf
  157.               oStr.Add2Strings "  2", vbCrLf
  158.               oStr.Add2Strings m_Blocks(lCnt).Name, vbCrLf
  159.               oStr.Add2Strings "  3", vbCrLf
  160.               oStr.Add2Strings m_Blocks(lCnt).Name, vbCrLf
  161.               oStr.Add2Strings "  70", vbCrLf
  162.               oStr.Add2Strings "    0", vbCrLf
  163.               oStr.AddString DxfNb(10, m_Blocks(lCnt).BaseX)
  164.               oStr.AddString DxfNb(20, m_Blocks(lCnt).BaseY)
  165.               oStr.AddString DxfNb(30, m_Blocks(lCnt).BaseZ)
  166.               oStr.AddString m_Blocks(lCnt).DxfDrawing
  167.               oStr.Add2Strings "  0", vbCrLf
  168.               oStr.Add2Strings "ENDBLK", vbCrLf
  169.            End If
  170.        Next lCnt
  171.        oStr.Add2Strings "  0", vbCrLf
  172.        oStr.Add2Strings "ENDSEC", vbCrLf
  173.     End If
  174.     '------------ Entities -------------
  175.     Call InsertDemo
  176.     oStr.Add2Strings "  0", vbCrLf
  177.     oStr.Add2Strings "SECTION", vbCrLf
  178.     oStr.Add2Strings "  2", vbCrLf
  179.     oStr.Add2Strings "ENTITIES", vbCrLf
  180.     oStr.AddString m_Entities.DxfDrawing
  181.     oStr.Add2Strings "  0", vbCrLf
  182.     oStr.Add2Strings "ENDSEC", vbCrLf
  183.     '-----------------------------------
  184.     oStr.Add2Strings "  0", vbCrLf
  185.     oStr.AddString "EOF"
  186.     Call DeleteFile(sDXFFile)
  187.     iFr = FreeFile
  188.     Open sDXFFile For Output As #iFr
  189.     Print #iFr, oStr.CurString
  190.     Close #iFr
  191.     Save = IsFile(sDXFFile)
  192.     Set oStr = Nothing
  193. End Function
  194.  
  195. Private Sub Class_Initialize()
  196.     Set oGlobals = New cGlobals
  197.     Set oHeader = New cHeader
  198.     LineTypeScale = 1
  199. End Sub
  200.  
  201. Private Sub Class_Terminate()
  202.     Dim lMax As Long, lCnt As Long
  203.     On Local Error Resume Next
  204.     Set oHeader = Nothing
  205.     Set m_Entities = Nothing
  206.     lMax = UBound(m_Blocks)
  207.     For lCnt = 1 To lMax
  208.         Set m_Blocks(lCnt) = Nothing
  209.     Next lCnt
  210.     Set oGlobals = Nothing
  211. End Sub
  212.