Microstation, VBA и TerraScan
Microstation, VBA и TerraScan
Сегодня я хотел бы показать небольшой пример работы с лазерными данными с помощью Microstation VBA.
Предлагаемый мною способ не является единственным, но вполне пригоден для повседневного использования.
Конечно, работать с данными, загруженными в TerraScan, используя VBA — это не самый правильный и далеко не самый оптимальный путь, но так как эта среда разработки поставляется вместе с Microstation и к тому же является невероятно простой, то для многих это будет достаточно хорошим выбором, который позволит решать небольшие повседневные задачи.
Сразу скажу о минусах, с которыми мы столкнемся:
- Лишнее потребление памяти из-за невозможности работать с указателями;
- Медленная скорость работы. Однако, вполне достаточная для решения небольших задач.
Дальнейшее небольшое повествование предполагает, что вы уже знакомы с VBA, а главное знакомы с принципами работы с массивами, которые в данном случае являются залогом успеха.
Итак, поехали!
Подготовка
Для начала создаем новый макрос, который просто будет выполнять роль тестовой площадки и на котором в последствии мы сможем отладить нужные нам функции.
Новый макрос
В этом макросе нам необходимо создать новый модуль (у меня он называется FnScan, а вы можете его назвать как вашей душе угодно).
Новый модуль FnScan
На этом подготовка завершена и мы можем приступать к написанию самих функций и процедур, которые будут взаимодействовать с TerraScan.
Формируем модуль FnScan
Далее мы должны написать все необходимые нам в работе функции. Возникает вопрос: а откуда мы их вообще возьмем? Ответ прост — из официальной документации к TerraScan, которую всегда можно взять на официальном сайте.
Комментарии к функциями приведены в самом коде, поэтому тут ничего писать просто не имеет смысла. Сразу предупрежу: далеко не все функции лично я использую в работе, поэтому в них вполне могут быть ошибки, допущенные мною при переносе и различном копировании, а также допущенные авторами документации к TerraScan (пример такой ошибки я приведу в самом конце).
Итак, вот сам код модуля:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 | Option Explicit ' Фунцкции для загрузки приложения Declare Function mdlSystem_findMdlDesc Lib "stdmdlbltin.dll" (ByVal nameP As String) As Long Declare Function mdlSystem_loadMdlProgram Lib "stdmdlbltin.dll" (ByVal pathP As String, ByVal Taskidp As String, ByVal pArgument As String) As Long ' Недокументированные функции работы с памятью (позволяет получать значение переменной по указателю) Private Declare Sub CopyMemoryToVBA Lib "kernel32" Alias "RtlMoveMemory" (ByRef VBALocation As Any, ByVal SourceLoc As Long, ByVal Length As Long) Private Declare Sub CopyMemoryFromVBA Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByRef VBALocation As Any, ByVal Length As Long) Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal strDest As Any, ByVal lpSource As Any, ByVal Length As Long) ' Тип точек с целочисленными координатами Type Point3dLong x As Long y As Long Z As Long End Type ' Тип цвета Type RGB r As Byte G As Byte B As Byte End Type ' Типы переменных, которые необходимо знать для работы с точками ' Point3d Pnt ; // Coordinates ' BYTE Code ; // Classification code ' BYTE Echo ; // Echo information ' BYTE Flag ; // Runtime flag (view visibility) ' BYTE Mark ; // Runtime flag ' USHORT Line ; // Flightline number ' USHORT Intensity ; // Intensity value ' Point3d - это X, Y, Z (каждая Long, т.е. 4 байта) ' Byte в C/C++ совпадает с Byte в VBA (1 байт) ' USHORT в C/C++ не имеет аналога в VBA, длина 2 байта, для хранения можно использовать Long (0 - 65535) ' Double в C/C++ совпадает с Double в VBA (8 байт) ' Функции FnScanGet возращают количество точек и адрес требуемого значения для первой точки ' Для получения значения нужно использовать такой вызов: ' CopyMemoryToVBA Value, Tbl, 4 ' Value - переменная того типа, который нужен (Byte, Long, Double) ' Tbl - указатель (адрес) где находится переменная ' 4 - размер в байтах, которые копируются в качестве значения (см. выше описание размеров переменных) ' Т.к. каждая FnScanGet возвращает количество точек, то можно получить весь массив значений ' Например: ' 1. для получения значения интенсивности последней точки: CopyMemoryToVBA Ints, Tbl + 2 * (Exp - 1), 2 ' 2. для получения значения цвета (R) последней точки: CopyMemoryToVBA Clr, Tbl + 1 * (Exp - 1) * 3, 1 ' 3. для получения значения цвета (B) последней точки: CopyMemoryToVBA Clr, Tbl + 1 * (Exp - 1) * 3 + 2, 1 'Attribute Always C Data Type Size 'Point coordinates Yes Point3d 12 bytes 'Time stamps - double 8 bytes 'Group identifiers - unsigned int 4 bytes 'Normal vectors - unsigned int 4 bytes 'Distances - int 4 bytes 'RGB colors - RgbClr 3 bytes 'Intensity values - unsigned short 2 bytes 'Line numbers - unsigned short 2 bytes 'Echo lengths - short 2 bytes 'Parameter values - unsigned short 2 bytes 'Point classes Yes unsigned char 1 byte 'Mark values -- run time only Yes unsigned char 1 byte 'Flag values -- run time only Yes unsigned char 1 byte 'Scanner angles - char 1 byte 'Echo bits - unsigned char 1 byte 'Scanner numbers - unsigned char 1 byte 'Echo normality values - unsigned char 1 byte ' Проверяем загружено ли приложение Sub LoadApp(Appname) Dim Ldd As Long If mdlSystem_findMdlDesc(Appname) = 0 Then Ldd = mdlSystem_loadMdlProgram(Appname, "Null", "") End If End Sub ' Координаты точек, изначально Point3d (формат TerraSolid) Function FnScanGetPnt(ByRef Tbl As Long) As Long FnScanGetPnt = GetCExpressionValue("FnScanGetPnt(" & VarPtr(Tbl) & ")") End Function Function FnScanGetCls(ByRef Tbl As Long) As Long FnScanGetCls = GetCExpressionValue("FnScanGetCls(" & VarPtr(Tbl) & ")") End Function Function FnScanGetMrk(ByRef Tbl As Long) As Long FnScanGetMrk = GetCExpressionValue("FnScanGetMrk(" & VarPtr(Tbl) & ")") End Function Function FnScanGetFlg(ByRef Tbl As Long) As Long FnScanGetFlg = GetCExpressionValue("FnScanGetFlg(" & VarPtr(Tbl) & ")") End Function Function FnScanGetInt(ByRef Tbl As Long) As Long FnScanGetInt = GetCExpressionValue("FnScanGetInt(" & VarPtr(Tbl) & ")") End Function Function FnScanGetLin(ByRef Tbl As Long) As Long FnScanGetLin = GetCExpressionValue("FnScanGetLin(" & VarPtr(Tbl) & ")") End Function Function FnScanGetDbl(ByRef Tbl As Long) As Long FnScanGetDbl = GetCExpressionValue("FnScanGetDbl(" & VarPtr(Tbl) & ")") End Function Function FnScanGetEch(ByRef Tbl As Long) As Long FnScanGetEch = GetCExpressionValue("FnScanGetEch(" & VarPtr(Tbl) & ")") End Function Function FnScanGetAng(ByRef Tbl As Long) As Long FnScanGetAng = GetCExpressionValue("FnScanGetAng(" & VarPtr(Tbl) & ")") End Function Function FnScanGetClr(ByRef Tbl As Long) As Long FnScanGetClr = GetCExpressionValue("FnScanGetClr(" & VarPtr(Tbl) & ")") End Function Function FnScanGetScr(ByRef Tbl As Long) As Long FnScanGetScr = GetCExpressionValue("FnScanGetScr(" & VarPtr(Tbl) & ")") End Function Function FnScanGetCoordSetup(ByRef Org As Point3d) As Long FnScanGetCoordSetup = GetCExpressionValue("FnScanGetCoordSetup(" & VarPtr(Org) & ")") End Function ' Функция для получения массива точек в нормальных координатах в соответствии с настройками исходного файла Function FnScanGetPntArray(ByRef Tbl() As Point3d) As Long Dim First As Long FnScanGetPntArray = FnScanGetPnt(First) If FnScanGetPntArray > 0 Then Dim i As Long, UorPerMast As Long Dim Org As Point3d Dim Mul As Double Dim PCoL() As Point3dLong UorPerMast = FnScanGetCoordSetup(Org) Mul = 1 / UorPerMast ReDim Preserve Tbl(FnScanGetPntArray - 1) ReDim Preserve PCoL(FnScanGetPntArray - 1) CopyMemoryToVBA PCoL(0), First, FnScanGetPntArray * 12 For i = LBound(PCoL) To UBound(PCoL) Tbl(i).x = Org.x + (Mul * PCoL(i).x) Tbl(i).y = Org.y + (Mul * PCoL(i).y) Tbl(i).Z = Org.Z + (Mul * PCoL(i).Z) Next i End If End Function ' Функция получения классов всех загруженных точек Function FnScanGetClsArray(ByRef Tbl() As Byte) As Long Dim First As Long FnScanGetClsArray = FnScanGetCls(First) If FnScanGetClsArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetClsArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetClsArray End Function ' Функция получения значений Mark всех загруженных точек Function FnScanGetMrkArray(ByRef Tbl() As Byte) As Long Dim First As Long FnScanGetMrkArray = FnScanGetMrk(First) If FnScanGetMrkArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetMrkArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetMrkArray End Function ' Функция получения значений Flag всех загруженных точек Function FnScanGetFlgArray(ByRef Tbl() As Byte) As Long Dim First As Long FnScanGetFlgArray = FnScanGetFlg(First) If FnScanGetFlgArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetFlgArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetFlgArray End Function ' Функция получения интенсивности всех загруженных точек ' Из-за ограничений типов данных VBA мы должны при необходимости прибавить 65536 к значению интенсивности Function FnScanGetIntArray(ByRef Tbl() As Long) As Long Dim First As Long, i As Long Dim Prelim() As Integer FnScanGetIntArray = FnScanGetInt(First) If FnScanGetIntArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetIntArray - 1) ReDim Preserve Prelim(FnScanGetIntArray - 1) CopyMemoryToVBA Prelim(0), First, FnScanGetIntArray * 2 For i = LBound(Prelim) To UBound(Prelim) If Prelim(i) >= 0 Then Tbl(i) = Prelim(i) Else Tbl(i) = Prelim(i) + 65536 End If Next i End Function ' Функция получения включений всех загруженных точек ' Из-за ограничений типов данных VBA мы должны при необходимости прибавить 65536 к значению включения Function FnScanGetLinArray(ByRef Tbl() As Long) As Long Dim First As Long, i As Long Dim Prelim() As Integer FnScanGetLinArray = FnScanGetLin(First) If FnScanGetLinArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetLinArray - 1) ReDim Preserve Prelim(FnScanGetLinArray - 1) CopyMemoryToVBA Prelim(0), First, FnScanGetLinArray * 2 For i = LBound(Prelim) To UBound(Prelim) If Prelim(i) >= 0 Then Tbl(i) = Prelim(i) Else Tbl(i) = Prelim(i) + 65536 End If Next i End Function ' Функция получения временных меток всех загруженных точек Function FnScanGetDblArray(ByRef Tbl() As Double) As Long Dim First As Long FnScanGetDblArray = FnScanGetDbl(First) If FnScanGetDblArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetDblArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetDblArray * 8 End Function ' Функция получения эхо всех загруженных точек Function FnScanGetEchArray(ByRef Tbl() As Byte) As Long Dim First As Long FnScanGetEchArray = FnScanGetEch(First) If FnScanGetEchArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetEchArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetEchArray End Function ' Функция получения цвета всех загруженных точек Function FnScanGetClrArray(ByRef Tbl() As RGB) As Long Dim First As Long FnScanGetClrArray = FnScanGetEch(First) If FnScanGetClrArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetClrArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetClrArray * 3 End Function ' Функция получения сканера всех загруженных точек Function FnScanGetScrArray(ByRef Tbl() As Byte) As Long Dim First As Long FnScanGetScrArray = FnScanGetScr(First) If FnScanGetScrArray = 0 Then Exit Function End If ReDim Preserve Tbl(FnScanGetScrArray - 1) CopyMemoryToVBA Tbl(0), First, FnScanGetScrArray End Function 'Классификация точек из класса в класс 'FromClass - исходные класс точек (значение 999 - все классы) 'ToClass - класс назначения (т.е. в какой класс переклассифицируем) 'Fence, если 0 - то все точки, если 1, то внутри фенса 'Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -3 если параметры неверные Function FnScanClassifyClass(ByVal FromClass As Long, ByVal ToClass As Long, ByVal Fence As Long) As Long FnScanClassifyClass = GetCExpressionValue("FnScanClassifyClass(" & FromClass & "," & ToClass & "," & Fence & ")") End Function 'Классификация Low Point 'FromClass - исходные класс точек (значение 999 - все классы) 'ToClass - класс назначения (т.е. в какой класс переклассифицируем) 'GrpCnt - максимальное количество Low Point в группе (от 1 до 99) 'Dz - минимальная разница по высоте относительно других точек (указывается в метрах) 'XyDst - радиус поиска (указывается в метрах) 'Fence, если 0 - то все точки, если 1, то внутри фенса 'Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyLow(ByVal FromClass As Long, ByVal ToClass As Long, ByVal GrpCnt As Long, ByVal dz As Double, ByVal XyDst As Double, ByVal Fence As Long) As Long FnScanClassifyLow = GetCExpressionValue("FnScanClassifyLow(" & FromClass & "," & ToClass & "," & GrpCnt & "," & dz & "," & XyDst & "," & Fence & ")") End Function ' Классификация Air Point ' ClsLst - список исходных классов, например "1,7-9". Т.е. передать надо просто строку, которую потом специально конвертируем в массив символов ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' XyDst - радиус поиска (указывается в метрах) ' ReqCnt - минимальное количество точек внутри многоугольника, в котором происходит поиск ' Lim - минимальный фактор ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyAir(ByVal ClsLst As String, ByVal ToClass As Long, ByVal XyDst As Double, ByVal ReqCnt As Long, ByVal Lim As Double, ByVal Fence As Long) As Long FnScanClassifyAir = GetCExpressionValue("FnScanClassifyAir(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & ToClass & "," & XyDst & "," & ReqCnt & "," & Lim & "," & Fence & ")") End Function ' Классификация Isolated Point ' ClsLst - список исходных классов, например "1,7-9". Т.е. передать надо просто строку, которую потом специально конвертируем в массив символов ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Dst - радиус поиска (указывается в метрах) ' LimCnt - классифицируется, если меньше чем Lim ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyIsolated(ByVal ClsLst As String, ByVal ToClass As Long, ByVal LimCnt As Long, ByVal dst As Double, ByVal Fence As Long) As Long FnScanClassifyIsolated = GetCExpressionValue("FnScanClassifyIsolated(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & ToClass & "," & LimCnt & "," & dst & "," & Fence & ")") End Function ' Классификация Ground Point ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' InitLow - начальные точки: 0 - текущие точки земли, 1 - нижние точки ' BldSz - максимальный размер зданий (в метрах) если InitLow = 1 ' MaxAng - максимальный terrain angle (градусы) ' IterAng - iteration angle (градусы) ' IterDst - iteration distance (метры) ' Reduce - reduce iteration length? ' RedLen - when edge length < RedLen ' Stopp - stop iteration? ' StopLen - when edge length < StopLen ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyGround(ByVal FromClass As Long, ByVal ToClass As Long, ByVal InitLow As Long, ByVal BldSz As Double, _ ByVal MaxAng As Double, ByVal IterAng As Double, ByVal IterDst As Double, ByVal Reduce As Long, _ ByVal RedLen As Double, ByVal Stopp As Long, ByVal StopLen As Double, ByVal Fence As Long) As Long FnScanClassifyGround = GetCExpressionValue("FnScanClassifyGround(" & FromClass & "," & ToClass & "," & InitLow & "," & BldSz & "," & _ MaxAng & "," & IterAng & "," & IterDst & "," & Reduce & "," & _ RedLen & "," & Stopp & "," & StopLen & "," & Fence & ")") End Function ' Классификация точек под поверхностью ' FromClass - исходные класс точек (класс земли, т.е. точек, которые дают поверхность) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Lim - лимит ' Tol - допуск по высоте ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyBelow(ByVal FromClass As Long, ByVal ToClass As Long, ByVal Lim As Double, ByVal TolZ As Double, ByVal Fence As Long) As Long FnScanClassifyBelow = GetCExpressionValue("FnScanClassifyBelow(" & FromClass & "," & ToClass & "," & Lim & "," & TolZ & "," & Fence & ")") End Function ' Классификация точек над землей ' Grd - класс земли или 1000000 + TerraModeler surface id ' MaxLen - maximum ground triangle length ' FromClass - source class (999 for any) ' ToClass - destination class ' MinH - minimum height above ground ' MaxH - maximum height above ground ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyHgtGrd(ByVal Grd As Long, ByVal MaxLen As Double, ByVal FromClass As Long, ByVal ToClass As Long, _ ByVal MinH As Double, ByVal MaxH As Double, ByVal Fence As Long) As Long FnScanClassifyHgtGrd = GetCExpressionValue("FnScanClassifyHgtGrd(" & Grd & "," & MaxLen & "," & FromClass & "," & ToClass & "," & MinH & "," & MaxH & "," & Fence & ")") End Function ' Классификация точек относительно нескольких классов ' Аналогичен FnScanClassifyHgtGrd, но вместо ByVal Grd As Long передается ByVal GrdLst As String ' GrdLst list of ground classes, example "2,8" Function FnScanClassifyHgtLst(ByVal GrdLst As String, ByVal MaxLen As Double, ByVal FromClass As Long, ByVal ToClass As Long, _ ByVal MinH As Double, ByVal MaxH As Double, ByVal Fence As Long) As Long FnScanClassifyHgtLst = GetCExpressionValue("FnScanClassifyHgtLst(" & StrPtr(StrConv(GrdLst & vbNullChar, vbFromUnicode)) & "," & MaxLen & "," & FromClass & "," & ToClass & "," & MinH & "," & MaxH & "," & Fence & ")") End Function ' Классификация точек в определенном диапазоне высот MinZ <= Z < MaxZ ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' MinZ - минимальная высота ' MaxZ - максимальная высота ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyAbsElev(ByVal FromClass As Long, ByVal ToClass As Long, ByVal MinZ As Double, ByVal MaxZ As Double, ByVal Fence As Long) As Long FnScanClassifyAbsElev = GetCExpressionValue("FnScanClassifyAbsElev(" & FromClass & "," & ToClass & "," & MinZ & "," & MaxZ & "," & Fence & ")") End Function ' Классификация точек в определенном диапазоне интенсивности MinV <= Intensity < MaxV ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' MinZ - минимальная интенсивность ' MaxZ - максимальная интенсивность ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyIntensity(ByVal FromClass As Long, ByVal ToClass As Long, ByVal MinV As Double, ByVal MaxV As Double, ByVal Fence As Long) As Long FnScanClassifyIntensity = GetCExpressionValue("FnScanClassifyIntensity(" & FromClass & "," & ToClass & "," & MinV & "," & MaxV & "," & Fence & ")") End Function ' Классификация точек в определенном диапазоне цветов с использованием цветовой модели HSV ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Source color source: 0=laser, 1=ortho, 2=raw images ' Foot laser footprint diameter (m) in ortho/raw images ' Hue hue value ' Tol +- tolerance for hue ' SatMin minimum saturation ' SatMax maximum saturation ' ValMin minimum value ' ValMax maximum value ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyColor(ByVal FromClass As Long, ByVal ToClass As Long, ByVal Source As Long, ByVal Foot As Double, ByVal Hue As Long, _ ByVal Tol As Long, ByVal SatMin As Long, ByVal SatMax As Long, ByVal ValMin As Long, ByVal ValMax As Long, ByVal Fence As Long) As Long FnScanClassifyColor = GetCExpressionValue("FnScanClassifyColor(" & FromClass & "," & ToClass & "," & Source & "," & Foot & "," & Hue & "," & _ Tol & "," & SatMin & "," & SatMax & "," & ValMin & "," & ValMax & "," & Fence & ")") End Function ' Классификация точек в определенном диапазоне времени Beg <= Time <= End ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' BegTime - начальное время (секунды) ' EndTime - конечное время (секунды) ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyTime(ByVal FromClass As Long, ByVal ToClass As Long, ByVal BegTime As Double, ByVal EndTime As Double, ByVal Fence As Long) As Long FnScanClassifyTime = GetCExpressionValue("FnScanClassifyTime(" & FromClass & "," & ToClass & "," & BegTime & "," & EndTime & "," & Fence & ")") End Function ' Classify model keypoints which produce a triangulated surface model of given accuracy. ' ClsLst - исходные класс точек, example "2,14" ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' InitDst - initial sampling distance (m) ' Above - distance points may be above model (m) ' Below - distance points may be below model (m) ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyModelKey(ByVal ClsLst As String, ByVal ToClass As Long, ByVal InitDst As Double, ByVal Above As Double, ByVal Below As Double, ByVal Fence As Long) As Long FnScanClassifyModelKey = GetCExpressionValue("FnScanClassifyModelKey(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & ToClass & "," & InitDst & "," & Above & "," & Below & "," & Fence & ")") End Function ' Classify contour keypoints which produce a triangulated surface suitable for generating contours. ' ClsLst - исходные класс точек, example "2,14" ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Interval - contour interval (m) ' Init - initial sampling distance (m) ' Lim - limit for classification (1=accure/many points, 100=pretty/few points) ' Peaks - 0=no, 1=keep peaks and pits ' PeakArea - minimum area (m2) for peak to keep ' PitArea - minimum area (m2) for pit to keep ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyContourKey(ByVal ClsLst As String, ByVal ToClass As Long, ByVal Interval As Double, ByVal Init As Double, _ ByVal Lim As Long, ByVal Peaks As Long, ByVal PeakArea As Double, ByVal Fence As Long) As Long FnScanClassifyContourKey = GetCExpressionValue("FnScanClassifyContourKey(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & ToClass & "," & Interval & "," & Init & "," & _ Lim & "," & Peaks & "," & PeakArea & "," & Fence & ")") End Function ' Классификация точек относительно ВЫДЕЛЕННОГО Centerline. ' ClsLst - исходные класс точек, example "2,14" ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Cmp - compare with 0=any line, 1=closest line ' Side - -1=left, 0=either, 1=right side ' OffMin - minimum xy offset from element (m) ' OffMax - maximum xy offset from element (m) ' UseDz - if true, use dz from alignment ' DzMin - minimum dz value ' DzMax - maximum dz value ' UseDst - if true, use distance from closest vertex ' DstMin - minimum longitudinal distance to vertex ' DstMax - minimum longitudinal distance to vertex ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если прервана ' Вернет -3 если параметры неверные Function FnScanClassifyCtrline(ByVal ClsLst As String, ByVal ToClass As Long, ByVal Cmp As Long, _ ByVal Side As Long, ByVal OffMin As Double, ByVal OffMax As Double, _ ByVal UseDz As Long, ByVal DzMin As Double, ByVal DzMax As Double, _ ByVal UseDst As Long, ByVal DstMin As Double, ByVal DstMax As Double) As Long FnScanClassifyCtrline = GetCExpressionValue("FnScanClassifyCtrline(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & ToClass & "," & Cmp & "," & _ Side & "," & OffMin & "," & OffMax & "," & _ UseDz & "," & DzMin & "," & DzMax & "," & _ UseDst & "," & DstMin & "," & DstMax & "," & ")") End Function ' Классификация точек по значению Echo ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Echo - значение Echo ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Valid values for Echo parameter are: ' 0 only Echo ' 1 first of many ' 2 intermediate ' 3 last of many ' 11 any first (only echo or first of many) ' 13 any last (only echo or last of many) ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -3 если параметры неверные Function FnScanClassifyEcho(ByVal FromClass As Long, ByVal ToClass As Long, ByVal Echo As Long, ByVal Fence As Long) As Long FnScanClassifyEcho = GetCExpressionValue("FnScanClassifyEcho(" & FromClass & "," & ToClass & "," & Echo & "," & Fence & ")") End Function ' Классификация точек по направлению сканирования или флагу edge ' FromClass - исходные класс точек (значение 999 - все классы) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Direction - 0=negative direction, 1=positive direction, 2=edge ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -2 если нет направления сканирования ' Вернет -3 если параметры неверные Function FnScanClassifyDirection(ByVal FromClass As Long, ByVal ToClass As Long, ByVal Direction As Long, ByVal Fence As Long) As Long FnScanClassifyDirection = GetCExpressionValue("FnScanClassifyDirection(" & FromClass & "," & ToClass & "," & Direction & "," & Fence & ")") End Function ' Classify points which are hits on building roofs. ' GrdClass - класс земли ' FromClass - исходный класс (high vegetation) ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' MinArea - минимальная площадь здания (m2) ' Tol - plane tolerance (m) ' UseEcho - use echo information? ' Fence, если 0 - то все точки, если 1, то внутри фенса ' Возвращает количество классифицированных точек (0...n) ' Вернет -1 если фенс не найден, но при этом заказано именно внутри фенса ' Вернет -3 если параметры неверные Function FnScanClassifyBuilding(ByVal GrdClass As Long, ByVal FromClass As Long, ByVal ToClass As Long, ByVal MinArea As Double, ByVal Tol As Double, ByVal UseEcho As Long, ByVal Fence As Long) As Long FnScanClassifyBuilding = GetCExpressionValue("FnScanClassifyBuilding(" & GrdClass & "," & FromClass & "," & ToClass & "," & MinArea & "," & Tol & "," & UseEcho & "," & Fence & ")") End Function ' Классификация точек внутри шейпа, который находится в заданном слое текущего DGN или референсе ' ClsLst - исходные класс точек, example "2,14" ' ToClass - класс назначения (т.е. в какой класс переклассифицируем) ' Lvl Level ' ByClr filter by color? ' Clr -Color ' ByWgt filter by weight? ' Wgt -Weight ' BySty filter by style? ' Sty -Style ' Dgn 0=active design and references, 1=active design file, 2=reference files ' Возвращает количество классифицированных точек (0...n) ' Вернет -2 если out of memory. Function FnScanClassifyShapes(ByVal ClsLst As String, ByVal ToClass As Long, ByVal Lvl As Long, ByVal Clr As Long, _ ByVal ByWgt As Long, ByVal Wgt As Long, ByVal BySty As Long, ByVal Sty As Long, ByVal Expand As Double, ByVal Dgn As Long) As Long FnScanClassifyShapes = GetCExpressionValue("FnScanClassifyShapes(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & FromClass & "," & Lvl & "," & Clr & "," & _ ByWgt & "," & Wgt & "," & BySty & "," & Sty & "," & Expand & "," & Dgn & ")") End Function ' Классификация точек, у которых Mark = 1 ' Return number of classified points. Function FnScanClassifyMarked(ByVal FromClass As Long, ByVal ToClass As Long) As Long FnScanClassifyMarked = GetCExpressionValue("FnScanClassifyMarked(" & FromClass & "," & ToClass & ")") End Function ' Удаление точек по классу ' Class source class to delete ' Fence 0=all points, -1=outside fence, 1=inside fence ' Return number of points deleted (0...n). ' Return -1 if no fence defined (and Fence was nonzero). Function FnScanDeleteClass(ByVal Class As Long, ByVal Fence As Long) As Long FnScanDeleteClass = GetCExpressionValue("FnScanDeleteClass(" & Class & "," & Fence & ")") End Function ' Удаление точек по включению ' Line flightline or measurement to delete ' Fence 0=all points, -1=outside fence, 1=inside fence ' Return number of points deleted (0...n). ' Return -1 if no fence defined (and Fence was nonzero). Function FnScanDeleteLine(ByVal Line As Long, ByVal Fence As Long) As Long FnScanDeleteLine = GetCExpressionValue("FnScanDeleteLine(" & Line & "," & Fence & ")") End Function ' Трансформация точек ' FromClass - исходные класс точек (значение 999 - все классы) ' Name - название трансформации в настройках TerraScan ' Fence 0=all points, 1=inside fence ' Return number of points deleted (0...n). ' Return -1 if no fence defined (and Fence was nonzero). ' Return -2 if was aborted. ' Return -3 if invalid parameters. ' Return -4 if transformation was not found. Function FnScanTransform(ByVal Class As Long, ByVal Name As String, ByVal Fence As Long) As Long FnScanTransform = GetCExpressionValue("FnScanTransform(" & Line & "," & StrPtr(StrConv(Name & vbNullChar, vbFromUnicode)) & "," & Fence & ")") End Function ' Перерисовка всех окон, на которых могут быть отображены точки ' Всегда возвращает 1 Function FnScanUpdateViews() As Long FnScanUpdateViews = GetCExpressionValue("FnScanUpdateViews()") End Function ' Сортировка загруженных точек ' 0 increasing easting ' 1 decreasing northing ' 2 increasing easting ' 3 decreasing northing ' 4 increasing time stamp ' 19 MDL Public Functions ' Return 1 if points were sorted. ' Return 0 if nothing was done. Function FnScanSort(ByVal By As Long) As Long FnScanSort = GetCExpressionValue("FnScanSort(" & By & ")") End Function ' Output points to a file. ' File - Output file name. If it contains string "######", that string will be replaced by active block number. ' Active project directory will be used if File does not include a directory specification. ' If File contains string "#name", that string will replaced by active file name. ' In that case, File should always include directory and extension such as "c:\output\#name.grd". ' ClsLst - list of classes to output, example "1,7-9" ' Fmt - Format of output file. ' Delim - Delimiter (0=space, 1=tabulator, 2=comma). ' Trans - Name of transformation in TerraScan settings. ' Pass - zero or "" for none. ' Append - If true, add to end of a possibly existing file. ' Fence - 0=all points, 1=inside fence ' Format can be: ' 1 X Y Z ' 2 Class X Y Z ' 3 X Y Z Intensity ' 5 Class X Y Z Intensity ' 7 TerraScan binary 8 bit line numbers ' 8 TerraScan binary 16 bit line numbers ' 13 EarthData binary ' 23 Grass Sites format ' 200+ User defined file format ' Return number of points written. ' Return -1 if no fence defined (and Fence was nonzero). ' Return -2 if failed to write to file. ' Return -3 if invalid parameters. ' Return -4 if transformation was not found. Function FnScanOutput(ByVal File As String, ByVal ClsLst As String, ByVal Fmt As Long, ByVal Delim As Long, ByVal nDelim As Long, ByVal Trans As String, ByVal Append As Long, ByVal Fence As Long, ByVal Block As Long, ByVal Val As Long) As Long FnScanOutput = GetCExpressionValue("FnScanOutput(" & StrPtr(StrConv(File & vbNullChar, vbFromUnicode)) & "," & _ StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & _ Fmt & "," & _ Delim & "," & _ nDelim & "," & _ StrPtr(StrConv(Trans & vbNullChar, vbFromUnicode)) & "," & _ Append & "," & _ Fence & "," & _ Block & "," & Val & ")") End Function ' Output points to a file based on flightline number. This will generate multiple output files if Line == -1 in which case one output file will be generated for every flightline. ' File - Output file name. If File contains string "#line", that string will be replaced by flight line number. ' Active project directory will be used if File does not include a directory specification. ' Line Line to output. Pass -1 for all lines and use "#line" as part of file name. ' Class - Class of points to output. Pass 999 for all points. ' Fmt - Format of output file, see FnScanOutput(). ' Delim - Delimiter (0=space, 1=tabulator, 2=comma). ' Trans - Name of transformation in TerraScan settings. Pass zero or "" for none. ' Append - If true, add to end of a possibly existing file. ' Return number of points written. ' Return -3 if invalid parameters. ' Return -4 if transformation was not found. Function FnScanOutputLine(ByVal File As String, ByVal Line As Long, ByVal Class As Long, ByVal Fmt As Long, ByVal Delim As Long, _ ByVal Trans As String, ByVal Append As Long) As Long FnScanOutputLine = GetCExpressionValue("FnScanOutputLine(" & StrPtr(StrConv(File & vbNullChar, vbFromUnicode)) & "," & Line & "," & Class & "," & _ Fmt & "," & Delim & "," & StrPtr(StrConv(Trans & vbNullChar, vbFromUnicode)) & "," & Append & ")") End Function ' Return information about the active project. Set: ' Type - project type: 0=airborne, 1=ground based ' Fmt - storage format: 0=TerraScan binary, 1=EarthData ' Описание FMT в документации устаревшее. По моим тестам так: ' 0 - Bin 8 bit ' 1 - Bin 16 bit ' 2 - EarthData EEBN и EBN ' 3 - LAS 1.0 ' 4 - LAS 1.1 ' 5 - LAS 2.0 ' 6 - FastBin ' Dir - data file directory ' Return number of blocks (0 - n). ' Return -1 if no active project. ' Параметры передаем как ByRef, т.к. функция их меняет! ' Сложность данной функции в том, она должна заполнить динамический массив символов Dir (char *Dir) ' В VBA мы такое проделать не можем, т.к. мы не знаем какой длины в итоге мы получили строку, т.е. мы понятия не имеем сколько нам надо байт считать по указателю ' Как выход забивать исходную строку Dir спецсимволами (например 10 000 символов), недопустимыми в названии путей и потом удалять лишее Function FnScanProjectInfo(ByRef Typep As Long, ByRef Fmt As Long, ByRef Dir As String) As Long Dim i As Long Dim bytArr() As Byte bytArr = StrConv(Dir & vbNullChar, vbFromUnicode) FnScanProjectInfo = GetCExpressionValue("FnScanProjectInfo(" & VarPtr(Typep) & "," & VarPtr(Fmt) & "," & VarPtr(bytArr(0)) & ")") Dir = "" For i = LBound(bytArr) To UBound(bytArr) Dir = Dir + Chr(bytArr(i)) Next i End Function ' Return information about project block index Ind. Set: ' Vrt[] boundary vertices (up to 41) ' File binary file name including full path ' Return number of boundary vertices (0 - 41). ' Return -1 if invalid index or no active project. ' Индексация блоков с 0 ' Vrt() - массив не динамический, а статический на 5000 элементов. Далее необходимо считать то количество элементов массива, сколько вернет функция в виде ответа ' File - аналогично DIR предыдущей функции FnScanProjectInfo Function FnScanProjectBlock(ByRef Vrt() As Point3d, ByRef File As String, ByVal Ind As Long) As Long Dim i As Long Dim bytArr() As Byte bytArr = StrConv(File & vbNullChar, vbFromUnicode) FnScanProjectBlock = GetCExpressionValue("FnScanProjectBlock(" & VarPtr(Vrt(0)) & "," & VarPtr(bytArr(0)) & "," & Ind & ")") File = "" For i = LBound(bytArr) To UBound(bytArr) File = File + Chr(bytArr(i)) Next i End Function ' Create lattice model from laser points in class Class and write that to file File. ' File - Output file name. Active project directory will be used if File does not include a directory specification. ' If it contains string "######" or "#block", that string will be replaced by active block number. ' If File contains string "#name", that string will be replaced by active file name. 'Class - Class of points to output. Pass 999 for all points. 'Elev - 0=lowest, 1=average, 2=highest hit, 3=triangle model 'Step - Grid step size (m). 'Len - Number of gap pixels to fill if Elev != 3. Maximum triangle length if Elev == 3. 'Fmt - Format of output file. 'UnitZ - Unit of Z values: 0=uor, 1=mm, 2=cm, 3=dm, 4=m. Used only with Intergraph and Raw binary formats. 'CrdBlk - 0=no coordinate block, nonzero=output. Used only with Intergraph format. 'Out - Value to output in undefined area. Pass NULL to skip. Used only with ArcInfo and Xyz text formats. ' Format can be: ' 0 Intergraph Grd ' 5 Raw binary 16 bit ' 6 Raw binary 32 bit ' 7 Raw binary 64 bit double ' 8 ArcInfo GRIDASCII ' 9 Xyz Text ' Return 1 on success. ' Return 0 if no source points. ' Return -2 if failed to write to file. Function FnScanExportLattice(ByVal File As String, ByVal Class As Long, ByVal Elev As Long, ByVal Step As Double, ByVal lenn As Double, ByVal Fmt As Long, _ ByVal UnitZ As Long, ByVal CrdBlk As Long, ByVal Out As String) As Long FnScanExportLattice = GetCExpressionValue("FnScanExportLattice(" & StrPtr(StrConv(File & vbNullChar, vbFromUnicode)) & "," & Class & "," & Elev & "," & _ Step & "," & lenn & "," & Fmt & "," & UnitZ & "," & CrdBlk & "," & _ StrPtr(StrConv(Out & vbNullChar, vbFromUnicode)) & ")") End Function ' Read points from file File into RAM. ' File Full path of input file(s). Multiple file names should be separated by '\n' ' First - Class for non-last echos (if not in input) ' Last - Class for last echos (if not in input) ' Line - Flightline number (if not in input) ' Inc - When flightline number is incremented. 0=never, 2=new file, 3=new file name, 4=new dir ' Trans - Name of transformation in TerraScan settings. Pass zero or "" for none ' Fence - 0=all points, 1=inside fence ' Every - 0=every, 1=every, n=every n:th ' Return number of points found. ' Return -2 if failed to open or recognize format of first file. ' Return -3 if invalid parameters. ' Return -4 if transformation was not found. ' Return -5 if out of memory. Function FnScanRead(ByVal File As String, ByVal First As Long, ByVal Last As Long, ByVal Line As Long, ByVal Inc As Long, ByVal Trans As String, ByVal Fence As Long, ByVal Every As Long) As Long FnScanRead = GetCExpressionValue("FnScanRead(" & StrPtr(StrConv(File & vbNullChar, vbFromUnicode)) & "," & First & "," & Last & "," & _ Line & "," & Inc & "," & StrPtr(StrConv(Trans & vbNullChar, vbFromUnicode)) & "," & Fence & "," & Every & ")") End Function ' Smoothen surface by adjusting point elevations. moving points points by adjusting elevations by a maximum of ' ModLst - classes to smoothen, example "1,7-9" ' UpCm - maximum movement up (cm) ' DnCm - maximum movement down (cm) ' FixLst - immovable classes to include in surface, "5-6" ' Fence - 0=all points, -1=outside fence, 1=inside fence ' Return 1 if points were adjusted. ' Return 0 if nothing was done. ' Return -2 if out of memory. Function FnScanSmoothen(ByVal ModLst As String, ByVal UpCm As Long, ByVal DnCm As Long, ByVal FixLst As String, ByVal Fence As Long) As Long FnScanSmoothen = GetCExpressionValue("FnScanSmoothen(" & StrPtr(StrConv(ModLst & vbNullChar, vbFromUnicode)) & "," & UpCm & "," & DnCm & "," & _ StrPtr(StrConv(FixLst & vbNullChar, vbFromUnicode)) & "," & Fence & ")") End Function ' Thin data set by removing points close to another point. Point can be removed if it is within Dxy horizontal distance and Dz elevation difference from another point. ' Class - source class to thin (999 for any) ' Keep point to keep in a group: 0=highest,1=lowest,2=central,3=create average ' Dxy - xy distance limit ' Dz - dz limit ' Fence - 0=all points, -1=outside fence, 1=inside fence ' Return number of points removed (0...n). ' Return -1 if no fence defined (and Fence was nonzero). ' Return -3 if invalid parameters. Function FnScanThinPoints(ByVal Class As Long, ByVal Keep As Long, ByVal Dxy As Double, ByVal dz As Double, ByVal Fence As Long) As Long FnScanThinPoints = GetCExpressionValue("FnScanThinPoints(" & Class & "," & Keep & "," & Dxy & "," & dz & "," & Fence & ")") End Function ' Cut points from overlapping flightlines by either flightline quality or by offset from trajectory. ' ClsLst - List of coverage classes, example "0-255" ' Action - Action: 0=add constant, 1=classify, 2=delete ' Val - If Action == 0, value to add to class ' If Action == 1, class to classify to ' If Action == 2, ignored ' Quality - 0=no, 1=cut by trajectory quality ' Gap - radius of empty area to consider a gap ' Offset 0=no, 1=cut by offset ' Keep - minimum corridor to keep (degrees) ' Return number of points affected (0...n). ' Return -3 if invalid parameters. ' Return -4 if no trajectories. Function FnScanCutOverlap(ByVal ClsLst As String, ByVal Action As Long, ByVal Val As Long, ByVal Quality As Long, ByVal Gap As Double, ByVal Offset As Long, ByVal Keep As Long) As Long FnScanCutOverlap = GetCExpressionValue("FnScanCutOverlap(" & StrPtr(StrConv(ClsLst & vbNullChar, vbFromUnicode)) & "," & Action & "," & Val & "," & Quality & "," & Gap & "," & Offset & "," & Keep & ")") End Function ' Adjust laser points using an angular change to the vector from scanner position to the point. ' Line Line to adjust. Pass -1 for all lines. ' Fix Coordinate axis to fix: 1=z, 2=xy, 3=xyz ' Input Angle unit used: 0=degrees, 1=radians, 2=ratio ' Head Heading correction angle ' Roll Roll correction angle ' Pitch Pitch correction angle ' Div Angle divider corresponding to full circle. ' Used if Input == 2. ' Return number of points adjusted. ' Return -1 if no trajectories loaded. Function FnScanAdjustAngles(ByVal Line As Long, ByVal Fixx As Long, ByVal Inputt As Long, ByVal Head As Double, ByVal Roll As Double, ByVal Pitch As Double, ByVal Div As Double) As Long FnScanAdjustAngles = GetCExpressionValue("FnScanAdjustAngles(" & Line & "," & Fixx & "," & Inputt & "," & Head & "," & Roll & "," & Pitch & "," & Div & ")") End Function ' Функция FnScanMarkAll помечает все загруженные точки заданым значением Mark Function FnScanMarkAll(ByVal MarkVal As Long) As Long FnScanMarkAll = GetCExpressionValue("FnScanMarkAll(" & MarkVal & ")") End Function ' Функция FnScanMarkFence помечает точки внутри фенса значением 1, вне фенса значением 0 ' Fst и Lst являются указателями на первую и последнюю точку внутри фенса ' Возвращает 1 если получилось, 0 если ошибка Function FnScanMarkFence(ByRef Fst As Long, ByRef Lst As Long) As Long FnScanMarkFence = GetCExpressionValue("FnScanMarkFence(" & VarPtr(Fst) & "," & VarPtr(Lst) & ")") End Function ' Fill option button with class names. ' Return 0 always. ' ВНИМАНИЕ: функция не работает! Надо реализовывать структуру rawitemhdr, которая описана c:\Program Files (x86)\Bentley\MicroStation\mdl\include\dlogitem.h Function FnScanClassOption(ByRef Raw As Long) As Long FnScanClassOption = GetCExpressionValue("FnScanClassOption(" & VarPtr(Sel) & ")") End Function 'Fill string list with: '- class numbers and names if Nbr is true '- class names only if Nbr is zero 'Return number of classes. ' ВНИМАНИЕ: функция не работает! Lst имеет тип StringList, аналог которого надо найти в VBA Function FnScanClassList(ByRef Lst() As String, ByVal Nbr As Long) As Long FnScanClassList = GetCExpressionValue("FnScanClassList(" & VarPtr(Lst(0)) & "," & Nbr & ")") End Function ' Функция FnScanSelectClasses сначала показывает форму со списком доступных классов ' В качестве Sel передается 0-ой элемент готового статического массива на 256 элементов (Dim Sel(255) As Byte) ' Возвращает количество выделенных классов и заполненный массив (0 - не выделен, 1 - выделен) ' Если нажата кнопка Cancel, то вернет -1 Function FnScanSelectClasses(ByRef Sel As Byte) As Long FnScanSelectClasses = GetCExpressionValue("FnScanSelectClasses(" & VarPtr(Sel) & ")") End Function ' Функция FnScanSave сохраняет загруженные точки во временный файл в бинарном формате ' Возвращает 1 если запись удалась, 0 - если произошла ошибка ' ВНИМАНИЕ: StrPtr нам даст адрес переменной. Но так как сама функция требует на входе char *Path (массив символов), то надо также сделать преобразование ' в байтовый массив, аналог строки LPSTR (ANSI с символом Char(0) в конце) ' Данное решение найдено тут: http://www.sql.ru/forum/505264-2/peredacha-char-cherez-vba-v-dll Function FnScanSave(ByVal Path As String) As Long FnScanSave = GetCExpressionValue("FnScanSave(" & StrPtr(StrConv(Path & vbNullChar, vbFromUnicode)) & ")") End Function ' Функция перезагружает точки из временного файла ' Возвращает 1 если удалось, 0 если ошибка чтения файла, ' -1 - если у нас в памяти уже есть точки, -2 - если ошибка Out of memory (короче не хватает памяти для загрузки) ' Что самое интересное: у нас открыт TerraScan, точек нет. Загружаем точки этой функцией - в памяти они есть, но они не отображаются (заведомо находимся там ' где точки находятся. Fit View помогает отобразить точки, но зум не работает) Function FnScanReload(ByVal Path As String) As Long FnScanReload = GetCExpressionValue("FnScanReload(" & StrPtr(StrConv(Path & vbNullChar, vbFromUnicode)) & ")") End Function ' Функцию FnScanPreFree необходимо запускать перед FnScanFreeTable ' Запрашивает пользователя о желании сохранить модифицированные данные перед закрытием ' Возвращает 1 если были сохранены (нажали кнопку Yes) ' Возвращает 0 если точек нет или они не были модифицированны Function FnScanPreFree() As Long FnScanPreFree = GetCExpressionValue("FnScanPreFree()") End Function ' Функция FnScanFreeTable освобождает аллокированную под точки память ' Никаких вопросов пользователю не задает!!! ' Параметров нет, всегда возвращает 1 Function FnScanFreeTable() As Long FnScanFreeTable = GetCExpressionValue("FnScanFreeTable()") End Function ' Find laser point closest to point Cp which is within distance R of point Cp when drawn in view Vw. ' Fp Point where the coordinates will be stored. ' Class Class of points to output. Pass 999 for all points. ' Cp Point at which to search. ' R Search radius (m). ' Vw View index for rotation of search (pass -1 for top view search logic). ' Return index of point if found (0,1,2,...). ' Return -1 if no point found. Function FnScanFindClosest(ByRef Fp As Point3d, ByVal Class As Long, ByRef CP As Point3d, ByVal r As Double, ByVal Vw As Long) As Long FnScanFindClosest = GetCExpressionValue("FnScanFindClosest(" & VarPtr(Fp) & "," & Class & "," & VarPtr(CP) & "," & r & "," & Vw & ")") End Function |
Если вы не просто копируете, а пытаетесь понять смысл написанного, то вам могут помочь мои комментарии. Хотя ничего особенно инновационного в них нет и в большинстве своем они содержат банальный перевод описания функций из официальной документации.
Пишем тестовую программу
Ну а теперь пришла пора протестировать несколько наших функций, чтобы убедиться, что приведенный код работает. Я буду проводить тестирование в среде Microstation v8. В среде Microstation CONNECT приведенный подход не работает, поэтому можете даже не пытаться. В следующий раз я приведу пример того какие доработки необходимо произвести, чтобы получить универсальный макрос, который будет работать во всех версиях Microstation.
Создадим форму с 5 кнопками, к каждой из которых в дальнейшем мы привяжем свою функцию.
Форма тестового макроса
Теперь давайте последовательно для каждой кнопки пропишем свои действия:
Сколько точек в классе №3
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | Private Sub CommandButton1_Click() ' Объявим массив для хранения значений классов ТЛС Dim PCl() As Byte ' Импортируем информацию о загруженных точках из TerraScan If FnScanGetClsArray(PCl) = 0 Then MsgBox "В TerraScan не загружены лазерные данные или их формат некорректный", vbCritical Exit Sub End If ' Посчитаем количество ТЛС в классе №3 в массиве Dim i As Long, Count As Long Count = 0 For i = LBound(PCl) To UBound(PCl) If PCl(i) = 3 Then Count = Count + 1 End If Next i ' Выведем результат MsgBox "Количество ТЛС в классе №3: " & Count & " шт." End Sub |
Максимальный номер включения
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | Private Sub CommandButton2_Click() ' Объявим массив для хранения значений включений ТЛС Dim PFl() As Long ' Импортируем информацию о загруженных точках из TerraScan If FnScanGetLinArray(PFl) = 0 Then MsgBox "В TerraScan не загружены лазерные данные или их формат некорректный", vbCritical Exit Sub End If ' Найдем максмальный номер включения Dim i As Long, MaxLin As Long MaxLin = 0 For i = LBound(PFl) To UBound(PFl) If PFl(i) > MaxLin Then MaxLin = PFl(i) End If Next i ' Выведем результат MsgBox "Максимальный номер включения: " & MaxLin End Sub |
Классификация внутри контура
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | Private Sub CommandButton3_Click() ' Проводим классификацию из класса 2 в класс 8 внутри фенса Dim Ret As Long Ret = FnScanClassifyClass(2, 8, 1) ' Выводим отчет о проведенной классификации If Ret >= 0 Then MsgBox "Классифицировано " & Ret & " ТЛС" ElseIf Ret = -1 Then MsgBox "Не найден фенс", vbCritical ElseIf Ret = -3 Then MsgBox "Неверно заданы параметры классификации", vbCritical End If End Sub |
Удаление класса №2
1 2 3 4 5 6 7 8 9 10 11 12 | Private Sub CommandButton4_Click() ' Удалим точки класса №2 вне заданного контура Dim Ret As Long Ret = FnScanDeleteClass(2, -1) ' Выводим отчет о проведенном удалении If Ret >= 0 Then MsgBox "Удалено " & Ret & " ТЛС" ElseIf Ret = -1 Then MsgBox "Не найден фенс", vbCritical End If End Sub |
Сохранение в новый файл
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | Private Sub CommandButton5_Click() Dim Ret As Long Ret = FnScanOutput("D:/TestBin.bin", "0-255", 8, 0, 3, "", -1, 0, 0, 0) Select Case Ret: Case Is >= 0 MsgBox "Сохранено " & Ret & " ТЛС" Case -1 MsgBox "Не найден фенс", vbCritical Case -2 MsgBox "Ошибка записи в файл", vbCritical Case -3 MsgBox "Неправильные параметры", vbCritical Case -4 MsgBox "Не найдена трансформация", vbCritical End Select End Sub |
Вот на эту функцию прошу обратить более пристальное внимание. Если вы посчитаете количество параметров, передаваемых в функцию, то заметите, что их количество не совпадает с тем, которое указано в документации. Это еще одна причина почему не стоит 100% доверять документации: определенные вещи в ней могут быть неактуальными и по меньшей мере запутывать пользователя.
Если какая-то функция не будет работать и будет выдавать ошибку, то можете для начала посмотреть наличие этой функции в родных макросах TerraScan и проверить достаточное ли количество параметров передаете и в том ли виде нужно передавать тот или иной параметр.
Неверное количество параметров
Заключение
Вот такое вот краткое описание возможностей взаимодействия TerraScan и Microstation посредством VBA. Надеюсь мое объяснение и небольшие примеры помогут вам понять суть и основы данного взаимодействия и вы сможете применять данные наработки в своей ежедневной работе.
В дальнейшем я покажу как реализовать тоже самое, но с использованием C# и инструментов от InnovoCAD, о которых мы говорили ранее (они как раз недавно выпустили новые версии своих инструментов).
Использование в работе C# или C++ позволит ускорить обработку большого количества данных, а также минимизирует количество используемой оперативной памяти, благодаря тому, что оба языка позволяют качественно работать с указателями.
На этом всё и всем всего!
С нетерпением ждем продолжения.
А что за странный суффикс в названии макроса: «_borisich»?
Александр, а вы догадайтесь)
смущает транслитерация «борисич»)))
Hi, I need your help. I tried below code.
FnScanFindClosest = GetCExpressionValue(«FnScanFindClosest(» & VarPtr(Fp) & «,» & Class & «,» & VarPtr(CP) & «,» & r & «,» & Vw & «)»)
But it is not work. I receive -1 after running. Do you have any help to me?
I used this function in my work and it worked.
I tried to your code like below.
Dim pnts(1) As Point3d
pnts(0) = Point3dFromXYZ(-49628.04687, -255862.255, 0)
Dim rt As Long
rt = FnScanFindClosest(pnts(1), 999, pnts(0), 2, 1)
But I receive -1. Is it wrong?
Hi. I am trying to create a surface using terramodeler and vba. But my code is not working well. It’s below.
id is integer as the index of surface.
pnts are the array of point3d as points.
FnInsertPoints = GetCExpressionValue(«FnInsertPoints(» & id & «,» & False & «,» & VarPtr(pnts(0)) & «,» & UBound(pnts) & «)», «tmodel»)
Do you have a anything to help me?