在ARCGIS加载后提示No new objects added.

楼主^#

更多发布于：2006-11-12 14:57

小弟编写了个将视图内的地图导出成dxf文件的一个程序,在使用UIcontrol时可以使用,想将其制作成dll使用,但生成后在ARCGIS加载后提示No new objects added.望老鸟指教!代码如下
''输出DXF文件所用变量////////////////////// Implements ICommand Public g_doc As IMxDocument Public OutputFile As String Public g_sCurrent As String Const Pi As Double = 3.14159265358979
Dim m_pPicture As Picture Dim m_pApplication As IApplication
Private Sub class_initialize() Set m_pPicutre = LoadResPicture(101, vbResBitmap) End Sub
Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE ICommand_Bitmap = m_pPicture End Property
Private Property Get ICommand_Caption() As String ICommand_Caption = "导出到DXF" End Property
Private Property Get ICommand_Category() As String ICommand_Category = "导出到DXF" End Property
Private Property Get ICommand_Checked() As Boolean
End Property
Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property
Private Property Get ICommand_HelpContextID() As Long
End Property
Private Property Get ICommand_HelpFile() As String
End Property
Private Property Get ICommand_Message() As String
End Property
Private Property Get ICommand_Name() As String ICommand_Name = "导出到DXF" End Property
Private Sub ICommand_OnCreate(ByVal hook As Object) Set m_pApplication = hook End Sub
Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = "导出到DXF" End Property
Private Sub ICommand_OnClick() If MsgBox("本工具只导出可见图层在视窗范围内的图形! 注意：不能导出分子分母注记", vbOKCancel, "提示") = vbCancel Then Exit Sub End If
Set g_doc = ThisDocument If g_doc.FocusMap.LayerCount = 0 Then MsgBox "当前视图没有加载图形!" Exit Sub End If Dim OutputFile As String OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "c:\test.dxf") If Trim(OutputFile) = "" Then ''MsgBox "请输入有效的文件名" ''OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "c:\test.dxf") Exit Sub End If Open_DXF OutputFile Write_Header Write_Tables Write_Blocks Write_Entities Application.StatusBar.Message(0) = "成功将窗口内的图形导出为DXF文件!" Close #1
Set g_doc = Nothing End Sub
 ''''以下代码用于将当前视图内的图形输出到DXF文件 '' ''''//////////////////////////////////////////////////////////////////////////////////////////////////////////////// ''Private Sub 导出到DXF_Click() '' '' If MsgBox("本工具只导出可见图层在视窗范围内的图形! 注意：不能导出分子分母注记", vbOKCancel, "提示") = vbCancel Then '' Exit Sub '' End If '' '' Set g_doc = ThisDocument '' If g_doc.FocusMap.LayerCount = 0 Then '' MsgBox "当前视图没有加载图形!" '' Exit Sub '' End If '' '' Dim OutputFile As String '' '' OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "c:\test.dxf") '' If Trim(OutputFile) = "" Then '' ''MsgBox "请输入有效的文件名" '' ''OutputFile = InputBox("请输入文件名", "导出DXF文件存放路径", "c:\test.dxf") '' Exit Sub '' End If '' '' Open_DXF OutputFile '' Write_Header '' Write_Tables '' Write_Blocks '' Write_Entities '' Application.StatusBar.Message(0) = "成功将窗口内的图形导出为DXF文件!" '' Close #1 '' '' Set g_doc = Nothing '' ''End Sub
 ''///////////////////////////////////////////////////////////////////////////////////////////
 Public Sub Open_DXF(sFile As String) On Error GoTo errhandle: Open sFile For Output As #1 Exit Sub errhandle: MsgBox "Open_DXF: " ; Err.Description
End Sub
Public 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
Public 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
Public 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
Public 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.StepValue = 1 pStepProgressor.Show
 For i = 0 To pMap.LayerCount - 1 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 g_sCurrent = pMap.layer(i).Name ''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 pShape Case esriGeometryMultipoint write_points pShape Case esriGeometryPolyline write_polyline pShape Case esriGeometryPolygon write_poly pShape Case esriGeometryEnvelope Case esriGeometryPath Case esriGeometryAny Case esriGeometryRing Case esriGeometryLine write_polyline pShape Case esriGeometryCircularArc Case esriGeometryBezier3Curve Case esriGeometryEllipticArc 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 And pFL.Visible = True Then g_sCurrent = pComLayer.layer(j).Name ''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 pShape Case esriGeometryMultipoint write_points pShape Case esriGeometryPolyline write_polyline pShape Case esriGeometryPolygon write_poly pShape Case esriGeometryEnvelope Case esriGeometryPath Case esriGeometryAny Case esriGeometryRing Case esriGeometryLine write_polyline pShape Case esriGeometryCircularArc Case esriGeometryBezier3Curve Case esriGeometryEllipticArc End Select End If Set pFeat = pFCursor.NextFeature ''//////////////////////////////////////////////// Wend End If End If Next j End If End If pStepProgressor.Position = i pStepProgressor.Message = "正在生成DXF文件" ''pStepProgressor.Step Next i pStepProgressor.Hide Print #1, 0 Print #1, "ENDSEC" Print #1, 0 Print #1, "EOF" Exit Sub ''errhandle: ''MsgBox "写实体出错: " ; Err.Description
