Option Explicit
Private Const RADIN = 3.1415926 / 180
Type ENTITY lEntityId As Long sEntityName As String fEntityLength As Double lEntityColor As Long fStartX As Double fStartY As Double fEndX As Double fEndY As Double fBoundingBoxLeft As Double fBoundingBoxBottom As Double fBoundingBoxRight As Double fBoundingBoxTop As Double sLayer As StringEnd Type
Type LAYER lIndex As Long sName As String lNum As LongEnd Type
Type PTLWPL x As Double y As Double fBulbe As DoubleEnd Type
Private Sub ReadDXF(ByVal dxfFile As String) Dim colors As Variant colors = Array( _ RGB(255, 255, 255), RGB(255, 0, 0), RGB(255, 255, 0), RGB(0, 255, 0), RGB(0, 255, 255), RGB(0, 0, 255), RGB(255, 0, 255), RGB(255, 255, 255), RGB(128, 128, 128), RGB(192, 192, 192), RGB(255, 0, 0), RGB(255, 127, 127), RGB(204, 0, 0), RGB(204, 102, 102), RGB(153, 0, 0), RGB(153, 76, 76), RGB(127, 0, 0), RGB(127, 63, 63), RGB(76, 0, 0), RGB(76, 38, 38), RGB(255, 63, 0), _ RGB(255, 159, 127), RGB(204, 51, 0), RGB(204, 127, 102), RGB(153, 38, 0), RGB(153, 95, 76), RGB(127, 31, 0), RGB(127, 79, 63), RGB(76, 19, 0), RGB(76, 47, 38), RGB(255, 127, 0), RGB(255, 191, 127), RGB(204, 102, 0), RGB(204, 153, 102), RGB(153, 76, 0), RGB(153, 114, 76), RGB(127, 63, 0), RGB(127, 95, 63), RGB(76, 38, 0), RGB(76, 57, 38), RGB(255, 191, 0), RGB(255, 223, 127), RGB(204, 153, 0), _ RGB(204, 178, 102), RGB(153, 114, 0), RGB(153, 133, 76), RGB(127, 95, 0), RGB(127, 111, 63), RGB(76, 57, 0), RGB(76, 66, 38), RGB(255, 255, 0), RGB(255, 255, 127), RGB(204, 204, 0), RGB(204, 204, 102), RGB(153, 153, 0), RGB(153, 153, 76), RGB(127, 127, 0), RGB(127, 127, 63), RGB(76, 76, 0), RGB(76, 76, 38), RGB(191, 255, 0), RGB(223, 255, 127), RGB(153, 204, 0), RGB(178, 204, 102), RGB(114, 153, 0), _ RGB(133, 153, 76), RGB(95, 127, 0), RGB(111, 127, 63), RGB(57, 76, 0), RGB(66, 76, 38), RGB(127, 255, 0), RGB(191, 255, 127), RGB(102, 204, 0), RGB(153, 204, 102), RGB(76, 153, 0), RGB(114, 153, 76), RGB(63, 127, 0), RGB(95, 127, 63), RGB(38, 76, 0), RGB(57, 76, 38), RGB(63, 255, 0), RGB(159, 255, 127), RGB(51, 204, 0), RGB(127, 204, 102), RGB(38, 153, 0), RGB(95, 153, 76), _ RGB(31, 127, 0), RGB(79, 127, 63), RGB(19, 76, 0), RGB(47, 76, 38), RGB(0, 255, 0), RGB(127, 255, 127), RGB(0, 204, 0), RGB(102, 204, 102), RGB(0, 153, 0), RGB(76, 153, 76), RGB(0, 127, 0), RGB(63, 127, 63), RGB(0, 76, 0), RGB(38, 76, 38), RGB(0, 255, 63), RGB(127, 255, 129), RGB(0, 204, 51), RGB(102, 204, 127), RGB(0, 153, 38), RGB(76, 153, 95), RGB(0, 127, 31), RGB(63, 127, 79), _ RGB(0, 76, 19), RGB(38, 76, 47), RGB(0, 255, 127), RGB(127, 255, 191), RGB(0, 204, 102), RGB(102, 204, 153), RGB(0, 153, 76), RGB(76, 153, 114), RGB(0, 127, 63), RGB(63, 127, 95), RGB(0, 76, 38), RGB(38, 76, 57), RGB(0, 255, 191), RGB(127, 255, 223), RGB(0, 204, 153), RGB(102, 204, 178), RGB(0, 153, 114), RGB(76, 153, 133), RGB(0, 127, 95), RGB(63, 127, 111), RGB(0, 76, 57), RGB(38, 76, 66), RGB(0, 255, 255), _ RGB(127, 255, 255), RGB(0, 204, 204), RGB(102, 204, 204), RGB(0, 153, 153), RGB(76, 153, 153), RGB(0, 127, 127), RGB(63, 127, 127), RGB(0, 76, 76), RGB(38, 76, 76), RGB(0, 191, 255), RGB(127, 223, 255), RGB(0, 153, 204), RGB(102, 178, 204), RGB(0, 114, 153), RGB(76, 133, 153), RGB(0, 95, 127), RGB(63, 111, 127), RGB(0, 57, 76), RGB(38, 66, 76), RGB(0, 127, 255), RGB(127, 191, 255), RGB(0, 102, 204), _ RGB(102, 153, 204), RGB(0, 76, 153), RGB(76, 114, 153), RGB(0, 63, 127), RGB(63, 95, 127), RGB(0, 38, 76), RGB(38, 57, 76), RGB(0, 63, 255), RGB(127, 159, 255), RGB(0, 51, 204), RGB(102, 127, 204), RGB(0, 38, 153), RGB(76, 95, 153), RGB(0, 31, 127), RGB(63, 79, 127), RGB(0, 19, 76), RGB(38, 47, 76), RGB(0, 0, 255), RGB(127, 127, 255), RGB(0, 0, 204), RGB(102, 102, 204), RGB(0, 0, 153), RGB(76, 76, 153), _ RGB(0, 0, 127), RGB(63, 63, 127), RGB(0, 0, 76), RGB(38, 38, 76), RGB(63, 0, 255), RGB(159, 127, 255), RGB(51, 0, 204), RGB(127, 102, 204), RGB(38, 0, 153), RGB(95, 76, 153), RGB(31, 0, 127), RGB(79, 63, 127), RGB(19, 0, 76), RGB(47, 38, 76), RGB(127, 0, 255), RGB(191, 127, 255), RGB(102, 0, 204), RGB(153, 102, 204), RGB(76, 0, 153), RGB(114, 76, 153), _ RGB(63, 0, 127), RGB(95, 63, 127), RGB(38, 0, 76), RGB(57, 38, 76), RGB(191, 0, 255), RGB(223, 127, 255), RGB(153, 0, 204), RGB(178, 102, 204), RGB(114, 0, 153), RGB(133, 76, 153), RGB(95, 0, 127), RGB(111, 63, 127), RGB(57, 0, 76), RGB(66, 38, 76), RGB(255, 0, 255), RGB(255, 127, 255), RGB(204, 0, 204), RGB(204, 102, 204), RGB(153, 0, 153), RGB(153, 76, 153), _ RGB(127, 0, 127), RGB(127, 63, 127), RGB(76, 0, 76), RGB(76, 38, 76), RGB(255, 0, 191), RGB(255, 127, 223), RGB(204, 0, 153), RGB(204, 102, 178), RGB(153, 0, 114), RGB(153, 76, 133), RGB(127, 0, 95), RGB(127, 63, 111), RGB(76, 0, 57), RGB(76, 38, 66), RGB(255, 0, 127), RGB(255, 127, 191), RGB(204, 0, 102), RGB(204, 102, 153), RGB(153, 0, 76), RGB(153, 76, 114), _ RGB(127, 0, 63), RGB(127, 63, 95), RGB(76, 0, 38), RGB(76, 38, 57), RGB(255, 0, 63), RGB(255, 127, 159), RGB(204, 0, 51), RGB(204, 102, 127), RGB(153, 0, 38), RGB(153, 76, 95), RGB(127, 0, 31), RGB(127, 63, 79), RGB(76, 0, 19), RGB(76, 38, 47), RGB(51, 51, 51), RGB(91, 91, 91), RGB(132, 132, 132), RGB(173, 173, 173), RGB(214, 214, 214), RGB(255, 255, 255) _ ) Dim codes As Variant Dim lastObj As String Dim xs, ys, xe, ye, t Dim ent As ENTITY Dim u As Long Dim pts() As PTLWPL Dim arrLayer() As LAYER Dim lIndex As Long Dim lItem As Long Dim coordinates(0 To 3) As Double Dim lw As AcadLWPolyline Dim fLen As Double Dim fBulbe As Double Dim xm As Double, ym As Double, xc As Double, yc As Double Dim fChord As Double, fInclAng As Double, fAng As Double, fRad As Double, fFlag As Double, c As Double, d As Double, h As Double
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 #1End 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
