'输出DXF文件所用变量//
Public g_doc As IMxDocument
Public OutputFile As String
Public layer_Current As String
Private Sub 导出DXF_Click()
Dim pActiveView As IActiveView
Set g_doc = Application.Document
Set pActiveView = g_doc.FocusMap
If g_doc.FocusMap.LayerCount = 0 Then
MsgBox "当前视图没有加载图形!", vbCritical
Exit Sub
End If
If MsgBox("本工具只导出可见图层在视窗范围内的图形!", vbOKCancel, "提示") = vbCancel Then
Exit Sub
End If
Dim OutputFile As String
OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "C:\导出.dxf")
If Len(Trim(OutputFile)) = 0 Then
MsgBox "请输入有效的文件名"
OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "c:\导出.dxf")
Exit Sub
End If
'Dim pMap As IMap, pCurrentScale As Double
'Set pMap = g_doc.FocusMap
'pCurrentScale = pMap.MapScale
If Open_DXF(OutputFile) = False Then Exit Sub
Write_Header
Write_Tables
Write_Blocks
Write_Entities
Application.StatusBar.Message(0) = "成功将窗口内的图形导出为DXF文件!"
Close #1
'pMap.MapScale = pCurrentScale
Set g_doc = Nothing
MsgBox "导出的CAD文件保存于" & OutputFile
End Sub
Private Function Open_DXF(sFile As String) As Boolean
On Error GoTo errhandle:
Open sFile For Output As #1
Open_DXF = True
Exit Function
errhandle:
Open_DXF = False
MsgBox "写文件出错，可能同名文件已经打开！"
' MsgBox "Open_DXF: " & Err.Description
End Function
Private Sub Write_Header()
On Error GoTo errhandle:
Dim pEnv As IEnvelope
Set pEnv = g_doc.ActiveView.Extent
Dim min_extents As IPoint
Set min_extents = New point
min_extents.X = pEnv.LowerLeft.X
min_extents.Y = pEnv.LowerLeft.Y
min_extents.Z = 0
Dim max_extents As IPoint
Set max_extents = New point
max_extents.X = pEnv.UpperRight.X
max_extents.Y = pEnv.UpperRight.Y
max_extents.Z = 0
Print #1, CStr(0)
Print #1, "SECTION"
Print #1, CStr(2)
Print #1, "HEADER"
Print #1, 9
Print #1, "$EXTMIN"
Print #1, 10
Print #1, CStr(min_extents.X)
Print #1, 20
Print #1, CStr(min_extents.Y)
Print #1, 30
Print #1, CStr(min_extents.Z)
Print #1, 9
Print #1, "$EXTMAX"
Print #1, 10
Print #1, CStr(max_extents.X)
Print #1, 20
Print #1, CStr(max_extents.Y)
Print #1, 30
Print #1, CStr(max_extents.Z)
Print #1, 0
Print #1, "ENDSEC"
Exit Sub
errhandle:
MsgBox "Write_Header: " & Err.Description
End Sub
Private Sub Write_Tables()
On Error GoTo errhandle:
Print #1, 0
Print #1, "SECTION"
Print #1, 2
Print #1, "TABLES"
'Write_VPort_Information
'Write_Layer_Information
Print #1, 0
Print #1, "ENDSEC"
Exit Sub
errhandle:
MsgBox "Write_Tables: " & Err.Description
End Sub
Private Sub Write_Blocks()
On Error GoTo errhandle:
Print #1, 0
Print #1, "SECTION"
Print #1, 2
Print #1, "BLOCKS"
Print #1, 0
Print #1, "ENDSEC"
Exit Sub
errhandle:
MsgBox "Write_Blocks: " & Err.Description
End Sub
'
Private Sub Write_Entities()
'On Error GoTo errhandle:
Dim pFeat As IFeature
Print #1, 0
Print #1, "SECTION"
Print #1, 2
Print #1, "ENTITIES"
Dim pMap As IMap
Dim pFCursor As IFeatureCursor, pFL As IFeatureLayer
Set pMap = g_doc.FocusMap
Dim pShape As IGeometry
Dim pSpatialFilter As ISpatialFilter
Dim pGeometry As IGeometry
Set pGeometry = g_doc.ActiveView.Extent.Envelope
Set pSpatialFilter = New SpatialFilter
Dim i, j As Integer
Dim layer As ILayer
Dim pComLayer As ICompositeLayer
Dim pStepProgressor As IStepProgressor
Set pStepProgressor = Application.StatusBar.ProgressBar
pStepProgressor.MinRange = 1
pStepProgressor.MaxRange = pMap.LayerCount
pStepProgressor.Show
Dim layersCount As Integer
layersCount = pMap.LayerCount
For i = 0 To pMap.LayerCount - 1
pStepProgressor.Message = "正在导出：" & pMap.layer(i).name
Set layer = pMap.layer(i)
If layer.Visible = True Then '只导出可见图层
If (TypeOf pMap.layer(i) Is IFeatureLayer) Then
'If Not pMap.layer(i).Name = "Graphics" Then
Set pFL = pMap.layer(i)
If Not pFL.FeatureClass Is Nothing Then
'If pFL.featureClass.featurecount(Nothing) > 0 And pFL.Visible = True Then
If pFL.FeatureClass.FeatureCount(Nothing) > 0 Then
layer_Current = pFL.FeatureClass.AliasName
'Application.StatusBar.Message(0) = "正在将视窗范围内的图形导出为DXF文件（" & Str(i) & "/" & Str(pMap.LayerCount) & "）"
'输出当前视窗内的要素
With pSpatialFilter
Set .Geometry = pGeometry
.GeometryField = pFL.FeatureClass.ShapeFieldName
.SpatialRel = esriSpatialRelRelation
.SpatialRelDescription = "T********" '完全被包含的和相交的
End With
Set pFCursor = pFL.Search(pSpatialFilter, False)
Set pFeat = pFCursor.NextFeature
'///
While Not pFeat Is Nothing
If TypeOf pFeat Is IAnnotationFeature Then ' Handle anno
write_anno pFeat
Else ' Handle normal features
Set pShape = pFeat.ShapeCopy
Select Case pShape.GeometryType
Case esriGeometryPoint
write_point pFeat
Case esriGeometryMultipoint
write_points pFeat
Case esriGeometryPolyline
write_polyline pShape
Case esriGeometryPolygon
write_poly pFeat
write_label pFeat
Case esriGeometryLine
write_polyline pShape
End Select
End If
Set pFeat = pFCursor.NextFeature
'
Wend
End If
End If
' End If
ElseIf TypeOf pMap.layer(i) Is IGroupLayer Then
Set pComLayer = pMap.layer(i)
For j = 0 To pComLayer.count - 1
Set pFL = pComLayer.layer(j)
If Not pFL.FeatureClass Is Nothing Then
If pFL.FeatureClass.FeatureCount(Nothing) > 0 Then
layer_Current = pFL.FeatureClass.AliasName
'Application.StatusBar.Message(0) = "正在将视窗范围内的图形导出为DXF文件（" & Str(i) & "/" & Str(pMap.LayerCount) & "）"
'输出当前视窗内的要素
With pSpatialFilter
Set .Geometry = pGeometry
.GeometryField = pFL.FeatureClass.ShapeFieldName
'第一种空间查询方式
'.SpatialRel = esriSpatialRelContains '完全被指定的范围所包含
'第二种空间查询方式
.SpatialRel = esriSpatialRelRelation
.SpatialRelDescription = "T********" '完全被包含的和相交的
End With
Set pFCursor = pFL.Search(pSpatialFilter, False)
Set pFeat = pFCursor.NextFeature
'///
While Not pFeat Is Nothing
If TypeOf pFeat Is IAnnotationFeature Then ' Handle anno
write_anno pFeat
Else ' Handle normal features
Set pShape = pFeat.ShapeCopy
Select Case pShape.GeometryType
Case esriGeometryPoint
write_point pFeat
Case esriGeometryMultipoint
write_points pFeat
Case esriGeometryPolyline
write_polyline pShape
Case esriGeometryPolygon
write_poly pFeat
write_label pFeat
Case esriGeometryLine
write_polyline pShape
End Select
End If
Set pFeat = pFCursor.NextFeature
'
Wend
End If
End If
Next j
End If
End If
pStepProgressor.position = i
Next i
pStepProgressor.Hide
Print #1, 0
Print #1, "ENDSEC"
Print #1, 0
Print #1, "EOF"
Exit Sub
'errhandle:
'MsgBox "写实体出错: " & Err.Description
End Sub
Private Sub Write_VPort_Information()
On Error GoTo errhandle:
Print #1, 0
Print #1, "TABLE"
Print #1, 2
Print #1, "VPORT"
Print #1, 0
Print #1, "VPORT"
Print #1, 2
Print #1, "*ACTIVE"
Print #1, 41
Print #1, CStr(1#)
Print #1, 0
Print #1, "ENDTAB"
Exit Sub
errhandle:
MsgBox "Write_VPort_Information: " & Err.Description
End Sub
Private Sub Write_Layer_Information()
On Error GoTo errhandle:
' Write the LineTypes
Print #1, 0
Print #1, "TABLE"
Print #1, 2
Print #1, "LTYPE"
Print #1, 5
Print #1, 1
Print #1, 0
Print #1, "LTYPE"
Print #1, 2
Print #1, "CONTINUOUS"
Print #1, 70
Print #1, 0
Print #1, 3
Print #1, "Solid line"
Print #1, 72
Print #1, 65
Print #1, 73
Print #1, 0
Print #1, 0
Print #1, "ENDTAB"
Print #1, 0
Print #1, "TABLE"
Print #1, 2
Print #1, "LAYER"
Print #1, 5
Print #1, 2
Print #1, 0
Print #1, "LAYER"
Print #1, 2
Print #1, 0
Print #1, 70
Print #1, 0
Print #1, 62
Print #1, 7
Print #1, 6
Print #1, "CONTINUOUS"
Print #1, 0
Print #1, "ENDTAB"
Exit Sub
errhandle:
MsgBox "Write_Layer_Information: " & Err.Description
End Sub
Private Sub write_polylineInPolygon(pShape As IGeometry)
'On Error GoTo errhandle:
Dim bFirstSeg As Boolean
bFirstSeg = True
Dim pSegColl As ISegmentCollection
Set pSegColl = pShape
Dim pSeg As ISegment
Dim i As Long
For i = 0 To pSegColl.SegmentCount - 1
Set pSeg = pSegColl.Segment(i)
Select Case pSeg.GeometryType
Case esriGeometryLine
If bFirstSeg Then
' First segment of polyline, print the header info
Print #1, CStr(0)
Print #1, "POLYLINE"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, CStr(66)
Print #1, CStr(1)
Print #1, CStr(62)
Print #1, CStr(7)
Print #1, CStr(6)
Print #1, "CONTINUOUS"
' Print the "from point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pSeg.FromPoint.X
Print #1, 20
Print #1, pSeg.FromPoint.Y
bFirstSeg = False
End If
' Now print the "to point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pSeg.ToPoint.X
Print #1, 20
Print #1, pSeg.ToPoint.Y
' Do we need to end the entity?
If i = pSegColl.SegmentCount - 1 Then
Print #1, CStr(0)
Print #1, "SEQEND"
Print #1, 8
Print #1, layer_Current
End If
' Handle curves
Case esriGeometryCircularArc
If Not bFirstSeg Then
' ArcMap allows a line and curve as one entity. Autocad doesn't.
' So, in this case, this is a curve but isn't the first segment.
' End the polyline entity first, then create a new ARC entity.
Print #1, CStr(0)
Print #1, "SEQEND"
Print #1, 8
Print #1, layer_Current
End If
Dim pCA As ICircularArc
Set pCA = pSeg
If Not pCA.CenterPoint Is Nothing Then
Print #1, CStr(0)
Print #1, "ARC"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pCA.CenterPoint.X
Print #1, 20
Print #1, pCA.CenterPoint.Y
Print #1, 40
Print #1, pCA.radius
If pCA.IsCounterClockwise Then
Print #1, 50
Print #1, CStr(CDbl(pCA.FromAngle * 180 / PI))
Print #1, 51
Print #1, CStr(CDbl(pCA.ToAngle * 180 / PI))
Else
Print #1, 50
Print #1, CStr(CDbl(pCA.ToAngle * 180 / PI))
Print #1, 51
Print #1, CStr(CDbl(pCA.FromAngle * 180 / PI))
End If
End If
'Debug.Print " *** Arc *** "
Set pCA = pSeg
'Debug.Print "Center: " & pCA.CenterPoint.X & " , " & pCA.CenterPoint.Y
'Debug.Print "Radius: " & pCA.radius
'Debug.Print "Start Angle: " & CDbl(pCA.FromAngle * 180 / Pi)
'Debug.Print "End Angle: " & CDbl(pCA.ToAngle * 180 / Pi)
bFirstSeg = True
End Select
Next i
' Exit Sub
'errhandle:
'
' MsgBox "Write_Polyline: " & Err.Description
End Sub
Private Sub write_polyline(pShape As IGeometry)
Dim bFirstSeg As Boolean
Dim pGeometryColl As IGeometryCollection
Dim pGeometryCount As Integer
Dim pPointColl As IPointCollection
Dim pPoint As IPoint
Dim i As Long
Set pGeometryColl = pShape
For pGeometryCount = 0 To pGeometryColl.GeometryCount - 1
Set pPointColl = pGeometryColl.Geometry(pGeometryCount)
bFirstSeg = True
For i = 0 To pPointColl.PointCount - 1
Set pPoint = pPointColl.point(i)
If bFirstSeg Then
' First segment of polyline, print the header info
Print #1, CStr(0)
Print #1, "POLYLINE"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, CStr(66)
Print #1, CStr(1)
Print #1, CStr(62)
Print #1, CStr(7)
Print #1, CStr(6)
Print #1, "CONTINUOUS"
' Print the "from point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pPoint.X
Print #1, 20
Print #1, pPoint.Y
bFirstSeg = False
End If
' Now print the "to point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pPoint.X
Print #1, 20
Print #1, pPoint.Y
' Do we need to end the entity?
If i = pPointColl.PointCount - 1 Then
Print #1, CStr(0)
Print #1, "SEQEND"
Print #1, 8
Print #1, layer_Current
End If
Next i
Next pGeometryCount
End Sub
Private Sub write_polyline_original(pShape As IGeometry)
On Error GoTo errhandle:
Dim pPoints As IPointCollection
Set pPoints = pShape
Dim pPoly As IPolygon
Dim pRing As IRing
Print #1, CStr(0)
Print #1, "POLYLINE"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, CStr(66)
Print #1, CStr(1)
Print #1, CStr(62)
Print #1, CStr(7)
Print #1, CStr(6)
Print #1, "CONTINUOUS"
Dim i As Long
For i = 0 To pPoints.PointCount - 1
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pPoints.point(i).X
Print #1, 20
Print #1, pPoints.point(i).Y
Dim j As Long
Next i
Print #1, CStr(0)
Print #1, "SEQEND"
Print #1, 8
Print #1, layer_Current
Exit Sub
errhandle:
MsgBox "Write_Polyline: " & Err.Description
End Sub
Private Sub write_poly(pFeature As IFeature)
' On Error GoTo errhandle:
Dim pShape As IGeometry
Dim pPoly As IPolygon, lLoop As Long, lExtCount As Long, pExtRings() As IRing
Dim pIntRings() As IRing, lLoop2 As Long, lIntCount As Long
Set pShape = pFeature.ShapeCopy
Set pPoly = pShape
lExtCount = pPoly.ExteriorRingCount
If lExtCount = 0 Then Exit Sub
ReDim pExtRings(lExtCount - 1)
For lLoop = 0 To lExtCount - 1
Set pExtRings(lLoop) = New ring
Next lLoop
pPoly.QueryExteriorRings pExtRings(0)
For lLoop = 0 To lExtCount - 1
'Write out the external ring
write_polylineInPolygon pExtRings(lLoop)
lIntCount = pPoly.InteriorRingCount(pExtRings(lLoop))
If lIntCount > 0 Then
ReDim pIntRings(lIntCount - 1)
For lLoop2 = 0 To lIntCount - 1
Set pIntRings(lLoop2) = New ring
Next lLoop2
pPoly.QueryInteriorRings pExtRings(lLoop), pIntRings(0)
For lLoop2 = 0 To lIntCount - 1
'Write out the internal rings
Dim pPoints As IPointCollection
Set pPoints = pIntRings(lLoop2)
write_polylineInPolygon pIntRings(lLoop2)
Next lLoop2
End If
Next lLoop
' Exit Sub
'errhandle:
' MsgBox "Write_Poly: " & Err.Description
End Sub
'写lable注记
Private Sub write_label(pFeat As IFeature)
On Error GoTo errhandle:
Dim Point1 As IPoint
Dim pDlbm As String
Dim pTbbh As String
Dim pLable As String
If IsNull(pFeat.value(pFeat.Fields.FindField("DLBM"))) Then
Exit Sub
Else
pDlbm = Trim(pFeat.value(pFeat.Fields.FindField("DLBM")))
End If
If IsNull(pFeat.value(pFeat.Fields.FindField("TBBH"))) Then
pTbbh = ""
Else
pTbbh = Trim(pFeat.value(pFeat.Fields.FindField("TBBH")))
End If
If pTbbh = "" Then
pLable = pDlbm
Else
pLable = pTbbh & "/" & pDlbm
End If
' Dim pGeometryColl As IGeometryCollection
' Set pGeometryColl = pFeat.Shape
Dim pArea As IArea
Set pArea = pFeat.ShapeCopy
Set Point1 = pArea.LabelPoint
Print #1, CStr(0)
Print #1, "TEXT"
Print #1, CStr(8)
Print #1, "图斑注记"
Print #1, CStr(1)
Print #1, pLable
Print #1, 72
Print #1, CStr(0)
Print #1, 73
Print #1, CStr(0)
Print #1, 50
Print #1, CStr(0)
Print #1, 40
Print #1, CStr(1)
Print #1, "10"
Print #1, Point1.X
Print #1, "20"
Print #1, Point1.Y
Print #1, "11"
Print #1, Point1.X + 30
Print #1, "21"
Print #1, Point1.Y + 30
Exit Sub
errhandle:
Exit Sub
End Sub
'写lable注记
Private Sub write_label22(pFeat As IFeature)
On Error GoTo errhandle:
Dim pShape As IGeometry
Set pShape = pFeat.ShapeCopy
Dim pArea As IArea
Dim Point1 As IPoint
Dim pDlbm As String
Dim pTbbh As String
Dim pLable As String
If IsNull(pFeat.value(pFeat.Fields.FindField("DLBM"))) Then
Exit Sub
Else
pDlbm = Trim(pFeat.value(pFeat.Fields.FindField("DLBM")))
End If
If IsNull(pFeat.value(pFeat.Fields.FindField("TBBH"))) Then
pTbbh = ""
Else
pTbbh = Trim(pFeat.value(pFeat.Fields.FindField("TBBH")))
End If
If pTbbh = "" Then
pLable = pDlbm
Else
pLable = pTbbh & "/" & pDlbm
End If
Dim pPoly As IPolygon, lLoop As Long, lExtCount As Long, pExtRings() As IRing
Set pPoly = pShape
lExtCount = pPoly.ExteriorRingCount
If lExtCount = 0 Then Exit Sub
ReDim pExtRings(lExtCount - 1)
For lLoop = 0 To lExtCount - 1
Set pExtRings(lLoop) = New ring
Next lLoop
pPoly.QueryExteriorRings pExtRings(0)
For lLoop = 0 To lExtCount - 1
Set pArea = pExtRings(lLoop)
Set Point1 = pArea.LabelPoint
Print #1, CStr(0)
Print #1, "TEXT"
Print #1, CStr(8)
Print #1, "图斑注记"
Print #1, CStr(1)
Print #1, pLable
Print #1, 72
Print #1, CStr(0)
Print #1, 73
Print #1, CStr(0)
Print #1, 50
Print #1, CStr(0)
Print #1, 40
Print #1, CStr(1)
Print #1, "10"
Print #1, Point1.X
Print #1, "20"
Print #1, Point1.Y
Print #1, "11"
Print #1, Point1.X + 30
Print #1, "21"
Print #1, Point1.Y + 30
Next lLoop
Exit Sub
errhandle:
Exit Sub
End Sub
Private Sub write_anno(pFeat As IFeature)
On Error GoTo errhandle:
Dim pAnno As IAnnotationFeature
Set pAnno = pFeat
Dim pShape As IGeometry
Set pShape = pFeat.ShapeCopy
Dim pPoly As IPolygon
Set pPoly = pShape
Dim pEnv As IEnvelope
Set pEnv = pPoly.Envelope
Dim pElem As IElement
Set pElem = pAnno.Annotation
Dim pTextEl As ITextElement
'处理地类注记中间的短线
If TypeOf pElem Is ITextElement Then
Set pTextEl = pElem
ElseIf TypeOf pElem Is ILineElement Then
write_middleLine pElem.Geometry '调用专门处理分子分母线的函数
End If
'Determine the size to use for the annotation in map units
Dim dSize As Double, pAnnoClass As IAnnoClass
Set pAnnoClass = pFeat.Class.Extension
Dim pMap As IMap, pCurrentScale As Double, pDisp As IScreenDisplay
Set pMap = g_doc.FocusMap
pCurrentScale = pMap.MapScale
pMap.MapScale = pAnnoClass.ReferenceScale
Dim pActive As IActiveView
Set pActive = pMap
Set pDisp = pActive.ScreenDisplay
dSize = pDisp.DisplayTransformation.FromPoints(pTextEl.Symbol.Size) / 1.333
Dim pMP As IMultipoint
Set pMP = New Multipoint
Dim pPoints As IPointCollection
'修改后的
Dim Point1 As IPoint
Dim Point2 As IPoint
Set Point1 = New point
Set Point2 = New point
Set Point1 = pEnv.LowerLeft
Set Point2 = pEnv.LowerRight
Set pPoints = pMP
pPoints.AddPoint Point1
pPoints.AddPoint Point2
'直接获取注记的角度
Dim dAngle As Double
dAngle = pTextEl.Symbol.Angle
'处理多行文本，如果为多行文本，只取第一行
Dim pText As String
pText = Trim(pTextEl.Text)
If InStr(pText, Chr(13)) > 0 Then
pText = Left(pText, InStr(pText, Chr(13)) - 1)
End If
Print #1, CStr(0)
Print #1, "TEXT"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, CStr(1)
Print #1, pText
Print #1, 72
Print #1, CStr(0)
Print #1, 73
Print #1, CStr(0)
Print #1, 50
Print #1, CStr(dAngle)
Print #1, 40
Print #1, CStr(dSize) ' TODO: if we're in meters, divide by 3. Otherwise, don't.
'Write out the first and last points (DXF only allows two points for defining the position)
Print #1, "10"
Print #1, pPoints.point(0).X
Print #1, "20"
Print #1, pPoints.point(0).Y
Print #1, "11"
Print #1, pPoints.point(pPoints.PointCount - 1).X
Print #1, "21"
Print #1, pPoints.point(pPoints.PointCount - 1).Y
Exit Sub
errhandle:
'MsgBox "写注记出错: " & Err.Description
Exit Sub
End Sub
'用于输出分数线
Private Sub write_middleLine(pShape As IGeometry)
On Error GoTo errhandle:
Dim bFirstSeg As Boolean
bFirstSeg = True
Dim pSegColl As ISegmentCollection
Set pSegColl = pShape
Dim pSeg As ISegment
Dim i As Long
For i = 0 To pSegColl.SegmentCount - 1
Set pSeg = pSegColl.Segment(i)
Select Case pSeg.GeometryType
Case esriGeometryLine
If bFirstSeg Then
' First segment of polyline, print the header info
Print #1, CStr(0)
Print #1, "POLYLINE"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, CStr(66)
Print #1, CStr(1)
Print #1, CStr(62)
Print #1, CStr(7)
Print #1, CStr(6)
Print #1, "CONTINUOUS"
' Print the "from point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pSeg.FromPoint.X
Print #1, 20
Print #1, pSeg.FromPoint.Y - 0.2
bFirstSeg = False
End If
' Now print the "to point"
Print #1, CStr(0)
Print #1, "VERTEX"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pSeg.ToPoint.X
Print #1, 20
Print #1, pSeg.ToPoint.Y - 0.2
' Do we need to end the entity?
If i = pSegColl.SegmentCount - 1 Then
Print #1, CStr(0)
Print #1, "SEQEND"
Print #1, 8
Print #1, layer_Current
End If
End Select
Next i
Exit Sub
errhandle:
MsgBox "Write_Polyline: " & Err.Description
End Sub
'输出单点
'private Sub write_point(pShape As IGeometry)
Private Sub write_point(pFeature As IFeature)
On Error GoTo errhandle:
Dim pPoint As IPoint
Set pPoint = pFeature.Shape
Dim index As Integer
index = pFeature.Fields.FindField("YSDM")
Print #1, CStr(0)
Print #1, "POINT"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pPoint.X
Print #1, 20
Print #1, pPoint.Y
Print #1, 39 ' Thickness
Print #1, CStr(3)
Exit Sub
errhandle:
MsgBox "Write_Point: " & Err.Description
End Sub
'输出多点
Private Sub write_points(pFeature As IFeature)
On Error GoTo errhandle:
Dim pPoints As IPointCollection
Set pPoints = pFeature.Shape
Dim index As Integer
index = pFeature.Fields.FindField("YSDM")
Dim i As Long
For i = 0 To pPoints.PointCount - 1
Print #1, CStr(0)
Print #1, "POINT"
Print #1, CStr(8)
Print #1, layer_Current
Print #1, 10
Print #1, pPoints.point(i).X
Print #1, 20
Print #1, pPoints.point(i).Y
Print #1, 39 ' Thickness
Print #1, CStr(3)
' If index <> -1 Then
' Print #1, Trim(pFeature.Value(index))
' Else
' Print #1, CStr(3)
' End If
Next i
Exit Sub
errhandle:
MsgBox "Write_Points: " & Err.Description
End Sub
扫一扫
2345
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