End Sub
Public 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
Public 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
Public Sub write_polyline(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, g_sCurrent 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, g_sCurrent 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, g_sCurrent 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, g_sCurrent 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, g_sCurrent End If Dim pCA As ICircularArc Set pCA = pSeg Print #1, CStr(0) Print #1, "ARC" Print #1, CStr(8) Print #1, g_sCurrent 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 ''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
 Public 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, g_sCurrent 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, g_sCurrent 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, g_sCurrent Exit Sub errhandle: MsgBox "Write_Polyline: " ; Err.Description
End Sub
Public Sub write_poly(pShape As IGeometry) On Error GoTo errhandle: Dim pPoly As IPolygon, lLoop As Long, lExtCount As Long, pExtRings() As IRing Dim pIntRings() As IRing, lLoop2 As Long, lIntCount As Long Set pPoly = pShape lExtCount = pPoly.ExteriorRingCount 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_polyline 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_polyline pIntRings(lLoop2) Next lLoop2 End If Next lLoop Exit Sub errhandle: MsgBox "Write_Poly: " ; Err.Description
End Sub
Public 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 x1 As Double, x2 As Double, y1 As Double, y2 As Double Dim pElem As IElement Set pElem = pAnno.Annotation Dim pTextEl As ITextElement ''处理地类注记中间的短线,如果短线是分开单独放置的,忽略它,不输出到DXF文件中. If TypeOf pElem Is ITextElement Then Set pTextEl = pElem Else Exit Sub End If ''如果地类注记中的短线和分子分母为一个整体,怎么处理?转换为"分子/分母"方式输出? ''Dim position As Integer ''position = InStr(1, pTextEl.Text, Chr(13), vbTextCompare) ''Dim bh As String ''bh = LTrim(pTextEl.Text, position - 1) ''MsgBox pTextEl.Text 
Dim pGeom As IGeometry Set pGeom = pElem.Geometry ''Determine the size to use for the annotation in map units Dim dSize As Double, dRatio 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 dRatio = pAnnoClass.ReferenceScale / pMap.MapScale ''For some reason the size needs to be divided by 1.333 to come out correctly. ''Have not figured out the reason for this. dSize = pDisp.DisplayTransformation.FromPoints(pTextEl.Symbol.Size) / 1.333 pMap.MapScale = pCurrentScale 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 '' point1.X = pEnv.XMin '' point1.Y = pEnv.YMin '' point2.X = pEnv.XMax '' point2.Y = pEnv.YMax Set point1 = pEnv.LowerLeft Set point2 = pEnv.LowerRight Set pPoints = pMP pPoints.AddPoint point1 pPoints.AddPoint point2
''//////////////////////////////////////// Dim dAngle As Double, deltaX As Double, deltaY As Double deltaX = pPoints.Point(1).x - pPoints.Point(0).x deltaY = pPoints.Point(1).y - pPoints.Point(0).y If deltaX = 0 Then If pPoints.Point(0).y > pPoints.Point(1).y Then dAngle = 270# Else dAngle = 90# End If Else dAngle = Atn(deltaY / deltaX) dAngle = dAngle * 180 / 3.14159 End If ''Debug.Print deltaX ; " - " ; dAngle Print #1, CStr(0) Print #1, "TEXT" Print #1, CStr(8) Print #1, g_sCurrent Print #1, CStr(1) Print #1, pTextEl.Text Print #1, 72 Print #1, CStr(0) Print #1, 73 Print #1, CStr(0) Print #1, 50 If deltaY > 0 Then Print #1, CStr(Abs(dAngle)) Else Print #1, CStr(dAngle) End If Print #1, 40 Print #1, CStr(dSize) '' TOD 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
Public Sub write_point(pShape As IGeometry) On Error GoTo errhandle:
Dim pPoint As IPoint Set pPoint = pShape Print #1, CStr(0) Print #1, "POINT" Print #1, CStr(8) Print #1, g_sCurrent 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
Public Sub write_points(pShape As IGeometry) On Error GoTo errhandle:
Dim pPoints As IPointCollection Set pPoints = pShape Dim i As Long For i = 0 To pPoints.PointCount - 1 Print #1, CStr(0) Print #1, "POINT" Print #1, CStr(8) Print #1, g_sCurrent 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) Next i Exit Sub errhandle: MsgBox "Write_Points: " ; Err.Description
End Sub

喜欢0 评分0

举报回复

zaozao1105 路人甲注册日期2004-03-24 发帖数15 QQ 铜币174枚威望0点贡献值0点银元0个加关注写私信	1楼^# 发布于：2006-11-12 14:58 <P>在制作dll时应该注意些什么啊?哪个GG做过给点建议呢?</P>
	举报回复(0) 喜欢(0) 评分

发帖回复

« 返回列表

您需要登录后才可以回帖，登录或者注册

返回顶部

在ARCGIS加载后提示No new objects added.

最新喜欢：