Выбор точек внутри-снаружи полигона

Форум » Программистские штучки » Выбор точек внутри-снаружи полигона » Ответить

Выбор точек внутри-снаружи полигона

HappyNewYear: Задача. Имеется набор точек (в моём случае это были скважины), надо выбрать те из них, которые находятся внутри некоторого полигона. В данном случае мною было решено, что координаты скважин я буду вводить непосредственно на лист Excel, а координаты узлов полигона получать из внешнего файла(в формате cps-3 lines или bln). Вот, собственно пользовательский интерфейс:

Ответов - 2

HappyNewYear: А это код основной программы [pre2] Global flg As Byte Option Explicit Sub pp() Change.Show End Sub Sub ggg(inside) Dim vnutr As Boolean Dim iii As Integer Dim nnn As Integer Dim mmm As Integer Dim ddr As Boolean Dim poly() As Double Dim index_poly() As Integer Dim ttt As Integer Dim nm As String Dim flg_bol() As Boolean Close Workbooks("poly.xls").Activate Application.ScreenUpdating = False Range("i3:m" + Format(Application.Rows.Count)).ClearContents Call get_poly(poly, index_poly) Range("a3").Select ttt = 0 Do While ActiveCell.Offset(ttt, 0) <> "" ttt = ttt + 1 Loop ttt = ttt - 1 'On Error GoTo boom ReDim flg_bol(UBound(index_poly)) For iii = 0 To ttt vnutr = False For nnn = 1 To UBound(index_poly) If flg_bol(nnn) = False Then flg = 0 Call Vnutr_li_point(poly, index_poly, nnn, iii, vnutr) If flg = 2 Then flg_bol(nnn) = True End If Next nnn If vnutr = inside Then ActiveCell.Offset(iii, 0).Range("A1:E1").Copy ActiveCell.Offset(mmm, 8).Select ActiveSheet.Paste mmm = mmm + 1 Range("a3").Select End If Next iii boom: Application.ScreenUpdating = True End Sub Sub get_poly(ByRef poly, ByRef index_poly) Dim str As String Dim kol_str As Integer On Error GoTo 1 If Range("g2") <> "" Then Open Range("g2") For Input As 1 Line Input #1, str If Left(str, 6) = "FFASCI" Then Call get_cps(poly, index_poly) ElseIf Asc(Left(str, 1)) > 47 And Asc(Left(str, 1)) < 58 Then kol_str = Val(str) Call get_bln(kol_str, poly, index_poly) Else: GoTo 1 End If Close Else: Close 1 MsgBox ("Требуется получить корректный адрес полигона") End If End Sub Sub get_cps(ByRef poly, ByRef index_poly) Dim str As String Dim colstr As Integer Dim spase1 As Byte Dim spase2 As Byte Dim ind_ind As Byte ReDim index_poly(100) ReDim poly(1, 10000) colstr = -1 ind_ind = 0 index_poly(ind_ind) = -1 Line Input #1, str Line Input #1, str Do 'цикл чтения строк до конца полигона или конца файла Line Input #1, str spase1 = InStr(str, " ") 'Поиск первого пробела If spase1 > 0 Then spase2 = InStr(spase1 + 1, str, " ") 'Поиск второго пробела colstr = colstr + 1 poly(0, colstr) = Left(str, spase1 - 1) 'Чтение координаты X poly(1, colstr) = Mid(str, spase1 + 1, spase2 - spase1 - 1) 'Чтение координаты Y Else ind_ind = ind_ind + 1 index_poly(ind_ind) = colstr End If Loop Until EOF(1) ind_ind = ind_ind + 1 index_poly(ind_ind) = colstr ReDim Preserve index_poly(ind_ind) ReDim Preserve poly(1, colstr) End Sub Sub get_bln(kol_str, ByRef poly, ByRef index_poly) Dim chislZAP As Integer 'Число строк полигона Dim ZAP As Integer 'Число строк полигона Dim ind_ind As Byte Dim colstr As Integer ReDim index_poly(100) ReDim poly(1, 10000) index_poly(ind_ind) = -1 colstr = -1 chislZAP = kol_str Do For ZAP = 1 To chislZAP colstr = colstr + 1 Input #1, poly(0, colstr), poly(1, colstr) Next ZAP ind_ind = ind_ind + 1 index_poly(ind_ind) = colstr If EOF(1) = False Then Input #1, chislZAP Input #1, ZAP End If Loop Until EOF(1) ReDim Preserve index_poly(ind_ind) ReDim Preserve poly(1, colstr) End Sub Sub Vnutr_li_point(poly, index_poly, nnn, iii, ByRef vnutr) ' ' Проверка местонахождения точки на плоскости ' относительно многоугольника - внутри или снаружи ' - ' ВХОД: ' xyd() - массив координат углов многоугольника ' x = xyd(1,i), y = xyd(2,i) ; i = 1 to Np ' (Np-1) - количество узлов ' координаты 1-й точки = координатам N-й точки ' x0,y0 - координаты тестируемой точки ' ' ВЫХОД: положение тестируемой точки ' kz = 0 - вне ' = -100 - на границе ' = -4 - внутри (обход по часовой стрелке) ' = 4 - внутри (против часовой стрелки) '''''''''''''''''''''''''' Dim kz As Integer Dim k As Integer Dim x2 As Double Dim y2 As Double Dim kv2 As Integer Dim kv1 As Integer Dim kv As Integer Dim x1 As Double Dim y1 As Double Dim yb As Double If poly(0, index_poly(nnn - 1) + 1) <> poly(0, index_poly(nnn)) Or poly(0, index_poly(nnn - 1) + 1) <> poly(0, index_poly(nnn)) Then Cl_pol.Show If flg = 1 Then ReDim Preserve poly(1, UBound(poly, 2) + 1) x1 = poly(0, index_poly(nnn - 1) + 1) y1 = poly(1, index_poly(nnn - 1) + 1) For kz = UBound(poly, 2) To index_poly(nnn) + 1 Step -1 poly(0, kz) = poly(0, kz - 1) poly(1, kz) = poly(1, kz - 1) Next kz poly(0, index_poly(nnn) + 1) = x1 poly(1, index_poly(nnn) + 1) = y1 For kz = nnn To UBound(index_poly) index_poly(kz) = index_poly(kz) + 1 Next kz flg = 0 End If If flg = 0 Then kz = 0 For k = index_poly(nnn - 1) + 1 To index_poly(nnn) ' Np + 1 ' IF l > Np THEN k = 1 ELSE k = l x2 = poly(0, k) - ActiveCell.Offset(iii, 0): y2 = poly(1, k) - ActiveCell.Offset(iii, 1) ' ' проверка четверти плоскости kv2 = 0 If x2 >= 0 And y2 > 0 Then kv2 = 1 If x2 < 0 And y2 >= 0 Then kv2 = 2 If x2 <= 0 And y2 < 0 Then kv2 = 3 If x2 > 0 And y2 <= 0 Then kv2 = 4 If kv2 = 0 Then kz = -100: Exit For ' If k > index_poly(nnn - 1) + 1 Then ' проверка перехода If kv2 <> kv1 Then ' переход в другую четверть kv = kv2 - kv1 If kv = 3 Then kv = -1 If kv = -3 Then kv = 1 If kv = 2 Or kv = -2 Then ' переход через две четверти If x1 = x2 Then kz = -100: Exit For yb = (y2 * x1 - y1 * x2) / (x1 - x2) If yb = 0 Then kz = -100: Exit For kv = kv * Sgn(yb) If kv1 = 2 Or kv1 = 4 Then kv = -kv End If kz = kz + kv End If End If x1 = x2: y1 = y2: kv1 = kv2 Next If kz = 4 Or kz = -4 Or kz = -100 Then vnutr = True Else End If End Sub Sub get_adr() On Error Resume Next With Application.FileDialog(1) 'Если не ошибаюсь, то это "метод" для диалогового окна открытия файлов .Title = "Выбирите файл полигона" 'Заголовок окна .InitialFileName = "D:\мои документы\Temp\" 'Адрес по умолчанию .AllowMultiSelect = False 'Включена возможность выбора нескольких файлов .Filters.Clear 'Очистка фильтра по расширенью .Show Range("G2") = Trim(.SelectedItems.Item(1)) End With 'Конец метода End Sub [/pre2] При нажатии на кнопку "Выборка" на листе выводится диалоговое окно: с кодом Sub CommandButton2_Click() Call ggg(OptionButton1.Value) Change.Hide End Sub Sub CommandButton1_Click() Change.Hide End Sub Если вдруг, так невзначай, окажется, что полигон не замкнут, то появится другое диалоговое окно: код: Private Sub CommandButton1_Click() flg = 1 Cl_pol.Hide End Sub Private Sub CommandButton2_Click() flg = 2 Cl_pol.Hide End Sub

