ESRI_AO_将测绘仪器测点数据生成Shape文件

<P> ESRI_AO_将测绘仪器测点数据生成Shape文件</P>
<P><a href="http://www1.tianyablog.com/blogger/post_show.asp?idWriter=0;Key=0;BlogID=275445;PostID=4686825" target="_blank" >http://www1.tianyablog.com/blogger/post_show.asp?idWriter=0;Key=0;BlogID=275445;PostID=4686825</A></P>

这个程序是在ArcMap的VBA环境中做的，仔细一看还写了不少代码．还有两个辅助模块：FilePathName用于对文件名进行处理，BrowseForFile用于弹出打开文件对话框（避免使用控件以及使用控件造成的位置随机的问题）．<BR>　　<BR>　　本帖为主程序，位于ThisDocument<BR>　　<BR>　　Option Explicit<BR>　　<BR>　　Const ForReading = 1<BR>　　<BR>　　Private Function SurveyPoint_Checked() As Boolean<BR>　　 <BR>　　End Function<BR>　　<BR>　　Private Sub SurveyPoint_Click()<BR>　　 <BR>　　 Dim fn As String<BR>　　 <BR>　　 Dim fso As Variant<BR>　　 Dim f As Variant<BR>　　 Dim fread As String<BR>　　 <BR>　　 Set fso = CreateObject("Scripting.FileSystemObject")<BR>　　<BR>　　 Dim m_ofn As OPENFILENAME<BR>　　 With m_ofn<BR>　　 .hwndOwner = Application.hwnd<BR>　　 .lStructSize = Len(m_ofn)<BR>　　 .lpstrFilter = "测点数据文件(*.dat)" + Chr$(0) + "*.dat"<BR>　　 .lpstrFile = Space(249) + "*.dat"<BR>　　 .nMaxFile = 255<BR>　　 .nMaxFileTitle = 255<BR>　　<BR>　　 'OFN_ENABLEHOOK 要使用勾子, 这个必须<BR>　　 .flags = OFN_EXPLORER Or OFN_ENABLEHOOK ' Or Or OFN_ENABLETEMPLATE Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS Or OFN_ENABLEHOOK<BR>　　 .lpfnHook = GetProcAddress(AddressOf OpenSaveHookProc)<BR>　　 End With<BR>　　 <BR>　　 If GetOpenFileName(m_ofn) Then<BR>　　 <BR>　　 fn = m_ofn.lpstrFile<BR>　　 If Not fso.FileExists(fn) Then<BR>　　 MsgBox "您要打开的文件不存在!"<BR>　　 Set fso = Nothing<BR>　　 Exit Sub<BR>　　 End If<BR>　　 <BR>　　 Set f = fso.OpenTextFile(fn, ForReading)<BR>　　 <BR>　　 Dim po As New ParseObject<BR>　　 Dim cValues As Collection<BR>　　 Dim cc As Integer<BR>　　 Dim pName As String, x As Double, y As Double, z As Double<BR>　　 Dim id_pname As Integer, id_x As Integer, id_y As Integer, id_z As Integer<BR>　　 <BR>　　 ' Get temp filename for output<BR>　　 Dim tempfn As String<BR>　　 Dim temppath As String<BR>　　 tempfn = GetTempFile("shp")<BR>　　 <BR>　　 ' Create temp file for no use but ID<BR>　　 Dim tempfile As Variant<BR>　　 Set tempfile = fso.CreateTextFile(tempfn, True)<BR>　　 tempfile.Close<BR>　　 <BR>　　 temppath = GetPathName(tempfn, 0)<BR>　　 tempfn = GetPathName(tempfn, 1)<BR>　　 tempfn = GetMainFileName(tempfn)<BR>　　 <BR>　　 Dim pFeatureClass As IFeatureClass<BR>　　 Set pFeatureClass = CreateShapefile(temppath, tempfn)<BR>　　 <BR>　　 Dim pGeometry As IGeometry<BR>　　 Dim pFeatureCursor As IFeatureCursor<BR>　　 Dim pFeatureBuffer As IFeatureBuffer<BR>　　 Set pFeatureCursor = pFeatureClass.Insert(True)<BR>　　 Set pFeatureBuffer = pFeatureClass.CreateFeatureBuffer<BR>　　 <BR>　　 Do While Not f.atEndOfStream<BR>　　 ' Get values from txt file<BR>　　 fread = f.readline<BR>　　 Set cValues = po.ParseString(fread, ",")<BR>　　 cc = cValues.Count<BR>　　 pName = cValues(1)<BR>　　 x = cValues(cc - 2): y = cValues(cc - 1): z = cValues(cc)<BR>　　 <BR>　　 ' Create point<BR>　　 Dim pZAware As IZAware<BR>　　 Dim pPoint As IPoint<BR>　　 <BR>　　 Set pPoint = New Point<BR>　　 <BR>　　 Set pZAware = pPoint<BR>　　 pZAware.ZAware = True<BR>　　<BR>　　 pPoint.x = x: pPoint.y = y: pPoint.z = z<BR>　　 <BR>　　 Set pGeometry = pPoint<BR>　　 <BR>　　 ' Get index of the field<BR>　　 id_pname = pFeatureClass.FindField("PNAME")<BR>　　 id_x = pFeatureClass.FindField("X")<BR>　　 id_y = pFeatureClass.FindField("Y")<BR>　　 id_z = pFeatureClass.FindField("Z")<BR>　　 <BR>　　 ' Set field value<BR>　　 pFeatureBuffer.Value(id_pname) = pName<BR>　　 pFeatureBuffer.Value(id_x) = x<BR>　　 pFeatureBuffer.Value(id_y) = y<BR>　　 pFeatureBuffer.Value(id_z) = z<BR>　　 <BR>　　 Set pFeatureBuffer.Shape = pGeometry<BR>　　 <BR>　　 pFeatureCursor.InsertFeature pFeatureBuffer<BR>　　 <BR>　　 Loop<BR>　　 <BR>　　 ' Adds the FC to the focus map<BR>　　 fn = GetPathName(fn, 1)<BR>　　 fn = GetMainFileName(fn)<BR>　　 <BR>　　 Dim pMxDocument As IMxDocument<BR>　　 Dim pMap As IMap<BR>　　 Dim pFeatureLayer As IFeatureLayer<BR>　　<BR>　　 'Create a new FeatureLayer and assign the FC to it<BR>　　 Set pFeatureLayer = New FeatureLayer<BR>　　 <BR>　　 Set pFeatureLayer.FeatureClass = pFeatureClass<BR>　　 pFeatureLayer.Name = fn<BR>　　 'Add the FeatureLayer to the focus map<BR>　　 Set pMxDocument = Application.Document<BR>　　 Set pMap = pMxDocument.FocusMap<BR>　　 pMap.AddLayer pFeatureLayer<BR>　　 <BR>　　 ' Force an update of the TOC<BR>　　 pMxDocument.UpdateContents<BR>　　 <BR>　　 ' Zoom the display to the full extent of all layers in the map<BR>　　 Dim pActiveView As IActiveView<BR>　　 Set pActiveView = pMxDocument.FocusMap<BR>　　 <BR>　　 Dim pGeodataSet As IGeoDataset<BR>　　 Set pGeodataSet = pFeatureClass<BR>　　 <BR>　　 pActiveView.Extent = pGeodataSet.Extent<BR>　　 pActiveView.PartialRefresh esriViewGeography, Nothing, Nothing<BR>　　 End If<BR>　　 <BR>　　 Set fso = Nothing<BR>　　End Sub<BR>　　<BR>　　Private Function SurveyPoint_Enabled() As Boolean<BR>　　 SurveyPoint_Enabled = True<BR>　　End Function<BR>　　<BR>　　Private Function SurveyPoint_Message() As String<BR>　　 SurveyPoint_Message = "将测绘仪器测点数据导入为点特征"<BR>　　End Function<BR>　　<BR>　　Private Function SurveyPoint_ToolTip() As String<BR>　　 SurveyPoint_ToolTip = "导入测点数据"<BR>　　End Function<BR>　　<BR>　　<BR>　　Private Function CreateShapefile(sPath As String, sName As String) As IFeatureClass ' Dont include .shp extension<BR>　　 <BR>　　 ' Open the folder to contain the shapefile as a workspace<BR>　　 Dim pFWS As IFeatureWorkspace<BR>　　 Dim pWorkspaceFactory As IWorkspaceFactory<BR>　　 Set pWorkspaceFactory = New ShapefileWorkspaceFactory<BR>　　 Set pFWS = pWorkspaceFactory.OpenFromFile(sPath, 0)<BR>　　 <BR>　　 ' Set up a simple fields collection<BR>　　 Dim pFields As IFields<BR>　　 Dim pFieldsEdit As IFieldsEdit<BR>　　 Set pFields = New Fields<BR>　　 Set pFieldsEdit = pFields<BR>　　 <BR>　　 Dim pField As IField<BR>　　 Dim pFieldEdit As IFieldEdit<BR>　　 <BR>　　 ' Make the shape field<BR>　　 ' it will need a geometry definition, with a spatial reference<BR>　　 Set pField = New Field<BR>　　 Set pFieldEdit = pField<BR>　　 pFieldEdit.Name = "Shape"<BR>　　 pFieldEdit.Type = esriFieldTypeGeometry<BR>　　 <BR>　　 Dim pGeomDef As IGeometryDef<BR>　　 Dim pGeomDefEdit As IGeometryDefEdit<BR>　　 Set pGeomDef = New GeometryDef<BR>　　 Set pGeomDefEdit = pGeomDef<BR>　　 With pGeomDefEdit<BR>　　 .GeometryType = esriGeometryPoint<BR>　　 .HasZ = True<BR>　　 Set .SpatialReference = New UnknownCoordinateSystem<BR>　　 End With<BR>　　 Set pFieldEdit.GeometryDef = pGeomDef<BR>　　 pFieldsEdit.AddField pField<BR>　　<BR>　　 ' Add PNAME text field<BR>　　 Set pField = New Field<BR>　　 Set pFieldEdit = pField<BR>　　 With pFieldEdit<BR>　　 .Length = 20<BR>　　 .Name = "PNAME"<BR>　　 .Type = esriFieldTypeString<BR>　　 End With<BR>　　 pFieldsEdit.AddField pField<BR>　　 <BR>　　 ' Add X double field<BR>　　 Set pField = New Field<BR>

