www.pudn.com > dxfimport.zip > Pubdxf.bas
Attribute VB_Name = "PubDXF"
' PubDXF
' This module allow you to import a DXF file into your project.
' The main sub is LoadDXF where I read each row writing
' the objects "BLOCKS" in an array structure MemBLK and
' all "ENTITIES" in another structure MemDXF
'
Type Coord
x As Double
y As Double
End Type
Public Const BIG As Double = 1E+30
Type DXFElem
Tipo As Integer ' 1-Line, 2-Solid, 3-PolyLine, 4 - Text, 5, Circle, 6-Arc, 7 - BLOCK
flag As Integer ' PolyLine Flag (1=close)
Layer As String ' Layer Name
Vert() As Coord ' Vertexes
nv As Integer ' tot Vertexes
Color As Long ' Color
Text As String ' Text
angle As Single ' Angle
TextHeight As Single ' Dim Text
Block As String ' Blocck Name
TextAttrib As String ' ATTRIB
Ang2 As Single ' 2° Angle (41)
End Type
Type rkLayer
Nome As String
Visible As Boolean
Color As Long
End Type
Public memDXF() As DXFElem
Public memBLK() As DXFElem
Public DXFCount As Long
Public BLKCount As Long
Public Layers() As rkLayer
Public nLayers As Long
Public Blocks() As String
Public nBlocks As Long
Public MaxX As Single
Public MaxY As Single
Public MinX As Single
Public MinY As Single
Public Canvas As Object
Sub WriteObj(stato As Integer, iv As Integer, Vert() As Coord, flag As Integer, Layer As String, Col As Integer, Text As String, Angolo As Single, TextHeight As Single, Block As String, TextAttrib As String, Ang2 As Single)
Dim i As Integer, s As Integer
If Len(Block) = 0 Then
DXFCount = DXFCount + 1
i = DXFCount
ReDim Preserve memDXF(i)
ReDim memDXF(i).Vert(iv)
memDXF(i).nv = iv
memDXF(i).Tipo = stato
memDXF(i).flag = flag
memDXF(i).Layer = Layer
memDXF(i).Text = Text
memDXF(i).angle = Angolo
memDXF(i).TextHeight = TextHeight
memDXF(i).Block = Block
memDXF(i).TextAttrib = TextAttrib ' or Block name
memDXF(i).Ang2 = Ang2
memDXF(i).Color = QBColor(Col)
For s = 0 To iv
memDXF(i).Vert(s) = Vert(s)
Next
Else
BLKCount = BLKCount + 1
i = BLKCount
ReDim Preserve memBLK(i)
ReDim memBLK(i).Vert(iv)
memBLK(i).nv = iv
memBLK(i).Tipo = stato
memBLK(i).flag = flag
memBLK(i).Layer = Layer
memBLK(i).Text = Text
memBLK(i).angle = Angolo
memBLK(i).TextHeight = TextHeight
memBLK(i).Block = Block
memBLK(i).TextAttrib = TextAttrib
memBLK(i).Ang2 = Ang2
memBLK(i).Color = QBColor(Col)
For s = 0 To iv
memBLK(i).Vert(s) = Vert(s)
Next
End If
End Sub
Public Sub readkey(FINP As Integer, dxfgroup As Integer, dxfvalue As String)
Static riga$
Line Input #FINP, riga$
dxfgroup = Val(riga$)
Line Input #FINP, riga$
dxfvalue = riga$
End Sub
Function ConvColor(Colore As Integer) As Integer
' VB QbColor AUTOCAD
' ============= ===========
'0 Nero 7
'1 Blu 50
'2 Verde 41
'3 Azzurro 45
'4 Rosso 34
'5 Fucsia 55
'6 Giallo 38
'7 Bianco 9
'8 Grigio 8
'9 Blu chiaro 5
'10 Verde limone 3
'11 Azzurro chiaro 4
'12 Rosso chiaro 1
'13 Fucsia chiaro 6
'14 Giallo chiaro 2
'15 Bianco brillante 0
' Converts a Color from AutoCAD 10-14 to VB
Dim c As Integer
Select Case Colore
Case 7: c = 0
Case 50: c = 1
Case 42: c = 2
Case 45: c = 3
Case 34: c = 4
Case 55: c = 5
Case 38: c = 6
Case 9: c = 7
Case 8: c = 8
Case 5: c = 9
Case 3: c = 10
Case 4: c = 11
Case 1: c = 12
Case 6: c = 13
Case 2: c = 14
Case 7: c = 15
End Select
ConvColor = c
End Function
Sub LoadDXF(nomedxf As String)
Dim iv As Integer
Dim FINP As Integer
Dim stato As Integer
Dim Vert(1000) As Coord
Dim dxfgroup As Integer, dxfvalue As String
Dim flag As Integer
Dim Layer As String
Dim Entities As Boolean
Dim Angolo As Single
Dim Text As String
Dim TextHeight As Single
Dim Col As Integer
Dim Block As String
Dim TextAttrib As String
Dim Ang2 As Single
On Error GoTo rdxf_err
Erase memDXF
DXFCount = 0
Screen.MousePointer = 11
FINP = FreeFile
Open nomedxf For Input As FINP
stato = 0
Entities = False
Do While Not (EOF(FINP))
readkey FINP, dxfgroup, dxfvalue
DoEvents
If dxfgroup = 9 And dxfvalue = "$EXTMIN" Then
iv = -1
stato = 25
GoTo Redo
End If
If dxfgroup = 9 And dxfvalue = "$EXTMAX" Then
stato = 26
GoTo Redo
End If
' If dxfvalue = "ENTITIES" Then Entities = True
' If stato < 25 And Not Entities Then GoTo Redo
If Attrib And dxfvalue = "SEQEND" Then Attrib = False
If stato <> 9 Then
If Not Attrib And (dxfgroup = 0 And stato <> 0 And stato <> 6 And dxfvalue <> "VERTEX" And iv >= 0) _
Or (dxfvalue = "SEQEND" And iv >= 0) Then
Call WriteObj(stato, iv, Vert, flag, Layer, Col, Text, Angolo, TextHeight, Block, TextAttrib, Ang2)
Erase Vert
iv = -1
stato = 0
flag = 0
Col = 0
Text = ""
Layer = ""
Angolo = 0
Ang2 = 0
TextHeight = 0
TextAttrib = ""
End If
Else
If dxfgroup = 0 Then
SetLayer Layer, Col
Col = 0: Layer = ""
End If
End If
' Verifica il tipo di oggetto
If dxfgroup = 0 Then
If dxfvalue = "LINE" Then
iv = -1
stato = 1
GoTo Redo
End If
If dxfvalue = "SOLID" Then
iv = -1
stato = 2
GoTo Redo
End If
If dxfvalue = "POLYLINE" Then
Do
readkey FINP, dxfgroup, dxfvalue
If dxfgroup = 70 Then flag = Val(dxfvalue) ' POLYLINE FLAGS
Loop While dxfvalue <> "VERTEX"
stato = 3
iv = -1
GoTo Redo
End If
If dxfvalue = "TEXT" Then
iv = -1
stato = 4
GoTo Redo
End If
If dxfvalue = "CIRCLE" Then
stato = 5
iv = -1
GoTo Redo
End If
If dxfvalue = "ARC" Then
stato = 8
iv = -1
GoTo Redo
End If
If dxfvalue = "LAYER" Then
stato = 9
iv = -1
GoTo Redo
End If
If dxfvalue = "BLOCK" Then
stato = 6
GoTo Redo
End If
If dxfvalue = "INSERT" Then
stato = 7
GoTo Redo
End If
If dxfvalue = "ENDBLK" Then
Block = ""
stato = 0
GoTo Redo
End If
End If
If stato = 0 Or dxfgroup = 0 Or dxfgroup > 80 Then GoTo Redo
' Load all items of current object
Select Case dxfgroup
Case 1
Text = dxfvalue
Case 2
If stato = 6 Then
Block = dxfvalue
ElseIf stato = 7 Then
TextAttrib = dxfvalue
ElseIf stato = 9 Then
Layer = dxfvalue
End If
Case 8
Layer = dxfvalue
Case 10 To 19
iv = iv + 1
Vert(iv).x = Val(dxfvalue)
Case 20 To 29
Vert(iv).y = Val(dxfvalue)
If stato = 26 Then
GoSub SetLim
stato = 0
iv = -1
End If
Case 30 To 39
' vert(iv).z = Val(dxfvalue)
Case 62
Col = Val(dxfvalue)
Col = ConvColor(Col)
Case 66
Attrib = Val(dxfvalue) = 1 ' ATTRIB di INSERT
If Attrib Then iv = -1
Case 40
TextHeight = Val(dxfvalue) ' if stato=4 it means TextHeight, if stato = 5 it means the circle radius
Case 50
Angolo = Val(dxfvalue)
Case 51
Ang2 = Val(dxfvalue)
End Select
Redo:
Loop
Close
' Load Blocks
For s = 1 To BLKCount
SetBlock memBLK(s).Block
Next s
Screen.MousePointer = 0
Exit Sub
SetLim:
MinX = Vert(0).x
MinY = Vert(0).y
MaxX = Vert(1).x
MaxY = Vert(1).y
Return
rdxf_err:
Rt% = MsgBox(Err & " " & Err.Description, vbAbortRetryIgnore, "Error")
If Rt% = vbIgnore Then Resume Next
If Rt% = vbAbort Then
Close
Exit Sub
End If
If Rt% = vbRetry Then Resume 0
End Sub
Sub SetBlock(Block As String)
On Error Resume Next
Dim i As Long
For i = 1 To nBlocks
If Blocks(i) = Block Then Exit Sub
Next
nBlocks = nBlocks + 1
ReDim Preserve Blocks(nBlocks)
Blocks(nBlocks) = Block
End Sub