HappyNewYear: Попутно я решил побаловаться с какой-никакой визуализацией. Код кнопки "Очистить график" Sub clear_craf() Dim sz As Integer ActiveSheet.ChartObjects(1).Activate sz = ActiveChart.SeriesCollection.Count For i = sz To 1 Step -1 ActiveChart.SeriesCollection(i).Delete Next i End Sub код кнопки "Отобразить линии полигона" [pre2] Sub graf_poly() Dim jjj As Integer Dim iii As Integer Dim poly() As Double Dim index_poly() As Integer Dim sz As Integer Close On Error GoTo boom Workbooks("poly.xls").Activate Application.ScreenUpdating = False Range("o3:p" + Format(Application.Rows.Count)).ClearContents Call get_poly(poly, index_poly) Range("a3").Select For jjj = 0 To UBound(poly, 2) ActiveCell.Offset(jjj, 14) = poly(0, jjj) ActiveCell.Offset(jjj, 15) = poly(1, jjj) Next jjj ActiveSheet.ChartObjects(1).Activate sz = ActiveChart.SeriesCollection.Count For iii = 1 To UBound(index_poly) ActiveChart.SeriesCollection.NewSeries ActiveChart.SeriesCollection(iii + sz).XValues = "=Ëèñò1!$O$" & (index_poly(iii - 1) + 4) & ":$O$" & (index_poly(iii) + 3) ActiveChart.SeriesCollection(iii + sz).Values = "=Ëèñò1!$P$" & (index_poly(iii - 1) + 4) & ":$P$" & (index_poly(iii) + 3) ActiveChart.SeriesCollection(iii + sz).ChartType = xlXYScatterLines ActiveChart.SeriesCollection(iii + sz).Name = "=" & """ " & "ëèíèÿ" & iii & """" Next iii boom: Application.ScreenUpdating = True End Sub [/pre2] код кнопок для отображения точек аналогичен [pre2] Sub graf_all_point() Dim ttt As Integer Dim sz As Integer Range("a3").Select ttt = 0 Do While ActiveCell.Offset(ttt, 0) <> "" ttt = ttt + 1 Loop ttt = ttt - 1 If ttt > 0 Then ActiveSheet.ChartObjects(1).Activate ActiveChart.SeriesCollection.NewSeries sz = ActiveChart.SeriesCollection.Count ActiveChart.SeriesCollection(sz).XValues = "=Ëèñò1!$A$3:$A$" & (ttt + 3) ActiveChart.SeriesCollection(sz).Values = "=Ëèñò1!$B$3:$B$" & (ttt + 3) ActiveChart.SeriesCollection(sz).ChartType = xlXYScatter ActiveChart.SeriesCollection(sz).Name = "=""âñå ò÷ê""" ActiveChart.SeriesCollection(sz).MarkerStyle = 5 ActiveChart.SeriesCollection(sz).MarkerSize = 10 End If End Sub [/pre2]

полная версия страницы