Set pFieldEdit = pField<BR>　　 With pFieldEdit<BR>　　 .Length = 20<BR>　　 .Name = "X"<BR>　　 .Type = esriFieldTypeDouble<BR>　　 End With<BR>　　 pFieldsEdit.AddField pField<BR>　　 <BR>　　 Set pField = New Field<BR>　　 Set pFieldEdit = pField<BR>　　 With pFieldEdit<BR>　　 .Length = 20<BR>　　 .Name = "Y"<BR>　　 .Type = esriFieldTypeDouble<BR>　　 End With<BR>　　 pFieldsEdit.AddField pField<BR>　　 <BR>　　 Set pField = New Field<BR>　　 Set pFieldEdit = pField<BR>　　 With pFieldEdit<BR>　　 .Length = 20<BR>　　 .Name = "Z"<BR>　　 .Type = esriFieldTypeDouble<BR>　　 End With<BR>　　 pFieldsEdit.AddField pField<BR>　　 <BR>　　 ' Create the shapefile<BR>　　 ' (some parameters apply to geodatabase options and can be defaulted as Nothing)<BR>　　 Dim pFeatClass As IFeatureClass<BR>　　 Set pFeatClass = pFWS.CreateFeatureClass(sName, pFields, Nothing, _<BR>　　 Nothing, esriFTSimple, "Shape", "")<BR>　　 <BR>　　 Set CreateShapefile = pFeatClass<BR>　　End Function </BLOGGER><BLOGGER>

希望对GPS的朋友有帮助

<a href="http://www.gisempire.com/blog/user1/38/409.html" target="_blank" >http://www.gisempire.com/blog/user1/38/409.html</A>