А это код основной программы
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
При нажатии на кнопку "Выборка" на листе выводится диалоговое окно:
с кодом
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
- участник сейчас на форуме
- участник вне форума
