VB读取DXF文件之二

liukaimin

    Open dxfFile For Input As #1
    codes = ReadCodes
    While codes(1) <> "EOF"
        If codes(0) = "0" And codes(1) = "SECTION" Then
            codes = ReadCodes()
            While codes(1) <> "ENDSEC"
                If codes(0) = "0" Then
               
                    If ((lastObj = "LWPOLYLINE" Or lastObj = "ARC" Or lastObj = "LINE") And ent.lEntityColor = 256) Or lastObj = "LAYER" Then
                        On Error Resume Next
                        u = UBound(arrLayer)
                        If Err.Number <> 0 Then
                            Err.Clear
                            u = 0
                        End If
                        On Error GoTo 0
                        
                        lIndex = 0
                        For lItem = 1 To u
                            If lIndex > arrLayer(lItem).lIndex Then lIndex = arrLayer(lItem).lIndex
                           
                            If arrLayer(lItem).sName = ent.sLayer Then
                                If lastObj = "LAYER" Then
                                    arrLayer(lItem).lNum = ent.lEntityColor
                                Else
                                    ent.lEntityColor = arrLayer(lItem).lIndex
                                End If
                                lIndex = Abs(lIndex)
                                Exit For
                            End If
                        Next
                        If lIndex <= 0 Then
                            lIndex = Abs(lIndex - 1)
                            ReDim Preserve arrLayer(1 To lIndex) As LAYER
                            arrLayer(lIndex).lIndex = -lIndex
                            arrLayer(lIndex).lNum = ent.lEntityColor
                            arrLayer(lIndex).sName = ent.sLayer
                           
                            ent.lEntityColor = -lIndex
                        End If
                    End If
               
                    fLen = 0#
                    Select Case lastObj
                    Case "LWPOLYLINE"
                        u = UBound(pts)
                        pts(u).x = xs
                        pts(u).y = ys
                        If Not IsEmpty(t) Then
                            pts(u).fBulbe = t
                        Else
                            pts(u).fBulbe = 0#
                        End If
                    
                        xs = Empty
                        ys = Empty
                        For lItem = 0 To UBound(pts)
                            If Not (IsEmpty(xs) Or IsEmpty(ys)) Then
                                coordinates(0) = xs
                                coordinates(1) = ys
                                coordinates(2) = pts(lItem).x
                                coordinates(3) = pts(lItem).y
                                
                                fBulbe = pts(lItem - 1).fBulbe
                                
                                Set lw = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates)
                                lw.SetBulge 0, fBulbe
                            End If
                            xs = pts(lItem).x
                            ys = pts(lItem).y
                        Next
                    Case "ARC"
                        If ye < xe Then ye = ye + 360 * RADIN
                        coordinates(0) = xs + t * Cos(xe)
                        coordinates(1) = ys + t * Sin(xe)
                        coordinates(2) = xs + t * Cos(ye)
                        coordinates(3) = ys + t * Sin(ye)
                        Set lw = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates)
                        lw.SetBulge 0, Tan((ye - xe) / 4)
                    Case "LINE"
                        coordinates(0) = xs
                        coordinates(1) = ys
                        coordinates(2) = xe
                        coordinates(3) = ye
                        Set lw = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates)
                        lw.SetBulge 0, 0#
                    End Select
                    
                    lastObj = codes(1)
                    
                    xs = Empty
                    ys = Empty
                    xe = Empty
                    ye = Empty
                    t = Empty
                End If
               
                Select Case lastObj
                Case "LWPOLYLINE"
                    Select Case codes(0)
                    Case "0"
                        ent.sEntityName = "AcDbPolyline"
                    Case "8" '图层名
                        ent.sLayer = codes(1)
                    Case "62" '颜色号（如果不是“随层”，则出现）；零表示“随块”（可变的）颜色；256 表示“随层”；负值表示层已关闭（可选）
                        ent.lEntityColor = CLng(codes(1))
'                    Case "90" '顶点数
                    Case "10" '顶点坐标x
                        If IsEmpty(xs) Or IsEmpty(ys) Then
                            ReDim pts(0 To 0)
                        Else
                            u = UBound(pts)
                           
                            pts(u).x = xs
                            pts(u).y = ys
                            If Not IsEmpty(t) Then
                                pts(u).fBulbe = t
                                t = Empty
                            Else
                                pts(u).fBulbe = 0#
                            End If
                           
                            ReDim Preserve pts(0 To u + 1)
                        End If
                        xs = CDbl(codes(1))
                    Case "20" '顶点坐标y
                        ys = CDbl(codes(1))
                    Case "42" '凸度
                        t = CDbl(codes(1))
                    End Select
                Case "ARC"
                    Select Case codes(0)
                    Case "0"
                        ent.sEntityName = "AcDbArc"
                    Case "8" '图层名
                        ent.sLayer = codes(1)
                    Case "62" '颜色号（如果不是“随层”，则出现）；零表示“随块”（可变的）颜色；256 表示“随层”；负值表示层已关闭（可选）
                        ent.lEntityColor = CLng(codes(1))
                    Case "10" '中心点x
                        xs = CDbl(codes(1))
                    Case "20" '中心点y
                        ys = CDbl(codes(1))
                    Case "40" '半径
                        t = CDbl(codes(1))
                    Case "50" '起点角度
                        xe = CDbl(codes(1)) * RADIN
                    Case "51" '端点角度
                        ye = CDbl(codes(1)) * RADIN
                    End Select
                Case "LINE"
                    Select Case codes(0)
                    Case "0"
                        ent.sEntityName = "AcDbLine"
                    Case "8" '图层名
                        ent.sLayer = codes(1)
                    Case "62" '颜色号（如果不是“随层”，则出现）；零表示“随块”（可变的）颜色；256 表示“随层”；负值表示层已关闭（可选）
                        ent.lEntityColor = CLng(codes(1))
                    Case "10" '起点x
                        xs = CDbl(codes(1))
                    Case "20" '起点y
                        ys = CDbl(codes(1))
                    Case "11" '端点x
                        xe = CDbl(codes(1))
                    Case "21" '端点y
                        ye = CDbl(codes(1))
                    End Select
                Case "LAYER"
                    Select Case codes(0)
                    Case "2" '图层名
                        ent.sLayer = codes(1)
                    Case "62" '颜色编号（如果为负值，则表明图层处于关闭状态）
                        ent.lEntityColor = Abs(CLng(codes(1)))
                    End Select
                End Select
               
                codes = ReadCodes
            Wend
        Else
            codes = ReadCodes
        End If
    Wend
   
    Close #1
End Sub
Private Function ReadCodes() As Variant
    Dim codeStr, valStr As String
    Line Input #1, codeStr
    Line Input #1, valStr
    ReadCodes = Array(Trim(codeStr), valStr)
End Function
Sub OpenDxf()
    ReadDXF ("c:\dxf.dxf")
End Sub

monkeylzx

多谢分享，要是有注解就更好了。怎么没人顶？

mycad

顶！！！！！！！！！！！！！！

xmok

希望能加上个注解就更完美了