VB读取DXF文件之二
Open dxfFile For Input As #1codes = 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
多谢分享，要是有注解就更好了。怎么没人顶？ 顶！！！！！！！！！！！！！！ 希望能加上个注解就更完美了
页:
[1]