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