Komplex példa - Log in
Pontok felrakása
Option Explicit Private Sub CancelButton_Click() Unload Me End Sub Private Sub lista() ' aktuális könyvtár tartalmának betöltése a listába Dim file_nev As String Dim i As Long Dim fs As Object Dim d, dc FileList.Clear ' lista törlése ' meghajtók betűjelei Set fs = CreateObject("scripting.filesystemobject") Set dc = fs.drives For Each d In dc On Error Resume Next FileList.AddItem d.Path & " (" & d.VolumeName & ")" If Err.Number <> 0 Then Err.Clear End If Next ' filenevek és könyvtárnevek file_nev = Dir("*", vbDirectory) Do While file_nev <> "" If file_nev <> "." Then FileList.AddItem file_nev End If file_nev = Dir() Loop FileList.ListIndex = 0 End Sub Private Sub FileList_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next ChDrive FileList.Value If Err.Number <> 0 Then ChDir FileList.Value If Err.Number <> 0 Then OKButton_Click End If End If FileName.Value = "" lista Exit Sub hiba: End Sub Private Sub FileName_Change() Dim i As Integer Dim w As String, w1 As String w1 = FileName.Value w = UCase$(FileName.Value) If Len(w) > 0 Then For i = 0 To FileList.ListCount - 1 If InStr(1, UCase$(FileList.List(i)), w) = 1 Then FileList.ListIndex = i FileName.Value = w1 Exit Sub End If Next FileList.ListIndex = -1 Beep Else FileList.ListIndex = 0 End If End Sub Private Sub OKButton_Click() If Mid$(FileList.Value, 2, 1) = ":" Then ' kiserlet az egység váltásra On Error Resume Next ChDrive Left$(FileList.Value, 1) If Err.Number = 0 Then On Error GoTo 0 ' meghajtó váltás sikeres, fájl lista feltöltése Call lista Exit Sub End If End If On Error Resume Next ' kisérlet a könyvtárváltásra ChDir FileList.Value If Err.Number = 0 Then On Error GoTo 0 ' könyvtárváltás sikeres, fájl lista feltöltése Call lista Exit Sub Else Err.Clear On Error GoTo 0 ' nem könyvtár töltsük be a fájlt felrak FileList.Value Unload Me End If End Sub Private Sub UserForm_Initialize() Call lista End Sub Private Sub felrak(ByVal fn As String) ' pontok bevitetele az aktuális rétegbe Dim f As Integer Dim x As Double Dim y As Double Dim id As String Dim pDoc As IMxDocument Set pDoc = ThisDocument Dim aLayer As ILayer ' szelektált réteg beszerzése Set aLayer = pDoc.SelectedLayer If aLayer Is Nothing Then MsgBox "nincs aktív réteg" Exit Sub End If If Not TypeOf aLayer Is IFeatureLayer Then MsgBox "Az aktív réteg nem megfelelő" Exit Sub End If Dim pLayer As IFeatureLayer Set pLayer = aLayer Dim fClass As IFeatureClass Set fClass = pLayer.FeatureClass If Not fClass.ShapeType = esriGeometryPoint Then MsgBox "aktív réteg nem pont réteg" Exit Sub End If Dim pTable As ITable ' aktiv réteghez tartozó attribútum táblázat Set pTable = pLayer Dim pID As New UID Dim pEditLayers As IEditLayers Dim pEditor As IEditor ' szerkesztés kezdése pID = "esriEditor.Editor" Set pEditor = Application.FindExtensionByCLSID(pID) Dim pWorkspace As IWorkspace Dim pDataSet As IDataset Set pDataSet = fClass Set pWorkspace = pDataSet.Workspace pEditor.StartEditing pWorkspace pEditor.StartOperation Set pEditLayers = pEditor pEditLayers.SetCurrentLayer pLayer, 0 Dim pFeature As IFeature Dim aPoint As IPoint Dim pRow As IRow ' fájl megnyitása f = FreeFile Open fn For Input As #f ' fájl olvasása soronként Do While Not EOF(f) On Error GoTo hiba Input #f, id, x, y Set pFeature = pEditLayers.CurrentLayer.FeatureClass.CreateFeature Set aPoint = New Point aPoint.PutCoords x, y Set pFeature.Shape = aPoint pFeature.Store Set pRow = pTable.GetRow(pFeature.OID) pRow.Value(pTable.FindField("ID")) = id pRow.Store Loop lezar: pEditor.StopOperation "x" pEditor.StopEditing True pDoc.ActiveView.Refresh Close f Exit Sub hiba: MsgBox "Hiba a fájl olvasása közben" Resume lezar End Sub
Last modified: Thursday, 9 March 2017, 7:30 PM