Excel VBA, Экспорт в txt, кодировка файла UTF-16 LE/UCS-2 Little Endian+еще один интересный вопрос

[Maxximus]

Спаси нас, господи, от GPS cофта написанного на Excel VBA

Ну нет конечно, просто вы меня неправильно поняли, или скорее всего я неправильно выразился, программа готовит и разбивает базы этих самых предупреждений.

[Maxximus]

EducatedFool, или люди програмирующие на VBA помогите немного пожалуйста, для вас это вопрос 3х минут,
Алгоритм проверки нахождения точки в области я нашел, но теперь стоит проблема возникает ошибка при считываниии в массив.
если координаты(массив) в макросе имеют вид:
ReDim Preserve xyp(Np)
xyp(0) = 10: xyp(1) = 20
xyp(2) = 0: xyp(3) = 10
xyp(4) = -10: xyp(5) = 20
xyp(6) = -10: xyp(7) = -20
xyp(8) = 10: xyp(9) = -20

то все нормально работает
теперь я не могу считать файл txt в правильный массив и проитись поиском по нему.
есть 2 варианта файла какой лучше использовать подскажите мне необходимо чтоб все быстро работало весь мир по регионам составляет порядка 18 мегабайт, можно сделать и 3 вариант с координатами вида:
1 вариант
40.0025072
55.68572331
39.9085555
55.78091377
2 вариант
40.0025072, 55.68572331
39.9085555,55.78091377
3 вариант
40.0025072, 55.68572331,39.9085555,55.78091377, 40.0025072, 55.68572331,39.9085555,55.78091377, 40.0025072, 55.68572331,39.9085555,55.78091377
разделитель во 2 и 3 вариантах может быть использован любой, это не важно.

[EducatedFool]

весь мир по регионам составляет порядка 18 мегабайт

Все регионы будут в одном файле, или в разных?

Если в одном файле координаты одного региона, то я бы посоветовал 2-й вариант.


Подобный код считывает в текстовую переменную всё содержимое текстового файла, разбивает считанный текст на массив (каждый элемент массива - одна строка текстового файла, например, 37.54173604,56.89734075)

Sub CommandButton1_Click()
    Fntxtfull = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "mo2.txt")

    txt = CreateObject("scripting.filesystemobject").OpenTextFile(Fntxtfull, 1, True).ReadAll
    МассивКоординат = Split(txt, vbNewLine)

    x0 = 37.678159: y0 = 55.600127   ' координаты тестируемой точки
    ПоложениеТестируемойТочки = CircleTestXY_Ex(МассивКоординат, x0, y0)
End Sub

Function CircleTestXY_Ex(МассивКоординат, x0, y0) As Boolean

    ' Проверка местонахождения точки на плоскости
    ' относительно многоугольника - внутри или снаружи
    '————————————————————————-
    ' ВХОД:
    ' массив координат углов многоугольника
    '  x0,y0  - координаты тестируемой точки

    ' ВЫХОД:  положение тестируемой точки
    '    true  - внутри, или на границе
    '    false - за пределами
    
    For Координата = LBound(МассивКоординат) To UBound(МассивКоординат)
        ТекущаяКоордината = МассивКоординат(Координата)
        x = Split(ТекущаяКоордината, ",")(0)
        y = Split(ТекущаяКоордината, ",")(1)
        ' так извлекаются координаты X и Y отдельных точек массива
    Next Координата
    
End Function

Соответственно, мы передаём в функцию сформированный массив и координаты проверяемой точки, а на выходе функции получаем результат - принадлежит точка региону, или нет.

PS: Код у Вас работать не будет - я лишь попытался объяснить, как сделал бы я.
Если проверяемых точек будет много, разумнее сразу считать в 100 переменных (или в массив) координаты из всех 100 текстовых файлов (получим 100 массивов МассивКоординат), и уже после этого производить проверку всех точек.

Мне лень писать реализацию алгоритма проверки принадлежности точки невыпуклому многоугольнику, а то бы выложил готовый код.

Алгоритмы можно посмотреть здесь:
http://www.opita.net/node/159
http://www.opita.net/node/24

[Maxximus]

Все регионы будут в одном файле, или в разных

Можно сделать в одном можно и разные для меня не принципиально главное быстрота работы проверки.

За подсказку с макросом, огромное!!!
Буду дальше учить VBA и делать программу, потом выложу отлаженный код здесь, так как ничего путного в нете не нашел.

За ссылки спасибо, не нашел, яндекс не рулит.

[EducatedFool]

За ссылки спасибо, не нашел, яндекс не рулит.

Не рулит???
А я-то думал наоборот, и им как раз и пользовался...

[Maxximus]

Значит плохо искал

[Maxximus]

Мне лень писать реализацию алгоритма проверки принадлежности точки невыпуклому многоугольнику, а то бы выложил готовый код.

Да не надо, я и так прыгая от счастья это уже сам допишу. Моя благодарность не знает границ!!!!

[Maxximus]

Итак благодаря EducatedFool и его помощи вот код:

Sub CommandButton1_Click()

    Fntxtfull = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "mo2.txt")

    txt = CreateObject("scripting.filesystemobject").OpenTextFile(Fntxtfull, 1, True).ReadAll
    МассивКоординат = Split(txt, vbNewLine)

    x0 = Replace(Cells(2, 6).Value, ",", "."): y0 = Replace(Cells(2, 7).Value, ",", ".") ' координаты тестируемой точки
    ПоложениеТестируемойТочки = CircleTestXY_Ex(МассивКоординат, x0, y0)
End Sub

Function CircleTestXY_Ex(МассивКоординат, x0, y0) As Boolean

    kz = 0
  For k = 1 To UBound(МассивКоординат)   ' Np + 1
        ТекущаяКоордината = МассивКоординат(k)
        x = Split(ТекущаяКоордината, ",")(0)
        Y = Split(ТекущаяКоордината, ",")(1)
    x2 = Val(x) - Val(x0): y2 = Val(Y) - Val(y0)
    '
    ' проверка четверти плоскости
    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 > 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 = 0 Then s$ = " - вне"
If kz = -100 Then s$ = "- на границе"  '      = -100  - на границе
If kz = -4 Then s$ = "- внутри"  '      = -4  - внутри (обход по часовой стрелке)
If kz = 4 Then s$ = "- внутри"   '      =  4   - внутри (против часовой стрелки)
 MsgBox s$, vbInformation, "Import Speedcams"
End Function