[求助]怎样用vb在arcmap里根据坐标生成polygon

楼主^#

更多发布于：2008-10-11 10:07

下面是我在vba里读取cad数据在arcmap里生成图形的代码，我想将他转换到vb里该怎么弄呀？ 求高手指点！谢谢

Dim pWorkspaceFactory As IWorkspaceFactory Dim pFeatureWorkspace As IFeatureWorkspace Dim pfeaturelayer As IFeatureLayer Dim pMxDocument As IMxDocument Dim pmap As IMap Dim plin As IPolyline Dim ppolygon As IPolygon Dim pPointCollection As IPointCollection Dim ppoint As IPoint Dim sDir As String Dim pFeatureTarget As IFeature Dim pFeatureClassTarget As IFeatureClass Dim acadApp As AcadApplication ' AutoCAD应用程序对象 Dim acadDoc As AcadDocument 'Dim pfeaturelayer As IFeatureLayer 'Dim pmxdocument As IMxDocument ' Dim pmap As IMap Sub hh() ' Dim acadApp As AcadApplication ' AutoCAD应用程序对象 ' Dim acadDoc As AcadDocument Dim cn As New ADODB.Connection Dim rst As New ADODB.RecordSet Dim gdp As New ADODB.RecordSet Dim gdv3 As New ADODB.RecordSet Dim cadtc As String '图层变量 Dim tcsz() As Variant '图层数组 Dim xh As Integer Dim sfilepath As String, sfilename As String Dim pfields As IFields Dim pfield As IField Dim shpname As String, nr As String Dim js As Integer Dim zdh As String, syz As String, jfh As String, fjqh As String, tdzl As String '宗地号、使用者、
街坊号、土地坐落 'Dim ftype(0 To 1) As Integer ' Dim fdata(0 To 1) As Variant Dim ftype(0) As Integer Dim fdata(0) As Variant Set acadApp = GetObject(, "AutoCAD.Application.16") If Err Then MsgBox "AUTOCAD图形软件未打开！" End End If Dim entry As AcadLayer
 If Err Then Err.Clear ' 创建一个新的AutoCAD应用程序对象 Set acadApp = CreateObject("AutoCAD.Application.16") If Err Then MsgBox Err.Description Exit Sub End If End If On Error GoTo ErrorHandler: ' 显示AutoCAD应用程序 acadApp.Visible = True Set acadDoc = acadApp.ActiveDocument acadDoc.SendCommand "zoom" ; vbCr ; "e" ; vbCr acadDoc.SendCommand "-purge" ; vbCr ; "a" ; vbCr ; "" ; vbCr ; "n" ; vbCr '清楚多余的图层 '下面进行图层循环加载不同的空表 p = 0 For Each entry In acadDoc.Layers If entry.Name <> "0" Then cadtc = entry.Name shpname = jztc(cadtc) ' End If If shpname <> "" Then ' ftype(0) = 0: fdata(0) = "LWPOLYLINE" ftype(0) = 8: fdata(0) = cadtc ' ftype(1) = 8: fdata(1) = cadtc On Error Resume Next Dim xzj As AcadSelectionSet Dim zb As Variant If Not IsNull(acadDoc.SelectionSets.Item("st")) Then Set xzj = acadDoc.SelectionSets.Item("st") xzj.Delete End If Set xzj = acadDoc.SelectionSets.Add("st") '新建选择集 'MsgBox xzj.Name xzj.Select acSelectionSetAll, , , ftype, fdata '选择宗地 js = 1 For Each ty In xzj If Right(cadtc, 1) = "屋" Then If ty.Closed = True Then If ty.Area > 0 Then dds = (UBound(ty.Coordinates) + 1) / 2 zb = ty.Coordinates scfw zb, dds, js, cadtc End If End If Else a = ty.ObjectName ' MsgBox ty.ObjectName If ty.ObjectName = "AcDbText" Then zb = ty.InsertionPoint nr = ty.TextString zj zb, cadtc, nr Else dds = (UBound(ty.Coordinates) + 1) / 2 zb = ty.Coordinates xzdw zb, dds, js, cadtc End If End If js = js + 1 Next ' For Each ty In xzj End If '' If shpname <> "" Then p = p + 1 End If 'If entry.Name <> "0" Then Next ' For Each entry In acadDoc.Layers
 '//结束编辑 ' pWorkspaceEdit.StopEditOperation ' pWorkspaceEdit.StopEditing True Exit Sub ErrorHandler: MsgBox Err.Description End Sub
 Function zbtq(pid, cn, zdh, syz, zdmj, jj, h, tdzl) As Variant '生成宗地 'On Error Resume Next 'Dim pfeaturelayer As IFeatureLayer ' Dim pmxdocument As IMxDocument ' Dim pmap As IMap Dim jdh As String, jfh As String, djh As String Dim xh As Integer xh = h + 1 jdh = Left(jj, 3) jfh = Right(jj, 3) djh = "320506" + Trim(jj) + Trim(zdh) Set pfeaturelayer = New FeatureLayer Set pMxDocument = Application.Document Set pmap = pMxDocument.FocusMap Set pfeaturelayer = pmap.Layer(0) Dim pFeatureClassTarget As IFeatureClass Dim pfclass As IFeature Dim pFeatureTarget As IFeature Set pFeatureClassTarget = pfeaturelayer.FeatureClass Set pFeatureTarget = pFeatureClassTarget.CreateFeature Dim zb() As Double Dim gdv3 As New ADODB.RecordSet Dim gdpv As New ADODB.RecordSet Dim ppoint As IPoint Set ppoint = New Point Dim ppolygon As IPolygon Dim pPointCollection As IPointCollection Set pPointCollection = New Polygon Dim sm As Integer Set pfields = pFeatureClassTarget.Fields ' k = pfields.FindField("code") pFeatureTarget.Value(2) = Str(xh) pFeatureTarget.Value(3) = "DJL507" pFeatureTarget.Value(4) = "2006010100" pFeatureTarget.Value(5) = "320506" pFeatureTarget.Value(6) = jdh pFeatureTarget.Value(7) = jfh pFeatureTarget.Value(8) = zdh pFeatureTarget.Value(9) = djh pFeatureTarget.Value(12) = zdmj pFeatureTarget.Value(15) = tdzl pFeatureTarget.Value(16) = "国有" gdv3.Open "select sm=count(vid) from gdv3 where vid in (select pvid from gdpv where pid= " ; pid ; " 
)", cn, adOpenDynamic, adLockPessimistic If Not gdv3.EOF Then sm = gdv3.Fields("sm") End If gdv3.Close ReDim zb(2 * sm - 1) i = 0 gdpv.Open "select * from gdpv where pid=" ; pid ; " order by pvo asc", cn, adOpenDynamic, 
adLockBatchOptimistic Do While Not gdpv.EOF gdv3.Open "select * from gdv3 where vid = " ; gdpv.Fields("pvid") ; " ", cn, adOpenDynamic, 
adLockPessimistic If Not gdv3.EOF Then X = gdv3.Fields("y") zb(i * 2) = gdv3.Fields("y") zb(i * 2 + 1) = gdv3.Fields("x") i = i + 1 End If gdpv.MoveNext gdv3.Close Loop gdpv.Close For i = 0 To sm - 1 ' Set pPointCollection = New polygon ppoint.PutCoords zb(2 * i), zb(2 * i + 1) pPointCollection.AddPoint ppoint Next Set ppolygon = pPointCollection ppolygon.Close ' Set pFeatureTarget.shape = pPointCollection Set pFeatureTarget.Shape = ppolygon ' Set pFeatureTarget.Shape = pPointCollection pFeatureTarget.Store zbtq = zb End Function 'Private Sub jztc(tc) '根据cad图层信息加载相应shape文件 Function jztc(tc) As String Dim sfilepath As String, shpname As String sfilepath = "d:\sy" Select Case tc Case "一般房屋" shpname = "dlgkb01a" Case "简单房屋" shpname = "dlgkb01a" Case "围墙" shpname = "dlgkb01l" Case "栏杆" shpname = "dlgkb01l" Case "活树篱笆" shpname = "dlgkb01l" Case "铁丝网" shpname = "dlgkb01l" 'Case "界址线" 'shpname = "djlkc14a" Case "内部道路" shpname = "dlgkd01l" Case "标注" shpname = "dlgkb03p" Case "居民地注记" shpname = "dlgkb03p" Case "交通及附属设施注记" shpname = "dlgkd03p" End Select
If shpname <> "" Then 'If shpname = "dlgkb01a" Then Set pWorkspaceFactory = New ShapefileWorkspaceFactory Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sfilepath, 0) Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(shpname) pfeaturelayer.Name = pfeaturelayer.FeatureClass.AliasName 'Add the FeatureLayer to the focus map Set pMxDocument = Application.Document Set pmap = pMxDocument.FocusMap pmap.AddLayer pfeaturelayer '打开图层 End If jztc = shpname End Function Private Sub scfw(zb, sm, xh, tc) '生成房屋等面状地物 Dim dldm As String Select Case tc Case "一般房屋" dldm = "211100" Case "简单房屋" dldm = "212000" Case "建筑中房屋" dldm = "213000" Case "破坏房屋" dldm = "214100" Case "棚房" dldm = 215100 End Select 'Dim zbz() As Double 'ReDim zbz(2 * sm - 1) As Double 'For j = 0 To sm * 2 - 1 'zbz(j) = zb(j) 'Next j 'Dim na As String Set pfeaturelayer = pmap.Layer(0) ' Dim pFeatureClassTarget As IFeatureClass ' Dim pfclass As IFeature 'Dim pFeatureTarget As IFeature Set pFeatureClassTarget = pfeaturelayer.FeatureClass Set pFeatureTarget = pFeatureClassTarget.CreateFeature ' Set pfield = pFeatureClassTarget.Fields ' s = pfield.Field("cord") pFeatureTarget.Value(2) = Str(xh) pFeatureTarget.Value(3) = dldm 'pFeatureTarget.Value(3) = "243100" ' Dim ppoint As IPoint Set ppoint = New Point ' Dim ppolygon As IPolygon ' Dim pPointCollection As IPointCollection Set pPointCollection = New Polygon For i = 0 To sm - 1 ' Set pPointCollection = New Polygon ppoint.PutCoords zb(2 * i), zb(2 * i + 1) pPointCollection.AddPoint ppoint Next Set ppolygon = pPointCollection ppolygon.Close ' Set pFeatureTarget.shape = pPointCollection Set pFeatureTarget.Shape = ppolygon ' Set pFeatureTarget.Shape = pPointCollection pFeatureTarget.Store
End Sub Private Sub xzdw(zb, sm, xh, tc) '生成围墙、栏杆、道路等线状地物 Dim dldm As String
Select Case tc Case "围墙" dldm = "243100" Case "栏杆" dldm = "245100" Case "等外公路" dldm = "433000" Case "内部道路" dldm = "444000" End Select Set pfeaturelayer = pmap.Layer(0) Set pFeatureClassTarget = pfeaturelayer.FeatureClass Set pFeatureTarget = pFeatureClassTarget.CreateFeature pFeatureTarget.Value(2) = Str(xh) pFeatureTarget.Value(3) = dldm Set ppoint = New Point Set pPointCollection = New Polyline For i = 0 To sm - 1 ' Set pPointCollection = New Polygon ppoint.PutCoords zb(2 * i), zb(2 * i + 1) pPointCollection.AddPoint ppoint Next ' Set ppolygon = pPointCollection ' ppolygon.Close ' Set pFeatureTarget.shape = pPointCollection Set pFeatureTarget.Shape = pPointCollection ' Set pFeatureTarget.Shape = pPointCollection pFeatureTarget.Store End Sub Private Sub zj(zb, tc, nr) '生成各种注记 Dim zjnr As String Dim dldm As String Select Case tc Case "居民地注记" dldm = "200000" Case "工矿建(构)筑物及其它设施注记" dldm = "300000" Case "交通及附属设施注记" dldm = "400000" Case "管线及附属设施注记" dldm = "500000" Case "水系及附属设施注记" dldm = "600000" Case "地貌和土质注记“" dldm = "800000" Case "境界注记" dldm = "700000" Case "植被注记" dldm = "900000" End Select
 Set pfeaturelayer = pmap.Layer(0) Set pFeatureClassTarget = pfeaturelayer.FeatureClass Set pFeatureTarget = pFeatureClassTarget.CreateFeature pFeatureTarget.Value(3) = dldm pFeatureTarget.Value(4) = nr Set ppoint = New Point ppoint.PutCoords zb(0), zb(1) Set pFeatureTarget.Shape = ppoint pFeatureTarget.Store ' pGraphicsContainer.AddElement pTextElement, 0 '向Map中添加元素 End Sub

喜欢0 评分0

举报回复

wheroy

路人甲

注册日期2004-09-04
发帖数159
QQ
铜币251枚
威望0点
贡献值0点
银元0个

加关注写私信

1楼^#

发布于：2008-10-12 19:16

要根据你最后的运行环境，如果是仍然是在ArcMap 环境下运行，就要做一个Command ，将VBA 代码直接拷贝到click 事件响应函数中调用，在Create 函数中获取Application ，和mxDocumanet ，然后编译成dll 。再启动Arcmap ，customize ，加入你的command ，即可。
 如果在Engine 环境下运行，就要将其中 Dim pMxDocument As IMxDocument，去掉，直接用 Imap 即可，其余代码基本不变。

举报回复喜欢评分

laoxie_1983 路人甲注册日期2006-04-20 发帖数11 QQ 铜币151枚威望0点贡献值0点银元0个加关注写私信	2楼^# 发布于：2008-10-16 19:02 谢谢！指点！已经弄好了！
	举报回复(0) 喜欢(0) 评分

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

[求助]怎样用vb在arcmap里根据坐标生成polygon

最新喜欢：