Attribute VB_Name = "MainDeclarations" 'Option Explicit Rem Public variables are declared here in this module Rem CONSTANTS Rem Maximum number of images to be displayed (0 to MAXIMA-1), e.g. 8 makes 9 images at max Public Const MAXIMA = 9 Public Const TO_RADIANS = 1.74532925199433E-02 Public Const TO_DEGREES = 57.2957795130823 Public Const pi = 3.14159265358979 Public Const CAM_TO_IMA = 0 Public Const IMA_TO_CAM = 1 Public Const N_CAND_MAX = 1000 Public Const MAXITE = 100 Rem Number of images in a SET Public NumOfImages As Integer Rem The descriptive name for the SET Public ImagesetName As String Rem An index Public pointnumber As Integer Public LastLIne As Long Public MinH As Double, maxh As Double, DotSIze As Double Public ColorMap(1 To 64, 1 To 3) As Byte Public BWColorMap(1 To 64, 1 To 3) As Byte Rem FileOut holds "C:\TEMP\PIC#.BMP" 16 character - string, Image takes palce I/O via BMP-files and Rem Picture -objects LOADIMAGE() -function Dim FileOut As String * 16 Public BatchFileName As String Public DemFileName As String Public DEMname As String Rem *************************************************************************** Rem Structs (Type) & VARS that have to do with saving / retrieving a measurement Type PlotInfo Number As Long ' Plot has an Id Radius As Double ' Radius of the plot Buffer As Double ' Additional radius, gives a buffer around the plot X As Double ' X of center, on ground Y As Double ' Y " z As Double ' Z " H_LiDAR As Double ' Maximum height of Lidar-points inside plot N_trees As Long ' Counter for tree observations X_shift As Double ' if shifted along X Y_shift As Double ' if shifted along Y Ctext As String * 60 ' Description of the plot End Type Public Plot_Info As PlotInfo Type MeasuredPoint Plot As String ' Point belongs to plot, key num As Integer ' Point Number (Id for the 3D-measurement) X As Double ' X of space intersection Y As Double ' Y of space intersection z As Double ' Z of space intersection Z_dtm As Single ' Z of GND rmse As Single ' RMSE in um of the space intersection Corr_Match As Double ' Correlation of the image matching images As Byte ' Number of images involved TreeSpecies As Byte ' Tree species as observed by the user: 1=Pine, 2=Norway spruce, 3 = Birch, 5 = Aspen, 6 Other bl. TreeStatus As Byte cf As Double ' Parameters of the crown model pw As Double cont As Double Crown_RMSE As Single ' RMSE of the lidar fit Lidar_Dcrm As Single Foto_Dcrm As Single ' Fotogrammetric Crown width Foto_h As Single Foto_Corr As Single ' Correlation of the Template MAtcihng for Crown width dbh_foto_Dcrm As Single ' dbh computed based on height, sp and foto Dcrm dbh_lidar_Dcrm As Single ' dbh " lidar Dcr, H_LiDAR As Single ' Height of the highest lidar hit X_lidar As Double ' X of the highest lidar hit Y_lidar As Double ' Y of the highest lidar hit Z_lidar As Double ' Z of the highest lidar hit FieldNumber As Integer ' Tree Number in field Data that the tree is exected to correspond to FieldHeight As Double Fielddbh As Double RefImage As Byte ' Index of the image used as reference in image matching Ima(0 To MAXIMA - 1) As Byte ' Indeces of Images involved in space intersection ImageCode(0 To MAXIMA - 1) As Long ' Indeces of Images involved in space intersection ima_x(0 To MAXIMA - 1) As Single ' Image (COL) coordinates ima_y(0 To MAXIMA - 1) As Single ' Image (ROW) coordinates TreeString As String * 30 ' Any notes End Type Public LidarFitDone As Boolean Public FotoTMdone As Boolean Type MeasuredDist ' Mäkinen et al CJFR measurements of dcrm num As Integer ' Point Number (Id for the width-measurement) X As Double ' X of space intersection Y As Double ' Y of space intersection z As Double ' Z of space intersection FieldNumber As Integer ' Tree Number in field Data that the tree is exected to correspond to FreeCode As Integer ' Free coding Ima As Byte ' Index of Image (0 to MAXIMA) ImageCode As Long ' Image code number (Label, identifies) ima_x(0 To 1) As Double ' Image x-coordinates, start-end ima_y(0 To 1) As Double ' Image y-coordinates, start-end Scalea As Single ' Image scale at given Z dist As Single ' Measured distance TreeString As String * 30 ' Any notes, 30 characters SunElev As Double SunAzi As Double SunAziDiff As Double NadirAngle As Double ObjectToCameraAzi As Double End Type Rem Measuring crown widths Public WidthMeasurements(0 To MAXIMA - 1) As MeasuredDist Public MeasurementCounter As Integer ' a counter that is updated automatically after saving a record Public Measurement As MeasuredPoint ' for writing (saving) a record Public SavedMeasurement As MeasuredPoint ' for reading a record Public TreeData(1 To 100) As MeasuredPoint ' storage to hold data (needed?) Public TreedataFilename As String ' Path & Filename where records are written / read from Public TreeDataFilesaveOk As Boolean ' A boolean that tells if the user is satisfied with the contents of the record (for SAVE) Rem ***************************************** Rem X,Y,Z Different versions of 3D-point Public X_cen As Double, Y_cen As Double, Z_cen As Double ' if the user wishes to give a coordinate to which all images are centered Public X_sol As Double, Y_sol As Double, Z_sol As Double ' current solution of space intersection is stored in these vars (copied to measurement.x, .y, .z) Public X_ini As Double, Y_ini As Double, Z_ini As Double ' Initial approx. for space resection (previous solution, or in case of failure nadir point of 2nd image | Z 2000) Public X_start As Double, Y_start As Double, Z_start As Double ' When program initiates, nadir point of 2nd image, used for initial approx. if others fail Rem ************************************************************************************************** Rem vars that have to do with warning the user of possible error in solving the correspondence problem Public initialize As Boolean Public RMSE_Beep_Level_One As Double ' A Beep -sound (alert) is set after space intersection to warn the user, specifies a level _1_ in um of RMSE) Public RMSE_Beep_Level_Two As Double ' A Beep -sound (alert) is set after space intersection to warn the user, specifies a level _2_ in um of RMSE) Public Beep_One_Frequency As Long ' Frequency in Hertz of level _1_ Beep (Beep API-function requires LONG) Public Beep_Two_Frequency As Long ' Frequency in Hertz of level _2_ Beep Public Beep_One_Duration As Long ' Duration in ms of level _1_ Beep Public Beep_Two_Duration As Long ' Duration in ms of level _1_ Beep Rem Other control vars Public Epi_Depth As Double ' Depth of epipolar lines over Z_sol in +/- meters Public StepValue As Double ' 3D-point (starting from solution) Public itestop_X As Double, itestop_Y As Double ' LS ray intersection stop criteria, m Public itestop_Z As Double Public Heigth_Limit As Double ' in plots we may want to restrict to Z > H Public Numbers_Plotted As Boolean Public Call_Clear_And_Plot_Measurements As Boolean Public After_Mouse_down_Call_Epipolar_Line As Boolean Rem ************************************************************ Rem Declarations for Elliptic kernel Cut / TEMPLATE ACQUISITION Type Point3d X As Double Y As Double z As Double End Type Type Vector3D X As Double Y As Double z As Double End Type Type Line3D p0 As Vector3D p1 As Vector3D End Type Type Point2D X As Double Y As Double End Type Type POINTAPI X As Long Y As Long End Type Type Ellipse A As Double ' length in Z-direction (um) B As Double ' length in perpendicular direction (um) X As Double ' midpoint, m, camera coords Y As Double ' midpoint, m, dX As Double ' translation because of Zasymmetry, m dY As Double ' translation because of Zasymmetry, m dx_col As Integer ' " pixels dx_row As Integer ' " pixels alpha As Double ' rotation angle (with respect to camera x-axis (positive counterclockwise) End Type Public Ellipse(0 To MAXIMA - 1) As Ellipse Rem ************************************************************************************** Rem Declarations needed in creating correlation images & computing backprojections in treetop Rem positioning with template matching Rem Metric parameters of Matching algorithm Rem Elliptic kernel Public Zdiff As Double, TemplateWidth As Double, EllipseZasymmetry As Double Rem Plot's radius, location, and XY-extent of search area Public Plotradius As Double, square_side As Double Type PlotCenter Code As String * 4 XYangle As Double X As Double Y As Double z As Double End Type Public PlotCenter As PlotCenter Rem Clustering parameters Public r_limit As Double, xy_thin As Double Rem XYZ-point set Public Meanheight As Double, Zasymmetry As Double Public gridXextent As Double, gridYextent As Double, gridZextent As Double Public gridXtess As Double, gridYtess As Double, gridZtess As Double Rem Time used for computations Public MatchDate As String * 10 ' stores the date Public CorTime(0 To MAXIMA - 1) As Double Public BackProjTime As Double Public MeshTime As Double Rem Image Codes, LONG integers Public ImageCodes(0 To MAXIMA - 1) As Long Rem Storage to hold the correlation arrays (9 x 8 x 1200 x 1200 = 104 Mbytes!, this is declared always!) Public Const maximasize = 1200 Public cor_arr(0 To MAXIMA - 1, 0 To maximasize, 0 To maximasize) As Double Public R_tau() As Double Public a_tau() As Single Public n_tau() As Long Public mC As Integer ' Number of clusters found Public n_candidate_points As Long Public cluscoords() As Point3d Public clus() As Single Public SearchSpaceData() As Point3d Public atausum() As Double Type ClusMatchStruct Index As Integer ' Index to arrays holding clus-data IsMatch As Boolean ' True for a match with a tree IsInside As Boolean IsInBorderZone As Boolean ' True for a cluster near (within half matchistance) border MatchTreeNum As Integer ' Field number of tree matching with MatchTreeSpec As Integer MatchTreeStat As Integer MatchTreed13 As Double MatchTreeh As Double MatchTreeZbuttTach As Double MatchTreeZbuttDem As Double Xtree As Double ' Coordinates of the tree top matched with YTree As Double ' " Ztree As Double ' " IsCommission As Boolean ' True for a commision error (no match found for a candidate) Dist3D As Double ' 3D distance to the matched tree NTreesInCylinder As Integer ' How many tree tops where in the match-cylinder IndecesTreesInCyl(1 To 10) As Integer Dist2dToTreesInCyl(1 To 10) As Double X As Double ' Coordinates of the cluster Y As Double ' z As Double ' Rvalue As Double ' 3D-correlation value Npoints As Integer ' Number of 3D-points that formed the cluster End Type Type TreeMatchStruct num As Integer ' Tree field number Spec As Integer ' Species Status As Integer ' Status d13 As Double ' dbh H As Double ' height X As Double ' Treetop's coordinates (using correct z-model) Y As Double ' z As Double ' ZButtTach As Double ' Elevation for butt, obtained with the ZbuttDEM As Double NclusInCylinder As Integer ' Number of clusters in the match-cylinedr of the tree IndecesClusInCyl(1 To 10) As Integer Dist2dToClusInCyl(1 To 10) As Double IndexMatchClus As Integer ' Index of the matched cluster Dist3D As Double ' 3D distance betweem the top and the cluster IsMatch As Boolean ' True for a match IsOmission As Boolean ' True for a missed tree IsInBorderZone As Boolean ' True for a cluster near (within half matchistance) border IsInside As Boolean Xclus As Double ' clusters coordinates Yclus As Double ' Zclus As Double ' End Type Type TreeVect Plot As String key As String Sptext As String X As Double Y As Double Zbutt As Double Zdem As Double Ztop As Double d13 As Double Height As Double hc As Single dcrm As Single d6 As Single age As Integer num As Long Species As Long Status As Long Vol As Double cf As Single cont As Single pw As Single rmse As Single DensityF As Single End Type Rem Accuracy checking Public FTrees() As TreeVect Public ClusMatchStruct() As ClusMatchStruct Public TreeMatchStruct() As TreeMatchStruct Type ImageInfoForOutput ImCode As Long CorrTime As Double SunA As Double SunE As Double x0 As Double y0 As Double z0 As Double End Type Type OutputVector PlotCode As String * 4 Date As String * 10 Time As String * 8 NImagesInMatch As Integer ImInfo(0 To MAXIMA - 1) As ImageInfoForOutput BkProjTime As Double ModelTreeNum As Integer ModelTreeX As Double ModelTreeY As Double ModelTreeZ As Double Rlimit As Double XYthin As Double XYMatchDist As Double ZMatchDist As Double TWidth As Double EllZasym As Double Zdiff As Double ZDepth As Double Zasym As Double Meshdist As Double Meanheight As Double Plotradius As Double PlotCenterX As Double PlotCenterY As Double PlotCenterZ As Double DigString As String * 8 NtreesInside As Integer NClusInside As Integer Nmatched As Integer Nomission As Integer NCommission As Integer MatchP As Double Mrate As Double ZbiasMatched As Double ZbiasAll As Double Xbiasmatched As Double Ybiasmatched As Double End Type Public OV As OutputVector Public pointset3D(1 To 300, 1 To 4) As Double ' Purpose ? Rem *********** IMAGE HDR CONTENTS **************** Type Orientation_information Imagetype As String ' FRAME, ADS L0, ADS L1 ImageCode As Long ' FileName As String * 120 ' Color As Byte ' 1 = 24-bit RGB, 0 = 8-bit BW, 2 = 16-bit BW, 3 = 16-bit RGB, 4 = 16-bit RGBNIR o_row As Double ' origin of subimage o_col As Double ' origin of subimage Width As Long ' width in pixels of aerial photo (main image) Height As Long ' height in pixels of aerial photo sub_c_row As Long ' sub image pan center row sub_c_col As Long ' sub image pan center col sub_width As Double ' width of sub-image (if the image is cropped) sub_height As Double ' height of subimage c As Double ' Focal lenght of camera x_ps As Double ' PPA in FC-x y_ps As Double ' PPA in FC-y lambda As Double ' Helmert scale factor alpha As Double ' Helmert angle mean_x As Double ' Mean of fiducial marks x's in PS-coords mean_y As Double X_mean As Double ' Mean of fid's in IMA-coords Y_mean As Double a_ As Double ' Affine coefficients of fiducial b_ As Double c_ As Double d_ As Double e_ As Double f_ As Double omega As Double ' exterior orientation parameters phi As Double kappa As Double Xo As Double Yo As Double Zo As Double Sun_azimuth As Double Sun_elevation As Double StartOf_string As String * 40 ' Starting row for additional exposures Num_of_addit_expos As Long ' Number of additional exposures AdditFileName(1 To 4) As String * 80 ' Image location AdditType(1 To 4) As Long ' 0 = BW 8-byte,1 = RGB 8-byte, 2 = BW 16-byte, 3 = RGBIR 16-byte AdditWidth(1 To 4) As Long ' width in pixels of aerial photo (main image) AdditHeight(1 To 4) As Long ' height in pixels of aerial photo EndOf_string As String * 60 ' Ending row for additional exposures ADSADSFILENAME As String * 120 ADSSUPFILENAME As String * 120 ADSCAMFILENAME As String * 120 ADSODFFILENAME As String * 120 End Type Rem Each of the windows holding images on Form1 has these values Type Window_information win_o_col As Long ' the col value(in main image coord system) of the origo in the picture-box win_o_row As Long win_width As Long ' width of the picture-box win_height As Long pan_x As Double ' Zoom factor pan_x = pan_y , 1 = No Zooming pan_y As Double End Type Rem Each pixel in the RAW-image files consists of R-,G- and B-value. Type RGBtriplet r As Byte G As Byte B As Byte End Type Rem Each Each pixels in a Windows BMP-file consists of a B,G R-value (in this order) Type RGBQ B As Byte G As Byte r As Byte End Type Rem win_info() -array stores pan-information Public win_info(0 To MAXIMA - 1) As Window_information Public cor_win_info(0 To MAXIMA - 1) As Window_information Rem image_info() -array stores image information 'Public image_info(0 To MAXIMA - 1) As Orientation_information Public image_info(0 To 700) As Orientation_information Public cor_ima_info(0 To MAXIMA - 1) As Orientation_information Rem 3D-rotation Matrices for (0 to MAXIMA-1) images 'Public A(1 To 3, 1 To 3, 0 To MAXIMA - 1) Public A(1 To 3, 1 To 3, 0 To 700) Rem Image-data (RGB) is stored for (0 to MAXIMA-1) images in a RGBtriplet array kuva() Public kuva() As RGBtriplet Rem Stores index of last mousedown-event in a pictureBox (used with VLL) Public LastImageClicked As Integer Rem Once there's a solution (X,Y,Z) of space intersection, this VAR i set to True, and we may use the solution Rem of the previous measured 3D-point as the startpoint (approximation) of the next iteration. Public SolutionExists As Boolean 'Public Imagesdisplayed(0 To MAXIMA - 1) As Integer Public Imagesdisplayed(0 To 700) As Integer Public Const AER_IMA = 1 Public Const CORR_IMA = 2 Public Const ADS_IMA = 3 Rem Global variables to VARS that hold min and max indeces of pixel-locations that make up the picture-box's area. Rem All picture Boxes are of equal size (an even number). win_w is width and win_h height. Public Win_w As Integer Public win_h As Integer Rem CCOR is used for computing VLL crosscorrelation Declare Function MYFUNC_TEMPMEANSTD Lib "c:\data\pascaldll.dll" (ByRef v1 As Byte, ByVal w As Long, ByVal H As Long, ByRef meanofimage As Double, ByRef STdOfImage As Double) As Double Declare Function MYFUNC_CCORA Lib "c:\data\pascaldll.dll" (ByRef im1 As Byte, ByRef im2 As Byte, ByRef r As Double, ByRef meanA As Double, ByRef TempS As Long) As Double Declare Function MYFUNC_CCORB Lib "c:\data\pascaldll.dll" (ByRef tempim1 As Byte, ByRef refim2 As Byte, ByRef r As Double, ByRef meantempim As Double, ByRef TempWidth As Long, ByRef TempHeight As Long) As Double Declare Function MYFUNC_CCOR Lib "c:\data\pascaldll.dll" (ByRef v1 As Byte, ByVal N1 As Integer, ByVal m1 As Integer, ByRef v2 As Byte, ByVal N2 As Integer, ByVal m2 As Integer, ByVal ima1_x As Integer, ByVal ima1_y As Integer, ByVal ima2_x As Integer, ByVal ima2_y As Integer, ByVal w_temp As Integer, ByVal h_temp As Integer) As Double Rem FLOOR is just a call to C-type floor() -function (which does not exist in VB) Declare Function MYFUNC_FLOOR Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Declare Function MYFUNC_CEIL Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Declare Function MYFUNC_TEST Lib "c:\data\pascaldll.dll" (ByRef v1 As String) As Double Declare Function MYFUNC_ASIN Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Declare Function MYFUNC_ACOS Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Declare Function MYFUNC_ATAN2 Lib "c:\data\pascaldll.dll" (ByVal v1 As Double, ByVal v1 As Double) As Double Declare Function MYFUNC_ATAN Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Declare Function MYFUNC_CREATEBMP Lib "c:\data\pascaldll.dll" (ByRef lfile As Byte, ByRef rfile As Byte, ByRef ofile As Byte, ByVal Index As Long, ByVal lstartcol As Long, ByVal rstartcol As Long, ByVal lstartrow As Long, ByVal rstartrow As Long, ByVal lendcol As Long, ByVal lendrow As Long, ByVal rendcol As Long, ByVal rendrow As Long, ByVal pan_x As Double, ByVal pan_y As Double, ByVal nwidth As Long, ByVal nheight As Long, ByVal stereoheight As Long, ByVal stereowidth As Long, ByVal colormodel As Long) As Double Declare Function MYFUNC_CORIMA Lib "c:\data\pascaldll.dll" (ByRef v1 As Byte, ByVal na As Integer, ByVal ma As Integer, ByRef t1 As Byte, ByVal wt As Integer, ByVal ht As Integer, ByVal c_col As Integer, ByVal c_row As Integer, ByRef rk As Double) As Double Declare Function MYFUNC_CREATENORMALIZEDIMAGE Lib "c:\data\pascaldll.dll" (ByVal c As Double, ByVal nwidth As Long, ByVal nheight As Long, ByVal Owidth As Long, ByVal Oheight As Long, ByRef filename_in As Byte, ByRef filename_out As Byte, ByRef PixelSize As Double, ByRef af As Double, ByRef r As Double) As Double Declare Function MYFUNC_READBINARYFILES Lib "c:\data\pascaldll.dll" (ByRef v1 As Byte, ByVal lstartrow As Long, ByVal rstartrow As Long, ByVal lstartcol As Long, ByVal rstartcol As Long, ByVal lendcol As Long, ByVal nwidth As Long) As Double Declare Function MYFUNC_MAKE3DPOINTS Lib "c:\data\pascaldll.dll" (ByVal origoX As Double, ByVal origoY As Double, ByVal origoZ As Double, ByVal gridXextent As Double, ByVal gridYextent As Double, ByVal gridZextent As Double, ByVal gridXtess As Double, ByVal gridYtess As Double, ByVal gridZtess As Double, ByVal XYrotangle As Double, ByRef FileName As Byte, ByVal strlen As Long) As Long Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal ncount As Long, lpObject As Any) As Long Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long Public Declare Function MYFUNC_COMPUTEBKPROJ Lib "c:\data\pascaldll.dll" (ByVal Nimage As Long, ByVal Npoints As Long, ByRef af As Double, ByRef ori As Double, ByRef cimainfo As Double, ByRef atau As Single, ByRef SSpace As Double, ByRef cor_arr As Double) As Long Public Declare Function MYFUNC_MATLABCALLNOMSGS Lib "c:\data\pascaldll.dll" (ByVal v1 As Double) As Double Public Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal ncount As Long) As Long Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long Public Declare Function rectangle Lib "gdi32" Alias "Rectangle" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Public Declare Function Ellipsi Lib "gdi32" Alias "Ellipse" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpstring As String, ByVal ncount As Long) As Long Declare Function MYFUNC_CASTIMAGERAYANDFINDCLOSESTLIDAR Lib "c:\data\pascaldll.dll" (ByRef x1 As Point3d, ByRef ray As Point3d, ByRef x2 As Point3d, ByRef PMin As Point3d, ByRef PMax As Point3d, ByVal distlimit As Double, ByRef MaxI As Long, ByRef TopPoint As Point3d) As Long Declare Function MYFUNC_CAST_IMAGE_RAY_AND_FIND_CLOSEST_RIEGL_LIDAR Lib "c:\data\ile.dll" (ByRef x1 As Point3d, ByRef ray As Point3d, ByRef x2 As Point3d, ByRef PMin As Point3d, ByRef PMax As Point3d, ByVal distlimit As Double, ByRef MaxI As Long, ByRef TopPoint As Point3d) As Long Declare Function MYFUNC_CAST_IMAGE_RAY_AND_FIND_CLOSEST_43BYTE_LIDAR Lib "c:\data\ile.dll" (ByRef x1 As Point3d, ByRef ray As Point3d, ByRef x2 As Point3d, ByRef PMin As Point3d, ByRef PMax As Point3d, ByVal distlimit As Double, ByRef MaxI As Long, ByRef TopPoint As Point3d) As Long Declare Function MYFUNCLARGEFILE Lib "c:\data\ile.dll" (ByRef fname As Byte) As Long Public Declare Function MYFUNC_MOMENT Lib "c:\data\pascall.dll" (ByRef data As Double, ByVal N As Long, ByRef ave As Double, ByRef adev As Double, ByRef sdev As Double, ByRef var As Double, ByRef skew As Double, ByRef curt As Double) As Long Public Type Size Cx As Long Cy As Long End Type Public Declare Function GetWindowExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As Size) As Long Const BI_RGB = 0& Rem RGBQUAD type is needed for DIB Rem DMC four channel images Type RGBN r As Byte G As Byte B As Byte N As Byte End Type Type RGBNIRPAN r As Integer G As Integer B As Integer NIR As Integer PAN As Integer End Type Type RGBNIR r As Integer G As Integer B As Integer NIR As Integer End Type Type RGBQUAD1 B As Byte G As Byte r As Byte N As Byte End Type Type RGBQUAD rgbblue As Byte rgbGreen As Byte rgbred As Byte rgbreserved As Byte End Type Rem The 14 byte file header that starts the BMP-file Type BITMAPFILEHEADER bfType As Integer ' always BM bfSize As Long ' size of file in bytes bfReserved1 As Integer ' always zero bfReserved2 As Integer ' always zero bfOffBits As Long ' the offset to first pixel (55 for true color images with no color-table) End Type Rem The 40-Byte BITMAPINFOHEADER follows the file header Type BITMAPINFOHEADER biSize As Long ' 40 for 40 Bytes (this could be sizeof(BITMAPINFOHEADER), but there's no sizeof() in VB) biWidth As Long ' image width in pixels biHeight As Long ' image height in pixels, if a negative number, the image is stored with low-left corner first biPlanes As Integer ' 1 biBitCount As Integer ' 24 for true-color biCompression As Long ' 0 " biSizeImage As Long ' 0 " biXPelsPerMeter As Long ' 0 " biYPelsPerMeter As Long ' 0 " biClrUsed As Long ' 0 " biClrImportant As Long ' 0 " End Type Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Rem ALTM2033 type of LiDAR records Type ALS_Point GPS_time As Double ' 8 Xl As Double ' 8 yl As Double ' 8 zl As Single ' 4 omega As Single ' 4 phi As Single ' 4 kappa As Single ' 4 Scan_angle As Single ' 4 Xf As Double ' 8 Yf As Double ' 8 Zf As Single ' 4 Intf As Single ' 4 Rangef As Single ' 4 Xs As Double ' 8 Ys As Double ' 8 Zs As Single ' 4 Ints As Single ' 4 Rangel As Single ' 4 End Type ' 100 bytes per pulse Public lp As ALS_Point Public LP_Arr() As ALS_Point Rem This is for the ESPOO data from FGI Type LP_Espoo echo As String * 5 X As Double Y As Double z As Single intensity As Single Int_ori As Byte Int_range_norm As Single Sensor As Integer Npulses As Byte End Type Public LPE_AR() As LP_Espoo Type LP_Suo X As Double Y As Double z As Single intensity As Single Strip As Integer Nechoes As Byte End Type Public LP_Suo() As LP_Suo Type Ltree ' LiDAR tree X As Double Y As Double z As Single H As Single NLP As Long cf As Double ' coefficient of crown model pw As Double ' coefficient of crown model cont2 As Double ' coefficient of crown model End Type Public Trees() As Ltree Public Tree As Ltree Type Hyde_Tree ' ANother descriptoin of a tree Xtop As Double Ytop As Double Ztop As Double ZDtm As Double sp As Byte dcrm As Double End Type Type SaplingObs_LiDAR ' Seedling stand study 2007-2008, feature selection id As Long Stand As Long PointType As Long X As Double Y As Double zgnd As Double Ztop As Double ZtopUsed As Double class As Long Cond As Long Height As Double Z_dtm As Double N_in_05 As Long N_in_07 As Long Closest_Point As Point3d Range_Closest As Double GHR_05 As Double GHR_07 As Double H_LiDAR3 As Double H_LiDAR1 As Double Int_Raw As Double Int_Norm As Double End Type Rem ***************************************** Rem Declarations for raster models (DTM / CHM) Type height_model Ncols As Double Nrows As Double xllcorner As Double yllcorner As Double Cellsize As Double nodata_value As Double filepath As String * 80 End Type Public Zmodel As height_model Public ZfXY() As Single Public CHMmodel As height_model Public CHMZfXY() As Single Public RasterModelReady As Boolean Rem TINs stuff Public TINModelReady As Boolean Public TINCHMModelReady As Boolean Rem Declarations for measuring crown diameter Public Pixel_width As Double Public FirstPointMeasured As Boolean Public SecondPointMeasured As Boolean Public Firstpixel As Point2D Public SecondPixel As Point2D Public crown_width As Double Rem DATA type for checking points in massive sets of stereo-pairs Type Ima_obs Point As Long Im As Long X As Double Y As Double End Type Public IM_OBS() As Ima_obs Type Ground_OBS Point As Long Type As Long X As Double Y As Double z As Double End Type Public GND_OBS() As Ground_OBS Rem Declarations for TIN-dem Type D3point id As Long X As Double Y As Double z As Double End Type Public Nodes() As D3point Type Point X As Double Y As Double End Type Type peakinfo ' waveform peak Ismax As Boolean Index As Single End Type Type WFsegment start As Single end As Single Npeaks As Long maxpeak As Long fwhm As Double length As Double energy As Double rise As Double pA As Double peaks(1 To 10) As peakinfo End Type Type triangle i As D3point '24 j As D3point '24 k As D3point '24 poly(0 To 2) As Point ' 3*2*8 = 48 needed? A As Double ' 8 single B As Double ' 8 single c As Double ' 8 single d As Double ' Surface equation Ax + By + Cz = D, is D needed if it is 0 8 xmin As Double ' 8 Ymin As Double ' 8 xmax As Double ' 8 ymax As Double ' 8 End Type ' 176 Bytes 2,000,000 * 176 = 352 Mbytes Public N_CHM_tri As Long Public N_CHM_Nodes As Long Public CHM_Nodes() As D3point Public CHM_Tri() As triangle Public East_IND() As Long Public CHM_TRI_east_IND() As Long Public N_Nodes As Long Public N_tri As Long ' number of triangles in the Tri-NODES -TIN model Public MinX1 As Double, MinY1 As Double, MaxY1 As Double, MaxX1 ' 1-Hectare addresses with respect to these Public Tri() As triangle Public KuvioRaj() As Point Rem Declarations needed in computing ZONAL_calc images Type ROwColIdTrip col As Long row As Long id As Long End Type Type SaplingStandObs X As Double Y As Double z As Double id As Long Radius As Double End Type Type TreeStruct ' May 2014 holds the trees to be checked in aerial images / LiDAR Serial As Long Plot As String Tree As String Code As String Geoloc_type As Byte meas_yr As Integer sp As Byte statusOld As Byte d13 As Single Height As Single Xnew As Double Ynew As Double Znew As Single statusnew As String C2010_2011 As Integer status2013 As String measured2013 As Integer Fha1 As String Fha2 As String BorderCase As Byte cf As Single cont As Single pw As Single rmse As Single DensityF As Single End Type Public MyTrees() As TreeStruct Rem Laserpoints (ALTM 2033 point data (not pulse data)) Type Lpoint Type As Byte X As Double Y As Double z As Single Ints As Single End Type Rem 2006 ALTM 3100 pulse data, 207 bytes per record Type LidarRecord GPStime As Double pulseCount As Byte Returns(1 To 4) As Point3d intensity(1 To 4) As Integer range(1 To 4) As Double angle As Double Roll As Double pitch As Double heading As Double PosLidar As Point3d StripNum As Integer SyncBit As Byte Res1 As Byte Res2 As Byte Res3 As Byte End Type Public Lidr() As LidarRecord Type sVector3d i As Single j As Single k As Single End Type Type P3d X As Double Y As Double z As Single End Type ' FOR254 (2018) 43-byte type Type For254Record return As P3d '20 intensity As Integer '2 angle As Byte ' 1 pulseCount As Byte ' 1 RetNum As Byte '1 Wavelen As Byte '1 AGC As Byte '1 range As Single '4 DirVect As sVector3d ' 12 End Type Public FLidr() As For254Record Type LidarRecord2010 GPStime As Double pulseCount As Byte Returns(1 To 4) As Point3d intensity(1 To 4) As Integer range(1 To 4) As Double angle As Double Roll As Single 'Wavetype As Byte ' 0, 128, or 256 'Dummy1 As Byte 'Dummy2 As Byte 'Dummy3 As Byte Fileoffset As Long ' byte 1, int 2, long 4 pitch As Double ' Single 4, Double 8 heading As Double PosLidar As Point3d StripNum As Integer ' int 2 tavun SyncBit As Byte Res1 As Byte Res2 As Byte wavetype As Byte End Type Public LidR2010() As LidarRecord2010 Public LdR1() As LidarRecord Public LdR2() As LidarRecord Public LdR3() As LidarRecord Type EchoRiegl pos As Point3d intensity As Integer Pointer As Long WaveSampleSize As Integer RetPointWFLoc As Single End Type Type PulseRIegl echocount As Byte GPStime As Double ByteLAS As Byte Echoes() As EchoRiegl ScanAngle As Byte PosLidar As Point3d StripNum As Byte End Type Public LiDRiegl() As PulseRIegl Type Point_3d X As Double Y As Double z As Single End Type Type EchoRiegl_1560 ' A discrete-return, there can be 1-10 in a pulse emitted pos As Point_3d ' XYZ of the echo intensity As Integer ' Intensity by RiProcess class As Byte ' classification End Type Type PulseRIegl_1560 ' A whole pulse-record echocount As Byte ' Tells how many echoes RiProcess extracted (EchoRiegls) GPStime As Double ' Seconds ByteLAS As Byte ' Byte copied from LAS-file, contains: return number, overall ScanAngle As Byte ' "Scan Angle Rank" -field copied from LAS PosLidar As Point_3d ' XYZ of LiDAR Receiver As Byte ' Which of the two StripNum As Byte ' Identifier for a strip Echoes() As EchoRiegl_1560 End Type Public Lidr1560() As PulseRIegl_1560 Public OLD_FN1 As String * 3 ' The address of currect hectare file (of LiDR) Public OLD_FN2 As String * 3 Type IntStruct ' for LiDAR features XYdist As Double Zdist As Double IntRaw As Double IntRange As Double IntFused As Double End Type Type ResultStruct mean_surface As IntStruct SD_surface As IntStruct curt_surface As IntStruct skew_surface As IntStruct p_surface As Single p_first As Single p_only As Single p_inter As Single p_last As Single int1234(1 To 4) As IntStruct hd(0 To 10) As Double ph(0 To 10) As Double pint(0 To 10) As IntStruct End Type Public Type Mask_info FileName As String * 60 Origo_X As Double Origo_Y As Double Resol As Double Cols As Long Rows As Long End Type Public WaterMaskInfo As Mask_info Public TreeMaskInfo As Mask_info Public WaterMask() As Byte Public TreeMask() As Byte Rem Struct to hold information in WF-feature estimation (12/2014) Type WF_peak pos As Single ' Time in nanoseconds from first wf-sample, assume 10 peaks X As Double Y As Double z As Double length As Byte ' How many consecutive samples above noise level Npeaks As Byte ' Number of other peaks in the sequence End Type Public WFPeak As WF_peak Public P() As Point Public Cpu As String Public NCounter As Long Public Const Inside = 1 Public Const OUTSIDE = 0 Rem Declarations for Image matching Public TempWidth As Long Public Rlim As Double Public CV_limit As Double Public Z_depth As Double Public Z_step As Double Public Spacing As Double Public ImageMatchingOutPutFile As String Public Sub Qhull(CoorDlist As Point2D) Rem this algorithm produces the Convex Hull of a 2D point set in CoordList End Sub Public Sub Mark_And_Plot(rmse As Double, Hlimit As Double, Hlowest As Double, maxA As Long, Ntrees As Long, LPE_SP() As Byte, Hftau() As Single, Hfind() As Long, sade() As Single, XYdist() As Single, Zdist() As Single, Trees() As Ltree, LPTreeHit() As Boolean) Rem Now should we mark again those lidar points that have been used Rem Dim Colorpix As Long Dim p_x As Double, p_y As Double, H As Double Select Case LPE_SP(Ntrees) Case 1 Colorpix = RGB(255, 0, 0) Case 2 Colorpix = RGB(0, 255, 0) Case 3 Colorpix = RGB(0, 0, 255) Case 4 Colorpix = RGB(255, 255, 0) Case 0 Colorpix = RGB(128, 128, 128) End Select aa = Trees(Ntrees).NLP ' = 0 ' why is zero? H = Trees(Ntrees).H Select Case LPE_SP(Ntrees) Case 0, 1, 3, 4 Hlow = 0.7 * Trees(Ntrees).H Case 2 Hlow = 0.5 * Trees(Ntrees).H End Select 'If Hlow < Hlimit Then ' Hlow = 0.7 * Hlimit 'End If 'Aw = Hlimit For i = UBound(Hftau) To 1 Step -1 If Hftau(Hfind(i)) > (Hlow) And LPTreeHit(Hfind(i)) = False Then XYdist(maxA) = Sqr((LPE_AR(Hfind(i)).X - Trees(Ntrees).X) ^ 2 + (LPE_AR(Hfind(i)).Y - Trees(Ntrees).Y) ^ 2) Zdist(maxA) = (Trees(Ntrees).H - Hftau(Hfind(i))) Rem Crown radius, given height and species and current three parameters cf, pw, cont2 'sade(maxA) = ((Trees(Ntrees).cf * h * (zdist(maxA) / h) ^ Trees(Ntrees).pw + Trees(1).cont2)) * 1.15 If Zdist(maxA) < 0 Then Zdist(maxA) = 0.01 sade(maxA) = (Trees(Ntrees).cf * H * Sin(4 * ((Zdist(maxA) + 0.001) / H)) ^ Trees(Ntrees).pw + Trees(Ntrees).cont2) * 1.2 Rem Increase sade by 20 % If sade(maxA) > XYdist(maxA) Then ' Or xydist(maxA) < (h / 20) Then ' Call r_transform_ground_to_pixel(1, LPE_AR(Hfind(i)).X, LPE_AR(Hfind(i)).Y, LPE_AR(Hfind(i)).z, p_x, p_y) ' Form1.Picture1(1).DrawWidth = 2 ' Form1.Picture1(1).PSet ((p_x - (image_info(1).o_col + win_info(1).win_o_col)) * win_info(1).pan_x - 1, ((image_info(1).Height - 1) - p_y - (image_info(1).o_row + win_info(1).win_o_row)) * win_info(1).pan_y - 1), Colorpix DoEvents Trees(Ntrees).NLP = Trees(Ntrees).NLP + 1 LPTreeHit(Hfind(i)) = True End If End If TakeNext: Next i 'Form1.Label10.Caption = "Done Fitting, iterations: " & Nite & " RMSE " & Format$(RMSE, "0.00 m") Dim Xt As Double, Zt As Double, Yt As Double, Xf As Double, Yf As Double Dim Zdiff As Double, p_x_beg As Double, p_y_beg As Double, p_x_end As Double, p_y_end As Double 'Colorpix = RGB(255, 255, 255) 'If RMSE > 0.7 Then GoTo OhitaPiirto If rmse > 0.5 Then Colorpix = RGB(255, 255, 255) For i = 0 To NumOfImages - 1 Call r_transform_ground_to_pixel(i, Trees(Ntrees).X, Trees(Ntrees).Y, Trees(Ntrees).z, p_x, p_y) Form1.Picture1(i).DrawWidth = 5 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix Next i 'If RMSE > 1 Then GoTo OhitaPiirto ' GoTo OhitaPiirto Select Case LPE_SP(Ntrees) Case 1 Colorpix = RGB(255, 0, 0) Case 2 Colorpix = RGB(0, 255, 0) Case 3 Colorpix = RGB(0, 100, 255) Case 4 Colorpix = RGB(255, 255, 0) Case 0 Colorpix = RGB(128, 128, 128) End Select 'apu = MIN(Hlowest, 0.3 * Trees(Ntrees).h) apu = 0.4 * Trees(Ntrees).H For Zdiff = 0 To apu Step 1.5 Zt = Trees(Ntrees).z - Zdiff Radius = (Trees(Ntrees).cf * Trees(Ntrees).H * Sin(4 * ((Zdiff) / H)) ^ Trees(Ntrees).pw + Trees(Ntrees).cont2) * 1 mx = 0 Shift = 3.14 / 10 For phi = -3.14 To 3.15 Step 3.14 / 8 Xt = Radius * Cos(phi) + Trees(Ntrees).X Yt = Radius * Sin(phi) + Trees(Ntrees).Y Xf = Radius * Cos(phi + Shift) + Trees(Ntrees).X Yf = Radius * Sin(phi + Shift) + Trees(Ntrees).Y Rem Using Line-method draw the crown For i = 0 To NumOfImages - 1 'DistA = ((image_info(i).Xo - Xt) ^ 2 + (image_info(i).Yo - Yt) ^ 2) 'DistB = ((image_info(i).Xo - Trees(Ntrees).X) ^ 2 + (image_info(i).Yo - Trees(Ntrees).Y) ^ 2) 'If (DistA + 1) > DistB Then Call r_transform_ground_to_pixel(i, Xt, Yt, Zt, p_x_beg, p_y_beg) Call r_transform_ground_to_pixel(i, Xf, Yf, Zt, p_x_end, p_y_end) Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).ForeColor = RGB(255, 255, 255) Form1.Picture1(i).Line ((p_x_beg - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_beg - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1)-((p_x_end - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_end - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix 'End If Next i Next phi Next Zdiff ' NCounter = NCounter + 1 ' SavePicture Form1.Picture1(1).Image, "c:\temp\AVI\" & Format$(NCounter, "0000") & ".bmp" OhitaPiirto: DoEvents End Sub Public Sub Find_Next_Tree(rmse As Double, maxA As Long, Hlowest As Double, Ntrees As Long, Hlimit As Double, Hftau() As Single, Hfind() As Long, Trees() As Ltree, LPE_AR() As LP_Espoo, LPTreeHit() As Boolean, XYdist() As Single, Zdist() As Single, sade() As Single, Inpoints() As Point3d, Z_gnd() As Single, LPE_SP() As Byte, cf() As Double, pw() As Double, cont2() As Double, A_MAT() As Double, LA() As Double) Rem (c) Ilkka Korpela May 2006 Rem Rem This subroutine operates with Rem (1) a set of already mapped tree crowns in Trees() - struct Rem (2) a set of lidar points, some of which are already marked as "used" in LPTreeHit() -array Rem Rem Array LPE_AR() contains the raw lidar data Rem Array Z_gnd() has ground elevations Rem Indec array Hfind() has the sorted order of ground normalized heights in Hftau() Dim Xsum As Double, Ysum As Double, H As Double Dim i As Long, k As Long, j As Long Dim red As Double, green As Double, blue As Double, testpoint As Point3d Dim p_x As Double, p_y As Double Rem The search for treetop positions is limited above Hlimit For i = UBound(Hftau) - 1 To 1 Step -1 If Hftau(Hfind(i)) > Hlimit And LPTreeHit(Hfind(i)) = False Then Rem We found the next highest, non-used point, it makes a tree top candidate Ntrees = Ntrees + 1 Trees(Ntrees).X = LPE_AR(Hfind(i)).X Trees(Ntrees).Y = LPE_AR(Hfind(i)).Y Trees(Ntrees).z = LPE_AR(Hfind(i)).z Trees(Ntrees).H = LPE_AR(Hfind(i)).z - Z_gnd(Hfind(i)) H = Trees(Ntrees).H testpoint.X = Trees(Ntrees).X testpoint.Y = Trees(Ntrees).Y testpoint.z = Trees(Ntrees).z LPTreeHit(Hfind(i)) = True ' Call r_transform_ground_to_pixel(1, Trees(Ntrees).X, Trees(Ntrees).Y, Trees(Ntrees).z, p_x, p_y) ' Form1.Picture1(1).DrawWidth = 5 ' Form1.Picture1(1).PSet ((p_x - (image_info(1).o_col + win_info(1).win_o_col)) * win_info(1).pan_x - 1, ((image_info(1).Height - 1) - p_y - (image_info(1).o_row + win_info(1).win_o_row)) * win_info(1).pan_y - 1), RGB(255, 255, 255) ' Form1.Picture1(1).DrawWidth = 1 DoEvents Rem Solve species from image j, assign basic crown parameters j = 1 Call RGB_Vector_For_Point(red, green, blue, testpoint, CLng(j)) LPE_SP(Ntrees) = FindSpecies(CDbl(red), CDbl(green), CDbl(blue), CDbl(1)) Trees(Ntrees).cf = cf(LPE_SP(Ntrees)) Trees(Ntrees).pw = pw(LPE_SP(Ntrees)) Trees(Ntrees).cont2 = cont2(LPE_SP(Ntrees)) k = i GoTo Found End If Next i Found: Rem The search for crown points is restricted. Assume relative crown lenght according to species Select Case LPE_SP(Ntrees) Case 0, 1, 3, 4 Hlow = 0.7 * Trees(Ntrees).H Case 2 Hlow = 0.5 * Trees(Ntrees).H End Select Hlowest = 0 Rem Find lidar points that possibly make the crown points For i = k To 1 Step -1 If Hftau(Hfind(i)) > Hlow And LPTreeHit(Hfind(i)) = False Then Rem Distances to candidate XYdist(maxA) = Sqr((LPE_AR(Hfind(i)).X - Trees(Ntrees).X) ^ 2 + (LPE_AR(Hfind(i)).Y - Trees(Ntrees).Y) ^ 2) Zdist(maxA) = (Trees(Ntrees).H - Hftau(Hfind(i))) Rem Crown radius, given height and species and current three parameters cf, pw, cont2 sade(maxA) = Trees(Ntrees).cf * Trees(Ntrees).H * Sin(4 * (Zdist(maxA) / Trees(Ntrees).H)) ^ Trees(Ntrees).pw + Trees(Ntrees).cont2 If sade(maxA) > XYdist(maxA) And Zdist(maxA) < (H - Hlow) Then Rem Distance to top (downwards) LPTreeHit(Hfind(i)) = True Trees(Ntrees).NLP = Trees(Ntrees).NLP + 1 XYdist(Trees(Ntrees).NLP) = XYdist(maxA) ' Exit Sub Zdist(Trees(Ntrees).NLP) = Zdist(maxA) If Zdist(maxA) > Hlowest Then Hlowest = Zdist(maxA) Rem Collect observations: Points XYZ Inpoints(Trees(Ntrees).NLP).X = LPE_AR(Hfind(i)).X Xsum = Xsum + LPE_AR(Hfind(i)).X Inpoints(Trees(Ntrees).NLP).Y = LPE_AR(Hfind(i)).Y Ysum = Ysum + LPE_AR(Hfind(i)).Y Inpoints(Trees(Ntrees).NLP).z = LPE_AR(Hfind(i)).z ' LPTreeHit(Hfind(i)) = True Call r_transform_ground_to_pixel(1, LPE_AR(Hfind(i)).X, LPE_AR(Hfind(i)).Y, LPE_AR(Hfind(i)).z, p_x, p_y) Form1.Picture1(1).DrawWidth = 1 Form1.Picture1(1).PSet ((p_x - (image_info(1).o_col + win_info(1).win_o_col)) * win_info(1).pan_x - 1, ((image_info(1).Height - 1) - p_y - (image_info(1).o_row + win_info(1).win_o_row)) * win_info(1).pan_y - 1), RGB(255, 156, 60) End If End If Next i Close (6) If Trees(Ntrees).NLP < (25) Then Rem It is not a tree, leave the routine Form1.Label10.Caption = "Fitting FAIL, too few points: " & Trees(Ntrees).NLP Ntrees = Ntrees - 1 Exit Sub End If Rem Check the distribution of the point cloud, omit if not a center Xsum = Xsum / CDbl((Trees(Ntrees).NLP)) If Abs((Trees(Ntrees).X - Xsum)) < 0.6 Then Trees(Ntrees).X = Xsum Ysum = Ysum / CDbl((Trees(Ntrees).NLP)) If Abs((Trees(Ntrees).Y - Ysum)) < 0.6 Then Trees(Ntrees).Y = Ysum NITE = 0 StartOfFitModel: Dim P As Double rmse = 0 P = 1 Call FitModel(rmse, Hlowest, Ntrees, XYdist(), sade(), Zdist(), Trees(), LA(), A_MAT(), P) apu = MYFUNC_MATLABCALLNOMSGS(CDbl(1)) NITE = NITE + 1 'Exit Sub Open "c:\data\corr_vectN.txt" For Input As 1 Input #1, Dcf Input #1, Dpw Input #1, Dcont2 Close (1) If Abs(Dcf) < 0.001 And Abs(Dpw) < 0.001 And Abs(Dcont2) < 0.001 Then GoTo DoneFitting If NITE > 20 Then GoTo DoneFitting Trees(Ntrees).cf = Trees(Ntrees).cf + Dcf Trees(Ntrees).pw = Trees(Ntrees).pw + Dpw Trees(Ntrees).cont2 = Trees(Ntrees).cont2 + Dcont2 If Trees(Ntrees).pw < 0 Or rmse > 3 Then Trees(Ntrees).pw = 0.7 Trees(Ntrees).cont2 = 0.6 Trees(Ntrees).cf = 0.15 End If GoTo StartOfFitModel Rem Let's draw the crown in the images DoneFitting: If rmse > 1.2 Then Rem It is not a tree Form1.Label10.Caption = "Fitting FAIL, iterations: " & NITE & " RMSE " & Format$(rmse, "0.00 m") & " in " & Trees(Ntrees).NLP & " points" Ntrees = Ntrees - 1 Exit Sub End If Rem Check if the h and CW(h-0.5h) make sense sade(maxA) = Trees(Ntrees).cf * Trees(Ntrees).H * Sin(4 * ((Trees(Ntrees).H * 0.5) / Trees(Ntrees).H)) ^ Trees(Ntrees).pw + Trees(Ntrees).cont2 If sade(maxA) / Trees(Ntrees).H < 0.05 Or sade(maxA) / Trees(Ntrees).H > 0.15 Then Rem It is not a tree! Form1.Label10.Caption = "Fitting FAIL/CROWN RATIO: " & NITE & " RMSE " & Format$(rmse, "0.00 m") & " in " & Trees(Ntrees).NLP & " points" Ntrees = Ntrees - 1 Exit Sub End If Form1.Label10.FontSize = 8 Form1.Label10.Caption = "Done Fitting, iterations: " & NITE & " RMSE " & Format$(rmse, "0.00 m") & " in " & Trees(Ntrees).NLP & " points" End Sub Public Sub FitModel(rmse As Double, Hlowest As Double, Ntrees As Long, XYdist() As Single, sade() As Single, Zdist() As Single, Trees() As Ltree, LA() As Double, A_MAT() As Double, P As Double) Rem We have observations of crown radius in xydist() -array Rem estimated " " in sade() -array Dim H As Double Open "c:\data\A_txt.txt" For Output As 1 Open "c:\data\L_txt.txt" For Output As 2 Close (3) Dim pi As Double Open "c:\data\weights.txt" For Output As 3 H = Tree.H rmse = 0 For i = 1 To Tree.NLP If Zdist(i) > Hlowest Then Hlowest = Zdist(i) j = j + 1 sade(i) = Tree.cf * H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw + Tree.cont2 LA(j) = XYdist(i) - sade(i) rmse = rmse + LA(j) ^ 2 A_MAT(j, 1) = H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw ' d(Sade)/d(cf) A_MAT(j, 2) = Tree.cf * H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw * Log(Sin(4 * ((Zdist(i) + 0.01) / H))) A_MAT(j, 3) = 1 For kX = 1 To 3 Print #1, j & " " & kX & " " & A_MAT(j, kX) Next kX Print #2, LA(j) If LA(j) < 0 Then Print #3, 1 / P Else Print #3, 1 + 0.0000000000012 End If Next i Open "c:\Data\matlab.txt" For Output As 4 Print #4, j & " " & 3 & " " & 3 * j Close (4) Close (1) Close (2) Close (3) rmse = Sqr(rmse / Tree.NLP) Rem Solve the system of equations End Sub Public Sub FitModelB(rmse As Double, Hlowest As Double, Ntrees As Long, XYdist() As Single, sade() As Single, Zdist() As Single, Trees() As Ltree, LA() As Double, A_MAT() As Double, P As Double, A0 As Double, c0 As Double, Wa As Double, Wc As Double) Rem We have observations of crown radius in xydist() -array Rem estimated " " in sade() -array Dim H As Double Open "c:\data\A_txt.txt" For Output As 1 Open "c:\data\L_txt.txt" For Output As 2 Close (3) Dim pi As Double Open "c:\data\weights.txt" For Output As 3 H = Tree.H rmse = 0 For i = 1 To Tree.NLP If Zdist(i) > Hlowest Then Hlowest = Zdist(i) j = j + 1 'sade(i) = Tree.cf * H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw + Tree.cont2 sade(i) = Tree.cf * H * ((1 / 0.4) * (Zdist(i) / H)) ^ Tree.pw + Tree.cont2 ^ 2 LA(j) = XYdist(i) - sade(i) rmse = rmse + LA(j) ^ 2 'A_MAT(j, 1) = H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw ' d(Sade)/d(cf) 'A_MAT(j, 2) = Tree.cf * H * Sin(4 * (Zdist(i) / H)) ^ Tree.pw * Log(Sin(4 * ((Zdist(i) + 0.01) / H))) 'A_MAT(j, 3) = 1 A_MAT(j, 1) = H * ((1 / 0.4) * (Zdist(i) / H)) ^ Tree.pw ' d(Sade)/d(cf) A_MAT(j, 2) = Tree.cf * H * ((1 / 0.4) * (Zdist(i) / H)) ^ Tree.pw * Log(((1 / 0.4) * ((Zdist(i)) / H)) + 0.000001) A_MAT(j, 3) = 2 * Tree.cont2 For kX = 1 To 3 Print #1, j & " " & kX & " " & A_MAT(j, kX) Next kX Print #2, LA(j) P = 1 pw = 1 + (Zdist(i) / H) ^ 2.2 * 100 pw = 1 + (Zdist(i) / H) * 100 ' pw = 40 If LA(j) < 0 Then Print #3, 0.1 * pw Else Print #3, 1 * pw End If Next i Rem additional Constraint (constant cont2^2) A_MAT(Tree.NLP + 1, 2) = 0 A_MAT(Tree.NLP + 1, 1) = 0 A_MAT(Tree.NLP + 1, 3) = -1 For kX = 1 To 3 Print #1, Tree.NLP + 1 & " " & kX & " " & A_MAT(Tree.NLP + 1, kX) Next kX Print #2, Tree.cont2 ^ 2 - A0 Print #3, Wa Rem Additional Constraint (shape pw) A_MAT(Tree.NLP + 2, 2) = -1 A_MAT(Tree.NLP + 2, 1) = 0 A_MAT(Tree.NLP + 2, 3) = 0 For kX = 1 To 3 Print #1, Tree.NLP + 2 & " " & kX & " " & A_MAT(Tree.NLP + 2, kX) Next kX Print #2, Tree.pw - c0 Print #3, 10 * Wc Open "c:\Data\matlab.txt" For Output As 4 Print #4, j + 2 & " " & 3 & " " & 3 * (j + 2) Close (4) Close (1) Close (2) Close (3) rmse = Sqr(rmse / Tree.NLP) Rem Solve the system of equations End Sub Public Function InsidePolygon(Polygon() As Point, ByVal N As Long, ByRef P As Point) As Long Dim counter As Long Dim i As Long Dim xinters As Double Dim p1 As Point, p2 As Point p1 = Polygon(0) If P.Y < p1.Y Then aa = 1: aa = P.X End If For i = 1 To N Step 1 p2 = Polygon(i Mod N) If (P.Y > Min(p1.Y, p2.Y)) Then If (P.Y <= Max(p1.Y, p2.Y)) Then If (P.X <= Max(p1.X, p2.X)) Then If (p1.Y <> p2.Y) Then xinters = (P.Y - p1.Y) * (p2.X - p1.X) / (p2.Y - p1.Y) + p1.X If ((p1.X = p2.X) Or (P.X <= xinters)) Then counter = counter + 1 End If End If End If End If End If p1 = p2 Next If (counter Mod 2 = 0) Then InsidePolygon = OUTSIDE Else InsidePolygon = Inside End If End Function Public Function Min(X, Y) If X < Y Then Min = X Else Min = Y End Function Public Function Max(X, Y) If X > Y Then Max = X Else Max = Y End Function Public Sub Main() Rem This code starts the program, it loads Form1, makes it visible and sets the path var Load Form1 Form1.Visible = True BAPPPATH = "C:\data" Dim l As Long l = 0 Open "C:\data\JetColorMAP.csv" For Input As 2 Do Until EOF(2) l = l + 1 Input #2, ColorMap(l, 1), ColorMap(l, 2), ColorMap(l, 3) Loop Close (2) l = 0 Open "C:\data\BWColorMAP.csv" For Input As 2 Do Until EOF(2) l = l + 1 Input #2, BWColorMap(l, 1), BWColorMap(l, 2), BWColorMap(l, 3) Loop Close (2) MinH = 5 maxh = 20 DotSIze = 3 End Sub Public Function getCHMheight(ByRef X As Double, Y As Double) As Double Dim weight1 As Double, weight2 As Double, weight3 As Double, weight4 As Double Dim row As Long, col As Long Dim Dec_X As Double, Dec_Y As Double If RasterModelReady = False Then getCHMheight = -99# Exit Function End If Dim Xa As Double, Ya As Double, Za As Double, z As Double Xa = X: Ya = Y: Za = z Call KKJ_to_UTM(Xa, Ya, Za, X, Y, z) 'col = CInt(((X) - CHMmodel.xllcorner) / CHMmodel.Cellsize) Call KKJ_to_UTM(Xa, Ya, Za, X, Y, z) col = CInt(((X) - CHMmodel.xllcorner) / CHMmodel.Cellsize) ' Exit Function row = CInt(((Y) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Rem The decimal portions of the testpoint (XY) 'If CHMZfXY(col, row) > 0 Then getCHMheight = CHMZfXY(col, row) ' - 18.67 + 0.27 X = Xa: Y = Ya: z = Za Exit Function ' Else ' getCHMheight = -99 ' Exit Function ' End If Rem BILINEAR INTERPOLATION Rem Cint is the round to Integer Rem Int is the integer portion Rem Check corners col = Int(((X - CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) ' Exit Function row = Int(((Y - CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Rem The decimal portions of the testpoint (XY) Dec_X = ((X - CHMmodel.Cellsize / 2) - Int(X - CHMmodel.Cellsize / 2)) Dec_Y = ((Y - CHMmodel.Cellsize / 2) - Int(Y - CHMmodel.Cellsize / 2)) apux = (((X - CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) apuY = (((Y - CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = apux - col Dec_Y = apuY - row weight1 = (Dec_X) * (Dec_Y) If col > UBound(CHMZfXY, 1) Or col < 1 Then GoTo Point_Falls_Out If row > UBound(CHMZfXY, 2) Or row < 1 Then GoTo Point_Falls_Out If CHMZfXY(col, row) > 0 Then getCHMheight = CHMZfXY(col, row) * weight1 Else getCHMheight = -99 Exit Function End If col = Int(((X - CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) row = Int(((Y + CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) If col > UBound(CHMZfXY, 1) Or col < 1 Then GoTo Point_Falls_Out If row > UBound(CHMZfXY, 2) Or row < 1 Then GoTo Point_Falls_Out Dec_X = ((X - CHMmodel.Cellsize / 2) - Int(X - CHMmodel.Cellsize / 2)) Dec_Y = ((Y + CHMmodel.Cellsize / 2) - Int(Y + CHMmodel.Cellsize / 2)) apux = (((X - CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) apuY = (((Y + CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = apux - col Dec_Y = 1 - (apuY - row) weight2 = (Dec_X) * (Dec_Y) If CHMZfXY(col, row) > 0 Then getCHMheight = getCHMheight + CHMZfXY(col, row) * weight2 Else getCHMheight = -99 Exit Function End If col = Int(((X + CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) row = Int(((Y + CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = ((X + CHMmodel.Cellsize / 2) - Int(X + CHMmodel.Cellsize / 2)) Dec_Y = ((Y + CHMmodel.Cellsize / 2) - Int(Y + CHMmodel.Cellsize / 2)) apux = (((X + CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) apuY = (((Y + CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = 1 - (apux - col) Dec_Y = 1 - (apuY - row) weight3 = (Dec_X) * (Dec_Y) If col > UBound(CHMZfXY, 1) Or col < 1 Then GoTo Point_Falls_Out If row > UBound(CHMZfXY, 2) Or row < 1 Then GoTo Point_Falls_Out If CHMZfXY(col, row) > 0 Then getCHMheight = getCHMheight + CHMZfXY(col, row) * weight3 Else getCHMheight = -99 Exit Function End If col = Int(((X + CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) row = Int(((Y - CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = ((X + CHMmodel.Cellsize / 2) - Int(X + CHMmodel.Cellsize / 2)) Dec_Y = ((Y - CHMmodel.Cellsize / 2) - Int(Y - CHMmodel.Cellsize / 2)) apux = (((X + CHMmodel.Cellsize / 2) - CHMmodel.xllcorner) / CHMmodel.Cellsize) apuY = (((Y - CHMmodel.Cellsize / 2) - CHMmodel.yllcorner) / CHMmodel.Cellsize) Dec_X = 1 - (apux - col) Dec_Y = apuY - row weight4 = (Dec_X) * (Dec_Y) Sum = weight1 + weight2 + weight3 + weight4 If col > UBound(CHMZfXY, 1) Or col < 1 Then GoTo Point_Falls_Out If row > UBound(CHMZfXY, 2) Or row < 1 Then GoTo Point_Falls_Out If CHMZfXY(col, row) > 0 Then getCHMheight = getCHMheight + CHMZfXY(col, row) * weight4 Else getCHMheight = -99 Exit Function End If Exit Function Point_Falls_Out: Rem Form1.Label10.Caption = "Error in elevation, p " & Format$(X, "0.0") & "," & Format$(Y, "0.0") Rem Slows down too much getCHMheight = -99# Exit Function End Function Public Function getheight(ByVal X As Double, ByVal Y As Double) As Double On Error GoTo Point_Falls_Out 'getheight = 150 'Exit Function Dim weight1 As Double, weight2 As Double, weight3 As Double, weight4 As Double Dim row As Long, col As Long Dim Dec_X As Double, Dec_Y As Double, z As Double Dim Xa As Double, Ya As Double, Za As Double Xa = X: Ya = Y: Za = z If Abs(Xa - 408000) > 20000 Then Call KKJ_to_UTM(Xa, Ya, Za, X, Y, z) 'Call KKJ_to_UTM(Xa, Ya, Za, X, Y, z) 'GoTo Soderkulla GoTo Bilinear col = CInt((X - Zmodel.xllcorner) / Zmodel.Cellsize) row = CInt((Y - Zmodel.yllcorner) / Zmodel.Cellsize) getheight = ZfXY(col, row) Exit Function Bilinear2: col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) getheight = ZfXY(col, row) 'Exit Function Rem The decimal portions of the testpoint (XY) Dec_X = ((X - Zmodel.Cellsize / 2) - Int(X - Zmodel.Cellsize / 2)) Dec_Y = ((Y - Zmodel.Cellsize / 2) - Int(Y - Zmodel.Cellsize / 2)) apux = (((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) apuY = (((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = apux - col Dec_Y = apuY - row weight1 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = ZfXY(col, row) * weight1 Else getheight = -99 Exit Function End If col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X - Zmodel.Cellsize / 2) - Int(X - Zmodel.Cellsize / 2)) Dec_Y = ((Y + Zmodel.Cellsize / 2) - Int(Y + Zmodel.Cellsize / 2)) apux = (((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) apuY = (((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = apux - col Dec_Y = 1 - (apuY - row) weight2 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * weight2 Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X + Zmodel.Cellsize / 2) - Int(X + Zmodel.Cellsize / 2)) Dec_Y = ((Y + Zmodel.Cellsize / 2) - Int(Y + Zmodel.Cellsize / 2)) apux = (((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) apuY = (((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = 1 - (apux - col) Dec_Y = 1 - (apuY - row) weight3 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * weight3 Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X + Zmodel.Cellsize / 2) - Int(X + Zmodel.Cellsize / 2)) Dec_Y = ((Y - Zmodel.Cellsize / 2) - Int(Y - Zmodel.Cellsize / 2)) apux = (((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) apuY = (((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = 1 - (apux - col) Dec_Y = apuY - row weight4 = (Dec_X) * (Dec_Y) Sum = weight1 + weight2 + weight3 + weight4 If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * weight4 Else getheight = -99 Exit Function End If Exit Function If RasterModelReady = False Then getheight = -99# Exit Function End If GoTo Bilinear Rem OLD col = CInt(((X) - Zmodel.xllcorner) / Zmodel.Cellsize) row = CInt(((Y) - Zmodel.yllcorner) / Zmodel.Cellsize) Rem The decimal portions of the testpoint (XY) If ZfXY(col, row) > 0 Then getheight = ZfXY(col, row) Exit Function Else getheight = -99 Exit Function End If Bilinear: Rem BILINEAR INTERPOLATION Rem Cint is the round to Integer Rem Int is the integer portion Rem Check corners col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Rem The decimal portions of the testpoint (XY) Dec_X = (X - Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y - Zmodel.Cellsize / 2) - CLng(Y) weight1 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = ZfXY(col, row) * Abs(weight1) Else getheight = -99 Exit Function End If col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X - Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y + Zmodel.Cellsize / 2) - CLng(Y) weight2 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * Abs(weight2) Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X + Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y + Zmodel.Cellsize / 2) - CLng(Y) weight3 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * Abs(weight3) Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X + Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y - Zmodel.Cellsize / 2) - CLng(Y) weight4 = (Dec_X) * (Dec_Y) Sum = Abs(weight1) + Abs(weight2) + Abs(weight3) + Abs(weight4) If ZfXY(col, row) > 0 Then getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum - 18.67 + 0.27 ' getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum - 18.67 + 0.32 ' N2000 'getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum - 18.67 + 0.1 ' + 0.32 + 0.32 'N60 Else getheight = -99 Exit Function End If ' getheight = getheight - 18.67 + 0.3 Exit Function 67 Soderkulla: Rem ********************** Rem BILINEAR INTERPOLATION Rem ********************** X = X + Rnd * 0.0001 Y = Y + Rnd * 0.0001 ' The point P falls in a particular cell Cell with (col,row) integer coords. ' This Cell has low left corner coords (ll_x, ll_y) ' Cellsize is called CS, it can be anything ' A grid is established around P, with x and y taking values CS/2.0 ' They are in Cells (col1, row1), (col2, row2), (col3, row3), (col4, row4) with Z-values Z1, Z2, Z3 and Z4 ' We compute the absolute distances to ll_x and ll_y and their product gives an area ' This area divided by CS^2 (area of a cell) is the weight for that cell, W1, W2, W3, W4 ' Height is the weighted sum (W1*Z1+W2*Z2+W3*Z3+W4*Z4)/area of cell Dim CS As Double, Z1 As Double, Z2 As Double, Z3 As Double, Z4 As Double Dim row1 As Long, row2 As Long, row3 As Long, row4 As Long Dim col1 As Long, col2 As Long, col3 As Long, col4 As Long Dim W1 As Double, W2 As Double, W3 As Double, W4 As Double ' Zfxy -array has dimensions (0...W-1, 0...H-1)) CS = CDbl(Zmodel.Cellsize) col = Int((X - Zmodel.xllcorner) / CS) row = Int((Y - Zmodel.yllcorner) / CS) ll_x = col * CS + Zmodel.xllcorner ll_y = row * CS + Zmodel.yllcorner ' The col,row coordinates of the four corners x1 = X + CS / 2#: col1 = Int(((x1) - Zmodel.xllcorner) / CS) y1 = Y + CS / 2#: row1 = Int(((y1) - Zmodel.yllcorner) / CS) x2 = x1: col2 = Int(((x2) - Zmodel.xllcorner) / CS) y2 = Y - CS / 2#: row2 = Int(((y2) - Zmodel.yllcorner) / CS) X3 = (X - CS / 2#): col3 = Int(((X3) - Zmodel.xllcorner) / CS) y3 = y2: row3 = Int(((y3) - Zmodel.yllcorner) / CS) X4 = X3: col4 = Int(((X4) - Zmodel.xllcorner) / CS) y4 = y1: row4 = Int(((y4) - Zmodel.yllcorner) / CS) Z1 = ZfXY(col1, row1) Z2 = ZfXY(col2, row2) Z3 = ZfXY(col3, row3) Z4 = ZfXY(col4, row4) Z5 = ZfXY(col, row) W1 = (Abs(ll_x - x1) * Abs(ll_y - y1)) W2 = (Abs(ll_x - x2) * Abs(ll_y - y2)) W3 = (Abs(ll_x - X3) * Abs(ll_y - y3)) W4 = (Abs(ll_x - X4) * Abs(ll_y - y4)) W5 = 4 getheight = (W1 * Z1 + W2 * Z2 + W3 * Z3 + W4 * Z4 + W5 * Z5) / (W1 + W2 + W3 + W4 + W5) Exit Function Rem The decimal portions of the testpoint (XY) Dec_X = (X - Zmodel.Cellsize / 2) - (X) Dec_Y = (Y - Zmodel.Cellsize / 2) - (Y) weight1 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = ZfXY(col, row) * Abs(weight1) Else getheight = -99 Exit Function End If col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X - Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y + Zmodel.Cellsize / 2) - CLng(Y) weight2 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * Abs(weight2) Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X + Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y + Zmodel.Cellsize / 2) - CLng(Y) weight3 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * Abs(weight3) Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = (X + Zmodel.Cellsize / 2) - CLng(X) Dec_Y = (Y - Zmodel.Cellsize / 2) - CLng(Y) weight4 = (Dec_X) * (Dec_Y) Sum = Abs(weight1) + Abs(weight2) + Abs(weight3) + Abs(weight4) If ZfXY(col, row) > 0 Then ' getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum ' - 18.67 '+ 0.27 getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum - 18.67 + 0.32 ' N2000 'getheight = (getheight + ZfXY(col, row) * Abs(weight4)) / Sum - 18.67 + 0.1 ' + 0.32 + 0.32 'N60 Else getheight = -99 Exit Function End If ' getheight = getheight - 18.67 + 0.3 Exit Function X = X Y = Y Rem BILINEAR INTERPOLATION Rem Cint is the round to Integer Rem Int is the integer portion Rem Check corners col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Rem The decimal portions of the testpoint (XY) Dec_X = ((X - Zmodel.Cellsize / 2) - Int(X - Zmodel.Cellsize / 2)) Dec_Y = ((Y - Zmodel.Cellsize / 2) - Int(Y - Zmodel.Cellsize / 2)) weight1 = (1 - Dec_X) * (1 - Dec_Y) If ZfXY(col, row) > 0 Then getheight = ZfXY(col, row) * weight1 Else getheight = -99 Exit Function End If col = Int(((X - Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X - Zmodel.Cellsize / 2) - Int(X - Zmodel.Cellsize / 2)) Dec_Y = ((Y + Zmodel.Cellsize / 2) - Int(Y + Zmodel.Cellsize / 2)) weight2 = (1 - Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * weight2 Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y + Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X + Zmodel.Cellsize / 2) - Int(X + Zmodel.Cellsize / 2)) Dec_Y = ((Y + Zmodel.Cellsize / 2) - Int(Y + Zmodel.Cellsize / 2)) weight3 = (Dec_X) * (Dec_Y) If ZfXY(col, row) > 0 Then getheight = getheight + ZfXY(col, row) * weight3 Else getheight = -99 Exit Function End If col = Int(((X + Zmodel.Cellsize / 2) - Zmodel.xllcorner) / Zmodel.Cellsize) row = Int(((Y - Zmodel.Cellsize / 2) - Zmodel.yllcorner) / Zmodel.Cellsize) Dec_X = ((X + Zmodel.Cellsize / 2) - Int(X + Zmodel.Cellsize / 2)) Dec_Y = ((Y - Zmodel.Cellsize / 2) - Int(Y - Zmodel.Cellsize / 2)) weight4 = (Dec_X) * (1 - Dec_Y) Sum = weight1 + weight2 + weight3 + weight4 If ZfXY(col, row) > 0 Then getheight = (getheight + ZfXY(col, row) * weight4) / Sum Else getheight = -99 Exit Function End If Exit Function Point_Falls_Out: Rem Form1.Label10.Caption = "Error in elevation, p " & Format$(X, "0.0") & "," & Format$(Y, "0.0") Rem Slows down too much getheight = -99# Exit Function End Function Public Sub GetRieglObs() Rem The routine captures data in a cylinder, centered at the XYZ-solution Rem Feb 2014; for the Siikaneva project Rem The stored variables include, for each encountered LiDAR echo at (X, Y, Z) with ID (needed)? Rem LiDAR data Rem ID, SurfaceType, Radius, X, Y, Z, StripNumber, ScanZenithAngle, ScanRange, Z, Height, Intensity, IntensityRangeNormalized Rem Image data for the echo Rem ID, SurfaceType, Radius, X, Y, Z, H, ImageCode, ViewAzim, ViewZenith, 25 x (R,G,B) Rem DEM data ' 10m_Hummock - look +/- 10 meters to East and West; North and South; difference to the minimum Z ' 2m_Hummock - look +/- 2 meters Window; difference to the minimum Z ' 1m_Flatness - look +/- 1 meters Window; MSE about the Z ' 06m_Flatness - look +/- 60 cm Window; MSE about the Z ' Slope_measure - look in a row: Zi, Zi+1, Zi+2, Zi+m consequtive Z's. If it is a sloe, the absolute sum of substracted values will be high ' hummock_measure ? it is flat and locally or globally depression Dim p_x As Double, p_y As Double, FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double, LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long Close (1) Xc = X_sol: Yc = Y_sol: Xs = Xc: Ys = Yc 'Open "i:\siikaneva\Siika_path.hdr" For Input As 1 Exit Sub Input #1, LiDARBinPath FN1 = Format$(Int((Xs - 349000) / 100), "000") FN2 = Format$(Int((Ys - 6857000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Close (101) Open LiDARBinPath & FN1 & "_" & FN2 & "_wf.bin" For Binary As 101 Get #100, , NHA If NHA = 0 Then Exit Sub ' ************* The radius of the cylinder minradii = 0.1 ReDim LiDRiegl(1 To NHA) As PulseRIegl Dim k As Long Get #100, 1, NHA Pointer = 5 ' Start reading the Riegl data records Nin = 0 Open "c:\temp\" & Measurement.num & ".txt" For Output As 6 Zmin = 1000 For k = 1 To NHA capu = "" Get #100, Pointer, LiDRiegl(k).echocount Get #100, , LiDRiegl(k).GPStime Get #100, , LiDRiegl(k).ByteLAS ReDim LiDRiegl(k).Echoes(1 To LiDRiegl(k).echocount) As EchoRiegl Get #100, , LiDRiegl(k).Echoes Get #100, , LiDRiegl(k).ScanAngle Get #100, , LiDRiegl(k).PosLidar Get #100, , LiDRiegl(k).StripNum Pointer = Pointer + 1 + 8 + 1 + CLng(LiDRiegl(k).echocount * 36) + 1 + 24 + 1 ' Compute the zenith angle Dim DirVect As Vector3D, plumb As Vector3D, Startpoint As Vector3D DirVect.X = LiDRiegl(k).Echoes(1).pos.X - LiDRiegl(k).PosLidar.X DirVect.Y = LiDRiegl(k).Echoes(1).pos.Y - LiDRiegl(k).PosLidar.Y DirVect.z = LiDRiegl(k).Echoes(1).pos.z - LiDRiegl(k).PosLidar.z plumb.X = 0: plumb.Y = 0: plumb.z = 1 ' The scan zenith angle zenith = 180 - TO_DEGREES * vector_angle(DirVect, plumb) If k Mod 10000 = 0 Then Form1.Caption = "Pulse " & k & " of " & NHA & " inside: " & Nin DoEvents End If Dim imdata As RGBtriplet If LiDRiegl(k).echocount < 3 Then For j = LiDRiegl(k).echocount To 1 Step -1 radi_2d = Sqr((LiDRiegl(k).Echoes(LiDRiegl(k).echocount).pos.X - X_sol) ^ 2 + (LiDRiegl(k).Echoes(LiDRiegl(k).echocount).pos.Y - Y_sol) ^ 2) If radi_2d < minradii Then ' The pulse is inside the AOI Nin = Nin + 1 Rem Get the waveform 'ReDim wave(1 To LiDRiegl(k).Echoes(j).WaveSampleSize) As Integer 'Get #101, LiDRiegl(k).Echoes(j).Pointer + 1, wave 'Picos = LiDRiegl(k).Echoes(j).RetPointWFLoc Rem Wavepacket starts 'Startpoint.X = LiDRiegl(k).Echoes(j).pos.X - DirVect.X * Picos / 1000 'Startpoint.Y = LiDRiegl(k).Echoes(j).pos.Y - DirVect.Y * Picos / 1000 'Startpoint.z = LiDRiegl(k).Echoes(j).pos.z - DirVect.z * Picos / 1000 ' H = height above the DEM H = LiDRiegl(k).Echoes(j).pos.z - getheight(LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y) range = Sqr((LiDRiegl(k).Echoes(j).pos.X - LiDRiegl(k).PosLidar.X) ^ 2 + (LiDRiegl(k).Echoes(j).pos.Y - LiDRiegl(k).PosLidar.Y) ^ 2 + (LiDRiegl(k).Echoes(j).pos.z - LiDRiegl(k).PosLidar.z) ^ 2) capu = capu & Format$(H, "0.00") & "," & Format$(range, "0.00") & "," capu = capu & Format$(LiDRiegl(k).Echoes(j).pos.z, "0.00") & "," Zmin = Min(Zmin, LiDRiegl(k).Echoes(j).pos.z) capu = capu & LiDRiegl(k).Echoes(j).intensity & "," capu = capu & Format$(LiDRiegl(k).Echoes(j).intensity * (range / 270#) ^ 2, "0.0") & "," ' Here, it would possible to collect pixel data for each echo ************* Dim red As Byte, grn As Byte, blu As Byte For i = 0 To 0 'NumOfImages - 1 Call r_transform_ground_to_pixel(i, LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y, LiDRiegl(k).Echoes(j).pos.z, p_x, p_y) p_y = (image_info(i).Height - 1) - p_y Open image_info(i).FileName For Binary As 20 Get #20, 1 + CLng(p_y) * image_info(i).Width * 3 + CLng(p_x) * 3, imdata p_y = -(p_y - (image_info(i).Height - 1)) Form1.Picture1(i).DrawWidth = 5 ''Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), RGB(red, grn, blu) Close (20) capu = capu & imdata.r & "," capu = capu & imdata.G & "," capu = capu & imdata.B & "," Next i End If NextEcho: Next j End If Nextpulse: If capu <> "" Then capu = LiDRiegl(k).StripNum & "," & LiDRiegl(k).echocount & "," & Format$(zenith, "0.0") & "," & "," & capu Print #6, capu End If Next k Form1.Picture1(i).Print Zmin Close (100): Close (101): Close (6) Exit Sub End Sub Public Sub MakeIntensityRaster() Call MakeCanopyRaster Exit Sub Dim p_x As Double, p_y As Double, FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double, LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long, k As Long Dim WidthArea As Double, HeightArea As Double Dim X_origo As Double, Y_origo As Double, CS As Double Dim Coldim As Long, rowdim As Long CS = 0.2 ' pixel size meters WidthArea = 600# ' raster size in meters HeightArea = 600# Coldim = CInt(WidthArea / CS) ' raster size in pixels rowdim = CInt(HeightArea / CS) X_origo = 350700 Y_origo = 6859000 ' This table stores the sum of intensity values (forced to integer, range correction results in float) ReDim Sumtab(1 To Coldim, 1 To rowdim) As Single ' The number of first echoes in a cell ReDim Ntab(1 To Coldim, 1 To rowdim) As Byte Close (1) Open "i:\siikaneva\Siika_path.hdr" For Input As 1 Input #1, LiDARBinPath Rem Loop a certain area for data, and fill a raster For Xs = (X_origo + 0.01) To (X_origo - 0.01 + WidthArea) Step 100# For Ys = (Y_origo + 0.01) To (Y_origo - 0.01 + HeightArea) Step 100# ' We are in a hectare, open files FN1 = Format$(Int((Xs - 349000) / 100), "000") FN2 = Format$(Int((Ys - 6857000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Open LiDARBinPath & FN1 & "_" & FN2 & "_wf.bin" For Binary As 101 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim LiDRiegl(1 To NHA) As PulseRIegl Get #100, 1, NHA Pointer = 5: Nin = 0 For k = 1 To NHA If k Mod 10000 = 0 Then Form1.Caption = "Hectare " & FN1 & " - " & FN2 & " pulse " & k & " of " & NHA DoEvents End If Get #100, Pointer, LiDRiegl(k).echocount Get #100, , LiDRiegl(k).GPStime Get #100, , LiDRiegl(k).ByteLAS ReDim LiDRiegl(k).Echoes(1 To LiDRiegl(k).echocount) As EchoRiegl Get #100, , LiDRiegl(k).Echoes Get #100, , LiDRiegl(k).ScanAngle Get #100, , LiDRiegl(k).PosLidar Get #100, , LiDRiegl(k).StripNum Pointer = Pointer + 1 + 8 + 1 + CLng(LiDRiegl(k).echocount * 36) + 1 + 24 + 1 ' The pulse data is now read, consider only first echoes, in single return pulses If LiDRiegl(k).echocount = 1 Then icol = 1 + Int((LiDRiegl(k).Echoes(LiDRiegl(k).echocount).pos.X - X_origo) / CS) irow = 1 + Int((LiDRiegl(k).Echoes(LiDRiegl(k).echocount).pos.Y - Y_origo) / CS) j = 1 ' H = LiDRiegl(k).Echoes(j).pos.z - getheight(LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y) range = Sqr((LiDRiegl(k).Echoes(j).pos.X - LiDRiegl(k).PosLidar.X) ^ 2 + (LiDRiegl(k).Echoes(j).pos.Y - LiDRiegl(k).PosLidar.Y) ^ 2 + (LiDRiegl(k).Echoes(j).pos.z - LiDRiegl(k).PosLidar.z) ^ 2) Sumtab(icol, irow) = Sumtab(icol, irow) + (LiDRiegl(k).Echoes(j).intensity * (range / 280#) ^ 2) Ntab(icol, irow) = Ntab(icol, irow) + 1 End If Next k Close (100): Close (101) Next Ys Next Xs ' Compute the values For i = 1 To Coldim For j = 1 To rowdim If Ntab(i, j) > 0 Then Sumtab(i, j) = (CDbl(Sumtab(i, j)) / CDbl(Ntab(i, j))) End If Next j Next i ' Fill the gaps NZeroes = 0 For i = 1 To Coldim For j = 1 To rowdim If Ntab(i, j) = 0 Then ' there's no data here Nin = 0: SumT = 0 For ii = -1 To 1 For jj = -1 To 1 ' If Sumtab(i + ii, j + jj) > 0 Then On Error Resume Next If Sumtab(i + ii, j + jj) > 0 Then Nin = Nin + 1 SumT = SumT + Sumtab(ii + i, jj + j) End If Next jj Next ii If Nin > 0 Then Sumtab(i, j) = (CDbl(SumT) / CDbl(Nin)) Else NZeroes = NZeroes + 1 Form1.Caption = NZeroes End If End If Ntab(i, j) = Sumtab(i, j) / 6 Next j Next i Open "C:\Temp\IntKuva.raw" For Binary As 2 Put #2, , Ntab Close (2) Form1.Caption = " IntKuva READY " Close (1) DoEvents Open "C:\Temp\IntMalli.raw" For Binary As 2 Put #2, , Sumtab Close (2) Form1.Caption = " IntMalli READY " Close (1) Exit Sub End Sub Public Sub MakeFWHMRaster() Dim p_x As Double, p_y As Double, FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double, LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long, k As Long Dim WidthArea As Double, HeightArea As Double Dim X_origo As Double, Y_origo As Double, CS As Double Dim Coldim As Long, rowdim As Long CS = 0.2 ' pixel size meters WidthArea = 400# ' raster size in meters HeightArea = 400# Coldim = CInt(WidthArea / CS) ' raster size in pixels rowdim = CInt(HeightArea / CS) X_origo = 350800 Y_origo = 6859100 ' This table stores the sum of intensity values (forced to integer, range correction results in float) ReDim Sumtab(1 To Coldim, 1 To rowdim) As Single ' The number of first echoes in a cell ReDim Ntab(1 To Coldim, 1 To rowdim) As Byte Close (1) Open "c:\data\als2013a_Siika_path.hdr" For Input As 1 Input #1, LiDARBinPath Hlimit = 0.5 Rem Loop a certain area for data, and fill a raster For Xs = (X_origo + 0.01) To (X_origo - 0.01 + WidthArea) Step 100# For Ys = (Y_origo + 0.01) To (Y_origo - 0.01 + HeightArea) Step 100# ' We are in a hectare, open files FN1 = Format$(Int((Xs - 349000) / 100), "000") FN2 = Format$(Int((Ys - 6857000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Open LiDARBinPath & FN1 & "_" & FN2 & "_wf.bin" For Binary As 101 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim LiDRiegl(1 To NHA) As PulseRIegl Get #100, 1, NHA Pointer = 5: Nin = 0 For k = 1 To NHA If k Mod 1000 = 0 Then Form1.Caption = "Hectare " & FN1 & " - " & FN2 & " pulse " & k & " of " & NHA DoEvents End If Get #100, Pointer, LiDRiegl(k).echocount Get #100, , LiDRiegl(k).GPStime Get #100, , LiDRiegl(k).ByteLAS ReDim LiDRiegl(k).Echoes(1 To LiDRiegl(k).echocount) As EchoRiegl Get #100, , LiDRiegl(k).Echoes Get #100, , LiDRiegl(k).ScanAngle Get #100, , LiDRiegl(k).PosLidar Get #100, , LiDRiegl(k).StripNum Pointer = Pointer + 1 + 8 + 1 + CLng(LiDRiegl(k).echocount * 36) + 1 + 24 + 1 ' Consider only echoes that have a certain height For j = LiDRiegl(k).echocount To 1 Step -1 H = LiDRiegl(k).Echoes(j).pos.z - getheight(LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y) If H < Hlimit Then ' Get the WF, compute the FWHM ReDim Wave(1 To LiDRiegl(k).Echoes(j).WaveSampleSize) As Integer Get #101, LiDRiegl(k).Echoes(j).Pointer + 1, Wave Rem Look for the maximal amplitude, and time offset Picos = LiDRiegl(k).Echoes(j).RetPointWFLoc / 1000 + 1 maxamp = 0: maxampI = 0 ' The max is near Cint(Picos), which may end up being at the end Uplevel = 8 If UBound(Wave) - CInt(Picos) < 6 Then GoTo Ongelma If CInt(Picos) < 6 Then GoTo Ongelma On Error Resume Next For l = CInt(Picos) - 5 To CInt(Picos) + 5 maxamp = Max(maxamp, Wave(l)) If Wave(l) = maxamp Then maxampI = l Next l delta_t = 0 On Error GoTo 0 GoTo Solved ' Solve a polynomialaround the WF peak , maxIndex has the index of wfc() maximum, it's tme is set to zero offset = maxampI If offset > 56 Then GoTo Ongelma Dim DesignMatrix(1 To 11, 1 To 7) As Variant, obs_vector(1 To 11) As Variant m = 0 For l = offset - 5 To offset + 5 ' we use eleven values m = m + 1 ik = l - offset DesignMatrix(m, 1) = CDbl(ik) ^ 6: DesignMatrix(m, 2) = CDbl(ik) ^ 5 DesignMatrix(m, 3) = CDbl(ik) ^ 4: DesignMatrix(m, 4) = CDbl(ik) ^ 3 DesignMatrix(m, 5) = CDbl(ik) ^ 2: DesignMatrix(m, 6) = CDbl(ik) ^ 1 DesignMatrix(m, 7) = 1 obs_vector(m) = CDbl(Wave(l)) Next l Dim Atb As Variant Dim solution As Variant, At As Variant, Ainv As Variant At = MatMult(MatTran(DesignMatrix), DesignMatrix) Ainv = MatInv(At) Atb = MatMult(MatTran(DesignMatrix), obs_vector) solution = MatMult(Ainv, Atb) maxp = 0 For m = -1 To 1 Step 0.01 amp = solution(1) * m ^ 6 + solution(2) * m ^ 5 + solution(3) * m ^ 4 + solution(4) * m ^ 3 + solution(5) * m ^ 2 + solution(6) * m + solution(7) If amp > maxp Then maxp = amp delta_t = m End If Next m Solved: Rem compute FWHM HM = maxp / 2# ' half maximum HM = maxamp / 2# StartIndex = CInt(CDbl(maxampI + delta_t)) Rem Look for the points of crossing limit = 0 If (StartIndex + Uplevel) > (UBound(Wave) - 1) Then GoTo Ongelma For o = StartIndex - (maxampI - 5) To StartIndex + Uplevel ' UBound(wave) - (StartIndex - 3) On Error GoTo Ongelma If Wave(o) >= HM And Wave(o - 1) < HM And limit = 0 Then DeltaA = Abs(Wave(o) - Wave(o - 1)) DeltaO = Abs(HM - Wave(o)) DeltaO1 = Abs(HM - Wave(o - 1)) fwhm1 = (o - 1) + DeltaO1 / DeltaA limit = 1 End If If Wave(o) >= HM And Wave(o + 1) < HM And limit = 1 Then DeltaA = Abs(Wave(o) - Wave(o + 1)) DeltaO = Abs(HM - Wave(o)) DeltaO1 = Abs(HM - Wave(o + 1)) fwhm2 = o + DeltaO / DeltaA limit = 2 End If If limit = 2 Then GoTo Compute If limit < 2 Then GoTo NextO Ongelma: fwhm1 = 0: fwhm2 = 0 ' could not be computed GoTo Compute NextO: Next o Compute: fwhm = fwhm2 - fwhm1 If fwhm <= 1 Then GoTo NextEcho icol = 1 + Int((LiDRiegl(k).Echoes(j).pos.X - X_origo) / CS) irow = 1 + Int((LiDRiegl(k).Echoes(j).pos.Y - Y_origo) / CS) ' H = LiDRiegl(k).Echoes(j).pos.z - getheight(LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y) ' range = Sqr((LiDRiegl(k).Echoes(j).pos.X - LiDRiegl(k).PosLiDAR.X) ^ 2 + (LiDRiegl(k).Echoes(j).pos.Y - LiDRiegl(k).PosLiDAR.Y) ^ 2 + (LiDRiegl(k).Echoes(j).pos.z - LiDRiegl(k).PosLiDAR.z) ^ 2) Sumtab(icol, irow) = Sumtab(icol, irow) + (fwhm) Ntab(icol, irow) = Ntab(icol, irow) + 1 End If NextEcho: Next j ' next echo Next k ' next pulse Close (100): Close (101) Next Ys Form1.Caption = Xs: DoEvents Next Xs ' Compute the values finalle For i = 1 To Coldim For j = 1 To rowdim If Ntab(i, j) > 0 Then Sumtab(i, j) = (CDbl(Sumtab(i, j)) / CDbl(Ntab(i, j))) End If Next j Next i ' Fill the gaps GoTo WriteArrays NZeroes = 0 For i = 1 To Coldim For j = 1 To rowdim If Ntab(i, j) = 0 Then ' there's no data here Nin = 0: SumT = 0 For ii = -1 To 1 For jj = -1 To 1 ' If Sumtab(i + ii, j + jj) > 0 Then On Error Resume Next If Sumtab(i + ii, j + jj) > 0 Then Nin = Nin + 1 SumT = SumT + Sumtab(ii + i, jj + j) End If Next jj Next ii If Nin > 0 Then Sumtab(i, j) = (CDbl(SumT) / CDbl(Nin)) Else NZeroes = NZeroes + 1 Form1.Caption = NZeroes End If End If Ntab(i, j) = Sumtab(i, j) * 40 Next j Next i WriteArrays: For i = 1 To Coldim For j = 1 To rowdim Ntab(i, j) = Sumtab(i, j) * 40 Next j Next i Open "C:\Temp\IntKuva.raw" For Binary As 2 Put #2, , Ntab Close (2) Form1.Caption = " IntKuva READY " Close (1) DoEvents Open "C:\Temp\IntMalli.raw" For Binary As 2 Put #2, , Sumtab Close (2) Form1.Caption = " IntMalli READY " Close (1) Exit Sub End Sub Public Sub MakeCanopyRaster() Dim p_x As Double, p_y As Double, FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double, LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long, k As Long Dim WidthArea As Double, HeightArea As Double Dim X_origo As Double, Y_origo As Double, CS As Double Dim Coldim As Long, rowdim As Long CS = 0.2 ' pixel size meters WidthArea = 400# ' raster size in meters HeightArea = 400# Coldim = CInt(WidthArea / CS) ' raster size in pixels rowdim = CInt(HeightArea / CS) X_origo = 350800 Y_origo = 6859100 ' This table stores the max of height values in decimeters ReDim Sumtab(1 To Coldim, 1 To rowdim) As Byte ReDim Ntab(1 To Coldim, 1 To rowdim) As Byte Close (1) Open "i:\siikaneva\Siika_path.hdr" For Input As 1 Input #1, LiDARBinPath Rem Loop a certain area for data, and fill a raster For Xs = (X_origo + 0.01) To (X_origo - 0.01 + WidthArea) Step 100# For Ys = (Y_origo + 0.01) To (Y_origo - 0.01 + HeightArea) Step 100# ' We are in a hectare, open files FN1 = Format$(Int((Xs - 349000) / 100), "000") FN2 = Format$(Int((Ys - 6857000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Open LiDARBinPath & FN1 & "_" & FN2 & "_wf.bin" For Binary As 101 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim LiDRiegl(1 To NHA) As PulseRIegl Get #100, 1, NHA Pointer = 5: Nin = 0 For k = 1 To NHA If k Mod 10000 = 0 Then Form1.Caption = "Hectare " & FN1 & " - " & FN2 & " pulse " & k & " of " & NHA DoEvents End If Get #100, Pointer, LiDRiegl(k).echocount Get #100, , LiDRiegl(k).GPStime Get #100, , LiDRiegl(k).ByteLAS ReDim LiDRiegl(k).Echoes(1 To LiDRiegl(k).echocount) As EchoRiegl Get #100, , LiDRiegl(k).Echoes Get #100, , LiDRiegl(k).ScanAngle Get #100, , LiDRiegl(k).PosLidar Get #100, , LiDRiegl(k).StripNum Pointer = Pointer + 1 + 8 + 1 + CLng(LiDRiegl(k).echocount * 36) + 1 + 24 + 1 If LiDRiegl(k).echocount > 0 Then j = LiDRiegl(k).echocount icol = 1 + Int((LiDRiegl(k).Echoes(j).pos.X - X_origo) / CS) irow = 1 + Int((LiDRiegl(k).Echoes(j).pos.Y - Y_origo) / CS) H = LiDRiegl(k).Echoes(j).pos.z - getheight(LiDRiegl(k).Echoes(j).pos.X, LiDRiegl(k).Echoes(j).pos.Y) If H > 0.8 And H < 25 Then On Error Resume Next Sumtab(icol, irow) = Max(Sumtab(icol, irow), CByte(H * 10)) Ntab(icol, irow) = Ntab(icol, irow) + 1 End If End If Next k Close (100): Close (101) 'Exit Sub Next Ys Next Xs ' Fill the gaps NZeroes = 0 For i = 1 To Coldim For j = 1 To rowdim If Ntab(i, j) > 0 Then ' there's data here, propagate to zeroes Nin = 0: SumT = 0 For ii = -1 To 1 For jj = -1 To 1 On Error Resume Next If Sumtab(i + ii, j + jj) = 0 Then Sumtab(i + ii, j + jj) = Sumtab(i, j) Next jj Next ii Form1.Caption = NZeroes End If 'Exit Sub Next j Next i Open "C:\Temp\HKuva.raw" For Binary As 2 Put #2, , Ntab Close (2) Form1.Caption = " HKuva READY " Close (1) DoEvents Open "C:\Temp\HMalli.raw" For Binary As 2 Put #2, , Sumtab Close (2) Form1.Caption = " HMalli READY " Close (1) Exit Sub End Sub Public Sub GetLiDARObs() 'Exit Sub Rem This routine searches for LIDAR obs in the visinity of the XYZ Rem solution and outputs them Dim FN1 As String * 3, FN2 As String * 3 Dim NHA As Long Open "c:\data\als2006_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) FN1 = Format$(Int((X_sol - 2510000) / 100), "000") FN2 = Format$(Int((Y_sol - 6850000) / 100), "000") Close (100) Rem Read the first Data Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim LiDR2012(1 To NHA) As LidarRecord2010 Form1.Label10.FontSize = 8 Form1.Label10.Caption = "Reading 2012 data.." Get #100, 5, LiDR2012 Close (100) Dim k As Long, j As Long, radi As Double, Radius As Double Dim minradii As Double, min_k_index As Long, min_j_index As Long Dim Xs As Double, Ys As Double, Zs As Double minradii = 8 Close (7) Open "c:\temp\Pisteita_2012.txt" For Append As 7 Measurement.num = Measurement.num + 1 Dim FileO As String For k = 1 To NHA For j = 4 To 4 ' If LiDR2012(k).PulseCount <> 1 Or LiDR2012(k).StripNum > 23 Or LiDR2012(k).StripNum < 15 Then GoTo NextPulse ' only echoes If LiDR2012(k).pulseCount > 5 Or LiDR2012(k).StripNum > 23 Or LiDR2012(k).StripNum < 15 Then GoTo Nextpulse ' only or first-of-many 'If LiDR2012(k).PulseCount = 1 Or LiDR2012(k).StripNum > 29 Then GoTo NextPulse ' first-of-many radi = Sqr((LiDR2012(k).Returns(j).X - X_sol) ^ 2 + (LiDR2012(k).Returns(j).Y - Y_sol) ^ 2) ' + (LiDR2012(k).Returns(j).z - Z_sol) ^ 2) H = LiDR2012(k).Returns(j).z - getheight(LiDR2012(k).Returns(j).X, LiDR2012(k).Returns(j).Y) If radi < minradii And H > 10 Then ' getheight(LiDR2012(k).Returns(4).X, LiDR2012(k).Returns(4).Y) < 1) Then ' And LiDR20122012(k).Returns(2).z = 0 And LiDR20122012(k).Returns(4).z <> 0 And LiDR20122012(k).Range(4) < 1000 Then If LiDR2012(k).wavetype = 255 Then FileO = LiDARBinPath & "WFs\" & FN1 & "_" & FN2 & "_256.bin" FileO = "L:\Leica2013\bin\WFs\" & FN1 & "_" & FN2 & "_256.bin" ReDim Wave(1 To 256) As Byte kmax = LiDR2012(k).range(4) / 1000 + 1 End If Open FileO For Binary As 100 'Exit Sub Get #100, 1 + LiDR2012(k).Fileoffset, Wave Close (100) maxA = 0 addv = H / 0.15 For ll = 1 To kmax + addv * 0.7 If Wave(ll) > 13 Then maxA = maxA + Wave(ll) - 13 lmax = ll End If Next ll width1 = 0: width2 = 0 'If LiDR2012(k).intensity(4) > 10 And LiDR2012(k).intensity(4) < 50 Then ' Open "c:\temp\test.txt" For Append As 10 ' For ll = 1 To 256 ' Print #10, ll, wave(ll) ' Next ll ' Close (10) ' End If For ll = 0 To 30 On Error Resume Next If Wave(kmax + ll) > (Wave(kmax) - 12) * 0.5 Then width1 = width1 + 1 If Wave(kmax - (ll + 1)) > (Wave(kmax) - 12) * 0.5 Then width2 = width2 + 1 Next ll 'ReDim Ints(1 To 4) As Integer mx = mx + 1 'capu = "2012" & "," & Measurement.num & "," 'capu = Measurement.num & "," capu = "Asfaltti" & "," capu = capu & LiDR2012(k).StripNum & "," 'capu = capu & Format$(X_sol, "0.000") & "," 'capu = capu & Format$(Y_sol, "0.000") & "," 'capu = capu & Format$(Z_sol, "0.000") & "," jx = 4 'capu = capu & LiDR2012(k).StripNum & "," range = Sqr((LiDR2012(k).PosLidar.X - LiDR2012(k).Returns(jx).X) ^ 2 + (LiDR2012(k).PosLidar.Y - LiDR2012(k).Returns(jx).Y) ^ 2 + (LiDR2012(k).PosLidar.z - LiDR2012(k).Returns(jx).z) ^ 2) Zdiff = LiDR2012(k).PosLidar.z - LiDR2012(k).Returns(jx).z xydiff = Sqr((LiDR2012(k).PosLidar.X - LiDR2012(k).Returns(jx).X) ^ 2 + (LiDR2012(k).PosLidar.Y - LiDR2012(k).Returns(jx).Y) ^ 2) angle = MYFUNC_ATAN(xydiff / Zdiff) * TO_DEGREES 'capu = capu & Format$(LiDR2012(k).PosLiDAR.X, "0.000") & "," 'capu = capu & Format$(LiDR2012(k).PosLiDAR.Y, "0.000") & "," 'capu = capu & Format$(LiDR2012(k).PosLiDAR.z, "0.000") & "," 'capu = capu & Format$(LiDR2012(k).Returns(jx).X, "0.000") & "," 'capu = capu & Format$(LiDR2012(k).Returns(jx).Y, "0.000") & "," 'capu = capu & Format$(LiDR2012(k).Returns(jx).z, "0.000") & "," capu = capu & Format$(range, "0.0") & "," capu = capu & Format$(angle, "0.00") & "," capu = capu & LiDR2012(k).Res1 & "," capu = capu & LiDR2012(k).intensity(jx) & "," capu = capu & (maxA) ' capu = capu & lmax - kmax & "," ' capu = capu & wave(lmax) & "," ' Amax ' capu = capu & wave(kmax) ' Amplitude at DR echo ' capu = capu & LiDR2012(k).wavetype Print #7, capu End If Next j Nextpulse: Next k Close (7) Form1.Caption = capu Exit Sub capu = "2006" & "," capu = capu & min_j_index & "," capu = capu & LiDR2012(min_k_index).pulseCount & "," capu = capu & LiDR2012(min_k_index).PosLidar.X & "," capu = capu & LiDR2012(min_k_index).PosLidar.Y & "," capu = capu & LiDR2012(min_k_index).PosLidar.z & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).X & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).Y & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).z & "," capu = capu & LiDR2012(min_k_index).intensity(min_j_index) & "," capu = capu & LiDR2012(min_k_index).range(min_j_index) & "," capu = capu & LiDR2012(min_k_index).Res1 & "," Xs = LiDR2012(min_k_index).Returns(min_j_index).X Ys = LiDR2012(min_k_index).Returns(min_j_index).Y Zs = LiDR2012(min_k_index).Returns(min_j_index).z Open LiDARBinPath2 & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub 'ReDim LiDR2012(1 To Nha) As LidarRecord Form1.Label10.FontSize = 8 Form1.Label10.Caption = "Reading 2006 data..." Get #100, 5, LiDR2012 ' Here we read 207-byte records record by record Close (100) minradii = 100: For k = 1 To NHA For j = 1 To 4 If LiDR2012(k).Returns(j).X < 10 Then GoTo NextPulse2 radi = Sqr((LiDR2012(k).Returns(j).X - Xs) ^ 2 + (LiDR2012(k).Returns(j).Y - Ys) ^ 2 + (LiDR2012(k).Returns(j).z - Zs) ^ 2) If radi < minradii Then minradii = radi min_k_index = k min_j_index = j End If Next j NextPulse2: Next k capu = capu & minradii capu = capu & "2006" & "," capu = capu & min_j_index & "," capu = capu & LiDR2012(min_k_index).pulseCount & "," capu = capu & LiDR2012(min_k_index).PosLidar.X & "," capu = capu & LiDR2012(min_k_index).PosLidar.Y & "," capu = capu & LiDR2012(min_k_index).PosLidar.z & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).X & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).Y & "," capu = capu & LiDR2012(min_k_index).Returns(min_j_index).z & "," capu = capu & LiDR2012(min_k_index).intensity(min_j_index) & "," capu = capu & LiDR2012(min_k_index).range(min_j_index) & "," Open "c:\data\NormalizationData.txt" For Append As 1 Print #1, capu Close (1) apu = Beep(CLng(500), CLng(500)) Form1.Label10.Caption = "Points stored" End Sub Public Sub DefineCameraVector(Index As Long, cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D) cam_vec_x.X = A(1, 1, Index): cam_vec_x.Y = A(2, 1, Index): cam_vec_x.z = A(3, 1, Index) cam_vec_y.X = A(1, 2, Index): cam_vec_y.Y = A(2, 2, Index): cam_vec_y.z = A(3, 2, Index) cam_vec_z.X = A(1, 3, Index): cam_vec_z.Y = A(2, 3, Index): cam_vec_z.z = A(3, 3, Index) End Sub Public Sub View_Globals() Dim cp As String i = MeasurementCounter cp = "Counter: " & i & " Serial: " cp = cp & MyTrees(i).Serial & " Code: " 'Exit Sub cp = cp & MyTrees(i).Code & " Sp: " cp = cp & MyTrees(i).sp & " Status: " cp = cp & MyTrees(i).status2013 & " dX: " cp = cp & Format$(MyTrees(i).Xnew - X_sol, "0.00") & " dY: " cp = cp & Format$(MyTrees(i).Ynew - Y_sol, "0.00") & " dZ: " cp = cp & Format$(MyTrees(i).Znew - Z_sol, "0.00") & ", " Open "c:\temp\mittaukset.txt" For Input As 111 Do Until EOF(111) Line Input #111, Rivi Loop Close (111) cp = cp & " last saved: " & Rivi Form1.Caption = cp End Sub Public Sub DefineLiDARHectar(x_soli As Double, y_soli As Double, exists As Boolean) Dim FN1 As String * 3, FN2 As String * 3 Dim LiDARBinPath As String, LiDARBinPath2 As String Dim Npulses As Long, NHA As Long, Nsum As Long, Hlimit As Double Dim Nha2 As Long ' For254 'GoTo ALS60: GoTo Riegl Close (1) Open "c:\data\alsFOR254_path.hdr" For Input As 1 Input #1, LiDARBinPath FN1 = Format$(Int((x_soli - 2510000) / 100), "000") FN2 = Format$(Int((y_soli - 6850000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA Close (100) Npulses = NHA Close (101) If NHA > 0 Then Open "c:\data\43ByteFilenames.txt" For Output As 101 Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Close (101) End If Exit Sub ' Riegl Riegl: Close (1) Open "c:\data\als2015_path.hdr" For Input As 1 Input #1, LiDARBinPath FN1 = Format$(Int((x_soli - 2510000) / 100), "000") FN2 = Format$(Int((y_soli - 6850000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA Close (100) Npulses = NHA Close (101) If NHA > 0 Then Open "c:\data\RieglFilenames.txt" For Output As 101 Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Close (101) End If Exit Sub ' Titan data 'Open "c:\data\als2016_path.hdr" For Input As 1 Close (1) Open "c:\data\als2016_path.hdr" For Input As 1 Input #1, LiDARBinPath FN1 = Format$(Int((x_soli - 2510000) / 100), "000") FN2 = Format$(Int((y_soli - 6850000) / 100), "000") Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA Close (100) Npulses = NHA Close (101) If NHA > 0 Then Open "c:\data\Filenames.txt" For Output As 101 Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Input #1, LiDARBinPath Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Input #1, LiDARBinPath Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Close (101) Close (1) Exit Sub End If ALS60: Close (1) Open "c:\data\als2007_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) Dim k As Long FN1 = Format$(Int((x_soli - 2510000) / 100), "000") FN2 = Format$(Int((y_soli - 6850000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 'Exit Sub Close (101) Open "c:\data\Filenames.txt" For Output As 101 Print #101, LiDARBinPath & FN1 & "_" & FN2 & ".bin" Get #100, , NHA Close (100) Npulses = NHA GoTo ohi Open "c:\data\als2011_path.hdr" For Input As 1 Input #1, LiDARBinPath2 Close (1) Open LiDARBinPath2 & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , Nha2 Close (100) Print #101, LiDARBinPath2 & FN1 & "_" & FN2 & ".bin" Npulses = Npulses + NHA Dim Nha3 As Long, LiDARBinPath3 As String Open "c:\data\als2012_path.hdr" For Input As 1 Input #1, LiDARBinPath3 Close (1) Open LiDARBinPath3 & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , Nha3 Close (100) Print #101, LiDARBinPath3 & FN1 & "_" & FN2 & ".bin" Npulses = Npulses + Nha3 'Dim Nha4 As Long, LiDARBinPath4 As String 'Open "c:\data\als2010_path.hdr" For Input As 1 'Input #1, LiDARBinPath4 'Close (1) 'Open LiDARBinPath4 & FN1 & "_" & FN2 & ".bin" For Binary As 100 'Get #100, , Nha4 'Close (100) 'Print #101, LiDARBinPath4 & FN1 & "_" & FN2 & ".bin" Close (101) 'Npulses = Npulses + Nha4 ohi: Close (101) If NHA < 10 Then ' Or Nha2 < 10 Or Nha3 < 10 Then MsgBox ("Outside LiDAR coverage!") exists = False Exit Sub End If End Sub Public Function lineMagnitude(p1 As Point2D, p2 As Point2D) As Double lineMagnitude = Sqr((p2.X - p1.X) ^ 2 + (p2.Y - p1.Y) ^ 2) End Function Public Function dist3D_Line_to_Line(L1 As Line3D, l2 As Line3D) ' get the 3D minimum distance between 2 lines ' Input: two 3D lines L1 and L2 ' Return: the shortest distance between L1 and L2 Dim u As Vector3D, v As Vector3D, w As Vector3D u.X = L1.p1.X - L1.p0.X: u.Y = L1.p1.Y - L1.p0.Y: u.z = L1.p1.z - L1.p0.z v.X = l2.p1.X - l2.p0.X: v.Y = l2.p1.Y - l2.p0.Y: v.z = l2.p1.z - l2.p0.z w.X = L1.p0.X - l2.p0.X: w.Y = L1.p0.Y - l2.p0.Y: w.z = L1.p0.z - l2.p0.z: a_ = dot(u, u) ' always >= 0 b_ = dot(u, v) c_ = dot(v, v) ' always >= 0 d_ = dot(u, w) e_ = dot(v, w) d__ = a_ * c_ - b_ * b_ ' always >= 0 Dim sc As Double, tc As Double SMALL_NUM = 0.000000001 '' compute the line parameters of the two closest points If (d_ < SMALL_NUM) Then '' the lines are almost parallel sc = 0# If b_ > c Then tc = d_ / b_ ElseIf b_ <= c Then tc = e_ / c_ End If End If If (d_ > SMALL_NUM) Then '' sc = (b_ * e_ - c_ * d_) / d__ tc = (a_ * e_ - b_ * d_) / d__ End If Dim dP As Vector3D '' get the difference of the two closest points dP.X = w.X + (sc * u.X) - (tc * v.X) '' L1(sc) - L2(tc) dP.Y = w.Y + (sc * u.Y) - (tc * v.Y) '' L1(sc) - L2(tc) dP.z = w.z + (sc * u.z) - (tc * v.z) '' L1(sc) - L2(tc) dist3D_Line_to_Line = norm(dP) '' // return the closest distance End Function Public Function dot(u As Vector3D, v As Vector3D) dot = (u.X * v.X + u.Y * v.Y + u.z * v.z) End Function Public Function norm(v As Vector3D) norm = Sqr(dot(v, v)) End Function Public Function Point_To_Line_Distance_2D(p1 As Point2D, p2 As Point2D, p0 As Point2D) As Double ' p0 is the point to test. ' p1,p2 is the line to check distance. ' ' Returns distance from the line, or if the intersecting point on the line nearest ' the point tested is outside the endpoints of the line, the distance to the ' nearest endpoint. ' ' Returns 9999 on 0 denominator conditions. Dim LineMag As Double, u As Double Dim Ix As Double, iy As Double ' intersecting point Dim pi As Point2D LineMag = lineMagnitude(p1, p2) If LineMag < 0.00000001 Then Point_To_Line_Distance_2D = 9999: Exit Function u = (((p0.X - p1.X) * (p2.X - p1.X)) + ((p0.Y - p1.Y) * (p2.Y - p1.Y))) u = u / (LineMag * LineMag) If u < 0.00001 Or u > 1 Then '// closest point does not fall within the line segment, take the shorter distance '// to an endpoint pi.X = lineMagnitude(p0, p1) pi.Y = lineMagnitude(p0, p2) If pi.X > pi.Y Then Point_To_Line_Distance_2D = pi.Y Else Point_To_Line_Distance_2D = pi.X Else ' Intersecting point is on the line, use the formula pi.X = p1.X + u * (p2.X - p1.X) pi.Y = p1.Y + u * (p2.Y - p1.Y) Point_To_Line_Distance_2D = lineMagnitude(p0, pi) End If End Function Public Function Point_To_Line_Distance_3D(x1 As Point3d, x2 As Point3d, x0 As Point3d) Dim X2mX1 As Point3d, X1mX0 As Point3d, XxY As Point3d Dim Norm2_X2X1 As Double X2mX1.X = x2.X - x1.X X2mX1.Y = x2.Y - x1.Y X2mX1.z = x2.z - x1.z Norm2_X2X1 = Sqr(X2mX1.X * X2mX1.X + X2mX1.Y * X2mX1.Y + X2mX1.z * X2mX1.z) X1mX0.X = x1.X - x0.X X1mX0.Y = x1.Y - x0.Y X1mX0.z = x1.z - x0.z Rem We need cross product of X2mX1 x X1mX0 XxY.X = X2mX1.Y * X1mX0.z - X2mX1.z * X1mX0.Y XxY.Y = X2mX1.z * X1mX0.X - X2mX1.X * X1mX0.z XxY.z = X2mX1.X * X1mX0.Y - X2mX1.Y * X1mX0.X Point_To_Line_Distance_3D = Sqr(XxY.X * XxY.X + XxY.Y * XxY.Y + XxY.z * XxY.z) / Norm2_X2X1 End Function Public Sub Cast_Image_ray_and_Find_Closest_LiDAR(Index As Long, p_x As Double, p_y As Double) Rem This routine casts the image ray and finds points along the "tube" Rem p_x, p_y are the image coords, index is the image pointed Dim cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D Dim ray As Point3d, z As Double Dim X3 As Point3d, X4 As Point3d Dim x1 As Point3d, x2 As Point3d, x0 As Point3d Rem these are the directions of the camera axes z = -image_info(Index).c Line = ADSOBS(Index).lp.Line If image_info(Index).Imagetype = "ADS L0" Then cam_vec_x.X = ODFs(Line, Index).a00 cam_vec_x.Y = ODFs(Line, Index).a01 cam_vec_x.z = ODFs(Line, Index).a02 cam_vec_y.X = ODFs(Line, Index).a10 cam_vec_y.Y = ODFs(Line, Index).a11 cam_vec_y.z = ODFs(Line, Index).a12 cam_vec_z.X = ODFs(Line, Index).a20 cam_vec_z.Y = ODFs(Line, Index).a21 cam_vec_z.z = ODFs(Line, Index).a22 image_info(Index).Xo = ODFs(Line, Index).X image_info(Index).Yo = ODFs(Line, Index).Y image_info(Index).Zo = ODFs(Line, Index).z p_x = ADSOBS(Index).xy.X p_y = ADSOBS(Index).xy.Y ray.X = p_x * cam_vec_x.X + p_y * cam_vec_y.X + z * cam_vec_z.X ray.Y = p_x * cam_vec_x.Y + p_y * cam_vec_y.Y + z * cam_vec_z.Y ray.z = p_x * cam_vec_x.z + p_y * cam_vec_y.z + z * cam_vec_z.z X3.X = image_info(Index).Xo + ray.X * image_info(Index).Zo X3.Y = image_info(Index).Yo + ray.Y * image_info(Index).Zo X3.z = image_info(Index).Zo + ray.z * image_info(Index).Zo Call LSR_TO_KKJ(Index, image_info(Index).Xo, image_info(Index).Yo, image_info(Index).Zo, x1.X, x1.Y, x1.z) Call LSR_TO_KKJ(Index, X3.X, X3.Y, X3.z, X4.X, X4.Y, X4.z) ray.X = X4.X - x1.X ray.Y = X4.Y - x1.Y ray.z = X4.z - x1.z End If If image_info(Index).Imagetype = "FRAME" Then Call DefineCameraVector(Index, cam_vec_x, cam_vec_y, cam_vec_z) ray.X = p_x * cam_vec_x.X + p_y * cam_vec_y.X + z * cam_vec_z.X ray.Y = p_x * cam_vec_x.Y + p_y * cam_vec_y.Y + z * cam_vec_z.Y ray.z = p_x * cam_vec_x.z + p_y * cam_vec_y.z + z * cam_vec_z.z x1.X = image_info(Index).Xo: x1.Y = image_info(Index).Yo: x1.z = image_info(Index).Zo End If Rem this is the direction of a ray cast from point p_x, p_y in the film plane Rem This is the principal point, point X1, then we have point X2 down Rem They make the line, LidAR point is point X0 Rem d (distance) is lenght((X2-X1) cross (X1-X0)) / lenght (X2-x1) Rem Place X2 down far away Rem currenly Z_sol gives a range in Z, over which compute XY, gives a tilted cylinder, use Rem it to define a box, inside which carry out proximity tests Dim Plow As Point3d, Phigh As Point3d Dim PMin As Point3d, PMax As Point3d Dim Dist_low As Double, Dist_high As Double Plow.z = Z_sol - Z_depth / 2: Phigh.z = Z_sol + Z_depth / 2 Rem Solve distances Dist_low = (Plow.z - x1.z) / ray.z 'Exit Sub Dist_high = (Phigh.z - x1.z) / ray.z Rem Solve X and Y Plow.X = x1.X + ray.X * Dist_low Plow.Y = x1.Y + ray.Y * Dist_low Phigh.X = x1.X + ray.X * Dist_high Phigh.Y = x1.Y + ray.Y * Dist_high x2.X = x1.X + ray.X * (Dist_low + 100): x2.Y = x1.Y + ray.Y * (Dist_low + 100): x2.z = x1.z + ray.z * (Dist_low + 100) Dist_mean = (Z_sol - x1.z) / ray.z Dim x_soli As Double, y_soli As Double x_soli = x1.X + ray.X * Dist_mean y_soli = x1.Y + ray.Y * Dist_mean Dim exists As Boolean exists = True Call DefineLiDARHectar(x_soli, y_soli, exists) Rem These xyz -coordinates are the centers of the cylinder facets, now if we make a square at both Rem Up and Down, then look for the min/max in XY, we have the bounding XY-area, and the Z-depth is Rem known Dim x_min As Double, x_max As Double Dim y_min As Double, y_max As Double x_min = 100000000000#: x_max = -100000000000# y_min = 100000000000#: y_max = -100000000000# Dim dX As Double For dX = -5 To 5.1 Step 10 x_min = Min(x_min, Plow.X + dX) x_min = Min(x_min, Phigh.X + dX) x_max = Max(x_max, Plow.X + dX) x_max = Max(x_max, Phigh.X + dX) y_min = Min(y_min, Plow.Y + dX) y_min = Min(y_min, Phigh.Y + dX) y_max = Max(y_max, Plow.Y + dX) y_max = Max(y_max, Phigh.Y + dX) Next dX PMin.X = x_min: PMin.Y = y_min: PMin.z = Plow.z PMax.X = x_max: PMax.Y = y_max: PMax.z = Phigh.z Rem ******** PERFORM RAY-CASTING ******* Dim apu As Variant, MaxI As Long, distlimit As Double Dim TopPoint As Point3d Dim H As Double, Apu_z As Byte, MaxDTM As Double, MinDTM As Double Dim dist As Double, Nin As Long, Hmax As Double distlimit = 0.35 MaxI = 0 Rem C-function in dll On Error Resume Next If exists = True And beencalled = False Then beencalled = True 'apu = MYFUNC_CASTIMAGERAYANDFINDCLOSESTLIDAR(x1, ray, x2, PMin, PMax, distlimit, MaxI, TopPoint) apu = MYFUNC_CAST_IMAGE_RAY_AND_FIND_CLOSEST_RIEGL_LIDAR(x1, ray, x2, PMin, PMax, distlimit, MaxI, TopPoint) ' apu = MYFUNC_CAST_IMAGE_RAY_AND_FIND_CLOSEST_43BYTE_LIDAR(x1, ray, x2, PMin, PMax, distlimit, MaxI, TopPoint) beencalled = False End If MaxDTM = 14 MinDTM = 4 Dim POnLine As Point3d Dim DistanceToPoint As Double If MaxI <> 0 Then Rem H = TopPoint.z - getheight(TopPoint.X, TopPoint.Y) DistanceToPoint = Sqr((TopPoint.X - x1.X) ^ 2 + (TopPoint.Y - x1.Y) ^ 2 + (TopPoint.z - x1.z) ^ 2) RayLen = Sqr((ray.X) ^ 2 + (ray.Y) ^ 2 + (ray.z) ^ 2) POnLine.X = x1.X + ray.X * DistanceToPoint * 1 / RayLen POnLine.Y = x1.Y + ray.Y * DistanceToPoint * 1 / RayLen POnLine.z = x1.z + ray.z * DistanceToPoint * 1 / RayLen Dim re As Long, gr As Long, bl As Long Dim ImaNum As Long, additnum As Long, PointNum As Integer, imdata As RGBNIR, Pan_mean As Double, Pan_Max As Double, Pan_Min As Double, Pan_SD As Double For i = 0 To NumOfImages - 1 apu = (255 - (255 - (H - MinDTM) * 255 / (MaxDTM - MinDTM))) / 4 ' DTM Rem HSV-code If apu < 1 Then apu = 1 If apu > 255 Then apu = 255 Apu_z = CByte(apu) If Apu_z > 64 Then Apu_z = 64 Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, POnLine.X, POnLine.Y, POnLine.z, p_x, p_y) Rem RGBNIR-VALUES 'GoTo PassBy Form1.Picture1(i).CurrentX = 10 Form1.Picture1(i).CurrentY = Form1.Picture1(i).ScaleHeight - 50 Form1.Picture1(i).FontSize = 10 Form1.Picture1(i).Font = Arial Form1.Picture1(i).FontBold = False ''Call Get_value_from_16_byte_image(CLng(i), POnLine.X, POnLine.Y, POnLine.z, 2, 1, imdata, Pan_mean, Pan_Max, Pan_Min, Pan_SD) ''Form1.Picture1(i).Print imdata.r & " " & imdata.G & " " & imdata.B & " " & imdata.NIR & " " & Format$(Pan_mean, "0.0") & " " & Format$(Pan_SD, "0.0") PassBy: Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix Phigh.z = TopPoint.z + 0.65 Dist_high = (Phigh.z - x1.z) / ray.z Rem Solve X and Y Phigh.X = x1.X + ray.X * Dist_high Phigh.Y = x1.Y + ray.Y * Dist_high Call r_transform_ground_to_pixel(i, TopPoint.X, TopPoint.Y, TopPoint.z, p_x, p_y) Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 255) Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).FontSize = 10 Form1.Picture1(i).Font = Arial Form1.Picture1(i).ForeColor = RGB(255, 255, 0) Form1.Picture1(i).FontBold = True Form1.Picture1(i).Print Format$(H, "0.00") 'Form1.Picture1(i).Print Format$(POnLine.z, "0.00 m") DoEvents End If Dim gp As Point3d, lp As ads40_image_point_struct If image_info(i).Imagetype = "ADS L0" Then Call KKJ_to_LSR(CLng(i), POnLine.X, POnLine.Y, POnLine.z, gp.X, gp.Y, gp.z) apu = grnd2lp(CLng(i), gp, lp) alku_x = (lp.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x alku_y = (lp.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y Form1.Picture1(i).DrawWidth = 3 Form1.Picture1(i).PSet (alku_x, alku_y), RGB(255, 0, 0) Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).FontSize = 10 Form1.Picture1(i).Font = Arial Form1.Picture1(i).FontBold = True Form1.Picture1(i).ForeColor = RGB(255, 255, 0) Form1.Picture1(i).Print Format$(H, "0.00 m") Form1.Picture1(i).Print Format$(POnLine.z, "0.00 m") End If Next i ' Open "c:\temp\toptest.txt" For Append As 4 ' Print #4, Phigh.X, Phigh.Y, Phigh.z, TopPoint.X, TopPoint.Y, TopPoint.z, POnLine.X, POnLine.Y, POnLine.z ' Close (4) 'X_sol = TopPoint.X 'Y_sol = TopPoint.Y 'Z_sol = TopPoint.z X_sol = POnLine.X Y_sol = POnLine.Y Z_sol = POnLine.z Dim testipiste As Point testipiste.X = X_sol testipiste.Y = Y_sol ' inout = InsidePolygon(P, UBound(P), testipiste) ' If inout = 1 Then Form1.Label10.Caption = "Point In" ' If inout = 0 Then Form1.Label10.Caption = "Point Out" Form1.Label4(0).Caption = Format$(X_sol, "#.00") Form1.Label4(1).Caption = Format$(Y_sol, "#.00") Form1.Label4(2).Caption = Format$(Z_sol, "#.00") SolutionExists = True Measurement.X = X_sol Measurement.Y = Y_sol Measurement.z = Z_sol Measurement.H_LiDAR = H ' Call GetLiDARObs 'Call center_to_xyz ' Call PlotMeasurements("C:\temp\for254_trees.txt") ' Call get_2012_image_values(X_sol, Y_sol, Z_sol) Call getheight(X_sol, Y_sol) End If Form1.Label10.Caption = "H: " & Format$(H, "0.00 m") End Sub Public Sub get_2012_image_values(X_sol As Double, Y_sol As Double, Z_sol As Double) ' This routine reads the CSV with 2012 image data, solves the file position, gets the RGB-values, computes ' the angular observations then. Note, versions for RGB, RGBN, PAN versions Dim N_image As Long, C_image As String, p_x As Double, p_y As Double, hdrname As String, k As Double ReDim Ar(1 To 3, 1 To 3) As Double Dim paikka As Long, i As Long Rem PARAMETERS ******************************** Dim kuvatyyppi As String Target = "vAAHTERA14" On Error GoTo uusi: Outpath = "c:\temp\markus\" & Target & "\" ChDir (Outpath) GoTo onjo: uusi: apu = MsgBox(Outpath & " does not exist, create?", vbOKCancel, "Viesti") If apu = 1 Then MkDir (Outpath) End If onjo: On Error Resume Next Dim kuva(1 To 3) As String kuva(1) = "RGB8" kuva(2) = "RGBN16" kuva(3) = "PAN16" '*********************************** SaveImage = True '***************** Form1.Width = 8500 Form1.Height = 6500 For k = 1 To 3 ' kuvatyyppi Close (22) kuvatyyppi = kuva(k) Select Case kuvatyyppi Case "RGBN16" Dim imdata As RGBNIR Open "c:\data\cam_data_2012_col_16.csv" For Input As 22 If Form1.Gamma_1.Checked = True Then Form1.Gamma_1.Checked = False End If Case "PAN16" Dim PANpikseli As Integer Open "c:\data\cam_data_2012_pan_16.csv" For Input As 22 If Form1.Gamma_1.Checked = False Then Form1.Gamma_1.Checked = True Form1.Gamma_2.Checked = False Form1.Gamma_3.Checked = False Form1.Gamma_4.Checked = False Form1.Gamma_5.Checked = False Form1.Gamma_6.Checked = False 'Exit Sub End If Case "RGB8" Dim pikseli As RGBtriplet Open "c:\data\cam_data_2012.csv" For Input As 22 If Form1.Gamma_1.Checked = True Then Form1.Gamma_1.Checked = False End If End Select counter = 0 On Error Resume Next Kill "c:\data\Imafiles\*.txt" Do Until EOF(22) Input #22, N_image, Ndummy, c_, omega, phi, kappa, Xo, Yo, Zo, C_image, hdrname, c_year Close (1) Open hdrname For Input As 1 Call read_set_file_for_an_image(100) Call r_transform_ground_to_pixel(100, X_sol, Y_sol, Z_sol, p_x, p_y) Rem Check if the point falls to this image p_y = (image_info(100).Height - 1) - p_y If p_x > 3 And p_x < image_info(100).Width - 3 And p_y > 3 And p_y < image_info(100).Height - 3 Then Rem it does 'Open "c:\temp\in.txt" For Append As 111 'Print #111, id & "," & N_image & "," & hdrname & ","; X_sol & "," & Y_sol & "," & Z_sol 'GoTo NextPoint Open "c:\data\ImaFiles\" & c_year & "_" & C_image & ".txt" For Output As 3 Print #3, N_image & "," & hdrname & ","; X_sol & "," & Y_sol & "," & Z_sol Close (3) Call Open_An_image_and_Center_to_XYZ("c:\data\ImaFiles\" & c_year & "_" & C_image & ".txt") Open image_info(100).FileName For Binary As 5 p_y = CDbl(CLng(p_y)) p_x = CDbl(CLng(p_x)) Select Case kuvatyyppi Case "RGBN16" ' ********** RGBN16 Get #5, 1 + ((p_y) * 4) * image_info(100).Width * 2 + (p_x) * 4 * 2, imdata.r Get #5, 1 + ((p_y) * 4) * image_info(100).Width * 2 + (p_x) * 4 * 2 + 2, imdata.G Get #5, 1 + ((p_y) * 4) * image_info(100).Width * 2 + (p_x) * 4 * 2 + 4, imdata.B Get #5, 1 + ((p_y) * 4) * image_info(100).Width * 2 + (p_x) * 4 * 2 + 6, imdata.NIR Case "RGB8" ' ********* RGB8 Rsum = 0: gsum = 0: bsum = 0 For Ix = -1 To 1 For jx = -1 To 1 paikka = CLng(p_y + jx) * CLng(image_info(100).sub_width) * 3 + CLng(p_x + Ix) * 3 Get #5, paikka, pikseli Rsum = Rsum + pikseli.r gsum = gsum + pikseli.G bsum = bsum + pikseli.B Next jx Next Ix pikseli.r = Rsum / 9 pikseli.G = gsum / 9 pikseli.B = bsum / 9 Case "PAN16" ' ************ PAN16 Rsum = 0 For Ix = -1 To 1 For jx = -1 To 1 Get #5, 1 + ((p_y + jx)) * image_info(100).Width * 2 + CLng(p_x + Ix) * 2, PANpikseli 'Get #5, paikka, PANpikseli Rsum = Rsum + PANpikseli Next jx Next Ix PANpikseli = Rsum / 9 End Select Rem Compute the view-illuimnation geometry i = 100 Fii = (90 - image_info(i).Sun_azimuth * TO_DEGREES) * TO_RADIANS ' sun azimuth Theta = (90 - image_info(i).Sun_elevation * TO_DEGREES) * TO_RADIANS ' sun elevation Dim SunV As Vector3D, CamV As Vector3D, plumb As Vector3D, t1 As Vector3D, t2 As Vector3D, east As Vector3D SunV.X = 1 * Sin(Theta) * Cos(Fii): SunV.Y = 1 * Sin(Theta) * Sin(Fii): SunV.z = 1 * Cos(Theta) CamV.X = image_info(i).Xo - X_sol: CamV.Y = image_info(i).Yo - Y_sol: CamV.z = image_info(i).Zo - Z_sol t1.X = SunV.X: t1.Y = SunV.Y: t1.z = 0 t2.X = CamV.X: t2.Y = CamV.Y: t2.z = 0 plumb.X = 0: plumb.Y = 0: plumb.z = 1 east.X = 3: east.Y = 0: east.z = 0 ViewZenith = TO_DEGREES * vector_angle(plumb, CamV) ' view zenith in degrees AzimDiff = TO_DEGREES * vector_angle(t1, t2) ' azimuth difference in degrees ViewAzimuth = TO_DEGREES * vector_angle(t2, east) ' view azimuth Rem Store the data per image to this file Select Case kuvatyyppi Case "RGBN16" Open Outpath & Target & "_RGBN16.txt" For Append As 6 If counter = 0 Then Print #6, "Target x y x kuva sarake rivi Katselukulma Atsimuuttiero KatseluAtsimuutti AurinkoKorkeus AurinkoAtsimuutti RED16 GRN16 BLU16 NIR16" Print #6, Target, X_sol, Y_sol, Z_sol, image_info(0).ImageCode, p_x, p_y, ViewZenith, AzimDiff, ViewAzimuth, Theta * TO_DEGREES, Fii * TO_DEGREES, imdata.r, imdata.G, imdata.B, imdata.NIR If SaveImage = True Then SavePicture Form1.Picture1(0).Image, Outpath & Target & "_RGBN16_" & image_info(0).ImageCode & ".bmp" End If Case "RGB8" Open Outpath & Target & "_RGB8.txt" For Append As 6 If counter = 0 Then Print #6, "Target x y x kuva sarake rivi Katselukulma Atsimuuttiero KatseluAtsimuutti AurinkoKorkeus AurinkoAtsimuutti RED8 GRN8 BLU8" Print #6, Target, X_sol, Y_sol, Z_sol, image_info(0).ImageCode, p_x, p_y, ViewZenith, AzimDiff, ViewAzimuth, Theta * TO_DEGREES, Fii * TO_DEGREES, pikseli.r, pikseli.G, pikseli.B If SaveImage = True Then SavePicture Form1.Picture1(0).Image, Outpath & Target & "_RGB8_" & image_info(0).ImageCode & ".bmp" End If Case "PAN16" Open Outpath & Target & "_PAN16.txt" For Append As 6 If counter = 0 Then Print #6, "Target x y x kuva sarake rivi Katselukulma Atsimuuttiero KatseluAtsimuutti AurinkoKorkeus AurinkoAtsimuutti PAN16" Print #6, Target, X_sol, Y_sol, Z_sol, image_info(0).ImageCode, p_x, p_y, ViewZenith, AzimDiff, ViewAzimuth, Theta * TO_DEGREES, Fii * TO_DEGREES, PANpikseli If SaveImage = True Then SavePicture Form1.Picture1(0).Image, Outpath & Target & "_PAN16_" & image_info(0).ImageCode & ".bmp" End If End Select Close (6) Close (5) counter = counter + 1 Rem Prepare for storing the images for later inspection 'If SaveImage = True Then ' SavePicture Form1.Picture1(0).Image, "c:\temp\Markus\" & Target & "_" & image_info(0).ImageCode & ".bmp" 'End If ' SavePicture Form1.Picture1(0).Image, "c:\temp\avi\" & Format$(counter, "000") & ".bmp" End If Call Remove_all_images NextPoint: Loop ' Next image Close (22) If selection = False Then MsgBox ("Written " & counter & " records") Next k MsgBox ("Done with all 3 image types") Close (22) Close (6) End Sub Public Sub clear_images() For i = 0 To NumOfImages - 1 Form1.Picture1(i).Cls Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).FontSize = 8 Next i End Sub Public Sub Get_Angular_Info(ByVal i As Integer, ByRef NadAng As Double, ByRef SolAziDiff As Double, ByRef ObjToCamAzi As Double) Dim Fii As Double, Theta As Double Dim sunray As Vector3D Dim cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D Dim raystart As Vector3D Dim p_x As Double, p_y As Double Dim sun As Double If SolutionExists = False Then Exit Sub Dim cout As String Rem Fii e [-Pi,Pi], (270W,270W), 90E=0 Fii = (90 - image_info(i).Sun_azimuth * TO_DEGREES) * TO_RADIANS Rem Theta: 0 = zenith, +Pi/2 = horizon Theta = (90 - image_info(i).Sun_elevation * TO_DEGREES) * TO_RADIANS Dim camera_x As Double, camera_y As Double Dim nadir_x As Double, nadir_y As Double Dim sun_x As Double, sun_y As Double Dim cam_x As Double, cam_y As Double Dim alpha As Double, z As Double, apu As Double Call r_transform_3D(i, X_sol, Y_sol, Z_sol, camera_x, camera_y) Call r_transform_3D(i, image_info(i).Xo, image_info(i).Yo, 100, nadir_x, nadir_y) Call create_vector(cam_vec_x, A(1, 1, i), A(2, 1, i), A(3, 1, i)) Call create_vector(cam_vec_y, A(1, 2, i), A(2, 2, i), A(3, 2, i)) Call create_vector(cam_vec_z, A(1, 3, i), A(2, 3, i), A(3, 3, i)) z = -image_info(i).c cam_x = -camera_x cam_y = -camera_y Rem Direction from tree to image center alpha = MYFUNC_ATAN2(cam_y, cam_x) alpha = alpha + pi sunray.X = Sin(Theta) * Cos(Fii) sunray.Y = Sin(Theta) * Sin(Fii) sunray.z = Cos(Theta) raystart.X = (camera_x) * cam_vec_x.X + (camera_y) * cam_vec_y.X + z * cam_vec_z.X raystart.Y = (camera_x) * cam_vec_x.Y + (camera_y) * cam_vec_y.Y + z * cam_vec_z.Y raystart.z = (camera_x) * cam_vec_x.z + (camera_y) * cam_vec_y.z + z * cam_vec_z.z sun = MYFUNC_ATAN2(100 * sunray.Y, 100 * sunray.X) ' MsgBox ("Sun's azimuth: " & -(-PI / 2 + sun) * TO_DEGREES) cout = cout & Format$(-(-pi / 2 + sun) * TO_DEGREES, "#.0") & Chr$(9) ' MsgBox ("Sun's elevation: " & CStr(image_info(i).Sun_elevation * TO_DEGREES)) 'Cout = Cout & Format$(image_info(i).Sun_elevation * TO_DEGREES, "#.0") & Chr$(9) 'sun = sun + PI Rem Alpha & beeta -Pi..Pi with respect to East alpha = MYFUNC_ATAN2(100 * raystart.Y, 100 * raystart.X) If alpha < -pi / 2 Then 'MsgBox ("Camera ray's azimuth: " & -(-PI / 2 + alpha) * TO_DEGREES) apu = -(-pi / 2 + alpha) * TO_DEGREES If apu > 180 Then apu = apu - 180 GoTo cout1 End If If apu < 180 Then apu = apu + 180 cout1: cout = cout & Format$(apu, "#.0") & Chr$(9) End If If alpha >= -pi / 2 Then 'MsgBox ("Camera ray's azimuth: " & -(-PI / 2 + alpha) * TO_DEGREES) apu = -(-pi / 2 + alpha) * TO_DEGREES If apu > 180 Then apu = apu - 180 GoTo cout2 End If If apu < 180 Then apu = apu + 180 cout2: cout = cout & Format$(apu, "#.0") & Chr$(9) End If Rem ************************ Rem CAMERA RAY's azimuth APU ObjToCamAzi = apu Rem ************************ Rem apu holds azimuth alpha = alpha + pi sun = -(-pi / 2 + sun) sun = sun * TO_DEGREES Rem Sun holds azimuth Call normalize(raystart) Call normalize(sunray) Call r_transform_3D(i, X_sol + 1000 * sunray.X, Y_sol + 1000 * sunray.Y, Z_sol + 1000 * sunray.z, sun_x, sun_y) Dim diff diff = sun - apu If diff < -180 Then diff = ((180 + diff) + 180) GoTo skip3 End If If diff > 180 Then diff = (180 - (diff - 180)) * -1 End If skip3: Rem ***************************************** Rem Diffrence in AZImuth -180,...,180 degrees SolAziDiff = diff 'If (Abs(diff) >= 0 And Abs(diff) < 45) Then cout = cout & "B" & Chr$(9) 'If (Abs(diff) >= 45 And Abs(diff) < 90) Then cout = cout & "BS" & Chr$(9) 'If (Abs(diff) >= 90 And Abs(diff) < 135) Then cout = cout & "FS" & Chr$(9) 'If (Abs(diff) >= 135 And Abs(diff) <= 180) Then cout = cout & "F" & Chr$(9) cam_vec_z.z = -cam_vec_z.z cam_vec_z.Y = -cam_vec_z.Y cam_vec_z.X = -cam_vec_z.X Call normalize(cam_vec_z) Rem *************** Rem Nadir angle (off-angle) NadAng = vector_angle(cam_vec_z, raystart) * TO_DEGREES End Sub ' Linear function with various extent Public Function Bartlett_Linear(ByVal X#, kernel_size As Double) As Double X = Abs(X) If X < kernel_size Then Bartlett_Linear = (1 - Abs(X) / kernel_size) / kernel_size End Function Public Sub Bilinear(k As Long, i As Long, w_temp As Long, h_temp As Long, SizeArr() As Byte, tx() As Byte, t1() As Byte) Dim X&, Y&, x1&, y1&, m&, N&, kX#, kY#, fX#, fY# Dim IR#, iG#, iB#, r1#, r2# If i = 2 And k = 6 Then aa = 1 End If srcWidth = w_temp srcHeight = h_temp dstWidth = SizeArr(k, 1) dstHeight = SizeArr(k, 2) kX = (srcWidth - 1) / (dstWidth - 1) kY = (srcHeight - 1) / (dstHeight - 1) For Y = dstHeight - 1 To 0 Step -1 fY = Y * kY ' Exact position (floating-point number) y1 = Int(fY) ' Integer position (integer part of number) fY = fY - y1 ' Fraction part of number (integer+fraction=exact) For X = 0 To dstWidth - 1 fX = X * kX x1 = Int(fX) fX = fX - x1 x1 = x1 IR = 0: iG = 0: iB = 0 ' Uses various kernel size kernel_size = 1 For m = -kernel_size + 1 To kernel_size r1 = Bartlett_Linear(m - fY, CDbl(kernel_size)) For N = -kernel_size + 1 To kernel_size r2 = Bartlett_Linear(fX - N, CDbl(kernel_size)) iB = iB + tx(x1 + N, y1 + m) * r1 * r2 Next Next t1(X, Y) = iB Next Next Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".img" For Output As 10 Print #10, dstWidth, dstHeight, SizeArr(k, 3), SizeArr(k, 4) Close (10) Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".raw" For Binary As 10 Put #10, , t1 Close (10) End Sub Public Sub Measure_tree_tops_By_Matching_sub(i_ref As Long) Rem This routine uses a reference image, that it clicked for its tree top image position Rem The reference image ray is discretized, and along it image correlation is calculated Rem for templates of varying size (the routine calls resize templates ()) Rem Rem Correlation is aggregated for points in a 2D space: Size x position (XYZ), and Rem the maximum value is given. The reference image template has an associated crown Rem width, which is re-scaled by the Size-parameter (multiplier) Rem MUFUNC_corima() routine is modified and used in VB for the cross-correlation between image patch Dim p_x As Double, p_y As Double Dim Z_gnd As Double, Y_Gnd As Double, X_Gnd As Double Rem First we solve the XY-position of the ray, given Z as Z_sol. We get X_gnd, Y_gnd_Z_gnd and the pixel-coordinates Z_gnd = Z_sol Call solve_3D_X_Y_from_Z_x_y(i_ref, Z_sol, CDbl(Form1.Text1(i_ref * 2).Text), CDbl(Form1.Text1(i_ref * 2 + 1).Text), X_Gnd, Y_Gnd) Rem Pixel values Call r_transform_ground_to_pixel(i_ref, X_Gnd, Y_Gnd, Z_gnd, p_x, p_y) Rem Loop the Z-values, discretize the reference ray in i_ref Dim Z_range As Double, Z_step As Double, X_test As Double, Y_test As Double, Z_test As Double Dim l As Long ReDim testpoints(1 To 200) As Point3d Z_range = 8 Z_step = 0.25 For Z_test = (Z_gnd - Z_range / 2) To (Z_gnd + Z_range / 2) Step Z_step l = l + 1 Call solve_3D_X_Y_from_Z_x_y(i_ref, Z_test, CDbl(Form1.Text1(i_ref * 2).Text), CDbl(Form1.Text1(i_ref * 2 + 1).Text), X_test, Y_test) testpoints(l).X = X_test testpoints(l).Y = Y_test testpoints(l).z = Z_test Next Z_test Dim N_Of_TestPoints As Long Dim R_Max As Double, R0_Max As Double Dim ScaleMax As Long, MaxPoint As Long R0_Max = -1 R_Max = -1 N_Of_TestPoints = l Rem This array will hold the aggregated correlation, for the 11 cases ReDim R_array(1 To N_Of_TestPoints, 1 To 11) As Double ReDim R0_Array(1 To 11) As Double Dim kX As Long, kY As Long Rem The discretized reference ray is now stored as points in the point3D array testpoints() Rem Which images are to be used Dim w_temp As Long, h_temp As Long, c_col As Long, c_row As Long, address As Long For i = 0 To NumOfImages - 1 If Form1.Check1(i).Value = 1 Then ReDim Color_photo_Patch(0 To image_info(i).sub_width - 1, 0 To 159) As RGBtriplet ' ReDim Color_Photo_temp(0 To 99, 0 To 139) As RGBtriplet ' ReDim Color_Photo_Row(0 To 99, 0 To 139) As RGBtriplet ' ReDim BW_Photo_Patch(0 To image_info(i).sub_width - 1, 0 To 139) As Byte ' ReDim BW_Photo_temp(0 To 99, 0 To 139) As Byte ' ReDim BW_Photo_Row(0 To 139) As Byte ReDim startRows(0 To MAXIMA - 1) As Long ReDim startCols(0 To MAXIMA - 1) As Long Rem Let's read the image patches for the first testpoint, store StartRows() Call r_transform_ground_to_pixel(i, X_Gnd, Y_Gnd, Z_gnd, p_x, p_y) address = CLng((image_info(i).sub_height - 1) - (p_y + 80)) * image_info(i).sub_width * 3 ' + p_x * 3 startRows(i) = CLng((image_info(i).sub_height - 1) - (p_y + 80)) startCols(i) = 0 'Open image_info(i).FileName For Binary As 1 Close (1) Open image_info(i).FileName For Binary As 1 'Exit Sub Get #1, address + 1, Color_photo_Patch 'Close (1) 'Exit Sub For k = 1 To 11 Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".img" For Input As 12 Input #12, w_temp, h_temp, c_col, c_row Close (12) ReDim template(0 To w_temp - 1, 0 To h_temp - 1) As Byte Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".raw" For Binary As 12 Get #12, , template Close (12) Rem Now we should take the values, from the image, let's take green ReDim Image(0 To w_temp - 1, 0 To h_temp - 1) As Byte For j = 1 To N_Of_TestPoints Call r_transform_ground_to_pixel(i, testpoints(j).X, testpoints(j).Y, testpoints(j).z, p_x, p_y) Rem we read a 100 by 100 image patch to be used with every template Rem Compute the row in the 100 row high image Rem p_x and p_y are in the hot_spot; we must shift apu = CLng((image_info(i).sub_height - 1) - p_y) - startRows(i) Rem apu is the shift in row direction, of the hot_spot row apu_y = apu - c_row apu_x = p_x - c_col For kX = 0 To w_temp - 1 For kY = 0 To h_temp - 1 ' Image(kX, kY) = CByte((CLng(Color_photo_Patch(apu_x + kX, apu_y + kY).r) + CLng(Color_photo_Patch(apu_x + kX, apu_y + kY).g) + CLng(Color_photo_Patch(apu_x + kX, apu_y + kY).B)) / 3#) Image(kX, kY) = CByte((Color_photo_Patch(apu_x + kX, apu_y + kY).G)) ' Exit Sub Next kY Next kX Dim meaIm As Double, stdIm As Double apu = MYFUNC_TEMPMEANSTD(template(0, 0), CLng(UBound(template, 1)), CLng(UBound(template, 2)), meaIm, stdIm) Dim rx As Double Rem Compute cross-correlation between the scaled template and the image patch apu = MYFUNC_CCORB(template(0, 0), Image(0, 0), rx, meaIm, w_temp, h_temp) R_array(j, k) = R_array(j, k) + rx If R_array(j, k) > R_Max Then R_Max = R_array(j, k) ScaleMax = k MaxPoint = j End If Next j Next k End If Next i Rem *********** TRY IMAGE 0 AGAIN AROUND SOLUTION " i = 0 Dim testpoint As Point3d testpoint.X = testpoints(MaxPoint).X ' Exit Sub testpoint.Y = testpoints(MaxPoint).Y testpoint.z = testpoints(MaxPoint).z Call Match_template(CLng(i), testpoint) ' Call r_transform_ground_to_pixel(i, testpoints(MaxPoint).X, testpoints(MaxPoint).Y, testpoints(MaxPoint).z, p_x, p_y) 'Exit Sub ' address = CLng((image_info(i).sub_height - 1) - (p_y + 70)) * image_info(i).sub_width * 3 ' + p_x * 3 ' startRows(i) = CLng((image_info(i).sub_height - 1) - (p_y + 70)) ' startCols(i) = 0 ' Open image_info(i).FileName For Binary As 1 ' Get #1, address + 1, Color_photo_Patch ' Close (1) ' r_maxc = -1 ' For k = 1 To 11 ' Open "d:\test_" & CStr(i) & "_" & CStr(k) & ".img" For Input As 12 ' Input #12, w_temp, h_temp, c_col, c_row ' Close (12) ' ReDim template(0 To w_temp - 1, 0 To h_temp - 1) As Byte ' Open "d:\test_" & CStr(i) & "_" & CStr(k) & ".raw" For Binary As 12 ' Get #12, , template ' Close (12) ' ReDim Image(0 To w_temp - 1, 0 To h_temp - 1) As Byte ' For d_p_x = -2 To 2 ' For d_p_y = -2 To 2 ' ' apu = CLng((image_info(i).sub_height - 1) - (p_y + d_p_y)) - startRows(i) ' apu_y = apu - c_row ' apu_x = (p_x + d_p_x) - c_col ' For kX = 0 To w_temp - 1 ' For kY = 0 To h_temp - 1 ' Image(kX, kY) = CByte((Color_photo_Patch(apu_x + kX, apu_y + kY).g)) ' Next kY ' Next kX ' apu = MYFUNC_TEMPMEANSTD(template(0, 0), CLng(UBound(template, 1)), CLng(UBound(template, 2)), meaIm, stdIm) ' apu = MYFUNC_CCORB(template(0, 0), Image(0, 0), rx, meaIm, w_temp, h_temp) ' If rx > r_maxc Then ' r_maxc = rx ' ScaleMaxi = k ' End If ' Next d_p_y ' Next d_p_x ' Next k ' For i = 0 To NumOfImages - 1 ' Form1.Picture1(i).Cls ' Call r_transform_ground_to_pixel(i, testpoints(MaxPoint).X, testpoints(MaxPoint).Y, testpoints(MaxPoint).z, p_x, p_y) 'Exit Sub ' Form1.Picture1(i).DrawWidth = 3 ' Form1.Picture1(i).FontSize = 8 ' Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 0) 'If i = 1 Then 'Form1.Picture1(i).CurrentX = Form1.Picture1(i).CurrentX + 5 'Form1.Picture1(i).CurrentY = Form1.Picture1(i).CurrentY + 5 'Form1.Picture1(i).Print Format$(R_Max / CDbl(NumOfImages + 1), "0.00") 'End If ' Next i Form1.Label10.Caption = "Height: " & Format$(testpoints(MaxPoint).z - getheight(testpoints(MaxPoint).X, testpoints(MaxPoint).Y), "0.00 m") & " r = " & Format$(R_Max / CDbl(NumOfImages + 1), "0.00") Rem draw a circle 'Ulim = 11 'ReDim ScalingArr(1 To Ulim) As Double 'ScalingArr(1) = 0.4: ScalingArr(2) = 0.5: ScalingArr(3) = 0.6 'ScalingArr(4) = 0.7: ScalingArr(5) = 0.75: ScalingArr(6) = 0.8 'ScalingArr(7) = 0.85: ScalingArr(8) = 0.9: ScalingArr(9) = 1#: ScalingArr(10) = 1.1 'ScalingArr(11) = 1.2: 'i = 0 'Form1.Picture1(i).DrawWidth = 2 'Dim Xt As Double, Yt As Double, Xf As Double, Yf As Double 'Dim Shift As Double, p_x_beg As Double, p_y_beg As Double, p_x_end As Double, p_y_end As Double 'Shift = 3.14 / 10 'Radius = CDbl(Form1.Text5.Text) * ScalingArr(R0_ind) 'Radius = CDbl(Form1.Text5.Text) * ScalingArr(ScaleMaxi) 'Exit Sub ' For phi = -3.14 To 3.15 Step 3.14 / 8 ' Colorpix = RGB(120, 255, 0) ' 255 - Zdiff * 10) ' Xt = Radius * Cos(phi) + testpoints(MaxPoint).X ' Yt = Radius * Sin(phi) + testpoints(MaxPoint).Y ' Xf = Radius * Cos(phi + Shift) + testpoints(MaxPoint).X ' Yf = Radius * Sin(phi + Shift) + testpoints(MaxPoint).Y ' Zt = testpoints(MaxPoint).z - 1 ' Call r_transform_ground_to_pixel(i, Xt, Yt, Zt, p_x_beg, p_y_beg) ' Call r_transform_ground_to_pixel(i, Xf, Yf, Zt, p_x_end, p_y_end) ' Form1.Picture1(i).Line ((p_x_beg - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_beg - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1)-((p_x_end - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_end - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix 'Next phi X_sol = testpoints(MaxPoint).X Y_sol = testpoints(MaxPoint).Y Z_sol = testpoints(MaxPoint).z Form1.Label4(0).Caption = Format$(X_sol, "0.00") Form1.Label4(1).Caption = Format$(Y_sol, "0.00") Form1.Label4(2).Caption = Format$(Z_sol, "0.00") DoEvents Rem ********'species For Index = 0 To NumOfImages - 1 Dim RedVal As Integer, GreenVal As Integer, BlueVal As Integer, IrVal As Integer If image_info(Index).Num_of_addit_expos = 2 Then additnum = 2 Call r_transform_ground_to_pixel(Index, testpoints(MaxPoint).X, testpoints(MaxPoint).Y, testpoints(MaxPoint).z, p_x, p_y) p_y = (image_info(Index).Height - 1) - p_y p_x = Int(p_x * (image_info(Index).AdditWidth(additnum) / image_info(Index).Width)) p_y = Int(p_y * (image_info(Index).AdditHeight(additnum) / image_info(Index).Height)) If image_info(Index).AdditType(additnum) = 3 Then ' Open image_info(Index).AdditFileName(additnum) For Binary As 20 'Get #20, 1 + ((p_y) * 4) * image_info(Index).AdditWidth(additnum) * 2 + (p_x) * 4 * 2, RedVal 'Close (20) 'Exit Sub ' Get #20, 1 + ((p_y) * 4) * image_info(Index).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 2, GreenVal ' Get #20, 1 + ((p_y) * 4) * image_info(Index).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 4, BlueVal ' Get #20, 1 + ((p_y) * 4) * image_info(Index).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 6, IrVal Close (20) sp = FindSpecies(CDbl(RedVal), CDbl(GreenVal), CDbl(BlueVal), CDbl(IrVal)) End If End If Next Index Form1.Label10.Caption = sp & " H: " & Format$(testpoints(MaxPoint).z - getheight(testpoints(MaxPoint).X, testpoints(MaxPoint).Y), "0.00 m") & " r = " & Format$(R_Max / CDbl(NumOfImages + 1), "0.00") Rem ************* species 'Measurement.Corr_Match = R_Max 'Open "c:\temp\mk_trees.txt" For Input As 6 Close (6) ' Open "c:\temp\mk_trees.txt" For Input As 6 ' Do Until EOF(6) ' Input #6, Xm, Ym, z_butt, TreeNum, TreeSpecies, Status, TreeHeight, TreeDiam ' If Sqr((X_sol - Xm) ^ 2 + (Y_sol - Ym) ^ 2) < 1 Then ' Rem The tree is found ' GoTo foundTRee ' End If ' Loop Rem If here, then no tree was found Close (6) Exit Sub foundTRee: Close (6) 'Open "d:\ko3_koe.txt" For Append As 12 'Print #12, X_sol, Y_sol, Z_sol, Z_sol - getheight(X_sol, Y_sol), Radius * 2, Xm, Ym, TreeNum, TreeHeight, TreeDiam 'Close (12) 'Open "d:\r_s.txt" For Append As 10 'For j = 1 To N_Of_TestPoints ' For k = 1 To 11 ' Print #10, R_array(j, k) & "," & j & "," & k & "," & testpoints(j).X & "," & testpoints(j).Y & "," & testpoints(j).z ' Next k 'Next j 'Close (10) End Sub Public Sub Match_Local_Crown_A(sp As Byte) Measurement.TreeSpecies = sp ' CHANGE '' If sp = 4 Then sp = 3 If sp = 4 Then sp = 2 If sp = 5 Then sp = 3 If sp = 6 Then sp = 3 If sp = 7 Then sp = 3 If sp = 13 Then sp = 3 If sp = 16 Then sp = 3 If sp = 20 Then sp = 3 If sp = 21 Then sp = 2 If sp < 1 Or sp > 3 Then MsgBox ("Species unresolved") Exit Sub End If Rem November 2006 - April 2014. Algorithm for fitting a crown model (Added from Form1 to BAS) Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Single, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double Dim LiDARBinPath As String, LiDARBinPath2 As String Dim Npulses As Long, NHA As Long, Nsum As Long, Hlimit As Double, Hscale As Double, DensityFactor As Double Dim Nha2 As Long, P As Double, MPlot As Long Dim Wa As Double, Wc As Double Rem *********** Parameters ******** DensityFactor = 1 On Error Resume Next Hscale = 0.6 ' Down to what relative height do we model the crown DensityFactor = 1 + CDbl(Form1.Text11(0).Text) ' Scale the average height : dcrm -ratio 'Exit Sub P = 1 ' The weight by which negative residuals (inside crown) are weighted MPlot = 1 Wa = 10 Wc = 40 Close (1) Xs = X_sol: Ys = Y_sol Rem *************** WE NEED TO SAMPLE SEVERAL HECTARES *************** Rem Rem The stored hectares are maintained as long as there is a need to change - re-read Rem There can be 1, 2 or 4 hectares in memory. If the point (x,y) has an x-coordinate Rem close to 100; read both sides; similarly for the y-coordinates FN1 = Format$(Int((Xs - 2510000) / 100), "000") FN2 = Format$(Int((Ys - 6850000) / 100), "000") Rem LiDR -data structure holds data, use it if we are in the same 1-ha cell Dim k As Long Open "c:\data\als2013b_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA Close (100) Npulses = NHA Form1.Caption = "Pulses per m2: " & Format$(NHA / 10000#, "0.0") On Error Resume Next Rem If we are in the same hectare, use current LiDR() - array Ax = -1 Ax = UBound(Lidr) - NHA If Ax = 0 Then GoTo SkipreadingLidar ReDim Lidr(1 To NHA) As LidarRecord Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 For k = 1 To NHA Get #100, 5 + k * 207, Lidr(k) ' Here we read 207-byte records record by record Next k Close (100) SkipreadingLidar: Hup = 0.3 ' underestiomation of H Hlimit = (Z_sol - getheight(X_sol, Y_sol)) * Hscale Htree = (Z_sol - getheight(X_sol, Y_sol)) * 10 ' dm Tree.H = Htree Rem Calculate average, NFI-based DCRM Select Case sp Case 1 ' Pine dcrm = Htree * 0.1636 + 13 ' Case 2, 4 ' Spruce, dead tree dcrm = Htree * 0.15 + 14 Case 3 ' Birch dcrm = Htree * 0.214 + 8 End Select Rem Rem Scale it to crown radiu, consider stand density dcrm = (((dcrm / 10)) / 2) * DensityFactor DistA = dcrm MaxDTM = 25 ' default MinDTM = 0 ' default Rem *********************************************************** Rem Lidar DATA has been read. Here starts the processing of it. Rem *********************************************************** Dim Np As Long ReDim cf(0 To 4) As Double, pw(0 To 4) As Double, cont2(0 To 4) As Double Dim cfa As Double, pwa As Double, cont2a As Double, H As Double Dim red As Double, blue As Double, green As Double, mx As Long, Ntrees As Long, maxA As Long Dim Hlowest As Double maxA = 4000 ReDim Inpoints(1 To maxA) As Point3d ' The points that make the tree ReDim intensities(1 To maxA) As Double ReDim LA(1 To maxA) As Double ' Residuals in crown radius (error vector v, vTv is minimized) ReDim A_MAT(1 To maxA, 1 To 3) As Double ' Partial derivates of the unknwons crown shape parameters, design matrix ReDim XYdist(1 To maxA) As Single ReDim Zdist(1 To maxA) As Single ReDim sade(1 To maxA) As Single Dim testpoint As Point3d Dim rmse As Double Rem Crown model, crown radius as function of tree height (h) and the relative distance down the crown (zdist/h) Rem cf * h * (zdist / h) ^ pw + cont2 Rem Assign basic values per species: pine(1), spruce(2), birch(3), aspen (4) He_ = Htree / 10# cf(0) = dcrm / He_: cf(1) = dcrm / He_: cf(2) = dcrm / He_: cf(3) = (dcrm / He_): cf(4) = (dcrm / He_) pw(0) = 0.75: pw(1) = 0.5: pw(2) = 0.6: pw(3) = 0.45: pw(4) = 0.7 cont2(0) = 0.4: cont2(1) = 0.6: cont2(2) = 0.6: cont2(3) = 0.9: cont2(4) = 0.6 Tree.cf = cf(sp) Tree.pw = pw(sp) + CDbl(Form1.Text11(1).Text) Tree.cont2 = cont2(sp) + CDbl(Form1.Text11(2).Text) 'MsgBox (Tree.cf) Np = UBound(Lidr()) ReDim LPE_AR(1 To 1) As LP_Espoo ' This array holds the lidar points; no intensity ReDim LPE_AR(1 To maxA) As LP_Espoo ' This array holds the lidar points; no intensity ReDim Z_gnd(1 To maxA) As Single For i = 0 To NumOfImages - 1 Form1.Picture1(i).Cls Next i Zmax = 0 l = 0 For k = 1 To Np For j = 4 To (5 - Lidr(k).pulseCount) Step -1 ' take only first retrun data? If Lidr(k).Returns(j).X > 1 And Lidr(k).Returns(j).z < (Z_sol + Hup) And Lidr(k).Returns(j).z > ((Z_sol) - (Tree.H * 0.06)) Then 'And Abs(LidR(k).Returns(1).z - LidR(k).Returns(4).z) < 1 Then Rem Here we collect the observations, we allow .25 m higher testisade = Tree.cf * (Tree.H * 0.1 + Hup) * (2.5 * ((Z_sol + Hup) - Lidr(k).Returns(j).z) / (Tree.H * 0.1 + Hup)) ^ Tree.pw + Tree.cont2 ^ 2 ' testisade2 = Tree.cf * (Tree.H * 0.3) * (2.5 * ((Z_sol + Hup) - Lidr(k).Returns(j).z) / (Tree.H)) ^ Tree.pw + Tree.cont2 ^ 2 If Sqr((Lidr(k).Returns(j).X - X_sol) ^ 2 + (Lidr(k).Returns(j).Y - Y_sol) ^ 2) < testisade Then l = l + 1 Z_gnd(l) = getheight(Lidr(k).Returns(j).X, Lidr(k).Returns(j).Y) LPE_AR(l).echo = j LPE_AR(l).X = Lidr(k).Returns(j).X LPE_AR(l).Y = Lidr(k).Returns(j).Y LPE_AR(l).z = Lidr(k).Returns(j).z If Lidr(k).PosLidar.z < 1500 Then ' 1 km point LPE_AR(l).intensity = ((1 - (1201 - Lidr(k).range(j)) / 1201) ^ 2.3) * Lidr(k).intensity(j) + (0.046 * Lidr(k).intensity(j) * (133 - Lidr(k).Res1)) End If If Lidr(k).PosLidar.z > 1500 Then ' 2km point LPE_AR(l).intensity = ((1 - (1942 - Lidr(k).range(j)) / 1942) ^ 2.3) * Lidr(k).intensity(j) + (0.0517 * Lidr(k).intensity(j) * (137 - Lidr(k).Res1)) End If End If End If Next j Next k Close (1) 'MsgBox (l) NCounter = 0 Rem ********TESTI If l < 2 Then MsgBox ("Less than 2 Points!"): Exit Sub End If ReDim Preserve LPE_AR(1 To l) As LP_Espoo ReDim Preserve Z_gnd(1 To l) As Single ReDim LPTreeHit(1 To l) As Boolean ReDim LPE_SP(1 To l) As Byte Rem Declare storage for ground normalized heights of first pulses (for sorting) i = UBound(LPE_AR) ReDim Hftau(1 To i) As Single Rem Array that hold the indeces for sorted heights ReDim Hfind(1 To i) As Long Rem Copy For mx = 1 To i Hftau(mx) = LPE_AR(mx).z - Z_gnd(mx) Next mx Rem Sort data in order 1st = lowest, last = highest Label10.Caption = "Sorting normalized heights..." DoEvents Call indexx(CLng(UBound(Hftau)), Hftau, Hfind) Rem Declare storage for treetops to be found Label10.Caption = "Fitting crowns..." DoEvents Rem ********** Rem FIRST TREE Rem Make foto-solution as seed Ntrees = 1 Tree.X = X_sol Tree.Y = Y_sol Tree.H = He_ Tree.z = Z_sol zgnd = getheight(X_sol, Y_sol) Tree.NLP = 0 LPTreeHit(Hfind(i)) = True Rem Determine RGB-vector from image j for point XYZ j = 1 testpoint.X = Tree.X testpoint.Y = Tree.Y testpoint.z = Tree.z Rem OMITTED SAMPLING! Rem Call RGB_Vector_For_Point(red, green, blue, testpoint, CLng(j)) Rem Include all points indide the crown and fit the model Rem Down to rhe height of Hlimit Dim Xsum As Double, Ysum As Double, Hlow As Double Xsum = 0: Ysum = 0 Rem the height of the tree, mark points down to 50% height H = Tree.H Hlow = Hlimit Dim HlidMax As Double HlidMax = 0 MinDTM = H * 0.6 MaxDTM = H Form1.Picture1(0).DrawWidth = 2 Form1.Picture1(1).DrawWidth = 2 Dim lp As ads40_image_point_struct For i = UBound(Hftau) To 1 Step -1 If Hftau(Hfind(i)) < (H + Hup) And Hftau(Hfind(i)) > Hlow Then XYdist_maxA = Sqr((LPE_AR(Hfind(i)).X - Tree.X) ^ 2 + (LPE_AR(Hfind(i)).Y - Tree.Y) ^ 2) Rem Distance down from top, m Zdist(maxA) = (Tree.H - Hftau(Hfind(i))) If Zdist(maxA) < 0 Then Zdist(maxA) = 0 Rem Crown radius, given height and species and current three parameters cf, pw, cont2 'sade(maxA) = Tree.cf * Tree.H * Sin(4 * (Zdist(maxA) / H)) ^ Tree.pw + Tree.cont2 sade(maxA) = (Tree.cf * Tree.H * (2.5 * (Zdist(maxA) / H)) ^ Tree.pw + Tree.cont2 ^ 2) * DensityFactor If sade(maxA) > XYdist(maxA) Then ' And zdist(maxA) < Hlow Then Rem Distance to top (downwards) If Hftau(Hfind(i)) > HlidMax Then HlidMax = Hftau(Hfind(i)) Tree.NLP = Tree.NLP + 1 XYdist(Tree.NLP) = XYdist_maxA Zdist(Tree.NLP) = Zdist(maxA) LPTreeHit(Hfind(i)) = True Rem Collect observations: Points XYZ Inpoints(Tree.NLP).X = LPE_AR(Hfind(i)).X Xsum = Xsum + LPE_AR(Hfind(i)).X Inpoints(Tree.NLP).Y = LPE_AR(Hfind(i)).Y Ysum = Ysum + LPE_AR(Hfind(i)).Y Inpoints(Tree.NLP).z = LPE_AR(Hfind(i)).z intensities(Tree.NLP) = LPE_AR(Hfind(i)).intensity apu = H - Zdist(maxA) 'apu = Hftau(Hfind(i)) If apu < MinDTM Then apu = MinDTM If apu > MaxDTM Then apu = MaxDTM - 0.02 Apu_z = 255 - (255 - (apu - MinDTM) * 255 / (MaxDTM - MinDTM)) ' DTM If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 Apu_z = Apu_z / 4 Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) For jx = 0 To NumOfImages - 1 ' do we need all images? Form1.Picture1(jx).DrawWidth = 3 ' If image_info(jx).Imagetype = "ADS L0" Then ' Call R_transform_ground_to_ADS40(CLng(jx), LPE_AR(Hfind(i)).X, LPE_AR(Hfind(i)).Y, CDbl(LPE_AR(Hfind(i)).z), lp) ' Form1.Picture1(jx).PSet ((lp.Sample - (image_info(jx).o_col + win_info(jx).win_o_col)) * win_info(jx).pan_x, (lp.Line - (image_info(jx).o_row + win_info(jx).win_o_row)) * win_info(jx).pan_y), Colorpix ' End If ' If image_info(jx).Imagetype = "FRAME" Then 'Call r_transform_ground_to_pixel(CLng(jx), LPE_AR(Hfind(i)).X, LPE_AR(Hfind(i)).Y, LPE_AR(Hfind(i)).z, p_x, p_y) 'Form1.Picture1(jx).PSet ((p_x - (image_info(jx).o_col + win_info(jx).win_o_col)) * win_info(jx).pan_x - 1, -1 + ((image_info(jx).Height - 1) - p_y - (image_info(jx).o_row + win_info(jx).win_o_row)) * win_info(jx).pan_y), Colorpix ' End If Next jx End If End If Next i Close (6) Close (15) ' Form1.Picture1(1).DrawWidth = 1 'MsgBox (Tree.NLP) Rem Here we shift to mass center LPTreeHit(Hfind(UBound(Hftau))) = True If Tree.NLP < 3 Then MsgBox ("Too few LiDAR points!") GoTo DoneFitting Exit Sub End If Dim A0 As Double, c0 As Double A0 = Tree.cont2 c0 = Tree.pw Rem ******* LOOP ********** NITE = 0 StartOfFitModel: Call FitModelB(rmse, Hlowest, Ntrees, XYdist(), sade(), Zdist(), Trees(), LA(), A_MAT(), P, A0, c0, Wa, Wc) ' Call FitModel(rmse, Hlowest, Ntrees, XYdist(), sade(), Zdist(), Trees(), LA(), A_MAT(), P) apu = MYFUNC_MATLABCALLNOMSGS(CDbl(1)) NITE = NITE + 1 Open "c:\data\corr_vectN.txt" For Input As 1 Input #1, Dcf Input #1, Dpw Input #1, Dcont2 Close (1) If Abs(Dcf) < 0.001 And Abs(Dpw) < 0.001 And Abs(Dcont2) < 0.001 Then GoTo DoneFitting If NITE > 15 Then GoTo DoneFitting 'Open "c:\data\parameters.txt" For Append As 11 'Print #11, NITE, Tree.NLP, Tree.H, Tree.cf, Tree.pw, Tree.cont2, rmse 'Close (11) Tree.cf = Tree.cf + Dcf Tree.pw = Tree.pw + Dpw Tree.cont2 = Tree.cont2 + Dcont2 If Tree.pw < 0 Or rmse > 3 Then Tree.pw = 0.5 Tree.cont2 = 0.1 Tree.cf = 0.15 End If GoTo StartOfFitModel Rem ******* END GOTO-LOOP ********** Rem Let's draw the crown in the images DoneFitting: Form1.Label10.FontSize = 9 sade(maxA) = 2 * (Tree.cf * Tree.H * (2.5 * (0.4)) ^ Tree.pw + Tree.cont2 ^ 2) aa = Tree.cf * Tree.H * (2.5 * ((l)) ^ Tree.pw + Tree.cont2 ^ 2) Form1.Label10.Caption = "Done, iters: " & NITE & " RMS " & Format$(rmse, "0.00 m") & " Dcrm: " & Format$(sade(maxA), "0.00 m") Dim Xt As Double, Zt As Double, Yt As Double, Xf As Double, Yf As Double Dim Zdiff As Double, p_x_beg As Double, p_y_beg As Double, p_x_end As Double, p_y_end As Double Dim LP_BEG As ads40_image_point_struct, lp_end As ads40_image_point_struct For Zdiff = 0.01 To (Tree.H * (1 - Hscale)) Step Tree.H * 0.05 Zt = Tree.z - Zdiff 'Radius = (Tree.cf * Tree.H * Sin(4 * ((Zdiff) / H)) ^ Tree.pw + Tree.cont2) '* 1.2 Radius = Tree.cf * Tree.H * (2.5 * ((Zdiff) / H)) ^ Tree.pw + Tree.cont2 ^ 2 mx = 0 Shift = 3.14 / 10 MaxDTM = (Z_sol - getheight(X_sol, Y_sol)) * 1.05 MinDTM = MaxDTM * 0.55 For phi = -3.14 To 3.15 Step 3.14 / 8 mx = mx + 1 Colorpix = RGB(255 - Zdiff * 10, 255 - Zdiff * 10, 255) ' 255 - Zdiff * 10) Xt = Radius * Cos(phi) + Tree.X Yt = Radius * Sin(phi) + Tree.Y apu = Zt - getheight(Xt, Yt) If apu < MinDTM Then apu = MinDTM If apu > MaxDTM Then apu = MaxDTM - 0.02 Apu_z = 255 - (255 - (apu - MinDTM) * 255 / (MaxDTM - MinDTM)) ' DTM If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 Apu_z = Apu_z / 4 Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) Xf = Radius * Cos(phi + Shift) + Tree.X Yf = Radius * Sin(phi + Shift) + Tree.Y Rem Using Line-method draw in all images on screen For i = 0 To NumOfImages - 1 Xvec = image_info(i).Xo - Xt: Yvec = image_info(i).Yo - Yt: Zvec = image_info(i).Zo - Zt Dvec = Sqr(Xvec ^ 2 + Yvec ^ 2 + Zvec ^ 2) Xvec = 0.1 * (Xvec / Dvec): Yvec = 0.1 * (Yvec / Dvec): Zvec = 0.1 * (Zvec / Dvec): zdifftest = Tree.z - (Zt + Zvec) disttostem = Sqr((Tree.X - (Xt + Xvec)) ^ 2 + (Tree.Y - (Yt + Yvec)) ^ 2) radiustest = Tree.cf * Tree.H * (2.5 * ((zdifftest) / H)) ^ Tree.pw + Tree.cont2 ^ 2 ' Xt, Yt, Zt represent the point, now draw a 10 cm vector towards camera - if inside - not visible Select Case image_info(i).Imagetype Case "FRAME" ' If distB > DistA Then Call r_transform_ground_to_pixel(i, Xt, Yt, Zt, p_x_beg, p_y_beg) Call r_transform_ground_to_pixel(i, Xf, Yf, Zt, p_x_end, p_y_end) Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).ForeColor = RGB(255, 255, 255) If disttostem > radiustest Then Form1.Picture1(i).Line ((p_x_beg - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_beg - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1)-((p_x_end - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_end - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix 'RGB(255, 120, 255) End If Case "ADS L0" ' Form1.Picture1(i).DrawWidth = 1 ' Call R_transform_ground_to_ADS40(CLng(i), Xt, Yt, Zt, LP_BEG) ' Call R_transform_ground_to_ADS40(CLng(i), Xf, Yf, CDbl(Zt), lp_end) ' Form1.Picture1(i).Line ((LP_BEG.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, (LP_BEG.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y)-((lp_end.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, (lp_end.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 120, 255) End Select Next i DoEvents Next phi Next Zdiff Close (6) mp = 2 * Form1.Picture1(0).Width / Tree.H - 3 mp = 30 h_offset = Form1.Picture1(0).Height - 30 lpp = 10 Form1.Picture1(0).DrawWidth = 1 For xx = 10 To Tree.H * mp Step Tree.H * mp / lpp dW = dW + 1 Form1.Picture1(0).DrawWidth = (dW Mod lpp) + 1 Form1.Picture1(0).Line (xx, h_offset)-(xx + Tree.H * mp / 10, h_offset), RGB(255, 255, 0) Next xx Form1.Picture1(0).DrawWidth = 2 Open "c:\temp\" & sp & ".txt" For Append As 8 Noutput = 0 MinDTM = Tree.H * 0.6 MaxDTM = Tree.H 'MsgBox (UBound(LPE_AR)) For l = 1 To UBound(XYdist) Form1.Picture1(0).DrawWidth = 3 zdifftest = Zdist(l) ' Tree.z - (LPE_AR(l).z) disttostem = XYdist(l) ' Sqr((Tree.X - (LPE_AR(l).X)) ^ 2 + (Tree.Y - LPE_AR(l).Y) ^ 2) radiustest = Tree.cf * Tree.H * (2.5 * ((zdifftest) / H)) ^ Tree.pw + Tree.cont2 ^ 2 apu = Tree.H - zdifftest If apu < MinDTM Then apu = MinDTM If apu > MaxDTM Then apu = MaxDTM - 0.02 Apu_z = 255 - (255 - (apu - MinDTM) * 255 / (MaxDTM - MinDTM)) ' DTM If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 Apu_z = Apu_z / 4 Colorpix1 = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) Colorpix = RGB(0, 0, 0) If disttostem < 0.3 And zdifftest > 0.1 * Tree.H Then Colorpix = RGB(255, 255, 255) Form1.Picture1(0).DrawWidth = 3 End If Form1.Picture1(0).DrawWidth = 1 Form1.Picture1(0).FillStyle = 0 Form1.Picture1(0).FillColor = Colorpix1 Form1.Picture1(0).Circle (10 + zdifftest * mp, h_offset - disttostem * mp), 3, Colorpix Next l Form1.Picture1(5).Print Noutput Form1.Picture1(0).DrawWidth = 3 For l = 0 To 0.4 Step 0.01 rad = Tree.cf * Tree.H * (2.5 * l) ^ Tree.pw + Tree.cont2 ^ 2 Form1.Picture1(0).PSet (10 + l * Tree.H * mp, h_offset - (Tree.cf * Tree.H * (2.5 * l) ^ Tree.pw + Tree.cont2 ^ 2) * mp), RGB(255, 255, 255) Next l Close (8) Label10.FontSize = 8 Rem The variables of measurement 'Measurement.plot = Plot_Info.Number Rem Start Collecting Image and LiDAR features Rem Of the images that have 16-bit R,G,B,NIR,PAN values, select one in direct light and Rem One in back-light. Move the point down 10% of tree height, towards sun and opposite dir. Rem This way we have XYZ-points Point.InSun and Point.InShade. Compute the camera-point Rem distances to these, select the closest / furthest Dim imdata As RGBNIR, Fii As Double, Theta As Double Dim Pan_mean As Double, Pan_Max As Double, Pan_Min As Double, Pan_SD As Double Dim objtocam As Vector3D, objtosun As Vector3D Dim PointInLight As Vector3D, PointInShade As Vector3D Dim plumbline As Vector3D plumbline.X = 0 plumbline.Y = 0 plumbline.z = 1 Rem Point on surface, in light and shadow 'm Cpu String ' holds output of image features Select Case sp 'LPE_SP(Ntrees) Case 1 Measurement.dbh_lidar_Dcrm = ((-3.155 + 1.323 * sqrt(sade(maxA) * 10) + 0.73 * sqrt(Tree.H * 10)) ^ 2 + 0.811) / 10 d13Foto = ((-3.155 + 1.323 * sqrt(Measurement.Foto_Dcrm * 10) + 0.73 * sqrt(Tree.H * 10)) ^ 2 + 0.811) / 10 Case 2 Measurement.dbh_lidar_Dcrm = ((-3.214 + 1.016 * sqrt(sade(maxA) * 10) + 0.861 * sqrt(Tree.H * 10)) ^ 2 + 0.742) / 10 d13Foto = ((-3.214 + 1.016 * sqrt(Measurement.Foto_Dcrm * 10) + 0.861 * sqrt(Tree.H * 10)) ^ 2 + 0.742) / 10 Case 3 Measurement.dbh_lidar_Dcrm = ((-3.341 + 1.143 * sqrt(sade(maxA) * 10) + 0.7 * sqrt(Tree.H * 10)) ^ 2 + 0.78) / 10 d13Foto = ((-3.341 + 1.143 * sqrt(Measurement.Foto_Dcrm * 10) + 0.7 * sqrt(Tree.H * 10)) ^ 2 + 0.78) / 10 Case 20 Measurement.dbh_lidar_Dcrm = ((-3.214 + 1.016 * sqrt(sade(maxA) * 10) + 0.861 * sqrt(Tree.H * 10)) ^ 2 + 0.811) / 10 d13Foto = ((-3.214 + 1.016 * sqrt(Measurement.Foto_Dcrm * 10) + 0.861 * sqrt(Tree.H * 10)) ^ 2 + 0.811) / 10 End Select Cpu = "" Cpu = Cpu & Format$(MPlot, "0") & "," Cpu = Cpu & Format$(X_sol, "0.00") & "," Cpu = Cpu & Format$(Y_sol, "0.00") & "," Cpu = Cpu & Format$(Z_sol, "0.00") & "," Cpu = Cpu & Format$(LPE_SP(Ntrees), "0") & "," Cpu = Cpu & Format$(zgnd, "0.00") & "," Cpu = Cpu & Format$(Tree.cf, "0.0000") & "," Cpu = Cpu & Format$(Tree.cont2, "0.0000") & "," Cpu = Cpu & Format$(Tree.pw, "0.0000") & "," Cpu = Cpu & Format$(rmse, "0.00") & "," Cpu = Cpu & Format$(HlidMax, "0.00") & "," Cpu = Cpu & Format$(He_, "0.00") & "," Cpu = Cpu & Format$(sade(maxA), "0.00") & "," Cpu = Cpu & Format$(Measurement.dbh_lidar_Dcrm, "0.0") & "," Cpu = Cpu & Format$(Hscale, "0.00") & "," Cpu = Cpu & Format$(DensityFactor, "0.00") & "," Cpu = Cpu & Format$(P, "0.0") & "," Rem Compute LiDAR-statistics Dim IntSum As Double, IntSum2 As Double, IntN As Double, IntMin As Double, IntMax As Double IntSum = 0: IntSum2 = 0: IntN = 0 IntMin = 5000: IntMax = 0 For i = 1 To Tree.NLP resid = XYdist(i) - sade(i) If Abs(resid) < rmse And intensities(i) > 1 Then IntSum = IntSum + intensities(i) IntSum2 = IntSum2 + intensities(i) ^ 2 IntN = IntN + 1 IntMin = Min(IntMin, intensities(i)) IntMax = Max(IntMax, intensities(i)) End If Next i If IntN > 1 Then IntMean = IntSum / IntN IntSD = Sqr((IntN * IntSum2 - IntSum ^ 2) / (IntN ^ 2)) End If Cpu = Cpu & Format$(IntMean, "0.0") & "," Cpu = Cpu & Format$(IntSD, "0.0") & "," Cpu = Cpu & Format$(IntMin, "0.0") & "," Cpu = Cpu & Format$(IntMax, "0.0") & "," Cpu = Cpu & Format$(IntN, "0") & "," For i = 0 To NumOfImages - 1 Fii = (90 - image_info(i).Sun_azimuth * TO_DEGREES) * TO_RADIANS ' azimuth (direction clockwise from KKJ-North in radians) Theta = (90 - image_info(i).Sun_elevation * TO_DEGREES) * TO_RADIANS ' sun's elevation in radians over horizon objtosun.X = 1 * Sin(Theta) * Cos(Fii) objtosun.Y = 1 * Sin(Theta) * Sin(Fii) objtosun.z = 1 * Cos(Theta) Call normalize(objtosun) Zdiff = 1 ' radius = (Tree.cf * Tree.H * Sin(4 * ((Zdiff) / H)) ^ Tree.pw + Tree.cont2) '* 1.2 PointInLight.X = X_sol + Radius * objtosun.X PointInLight.Y = Y_sol + Radius * objtosun.Y PointInLight.z = Z_sol - Zdiff PointInShade.X = X_sol + Radius * -objtosun.X PointInShade.Y = Y_sol + Radius * -objtosun.Y PointInShade.z = Z_sol - Zdiff Rem Come down 10% towards sun, on the surface of the crown model objtocam.X = image_info(i).Xo - X_sol objtocam.Y = image_info(i).Yo - Y_sol objtocam.z = image_info(i).Zo - Z_sol Call normalize(objtocam) Rem Using vector inner product arg = (objtocam.X * objtosun.X + objtocam.Y * objtosun.Y) / ((objtocam.X ^ 2 + objtocam.Y ^ 2) ^ 0.5 * (objtosun.X ^ 2 + objtosun.Y ^ 2) ^ 0.5) SunObjCamAngleXY = TO_DEGREES * MYFUNC_ACOS(arg) PhaseAngle = TO_DEGREES * vector_angle(objtocam, objtosun) NadirAngle = TO_DEGREES * vector_angle(objtocam, plumbline) InLight = -1 Form1.Picture1(i).DrawWidth = 1 If image_info(i).Num_of_addit_expos > 0 And (SunObjCamAngleXY < 45 And SunObjCamAngleXY > -45) Then InLight = 1 Call Get_value_from_16_byte_image(CLng(i), PointInLight.X, PointInLight.Y, PointInLight.z, CLng(2), CInt(1), imdata, Pan_mean, Pan_Max, Pan_Min, Pan_SD) Call r_transform_ground_to_pixel(i, PointInLight.X, PointInLight.Y, PointInLight.z, p_x, p_y) Rem Cyan 'Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 0, 255) End If If image_info(i).Num_of_addit_expos > 0 And (SunObjCamAngleXY > 135 Or SunObjCamAngleXY < -135) Then Call Get_value_from_16_byte_image(CLng(i), PointInShade.X, PointInShade.Y, PointInShade.z, CLng(2), CInt(1), imdata, Pan_mean, Pan_Max, Pan_Min, Pan_SD) InLight = 0 Rem Yellow Call r_transform_ground_to_pixel(i, PointInShade.X, PointInShade.Y, PointInShade.z, p_x, p_y) 'Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 0) End If Form1.Picture1(i).DrawWidth = 1 Rem Assign to public string Cpu Cpu = Cpu & image_info(i).ImageCode & "," Cpu = Cpu & InLight & "," Cpu = Cpu & Format$(SunObjCamAngleXY, "0.00") & "," Cpu = Cpu & Format$(PhaseAngle, "0.00") & "," Cpu = Cpu & Format$(NadirAngle, "0.00") & "," Cpu = Cpu & Format$(imdata.r, "0") & "," Cpu = Cpu & Format$(imdata.G, "0") & "," Cpu = Cpu & Format$(imdata.B, "0") & "," Cpu = Cpu & Format$(imdata.NIR, "0") & "," Cpu = Cpu & Format$(Pan_mean, "0.0") & "," Cpu = Cpu & Format$(Pan_Max, "0.0") & "," Cpu = Cpu & Format$(Pan_Min, "0.0") & "," Cpu = Cpu & Format$(Pan_SD, "0.0") & "," Next i Rem TestOutput 'Open "c:\test.txt" For Append As 1 'Print #1, Cpu 'Close (1) 'Cpu = "" Measurement.cf = Tree.cf Measurement.cont = Tree.cont2 Measurement.pw = Tree.pw Measurement.Crown_RMSE = rmse Measurement.H_LiDAR = HlidMax 'Measurement.TreeSpecies = LPE_SP(Ntrees) Measurement.z = Z_sol Measurement.X = X_sol Measurement.Y = Y_sol Measurement.Z_dtm = zgnd Measurement.Foto_h = Z_sol - zgnd Measurement.num = Measurement.num + 1 Measurement.Lidar_Dcrm = sade(maxA) LidarFitDone = True 'Form1.Label10.Caption = "Plot: " & MPlot & "Dcr: " & Format$(sade(maxA), "0.0 m") & " L-h: " & Format$(HlidMax, "0.0 m") & " F-h: " & Format$(Tree.H, "0.0 m") & " d13: " & Format$(Measurement.dbh_lidar_Dcrm, "0.0 ") Form1.Label10.FontBold = False Form1.Label10.Caption = "Dcr: " & Format$(sade(maxA), "0.0 m") & " H: " & Format$(Measurement.Foto_h, "0.0 m") & " cf: " & Format$(Tree.cf, "0.00") & " pw: " & Format$(Tree.pw, "0.00") & " cont: " & Format$(Tree.cont2 ^ 2, "0.00") & " rms: " & Format$(rmse, "0.00") Call View_Globals NotFound: Close (6) 'Open "c:\mk_lidar.txt" For Append As 6 'Print #6, Format$(Tree.X, "0.00") & "," & Format$(Tree.Y, "0.00") & "," & Format$(Tree.z, "0.00") & "," & Format$((Tree.cf * Tree.h * Sin(4 * (0.3)) ^ Tree.pw + Tree.cont2) * 2, "0.0 ") & "," & Format$(Measurement.RMSE, "0.00") & "," & Format$(Tree.h, "0.00") & "," & Format$(X_sol, "0.00") & "," & Format$(Y_sol, "0.00") & "," & Format$(Z_sol, "0.00") & "," & Format$(getheight(X_sol, Y_sol), "0.00") & "," & Format$(Xm, "0.00") & "," & Format$(Ym, "0.00") & "," & Format$(TreeHeight, "0.00") & "," & Format$(TreeDiam, "0.00") 'Close (6) Rem ******************* Rest of the trees ****************** 'Call Mark_And_Plot(RMSE, Hlimit, Hlowest, CLng(maxA), Ntrees, LPE_SP(), Hftau(), Hfind(), sade(), xydist(), zdist(), Trees(), LPTreeHit()) Exit Sub ErrorInMatchLocalCrown: Close MsgBox ("Error occurred, resuming") End Sub Public Sub Match_template(i As Long, testpoint As Point3d) 'Exit Sub ReDim Color_photo_Patch(0 To image_info(i).sub_width - 1, 0 To 139) As RGBtriplet Rem *********** TRY IMAGE 0 AGAIN AROUND SOLUTION " Dim p_x As Double, p_y As Double, address As Long ReDim startRows(0 To MAXIMA - 1) As Long Call r_transform_ground_to_pixel(i, testpoint.X, testpoint.Y, testpoint.z, p_x, p_y) address = CLng((image_info(i).sub_height - 1) - (p_y + 70)) * image_info(i).sub_width * 3 ' + p_x * 3 startRows(i) = CLng((image_info(i).sub_height - 1) - (p_y + 70)) Close (1) Open image_info(i).FileName For Binary As 1 Get #1, address + 1, Color_photo_Patch ' Exit Sub Close (1) r_maxc = -1 For k = 1 To 11 apu = Dir("c:\data\test_" & CStr(i) & "_" & CStr(k) & ".img") If apu = "" Then Exit Sub Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".img" For Input As 12 'Exit Sub Input #12, w_temp, h_temp, c_col, c_row Close (12) ReDim template(0 To w_temp - 1, 0 To h_temp - 1) As Byte Open "c:\data\test_" & CStr(i) & "_" & CStr(k) & ".raw" For Binary As 12 Get #12, , template Close (12) ReDim Image(0 To w_temp - 1, 0 To h_temp - 1) As Byte For d_p_x = -4 To 4 For d_p_y = -4 To 4 apu = CLng((image_info(i).sub_height - 1) - (p_y + d_p_y)) - startRows(i) apu_y = apu - c_row apu_x = (p_x + d_p_x) - c_col For kX = 0 To w_temp - 1 For kY = 0 To h_temp - 1 Image(kX, kY) = CByte((Color_photo_Patch(apu_x + kX, apu_y + kY).G)) ' Exit Sub Next kY Next kX apu = MYFUNC_TEMPMEANSTD(template(0, 0), CLng(UBound(template, 1)), CLng(UBound(template, 2)), meaIm, stdIm) apu = MYFUNC_CCORB(template(0, 0), Image(0, 0), rx, meaIm, w_temp, h_temp) If rx > r_maxc Then r_maxc = rx ScaleMaxi = k End If Next d_p_y Next d_p_x Next k For i = 0 To NumOfImages - 1 Call r_transform_ground_to_pixel(i, testpoint.X, testpoint.Y, testpoint.z, p_x, p_y) Form1.Picture1(i).DrawWidth = 3 Form1.Picture1(i).FontSize = 8 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), RGB(255, 255, 0) Next i Ulim = 11 ReDim ScalingArr(1 To Ulim) As Double ScalingArr(1) = 0.4: ScalingArr(2) = 0.5: ScalingArr(3) = 0.6 ScalingArr(4) = 0.7: ScalingArr(5) = 0.75: ScalingArr(6) = 0.8 ScalingArr(7) = 0.85: ScalingArr(8) = 0.9: ScalingArr(9) = 1#: ScalingArr(10) = 1.1 ScalingArr(11) = 1.2: i = 0 Form1.Picture1(i).DrawWidth = 2 Dim Xt As Double, Yt As Double, Xf As Double, Yf As Double Dim Shift As Double, p_x_beg As Double, p_y_beg As Double, p_x_end As Double, p_y_end As Double Shift = 3.14 / 10 'radius = CDbl(Form1.Text5.Text) * ScalingArr(R0_ind) Radius = CDbl(Form1.Text5.Text) * ScalingArr(ScaleMaxi) 'Exit Sub For phi = -3.14 To 3.15 Step 3.14 / 8 Colorpix = RGB(120, 255, 0) ' 255 - Zdiff * 10) Xt = Radius * Cos(phi) + testpoint.X Yt = Radius * Sin(phi) + testpoint.Y Xf = Radius * Cos(phi + Shift) + testpoint.X Yf = Radius * Sin(phi + Shift) + testpoint.Y Zt = testpoint.z - 1 Call r_transform_ground_to_pixel(i, Xt, Yt, Zt, p_x_beg, p_y_beg) Call r_transform_ground_to_pixel(i, Xf, Yf, Zt, p_x_end, p_y_end) Form1.Picture1(i).Line ((p_x_beg - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_beg - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1)-((p_x_end - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y_end - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix Next phi FotoTMdone = True Measurement.Foto_Dcrm = Radius * 2 Measurement.Corr_Match = r_maxc End Sub Public Sub savemeasurement(FileName, PlotCode, sp) Rem This routine adds a measurement MeasurementCounter = MeasurementCounter + 1 'If LidarFitDone = True Then ' And FotoTMdone = True Then 'Open "C:\temp\LH_kallio_mittaus2.txt" For Append As 1 'Open "c:\temp\106.txt" For Append As 1 ' Open "c:\temp\korpi.txt" For Append As 1 'Open "c:\temp\ku_mä_vanha.txt" For Append As 1 Close (1) Open FileName For Append As 1 'Exit Sub Dim capu As String 'capu = Format$(1, "0") & "," capu = capu & Format$(Measurement.num, "0") & "," capu = capu & Format$(Measurement.TreeSpecies, "0") & "," capu = capu & Format$(Measurement.X, "0.00") & "," capu = capu & Format$(Measurement.Y, "0.00") & "," capu = capu & Format$(Measurement.z, "0.00") & "," capu = capu & Format$(Measurement.Z_dtm, "0.00") & "," capu = capu & Format$(Measurement.Foto_h, "0.00") & "," capu = capu & Format$(Measurement.H_LiDAR, "0.00") & "," capu = capu & Format$(Measurement.Foto_Dcrm, "0.00") & "," capu = capu & Format$(Measurement.Lidar_Dcrm, "0.00") & "," capu = capu & Format$(Measurement.Crown_RMSE, "0.00") & "," capu = capu & Format$(Measurement.cf, "0.0000") & "," capu = capu & Format$(Measurement.pw, "0.0000") & "," capu = capu & Format$(Measurement.cont, "0.0000") capu = PlotCode & "," capu = capu & Format$(MeasurementCounter, "0") & "," capu = capu & Format$(sp, "0") & "," capu = capu & Format$(X_sol, "0.00") & "," capu = capu & Format$(Y_sol, "0.00") & "," capu = capu & Format$(Z_sol, "0.00") & "," capu = capu & Format$(Z_sol - getheight(X_sol, Y_sol), "0.00") Print #1, capu Close (1) Measurement.TreeSpecies = 0 Measurement.X = 0 Measurement.Y = 0 Measurement.z = 0 Measurement.Z_dtm = 0 Measurement.Foto_h = 0 Measurement.H_LiDAR = 0 Measurement.Foto_Dcrm = 0 Measurement.Lidar_Dcrm = 0 Measurement.Crown_RMSE = 0 Measurement.cf = 0 Measurement.pw = 0 Measurement.cont = 0 LidarFitDone = False FotoTMdone = False 'Call PlotMeasurements(FileName) 'Else ' MsgBox ("You forgot crown modelling with lidar") 'End If End Sub Public Function CCOR1() As Double ' This routine computes [-1,1] correlation image using cross-correlation. Correlation is computed ' for image akuva[] and template[] for the common area. ' BW-image BYTE (uchar) array *akuva[], declared as akuva(0 to width-1, 0 to height-1) in VB ' Template is the BYTE (uchar) array *temp[], declared also as temp(0 to wt-1, 0 to ht-1) in VB ' The center of the template (tree top's location) is given in (c_col, c_row) ' The output goes to the correlation double-array, declared same size as akuva-image-array. ' ' Dim i As Long, j As Long ' Dim m As Long, startrow As Long, startcol As Long, StartIndex As Long ' Dim lkm_a As Long, lkm_b As Long ' Dim nominator As Double, denominator1 As Double, denominator2 As Double, meanA As Double, meanB As Double ' lkm_a = 0 ' meanA = 0# ' Loop the template area, calculate mean of template, omit all zero values (outside ! ' For l = 0 To wt - 1 ' cols ' For m = 0 To ht - 1 ' rows ' If temp_a(l, m) <> 0 Then ' meanA = meanA + CDbl(temp_a(l, m)) ' lkm_a = lkm_a + 1 ' End If ' Next m ' Next l ' meanA = meanA / CDbl(lkm_a) ' ' Too be sure we do not travel outside the image area, main loop is restricted to the area ' ' with template width & height removed from top&bottom, left & right. ' ' Constants ' denominator1 = 0# ' For l = 0 To wt - 1 ' loop template columns ' For m = 0 To ht - 1 ' loop template rows ' If temp_a(l, m) <> 0 Then ' it's a valid element ' denominator1 = denominator1 + (CDbl(temp_a(l, m)) - meanA) * (CDbl(temp_a(l, m)) - meanA) ' nom_term1(l, m) = CDbl(temp_a(l, m)) - meanA ' End If ' Next m ' Next l ' for (i= 1 ;i<=(width-1)-wt;i++) { // i loops main image columns ' for (j= 1;j<=(height-1)-ht;j++) { // j loops main image rows ' // Cross-correlation is now computed for point (i,j), => rkuva[j*width+i] ' // c_col and c_row give the location of the HOTSPOT-point of the template. startrow = j ' ; // -(c_row); // the location of the upper left corner of the template on the image startcol = i ' ; // -(c_col); // " ' startindex = startrow*width+startcol; // " index in akuva[] ' ' lkm_b=0; ' meanB=0.0; ' for (l=0;l<=wt-1;l++) { // loop template columns ' for (m=0;m<=ht-1;m++) { // loop template rows ' if (temp_a(l,m)!=0) // it's a valid element ' { ' lkm_b++; ' temp_b(l,m)=akuva[startindex+(m*width)+l]; ' meanB += double(temp_b(l,m)); ' } ' ' } ' } ' meanB /= double(lkm_b); ' nominator=0.0; ' denominator2=0.0; ' for (l=0;l<=wt-1;l++) { // loop template cols ' for (m=0;m<=ht-1;m++) { // loop template rows ' if (temp_a(l,m)!=0) ' { ' nominator += nom_term1(l,m) * (double(temp_b(l,m)) - meanB); ' denominator2 += (double(temp_b(l,m)) - meanB) * (double(temp_b(l,m)) - meanB); ' } ' } ' } ' if ((denominator1 * denominator2) < 0.000002 ) ' { ' j = sprintf(buffer,"Trying to divide by zero in Myfunc_corima"); ' MessageBox ( NULL, buffer,"MyFunc_corima",MB_OK); ' return -1.0; ' } ' // Here we put the results to the location of the hotspot ' rkuva[(j+(c_row))*width+(i+(c_col))] = nominator/pow((denominator1 * denominator2),0.5); ' } // main loop rows ' } // main loop cols ' return 1.0; ' } End Function Public Function ASIN(X As Double) As Double ASIN = Atn(X / (-X * X + 1) ^ 0.5) End Function Public Sub CaptureEllipticTemplate(i As Integer, Ellipse As Ellipse) Rem This Routine receives the middlepoint photo-coordinates (metric) of the Rem template image, and the parameters of the ellipse ( a, b, rot angle, x, y). Rem Routine scans a 101 x 101 pixel-area around the midpoint. If a scanline does not contain Rem a single pixel belonging to the ellipse, scanline is dropped out, same applies for scan- Rem columns. Rem Parameter i refers to image (0 to numofimages-1) Rem Type (struct) ellipse holds data: Rem .alpha (rotation angle, rotation about mid-point, in photo-coordinate system) Rem .a (axis length in the direction of radial displacement (affected by Zdiff-parameter)) Rem .b (axis length in crown width direction, affected by parameter TemplateWidth) Rem .x (x coord of center point in camera coordinates, affected by EllipseZasymmetry) Rem .y (y coord of center point in camera coordinates, " " ") Rem Rem I.e. We let the ellipse be translated along the direction of the radial displacement, as Rem defined by the metric EllipseZasymmetry -parameter, that 'tells' were the template center Rem is located along the tree stem / ot may also be above the top, if parameter is set a positive Rem value. Dim p_x As Double, p_y As Double, apu_x As Double, apu_y As Double Dim CenCol As Integer, CenRow As Integer ' The image coordinates of the ellipse center (tree top) Dim startrow As Integer, startcol As Integer Dim endrow As Integer, endcol As Integer Dim j As Integer, k As Integer, Ninside As Integer, jx As Integer, kX As Integer, apu Dim Colorpix As RGBtriplet Dim BWpix As Byte Dim Inside As Boolean Dim firstcol As Integer, firstrow As Integer, lastcol As Integer, lastrow As Integer Dim firstrowdet As Boolean Dim firstcoldet As Boolean Dim HALFTEMPSIZE As Integer HALFTEMPSIZE = 50 Rem Get the image pixel-coordinates of template center Call a_transform_affine(i, 0, Ellipse.X, Ellipse.Y, p_x, p_y) Rem Re-assigning (necessary?) and round to nearest integer value CenCol = CInt(p_x - image_info(i).o_col): CenRow = CInt(((image_info(i).Height - 1) - p_y) - image_info(i).o_row) 'Exit Sub Rem Define the outer coords of the scan area, which will be 101 x 101 in size startrow = CenRow - HALFTEMPSIZE endrow = CenRow + HALFTEMPSIZE startcol = CenCol - HALFTEMPSIZE endcol = CenCol + HALFTEMPSIZE Rem Declare an array to hold the the template image (grayscale, Byte-array) ReDim template(0 To endcol - startcol, 0 To endrow - startrow) As Byte Rem Declare an array of same size. Boolean, each pixel value is TRUE for 'a member of the template' or FALSE for 'outside' ReDim insidetemplate(0 To endcol - startcol, 0 To endrow - startrow) As Boolean Rem The Template-image filenames are c:\temp\temp#.raw Rem It's first deleted before opening in binary mode Close (2) Close (1) On Error Resume Next Kill "c:\data\temp" & CStr(i) & ".raw" Open "c:\data\temp" & CStr(i) & ".raw" For Binary As 2 'Exit Sub Rem Open the Image file for input also (for retrieving the pixels) Open image_info(i).FileName For Binary As 1 'Exit Sub Rem start scanning columns and rows, counters j and k are assigned pixel coordinates of the main image! Rem counter jx and kx act... Rem Counter Ninside Rem Boolean inside Dim row As Double, col As Double Inside = False jx = -1 For j = startcol To endcol ' loop columns (x), there are 101, j is in the sub-image coords! Ninside = 0 jx = jx + 1 kX = -1 For k = startrow To endrow ' loop rows (y) 101 kX = kX + 1 Rem Obtain photo-coordinates for this pixel location Call a_transform_affine(i, 1, CDbl(j + image_info(i).o_col), CDbl((image_info(i).Height - image_info(i).o_row - 1) - (k)), p_x, p_y) Rem Transfer this point's photo-coordinates (p_x, p_y) to ellipse center apu_x = p_x - Ellipse.X apu_y = p_y - Ellipse.Y Rem Rotate it to normal position, by alpha, alpha is adjusted by 90 degrees WHY??? Rem There's a problem here. p_x = Cos(Ellipse.alpha) * apu_x + Sin(Ellipse.alpha) * apu_y p_y = -Sin(Ellipse.alpha) * apu_x + Cos(Ellipse.alpha) * apu_y Rem Check if the point is inside normalized ellipse Inside = False If ((p_x ^ 2) / (Ellipse.A ^ 2) + (p_y ^ 2) / (Ellipse.B ^ 2)) < 1# Then Ninside = Ninside + 1 ' Add Counter insidetemplate(jx, kX) = True ' Set Boolean End If Rem According to image's color model perform color -> greyscale transformation Select Case image_info(i).Color Case 0 ' It is a BW image, we put pixel value in all three rgb-componenets ' Image begins at address 1, 2nd line at width + 1, k = row, j = column (0,..w-1) Get #1, CLng(k) * image_info(i).sub_width + CLng(j) + 1, BWpix Colorpix.r = BWpix Colorpix.G = BWpix Colorpix.B = BWpix Case 1 ' It is a COLOR image Get #1, CLng(k) * 3 * image_info(i).sub_width + CLng(j) * 3 + 1, Colorpix 'Exit Sub End Select If insidetemplate(jx, kX) = False Then Colorpix.r = 0 Colorpix.G = 0 Colorpix.B = 0 End If Rem template-array was a byte array, let's combine here. NOTE! There are more elegant Rem 3->1 transformations than average! ' apu = ((CInt(Colorpix.R) + CInt(Colorpix.g) + CInt(Colorpix.B)) / 3) 'apu = ((CInt(0.333 * Colorpix.r) + CInt(0.333 * Colorpix.g) + CInt(0.333 * Colorpix.B))) apu = Colorpix.G If apu < 0 Then apu = 0 If apu > 255 Then apu = 255 template(jx, kX) = CByte(apu) Next k ' Next row in the 101x101 search area Next j ' Next column in the 101x101 search area Rem Now we have a 101x101 template, that needs to be polished from lines and rows Rem containing only zero-values (insidetemplate(col,row) = FALSE) firstrowdet = False firstcoldet = False firstcol = 0 For j = 0 To endcol - startcol ' Loop 101 columns Ninside = 0 For k = 0 To endrow - startrow ' Loop 101 rows If insidetemplate(j, k) = True Then Ninside = 1 ' there's a value in this column End If Next k If firstcoldet = False And Ninside = 1 Then Rem We've found the first column where there's an inside pixel firstcol = j firstcoldet = True GoTo nextcol ' Hop to find the last column End If If firstcoldet = True And Ninside = 0 Then Rem We've found the last column lastcol = j - 1 GoTo testrows ' Hop for finding the row-bounds End If nextcol: Next j Rem We should never end up executing the next line! MsgBox ("Image template n:o " & CStr(i) & " cannot define col borders!") Rem Start to look for row-bounds testrows: firstrow = 0 For k = 0 To endrow - startrow ' Loop thru 101 rows Ninside = 0 For j = 0 To endcol - startcol ' Loop thru 101 columns If insidetemplate(j, k) = True Then Ninside = 1 ' there's a value in this row End If Next j ' Next column If Ninside = 1 And firstrowdet = False Then firstrow = k firstrowdet = True GoTo nextrow End If If Ninside = 0 And firstrowdet = True Then lastrow = k - 1 GoTo templatesizedetermined End If nextrow: Next k ' next row Rem We should never end up executing the next line! MsgBox ("Image template n:o " & CStr(i) & " cannot define row borders!") templatesizedetermined: Rem The size of the template image is determined Rem Declare the array ReDim temp(0 To (lastcol - firstcol), 0 To (lastrow - firstrow)) As Byte jx = -1 For j = firstcol To lastcol ' Loop columns in the 101x101 area jx = jx + 1 kX = -1 For k = firstrow To lastrow ' Loop rows in the 101x101 area kX = kX + 1 temp(jx, kX) = template(j, k) Next k Next j Rem write the header and the template Open "c:\data\temp" & CStr(i) & ".img" For Output As 3 Print #3, lastcol - firstcol + 1 ' width Print #3, lastrow - firstrow + 1 ' height Print #3, HALFTEMPSIZE - firstcol + Ellipse.dx_col ' c_col HOTSPOT, it's not here, it's off by Print #3, HALFTEMPSIZE - firstrow - Ellipse.dx_row ' c_row HOTSPOT Close (3) Put #2, 1, temp Close (2) Close (1) End Sub Public Sub RGB_Vector_For_Point(ByRef red As Double, green As Double, blue As Double, testpoint As Point3d, Image As Long) Dim p_x As Double, p_y As Double Dim j As Long j = Image Call r_transform_ground_to_pixel(j, testpoint.X, testpoint.Y, testpoint.z, p_x, p_y) Close (2) Open image_info(j).FileName For Binary As 2 Dim paikka As Long, startrow As Long, startcol As Long ReDim Winrow(1 To 3) As RGBtriplet startcol = p_x - 1 startrow = (image_info(j).Height - 1) - p_y - 1 'Dim red As Double, blue As Double, green As Double For lx = -1 To 1 paikka = CLng(startrow + lx) * (image_info(j).sub_width) * CLng(3) + CLng(startcol) * 3 Get #2, paikka + 1, Winrow red = red + Winrow(1).r + Winrow(2).r + Winrow(3).r green = green + Winrow(1).G + Winrow(2).G + Winrow(3).G blue = blue + Winrow(1).B + Winrow(2).B + Winrow(3).B Next lx red = red / 9# green = green / 9# blue = blue / 9# Close (2) End Sub Public Sub a_transform_affine(ByVal i As Integer, ByVal direction As Integer, X As Double, Y As Double, p_x As Double, p_y As Double) Dim a_ As Double, b_ As Double, c_ As Double, d_ As Double, e_ As Double, f_ As Double a_ = image_info(i).a_ b_ = image_info(i).b_ c_ = image_info(i).c_ d_ = image_info(i).d_ e_ = image_info(i).e_ f_ = image_info(i).f_ Select Case direction Case 0 ' From camera coordinates to image cordinates (pixels) p_x = a_ * X + b_ * Y + c_ p_y = d_ * X + e_ * Y + f_ Case 1 ' From image coordinates (pixels) to camera cordinates (mm) p_x = (-e_ * c_ + e_ * X + f_ * b_ - Y * b_) / (a_ * e_ - b_ * d_) p_y = -(a_ * f_ - a_ * Y - c_ * d_ + X * d_) / (a_ * e_ - b_ * d_) ' p_x = p_x + camera.ps_x ' p_y = p_y + camera.ps_y End Select End Sub Public Sub PlotLiDARPoints() Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Double, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double Dim LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long Close (1) Xc = X_sol: Yc = Y_sol Xs = Xc: Ys = Yc Rem ********************** PATH Open "c:\data\als2013b_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) FN1 = Format$(Int((Xs - 2510000) / 100), "000") FN2 = Format$(Int((Ys - 6850000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub Rem, we read only if On Error Resume Next skipread = False If NHA = UBound(Lidr) Then skipread = True If skipread = False Then ReDim Lidr(1 To NHA) As LidarRecord End If Nsum = 1 Dim Radius As Double, Height As Double Dim RedVal As Integer, GreenVal As Integer, BlueVal As Integer, IrVal As Integer Radius = (Z_sol - getheight(X_sol, Y_sol)) * 0.08 Height = 100 Dim k As Long For i = 0 To NumOfImages - 1 Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).FontSize = 18 Next i Close (6) Dim radi As Double, Zero As Double Dim x1 As Point3d, x2 As Point3d, Pt As Point3d MaxDTM = (Z_sol - getheight(X_sol, Y_sol)) * 1.05 MinDTM = MaxDTM * 0.55 MaxDTM = (Z_sol - getheight(X_sol, Y_sol)) * 1.05 MinDTM = MaxDTM * 0.55 Radius = MaxDTM Radius = 5 If skipread = False Then Get #100, 1, NHA Get #100, 5, Lidr ' Here we read 207-byte records record by record End If Dim UTM_E As Double, UTM_N As Double, UTM_H As Double Dim ll As Long, Nka As Long For k = 1 To NHA For j = 4 To 4 '(5 - Lidr(k).PulseCount) Step -1 radi = Sqr((Lidr(k).Returns(j).X - X_sol) ^ 2 + (Lidr(k).Returns(j).Y - Y_sol) ^ 2) ' Dire = MYFUNC_ATAN2((LidR(k).Returns(j).X - X_sol), (LidR(k).Returns(j).Y - Y_sol)) If radi < Radius Then ' And Lidr(k).PosLiDAR.z < 900 Then ' And Lidr(k).StripNum > 20 And Lidr(k).StripNum < 24 Then ' And Lidr(k).PosLiDAR.z < 900 Then ' 800 And Lidr(k).PosLiDAR.z < 1800 Then ' And Abs(LidR(k).Returns(j).X - X_sol) < 0.5 Then ' And (Dire < 0.5 Or Dire > 1.2 * PI / 2) Then Zmaaf = getheight(Lidr(k).Returns(j).X, Lidr(k).Returns(j).Y) range = Sqr((Lidr(k).Returns(j).X - Lidr(k).PosLidar.X) ^ 2 + (Lidr(k).Returns(j).Y - Lidr(k).PosLidar.Y) ^ 2 + (Lidr(k).Returns(j).z - Lidr(k).PosLidar.z) ^ 2) aa = Lidr(k).StripNum H = Lidr(k).Returns(j).z - Zmaaf AGC = CInt(Lidr(k).Res1) apu = H If apu < MinDTM Then apu = MinDTM If apu > MaxDTM Then apu = MaxDTM - 0.02 Apu_z = 255 - (255 - (apu - MinDTM) * 255 / (MaxDTM - MinDTM)) ' DTM If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 Apu_z = Apu_z / 4 Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) Dim gp As Point3d, lp As ads40_image_point_struct If (H > MinDTM) Then For i = 0 To NumOfImages - 1 dX = 0 dY = 0 Form1.Picture1(i).DrawWidth = 1 + CLng(Lidr(k).PosLidar.z / 1000) * 1 If image_info(i).Imagetype = "ADS L0" Then Call KKJ_to_LSR(CLng(i), Lidr(k).Returns(j).X, Lidr(k).Returns(j).Y, Lidr(k).Returns(j).z, gp.X, gp.Y, gp.z) apu = grnd2lp(CLng(i), gp, lp) c_col = lp.Sample c_row = lp.Line Form1.Picture1(i).PSet ((c_col - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - m, (c_row - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix End If If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, Lidr(k).Returns(j).X + dX, Lidr(k).Returns(j).Y + dY, Lidr(k).Returns(j).z, p_x, p_y) Form1.Picture1(i).FillColor = Colorpix ' RGB(255, 255, 255) 'Colorpix Form1.Picture1(i).FillStyle = 0 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), Colorpix End If Next i End If End If Next j Nextpulse: If k Mod 100 = 0 Then DoEvents Next k Close (100) Close (6) Close (111) Exit Sub ErrorInPlot2007: Close (All) MsgBox ("Some error!") End Sub Public Sub PlotMeasurements(FileName) Rem For plotting MARV4-data Rem For pplotting MARV1-data (2008) 'Open "C:\temp\test.txt" For Input As 2 Close (2) 'Exit Sub Dim MPlot As Long, MNum As Long, MTreeSpecies As Long, mx As Double, MY As Double, Mz As Double Dim Mz_DTM As Double, MFoto_h As Double, MH_lidar As Double, MFoto_Dcrm As Double, MLidar_Dcrm As Double Dim MCrown_RMSE As Double, Mcf As Double, Mpw As Double, Mcont As Double Dim p_x As Double, p_y As Double Dim Cstring As String Close (1): Close (2) 'Open "C:\temp\kallio.txt" For Input As 1 'Open "C:\temp\kallio.txt" For Input As 2 'Open "C:\temp\LH_kallio_mittaus2.txt" For Input As 1 'Open "C:\temp\LH_kallio_mittaus2.txt" For Input As 2 Close (3) 'Open FileName For Input As 3 Close (3) Open FileName For Input As 3 For i = 0 To NumOfImages - 1 'Form1.Picture1(i).Cls Next i Do Until EOF(3) 'Exit Sub Input #3, PlotCode, num, MTreeSpecies, mx, MY, Mz, H 'Exit Sub MFoto_h = Mz - getheight(mx, MY) MinDTM = 12 MaxDTM = 25 Apu_z = GetApuZ(MFoto_h, MinDTM, MaxDTM) Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) For i = 0 To NumOfImages - 1 'GoTo ohi Select Case MTreeSpecies Case 1 ' , 2, 3, 4 Colorpix = RGB(255, 0, 0) 'Colorpix = RGB(255, 255, 255) Case 2 Colorpix = RGB(0, 255, 0) Case 3 Colorpix = RGB(100, 120, 255) Case 4 Colorpix = RGB(225, 225, 25) End Select ohi: ' Apu_z = 255 - (255 - (MFoto_h - 10) * 255 / (29 - 10)) ' If Apu_z < 4 Then Apu_z = 4 ' If Apu_z > 254 Then Apu_z = 254 ' Apu_z = Apu_z / 4 Form1.Picture1(i).DrawWidth = 1 If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, mx, MY, Mz, p_x, p_y) 'Colorpix = RGB(0, 0, 0) Form1.Picture1(i).DrawWidth = 3 Form1.Picture1(i).FillStyle = 1 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix Form1.Picture1(i).FontSize = 8 Form1.Picture1(i).CurrentX = Form1.Picture1(i).CurrentX + 2 'Form1.Picture1(i).Print Format$(H, "0") 'DoEvents End If Next i Loop Close (3) Exit Sub 'Open "C:\temp\korpi.txt" For Input As 1 'Open "C:\temp\korpi.txt" For Input As 2 'Open "c:\temp\106.txt" For Input As 1 'Open "c:\temp\106.txt" For Input As 2 'Open "c:\temp\ku_mä_vanha.txt" For Input As 1 'Open "c:\temp\ku_mä_vanha.txt" For Input As 2 'Open "c:\temp\VinoManty.txt" For Input As 1 'Open "c:\temp\VinoManty.txt" For Input As 2 'Open "c:\temp\mä_seka.txt" For Input As 1 'Open "c:\temp\mä_seka.txt" For Input As 2 'Open "c:\temp\ku_ko_seka.txt" For Input As 1 'Open "c:\temp\ku_ko_seka.txt" For Input As 2 'Open "c:\temp\leku.txt" For Input As 1 'Open "c:\temp\leku.txt" For Input As 2 'Open "c:\temp\kontorta.txt" For Input As 1 'Open "c:\temp\kontorta.txt" For Input As 2 'Open "c:\temp\VinoKuusi.txt" For Input As 1 'Open "c:\temp\VinoKuusi.txt" For Input As 2 'Open "c:\temp\2014.csv" For Input As 1 Close (3) 'Open "c:\temp\2014_puut.csv" For Input As 3 GoTo alku Dim Npoint As Long, luku As Long, X As Double, Y As Double, z As Double, luokka As String Open "o:\gpstesti.txt" For Output As 2 For Ix = -0.3 To 0.3 Step 0.05 For jx = -0.3 To 0.3 Step 0.05 Open "o:\gpsluokat.txt" For Input As 1 ZdiffS = 0 Zdiff2s = 0 Nsum = 0 Do Until EOF(1) Input #1, luku, Npoint, X, Y, z, luokka If luokka <> "HU" And luokka <> "HHU" Then GoTo seuraava Zdiff = z - getheight(X + Ix, Y + jx) ZdiffS = ZdiffS + Zdiff Zdiff2s = Zdiff2s + Zdiff ^ 2 Nsum = Nsum + 1 seuraava: Loop Print #2, Ix, jx, ZdiffS / Nsum, Sqr(Zdiff2s / Nsum), Nsum Close (1) Next jx Next Ix Close (2) Exit Sub alku: 'Open "C:\temp\kallio.txt" For Input As 2 For i = 0 To NumOfImages - 1 Form1.Picture1(i).Cls Next i For xx = 1 To 31000 On Error Resume Next GoTo luku2 ReDim commas(1 To 5) As Integer commas(1) = 1 Line Input #1, Cstring ic = 1 For i = 1 To 40 If Mid(Cstring, i, 1) = "," Then ic = ic + 1 If ic > 5 Then Exit For commas(ic) = i Select Case ic Case 2 MPlot = Val(Mid(Cstring, commas(1), commas(ic) - commas(1))) Case 3 mx = Val(Mid(Cstring, commas(2) + 1, commas(3) - commas(2) - 1)) Case 4 MY = Val(Mid(Cstring, commas(3) + 1, commas(4) - commas(3) - 1)) Case 5 Mz = Val(Mid(Cstring, commas(4) + 1, commas(5) - commas(4) - 1)) End Select End If Next i Rem *************************** luku2: Dim Code As String 'Input #1, MNum, MTreeSpecies, mx, MY, Mz, Mz_DTM, MFoto_h, MH_lidar, MFoto_Dcrm, MLidar_Dcrm, MCrown_RMSE, Mcf, Mpw, Mcont ' , dummy, dummy, dummy Input #3, MTreeSpecies, mx, MY, Mz MFoto_h = Mz - getheight(mx, MY) For i = 0 To NumOfImages - 1 ' MTreeSpecies = 1 Select Case MTreeSpecies Case 1 Colorpix = RGB(255, 0, 0) Case 2 Colorpix = RGB(0, 255, 0) Case 3 Colorpix = RGB(100, 120, 255) Case 4 Colorpix = RGB(225, 225, 25) End Select Apu_z = 255 - (255 - (MFoto_h - 10) * 255 / (29 - 10)) If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 254 Apu_z = Apu_z / 4 Form1.Picture1(i).DrawWidth = 5 ' If image_info(i).Imagetype = "ADS L0" Then ' Call R_transform_ground_to_ADS40(CLng(i), mx, MY, CDbl(Mz), lp) ' Form1.Picture1(i).PSet ((lp.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, (lp.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix ' End If If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, mx, MY, Mz, p_x, p_y) Form1.Picture1(i).DrawWidth = 3 Form1.Picture1(i).FillStyle = 1 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix 'Form1.Picture1(i).Circle ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), 6, Colorpix Form1.Picture1(i).FontSize = 8 Form1.Picture1(i).CurrentX = Form1.Picture1(i).CurrentX + 2 DoEvents 'Form1.Picture1(i).Print Int(Mz_DTM) End If Next i mx = 0 'Input #1, MNum, MTreeSpecies, mx, MY, Mz, Mz_DTM, MFoto_h, MH_lidar, MFoto_Dcrm, MLidar_Dcrm, MCrown_RMSE, Mcf, Mpw, Mcont ' , dummy, dummy, dummy For i = 0 To NumOfImages - 1 ' MTreeSpecies = 1 'Select Case MTreeSpecies 'Case 1 'Colorpix = RGB(255, 0, 0) 'Case 2 'Colorpix = RGB(0, 255, 0) 'Case 3 'Colorpix = RGB(100, 120, 255) 'Case 4 'Colorpix = RGB(225, 225, 25) 'End Select 'Apu_z = 255 - (255 - (MFoto_h - 10) * 255 / (29 - 10)) 'If Apu_z < 4 Then Apu_z = 4 'If Apu_z > 254 Then Apu_z = 254 'Apu_z = Apu_z / 4 'Form1.Picture1(i).DrawWidth = 5 'Colorpix = RGB(255, 255, 255) ' If image_info(i).Imagetype = "ADS L0" Then ' Call R_transform_ground_to_ADS40(CLng(i), mx, MY, CDbl(Mz), lp) ' Form1.Picture1(i).PSet ((lp.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, (lp.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix ' End If If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, mx, MY, Mz, p_x, p_y) Form1.Picture1(i).DrawWidth = 2 Form1.Picture1(i).FillStyle = 1 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix 'Form1.Picture1(i).Circle ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), 6, Colorpix Form1.Picture1(i).FontSize = 10 Form1.Picture1(i).CurrentX = Form1.Picture1(i).CurrentX + 2 'Form1.Picture1(i).Print MNum End If Next i nextxx: Next xx Close (1) Close (2) 'Next j Exit Sub Do Until EOF(2) Exit Sub Line Input #2, Cstring ' Input #2, MPlot, MNum, MTreeSpecies, mx, MY, Mz, Mz_DTM, MFoto_h, MH_lidar, MFoto_Dcrm, MLidar_Dcrm, MCrown_RMSE, Mcf, Mpw, Mcont ' , dummy, dummy, dummy MPlot = Val(Left$(Cstring, 1)) mx = Val(Mid$(Cstring, 3, 12 - 2)) MY = Val(Mid$(Cstring, 14, 23 - 13)) Mz = Val(Mid$(Cstring, 25, 30 - 24)) MTreeSpecies = Val(Mid$(Cstring, 32, 1)) 'Close (2) Exit Sub If MPlot <> Newplot Then i = 0 Call r_transform_ground_to_pixel(i, mx + 35, MY, Mz, p_x, p_y) Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix Form1.Picture1(i).FontSize = 15 Form1.Picture1(i).Print MPlot End If Newplot = MPlot 'Exit Sub 'If Mplot = Measurement.plot Then For i = 0 To NumOfImages - 1 Select Case MTreeSpecies Case 1 Colorpix = RGB(255, 0, 0) Case 2 Colorpix = RGB(0, 255, 0) Case 3 Colorpix = RGB(100, 120, 255) Case 4 Colorpix = RGB(225, 225, 25) End Select Colorpix = RGB(255, 255, 255) Form1.Picture1(i).DrawWidth = 3 'If image_info(i).Imagetype = "ADS L0" Then ' Call R_transform_ground_to_ADS40(CLng(i), mx, MY, CDbl(Mz), lp) ' Form1.Picture1(i).PSet ((lp.Sample - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, (lp.Line - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix 'End If If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, mx, MY, Mz, p_x, p_y) Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix Form1.Picture1(i).FontSize = 10 'Form1.Picture1(i).Print MNum Form1.Picture1(i).DrawWidth = 1 End If Next i Loop Close (2) End Sub Public Sub Plot_Tie_Points() Open "c:\data\imageobs.txt" For Input As 100 Do Until EOF(100) Input #100, ImageCode, PointId, p_x, p_y p_y = (image_info(q).Height - 1) - p_y For i = 0 To NumOfImages - 1 If image_info(i).ImageCode = ImageCode Then Form1.Picture1(i).DrawWidth = 3 Form1.Picture1(i).FontSize = 12 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 0, 0) Form1.Picture1(i).Print PointId DoEvents End If Next i Loop Close (100) End Sub Public Sub Plot_measurements() Dim p_x As Double, p_y As Double Dim Pnumber As Double Dim inputstring As String Dim s_start As Integer, s_end As Integer Dim s_case As Integer, i As Integer 'On Error GoTo error_in_reading_and_plotting Close (11) 'ReDim ColorMap(1 To 64, 1 To 3) As Byte l = 0 Open "C:\data\JetColorMAP.csv" For Input As 2 Do Until EOF(2) l = l + 1 Input #2, ColorMap(l, 1), ColorMap(l, 2), ColorMap(l, 3) Loop Close (2) MaxDTM = 35 MinDTM = 0 'Open "f:\temp\kuiva\Kuiva_polyline.txt" For Input As 1 ReDim PlotPoly(0 To 200) As Point 'i = 0 'Do Until EOF(1) ' Input #1, PlotPoly(i).X, PlotPoly(i).Y, dummy ' i = i + 1 'Loop Close (1) Rem Make last point meet first PlotPoly(i).X = PlotPoly(0).X PlotPoly(i).Y = PlotPoly(0).Y ReDim Preserve PlotPoly(0 To i) As Point Close (1) Dim teksti As String 'Open "c:\apu\ilkka.txt" For Output As 200 Close (200) 'Open "c:\apu\ilkka.txt" For Output As 200 Exit Sub 'Open TreedataFilename For Input As 11 Open "d:\tyo\silmapaa.csv" For Input As 11 'Exit Sub Do Until EOF(11) 'Exit Sub ' Input #11, SavedMeasurement.Num, teksti, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z ', teksti ' , dummy ' Input #11, SavedMeasurement.Num, SavedMeasurement.X, SavedMeasurement.Y, Zbutt, SavedMeasurement.z, pit, teksti ' , dummy ' Input #11, SavedMeasurement.Num, SavedMeasurement.X, SavedMeasurement.Y, Zbutt, SavedMeasurement.z, teksti, dummy ' Input #11, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z, teksti ' , dummy ' Input #11, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z, dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy 'Close (11) 'Exit Sub Input #11, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z, SavedMeasurement.num ', hf 'Close (11) 'Exit Sub ' Line Input #11, inputstring 'GoTo SkipParse Rem Parse it s_case = 0 s_start = 0 For i = 2 To 100 If Mid$(inputstring, i, 1) = "," Then s_end = i s_case = s_case + 1 Select Case s_case Case 1 ' Num SavedMeasurement.num = CInt(Mid$(inputstring, s_start + 1, s_end - s_start - 1)) s_start = s_end Case 2 ' X SavedMeasurement.X = CDbl(Mid$(inputstring, s_start + 1, s_end - s_start - 1)) s_start = s_end Case 3 ' Y SavedMeasurement.Y = CDbl(Mid$(inputstring, s_start + 1, s_end - s_start - 1)) s_start = s_end Case 4 ' Z SavedMeasurement.z = CDbl(Mid$(inputstring, s_start + 1, s_end - s_start - 1)) s_start = s_end End Select End If Next i SkipParse: ' MsgBox (Pnumber & " " & X_ini & " " & Y_ini & " " & Z_ini) If SavedMeasurement.X > 1 Then Z_maa = getheight(SavedMeasurement.X, SavedMeasurement.Y) 'Z_maa = getTINheight(SavedMeasurement.X, SavedMeasurement.Y, CLng(0)) 'Z_maa = SavedMeasurement.z - Z_maa 'Open "c:\apu\ilkka.txt" For Append As 200 ' Print #200, SavedMeasurement.X, SavedMeasurement.Y, Zbutt, Z_maa, teksti Print #200, SavedMeasurement.X, SavedMeasurement.Y, Zbutt - Z_maa Dim testpoint As Point testpoint.X = SavedMeasurement.X testpoint.Y = SavedMeasurement.Y 'INOUT = InsidePolygon(PlotPoly, UBound(PlotPoly), testpoint) 'If INOUT = Inside Then Apu_z = 255 - (255 - (Z_maa - MinDTM) * 255 / (MaxDTM - MinDTM)) ' DTM Rem HSV-code If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 Apu_z = Apu_z / 4 'Colorpix = RGB(ColorMap(Apu_z, 1), ColorMap(Apu_z, 2), ColorMap(Apu_z, 3)) 'Colorpix = RGB(255, 255, 255) Dim maa_x As Double, maa_y As Double If SavedMeasurement.num > 6 And SavedMeasurement.num < 9 Then ' SavedMeasurement.num = 9 Or SavedMeasurement.num = 12 Or SavedMeasurement.num = 16 Or SavedMeasurement.num = 17 Or SavedMeasurement.num = 18 Then For i = 0 To NumOfImages - 1 Call r_transform_ground_to_pixel(i, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z, p_x, p_y) alku_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 0 alku_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 0 Call r_transform_ground_to_pixel(i, SavedMeasurement.X, SavedMeasurement.Y, Z_maa, p_x, p_y) p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 0 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 0 Colorpix = RGB(255, 0, 0) Form1.Picture1(i).DrawWidth = 2 'Form1.Picture1(i).Line (alku_x, alku_y)-(p_x, p_y), RGB(225, 225, 225) Call r_transform_ground_to_pixel(i, SavedMeasurement.X, SavedMeasurement.Y, SavedMeasurement.z, p_x, p_y) Form1.Picture1(i).DrawWidth = 2 Form1.Picture1(i).FontBold = True Form1.Picture1(i).Font = Arial Form1.Picture1(i).FontSize = 10 Form1.Picture1(i).ForeColor = RGB(255, 255, 255) 'If dummy < 10 Then ' Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix Form1.Picture1(i).Circle ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), 6, Colorpix 'End If col_a = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 row_a = -1 + ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y Form1.Picture1(i).FillStyle = 1 'Form1.Picture1(i).Circle (col_a, row_a), 5 'Exit Sub Form1.Picture1(i).ForeColor = RGB(255, 255, 255) Form1.Picture1(i).CurrentY = Form1.Picture1(i).CurrentY + 2 'Form1.Picture1(i).Print Format$(SavedMeasurement.num, "0") ' Form1.Picture1(i).Print " " & teksti 'Form1.Picture1(i).ForeColor = RGB(255, 255, 255) ' Form1.Picture1(i).Print Pnumber & " " & Format$(Z_ini, "#.0") If Numbers_Plotted = True Then Form1.Picture1(i).ForeColor = RGB(0, 0, 0) Form1.Picture1(i).Print SavedMeasurement.num ' Format$(SavedMeasurement.z - Z_maa, "0.00 m") ' ' Form1.Picture1(i).Print Format$(SavedMeasurement.z - Z_maa, "0.0") ' ' Form1.Picture1(i).Print teksti End If Form1.Picture1(i).DrawWidth = 1 Next i End If End If Loop Close (11) Close (200) Exit Sub error_in_reading_and_plotting: MsgBox ("An error occurred in reading the file: " & TreedataFilename & " , check that it has no blank lines at the end or eq.") Exit Sub End Sub Public Sub calculate_region(ByVal i As Long, CenterCol As Long, CenterRow As Long, ByVal Width As Long, ByVal Height As Long, ByRef Start_Col As Long, Start_Row As Long, End_Col As Long, End_Row As Long, pan_x As Double, pan_y As Double) Rem For image i, check if for region width, height, centered at CenterCol, CenterRow Rem may be defined, return values for StartCol, StartRow, EndCol, EndRow Rem If Overflow in any direction (Col, Row), positive, negative Rem then adjust CenterCol or CenterRow to fit main image Rem i , CenterCol, CenterRow width, height Rem StartCol , Start_Row EndCol , EndRow Rem calculate MinCol, MaxCol, MinRow, MaxRow Dim MinCol As Long, maxcol As Long, MinRow As Long, maxrow As Long Rem check first that window isn't larger than image 'MsgBox (width) 'MsgBox (height) If Width > image_info(i).sub_width Or Height > image_info(i).sub_height Then MsgBox ("Pan window is too large") Start_Col = 0 Start_Row = 0 End_Col = image_info(i).sub_width - 1 End_Row = image_info(i).sub_height - 1 Exit Sub End If Rem startCol & end Col Recalculate: If Width Mod 2 = 1 Then ' odd width MinCol = CInt(CenterCol - (Width - 1) / 2) If MinCol < 0 Then MinCol = 0 maxcol = MinCol + (Width) - 1 GoTo checkheight End If maxcol = CInt(CenterCol + (Width - 1) / 2) If (maxcol > (image_info(i).sub_width - 1)) Then maxcol = image_info(i).sub_width - 1 MinCol = maxcol - Width GoTo checkheight End If End If If Width Mod 2 = 0 Then MinCol = CenterCol - (Width / 2) + 1 If MinCol < 0 Then MinCol = 0 maxcol = MinCol + Width - 1 GoTo checkheight End If maxcol = CenterCol + Width / 2 If maxcol > (image_info(i).sub_width - 1) Then maxcol = image_info(i).sub_width - 1 MinCol = maxcol - Width + 1 GoTo checkheight End If End If checkheight: If Height Mod 2 = 1 Then ' odd height MinRow = CLng(CenterRow - (Height - 1) / 2) If MinRow < 0 Then MinRow = 0 maxrow = MinRow + Height - 1 GoTo loppu End If maxrow = CLng(CenterRow + (Height - 1) / 2) If maxrow > (image_info(i).sub_height - 1) Then maxrow = image_info(i).sub_height - 1 MinRow = maxrow - Height + 1 GoTo loppu End If End If If Height Mod 2 = 0 Then MinRow = CenterRow - (Height / 2) + 1 If MinRow < 0 Then MinRow = 0 maxrow = MinRow + Height - 1 GoTo loppu End If maxrow = CenterRow + Height / 2 If maxrow > (image_info(i).sub_height - 1) Then maxrow = (image_info(i).sub_height - 1) MinRow = maxrow - Height + 1 End If End If loppu: Start_Col = MinCol Start_Row = MinRow End_Col = maxcol End_Row = maxrow win_info(i).win_o_col = MinCol win_info(i).win_o_row = MinRow End Sub Public Sub Move_By_Step(key As String) Dim p_x As Double, p_y As Double Dim Xr As Double, Yr As Double, Zr As Double ' get the current solution Xr = X_sol Yr = Y_sol Zr = Z_sol ' Update Yr Rem Select the case Select Case key Case "E" ' Move to East Xr = Xr + StepValue Case "W" ' Move to West Xr = Xr - StepValue Case "N" ' Move to North Yr = Yr + StepValue Case "S" ' Move to South Yr = Yr - StepValue Case "U" ' Move Up Zr = Zr + StepValue Case "D" ' Move Down Zr = Zr - StepValue End Select X_sol = Xr Y_sol = Yr Z_sol = Zr Form1.Label4(0).Caption = Format$(X_sol, "#.00") Form1.Label4(1).Caption = Format$(Y_sol, "#.00") Form1.Label4(2).Caption = Format$(Z_sol, "#.00") ' Update Images 1, 2 and 3 Dim i As Integer For i = 0 To NumOfImages - 1 Form1.Picture1(i).DrawWidth = 3 If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, Xr, Yr, Zr, p_x, p_y) Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1), RGB(255, 55, 10) Form1.Picture1(i).DrawWidth = 1 End If Next i 'Call center_to_xyz Form1.Label10.Caption = "Solution moved as " & key & " pressed by " & StepValue & " meters" End Sub Public Sub MATVECMULT_D(Y() As Double, Dim_Y As Integer, A() As Double, na As Integer, ma As Integer, YOUT() As Double) Rem Multiply matrix A(i,j) with vector Y(j) to get vector X(i) If ma <> Dim_Y Then MsgBox ("In MATVECMULT_D dimensions of Matrix and Vector conflict!") Exit Sub End If Dim Ix As Integer, jx As Integer For Ix = 1 To na For jx = 1 To ma YOUT(Ix) = YOUT(Ix) + A(Ix, jx) * Y(jx) Next jx Next Ix End Sub Public Sub indexx(ByVal N As Long, ra() As Single, indx() As Long) Rem Heapsort from Numerical recipes Rem indx(1 to N) is an index table, returned Rem ra(1 to N) is the data to be sorted, left as is. Dim i As Long, j As Long, l As Long, IR As Long, indxt As Long Dim q As Single Dim apu As Integer On Error GoTo virhe_sort For j = 1 To N indx(j) = j Next j l = N / 2 + 1 IR = N 10: If (l > 1) Then l = l - 1 indxt = indx(l) q = ra(indxt) Else indxt = indx(IR) q = ra(indxt) indx(IR) = indx(1) IR = IR - 1 If (IR = 1) Then indx(1) = indxt Exit Sub End If End If i = l j = l + l 20: If j <= IR Then If j < IR Then If (ra(indx(j)) < ra(indx(j + 1))) Then j = j + 1 End If If (q < ra(indx(j))) Then indx(i) = indx(j) i = j j = j + j Else j = IR + 1 End If GoTo 20 End If indx(i) = indxt GoTo 10 virhe_sort: 'MsgBox ("Error in Heapsort, l is " & l) End Sub Public Function FindSpecies(red As Double, green As Double, blue As Double, IR As Double) As Byte For i = 0 To 3 If Form1.Check2(i).Value = 1 Then FindSpecies = i + 1 End If Next i Exit Function ReDim meanvect(1 To 4) As Point2D ReDim VarCov(1 To 4, 1 To 2, 1 To 2) As Double ReDim Detc(1 To 4) As Double meanvect(1).X = 262.990566 meanvect(1).Y = 1930.501048 meanvect(2).X = 213.0305944 meanvect(2).Y = 1707.183566 meanvect(3).X = 246.0503686 meanvect(3).Y = 2424.57371 meanvect(4).X = 285.8220339 meanvect(4).Y = 870.4576271 VarCov(1, 1, 1) = 0.00163134 VarCov(1, 1, 2) = -0.00014061 VarCov(1, 2, 1) = -0.00014061 VarCov(1, 2, 2) = 0.00002091 VarCov(2, 1, 1) = 0.00186288 VarCov(2, 1, 2) = -0.00011466 VarCov(2, 2, 1) = -0.00011466 VarCov(2, 2, 2) = 0.00001327 VarCov(3, 1, 1) = 0.00127503 VarCov(3, 1, 2) = -0.00006913 VarCov(3, 2, 1) = -0.00006913 VarCov(3, 2, 2) = 0.00000797 VarCov(4, 1, 1) = 0.00023066 VarCov(4, 1, 2) = -0.00004818 VarCov(4, 2, 1) = -0.00004818 VarCov(4, 2, 2) = 0.00001856 Detc(1) = 7.843681841 Detc(2) = 7.936855713 Detc(3) = 8.26850951 Detc(4) = 8.707540423 ReDim dist(1 To 4) As Double ReDim vect1(1 To 2) As Double ReDim Vect2(1 To 2) As Double Dim maxdist As Double maxdist = -100000 For i = 1 To 4 vect1(1) = (meanvect(i).X - blue) * VarCov(i, 1, 1) + (meanvect(i).Y - IR) * VarCov(i, 2, 1) vect1(2) = (meanvect(i).X - blue) * VarCov(i, 1, 2) + (meanvect(i).Y - IR) * VarCov(i, 2, 2) dist(i) = -0.5 * Detc(i) - 0.5 * (vect1(1) * (meanvect(i).X - blue) + vect1(2) * (meanvect(i).Y - IR)) If dist(i) > maxdist Then maxdist = dist(i) sp = i End If Next i 'Form1.Picture1(0).Cls Form1.Picture1(0).Print sp Form1.Picture1(0).CurrentY = 10 FindSpecies = sp Exit Function ReDim Spvect(1 To 4) As Vector3D Rem Assign 1 = Pine, 2 = Spruce , 3 = Birch , 4 = Aspen Spvect(1).X = 194.5: Spvect(1).Y = 100.2: Spvect(1).z = 98.1 Spvect(2).X = 191.2: Spvect(2).Y = 63.8: Spvect(2).z = 69.4 Spvect(3).X = 212.2: Spvect(3).Y = 185.4: Spvect(3).z = 141.6 Spvect(4).X = 148.2: Spvect(4).Y = 151.4: Spvect(4).z = 131.9 ReDim SpDist(1 To 4) As Double SpDist(1) = 0: SpDist(2) = 0: SpDist(3) = 0: SpDist(4) = 0: Dim Species As Long, mindist As Double mindist = 255# For j = 1 To 4 SpDist(j) = Sqr((Spvect(j).X - red) ^ 2 + (Spvect(j).Y - green) ^ 2 + (Spvect(j).z - blue) ^ 2) If SpDist(j) < mindist Then mindist = SpDist(j) If mindist < 100 Then Species = j Else Species = 0 End If End If Next j 'FindSpecies = Species End Function Public Sub MMULT_D(A() As Double, na As Integer, ma As Integer, B() As Double, NB As Integer, MB As Integer, c() As Double) Rem multiply matrix B*A !! to get C If na <> MB Then MsgBox ("Error in MMUL_D, cannot multiply matrices with dimension conflict!") Exit Sub End If Dim Ix As Integer, jx As Integer, kX As Integer For Ix = 1 To NB ' loop B's rows For jx = 1 To ma ' loop A's cols c(Ix, jx) = 0 For kX = 1 To na ' loop A's rows c(Ix, jx) = c(Ix, jx) + B(Ix, kX) * A(kX, jx) ' NA x MB NA x MB NB x MB NA x MA Next kX Next jx Next Ix End Sub Public Sub Read_Field_Trees(Filename1 As String) ReDim Preserve FTrees(1 To 13500) As TreeVect Open Filename1 For Input As 1 'Exit Sub j = 0 Line Input #1, HeaderRow Do Until EOF(1) j = j + 1 Rem Input #1, FTrees(j).Plot, FTrees(j).num, FTrees(j).X, FTrees(j).Y _ , FTrees(j).Ztop, FTrees(j).Zbutt, FTrees(j).Species _ , FTrees(j).STATUS, FTrees(j).d13, FTrees(j).Height _ , FTrees(j).hc, FTrees(j).d6, FTrees(j).age Input #1, FTrees(j).key, FTrees(j).Plot, FTrees(j).num, FTrees(j).Sptext, FTrees(j).X, FTrees(j).Y, _ FTrees(j).Ztop, FTrees(j).Zbutt, FTrees(j).d13, FTrees(j).Height, _ FTrees(j).Status, FTrees(j).cf, FTrees(j).cont, FTrees(j).pw, FTrees(j).rmse, FTrees(j).DensityF ' FTrees(j).Zbutt = getheight(FTrees(j).X, FTrees(j).Y) ' FTrees(j).Ztop = FTrees(j).Zbutt + FTrees(j).Height 'Input #1, FTrees(j).num, FTrees(j).X, FTrees(j).Y, FTrees(j).Ztop _ , FTrees(j).Zbutt, FTrees(j).d13, FTrees(j).hc, FTrees(j).Height, FTrees(j).Species, FTrees(j).Status, dummy 'FTrees(j).Plot = "MK" 'FTrees(j).d13 = FTrees(j).d13 * 100 ' FTrees(j).Height = FTrees(j).Ztop - FTrees(j).Zbutt 'FTrees(j).Zbutt = getheight(FTrees(j).X, FTrees(j).Y) 'FTrees(j).Ztop = getheight(FTrees(j).X, FTrees(j).Y) + FTrees(j).Height Loop Close (1) ReDim Preserve FTrees(1 To j) As TreeVect End Sub Public Sub Trace_Pulses_For_Losses() Rem Combine tree/crown data with only echoes from the ground, compute path length in crowns Rem for each pulse Rem Read the trees Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Double, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double Dim LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long Dim e As Vector3D, l As Vector3D Open "c:\temp\book1.csv" For Input As 1 i = 1 ReDim FTrees(1 To 1000) As TreeVect Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ dbh, Hscale, df, pA Close (1) Rem Read LiDAR Rem ********************** PATH Open "c:\data\als2012_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) FN1 = Format$(Int((FTrees(i).X - 2510000) / 100), "000") FN2 = Format$(Int((FTrees(i).Y - 6850000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim Lidr(1 To NHA) As LidarRecord Dim k As Long Get #100, 1, NHA Get #100, 5, Lidr Close (100) Rem LiDAR is stored for one hectare loop trees and pulses Open "c:\temp\book1.csv" For Input As 1 i = 1 Do Until EOF(1) Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ dbh, Hscale, df, pA i = i + 1 X_sol = Measurement.X Y_sol = Measurement.Y Loop Open "c:\temp\idata.txt" For Output As 2 ReDim Preserve FTrees(1 To i - 1) As TreeVect Dim offset As Double atm = 1# ' accounts for the varying output power and atmospheric attenuation Rref = 1: a1 = -0.000690979: a2 = 0.243645961: a3 = -18.08813852: offset = 11.4 Dim dirv As Vector3D For k = 1 To NHA If Lidr(k).pulseCount <> 1 Then GoTo Nextpulse e.X = Lidr(k).Returns(1).X: e.Y = Lidr(k).Returns(1).Y: e.z = Lidr(k).Returns(1).z: l.X = Lidr(k).PosLidar.X: l.Y = Lidr(k).PosLidar.Y: l.z = Lidr(k).PosLidar.z range = Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2 + (e.z - l.z) ^ 2) maxradi = 1000 For ll = 1 To UBound(FTrees) Rem Solve Pulse coordinates for Z at crown base Zint = (FTrees(ll).Ztop - FTrees(ll).Zdem) * 0.6 + FTrees(ll).Zdem dirv.X = l.X - e.X: dirv.Y = l.Y - e.Y: dirv.z = l.z - e.z Call normalize(dirv) kk = (Zint - e.z) / dirv.z EdgeX = e.X + kk * dirv.X EdgeY = e.Y + kk * dirv.Y ' We need to bring Z to Zint radi = Sqr((EdgeX - FTrees(ll).X) ^ 2 + (EdgeY - FTrees(ll).Y) ^ 2) If radi < FTrees(ll).dcrm * 2 Then Zmaaf = getheight(Lidr(k).Returns(1).X, Lidr(k).Returns(1).Y) H = Lidr(k).Returns(1).z - Zmaaf If H < 0.5 And radi < maxradi Then maxradi = radi scan_zenith = pi / 2 - MYFUNC_ATAN((l.z - e.z) / Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2)) Rem Declare storage for waveform versions Rem Coefficients for range and gain control modeling, 2012 Leica data (multifootprint) atm = 1 If l.z > 2400 Then atm = 4.54045287428403E-02 If 1300 < l.z And l.z < 2400 Then atm = 7.73328125117215E-02 If 750 < l.z And l.z < 1300 Then atm = 0.280683361328588 scalef = 0.000007 ' Just to scale the amplitude values back to 0...100 range GAIN = Lidr(k).Res1 intensity1 = Lidr(k).intensity(1) intensity1 = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (intensity1 + 25)) * atm / (1 + (1 * (Cos(scan_zenith) - 1)))) * scalef dcrm = FTrees(ll).dcrm End If End If Next ll If maxradi < 10 Then Print #2, Lidr(k).Returns(1).X, Lidr(k).Returns(1).Y, maxradi, dcrm / 2, range, scan_zenith, intensity1 Nextpulse: If k Mod 1000 = 0 Then Form1.Caption = k: DoEvents End If Next k Close (2) Close (1) 'MsgBox (A1 & A2 & A3 & A4 & A5 & A6 & A7) Close (100) Exit Sub ErrorInPlot2007: Close (All) MsgBox ("Some error!") End Sub Public Sub Trace_Trunk_Pulses() Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Double, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double Dim LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long Dim e As Vector3D, l As Vector3D Open "c:\temp\book1.csv" For Input As 1 i = 1 ReDim FTrees(1 To 1000) As TreeVect Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ dbh, Hscale, df, pA Close (1) Rem Read LiDAR Rem ********************** PATH Open "c:\data\als2012_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) FN1 = Format$(Int((FTrees(i).X - 2510000) / 100), "000") FN2 = Format$(Int((FTrees(i).Y - 6850000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim Lidr(1 To NHA) As LidarRecord Dim k As Long Get #100, 1, NHA Get #100, 5, Lidr Close (100) Rem LiDAR is stored for one hectare loop trees and pulses Open "c:\temp\book1.csv" For Input As 1 i = 1 Do Until EOF(1) Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ FTrees(i).d13, Hscale, df, pA i = i + 1 X_sol = Measurement.X Y_sol = Measurement.Y Loop Open "c:\temp\trunkdata.txt" For Output As 2 ReDim Preserve FTrees(1 To i - 1) As TreeVect Dim offset As Double atm = 1# ' accounts for the varying output power and atmospheric attenuation Rref = 1: a1 = -0.000690979: a2 = 0.243645961: a3 = -18.08813852: offset = 11.4 Dim dirv As Vector3D For k = 1 To NHA For j = 4 To (5 - Lidr(k).pulseCount) Step -1 e.X = Lidr(k).Returns(j).X: e.Y = Lidr(k).Returns(j).Y: e.z = Lidr(k).Returns(j).z: l.X = Lidr(k).PosLidar.X: l.Y = Lidr(k).PosLidar.Y: l.z = Lidr(k).PosLidar.z range = Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2 + (e.z - l.z) ^ 2) maxradi = 1 Found = False For ll = 1 To UBound(FTrees) radi = Sqr((e.X - FTrees(ll).X) ^ 2 + (e.Y - FTrees(ll).Y) ^ 2) If radi < FTrees(ll).d13 / 100 * 2 Then Zmaaf = getheight(Lidr(k).Returns(j).X, Lidr(k).Returns(j).Y) H = Lidr(k).Returns(j).z - Zmaaf If H < 0.5 * FTrees(ll).Height And radi < maxradi Then Found = True maxradi = radi scan_zenith = pi / 2 - MYFUNC_ATAN((l.z - e.z) / Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2)) atm = 1 If l.z > 2400 Then atm = 4.54045287428403E-02 If 1300 < l.z And l.z < 2400 Then atm = 7.73328125117215E-02 If 750 < l.z And l.z < 1300 Then atm = 0.280683361328588 scalef = 0.000007 ' Just to scale the amplitude values back to 0...100 range GAIN = Lidr(k).Res1 intensity1 = Lidr(k).intensity(j) intensity1 = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (intensity1 + 25)) * atm / (1 + (1 * (Cos(scan_zenith) - 1)))) * scalef dbh = FTrees(ll).d13 End If End If Next ll If Found = True And H > 0.5 Then Print #2, j, Lidr(k).Returns(j).X, Lidr(k).Returns(j).Y, maxradi, dbh, H, range, scan_zenith, intensity1 Next j Nextpulse: If k Mod 1000 = 0 Then Form1.Caption = k: DoEvents End If Next k Close (2) Close (1) 'MsgBox (A1 & A2 & A3 & A4 & A5 & A6 & A7) Close (100) Exit Sub ErrorInPlot2007: Close (All) MsgBox ("Some error!") End Sub Public Sub Trace_Amplitude_data_on_ground() Rem Take only returns in canopy, check fr any pseudopulse or later bkscattering on the gnd, undetected Rem for each pulse Rem Read the trees Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Double, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1 As String * 3, FN2 As String * 3 Dim Xc As Double, Yc As Double Dim LiDARBinPath As String Dim Npulses As Long, NHA As Long, Nsum As Long Dim e As Vector3D, l As Vector3D Open "c:\temp\book1_kuusi.csv" For Input As 1 'Open "c:\temp\book1.csv" For Input As 1 i = 1 ReDim FTrees(1 To 1000) As TreeVect Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ dbh, Hscale, df, pA Close (1) Rem Read LiDAR Rem ********************** PATH Open "c:\data\als2012_path.hdr" For Input As 1 Input #1, LiDARBinPath Close (1) FN1 = Format$(Int((FTrees(i).X - 2510000) / 100), "000") FN2 = Format$(Int((FTrees(i).Y - 6850000) / 100), "000") Close (100) Open LiDARBinPath & FN1 & "_" & FN2 & ".bin" For Binary As 100 Get #100, , NHA If NHA = 0 Then Exit Sub ReDim LiDri(1 To NHA) As LidarRecord2010 Dim k As Long Get #100, 1, NHA Get #100, 5, LiDri Close (100) Rem LiDAR is stored for one hectare loop trees and pulses Open "c:\temp\book1_kuusi.csv" For Input As 1 'Open "c:\temp\book1.csv" For Input As 1 i = 1 Do Until EOF(1) Input #1, FTrees(i).Plot, _ FTrees(i).X, FTrees(i).Y, FTrees(i).Ztop, FTrees(i).Species, _ FTrees(i).Zdem, FTrees(i).cf, FTrees(i).cont, FTrees(i).pw, _ FTrees(i).rmse, FTrees(i).Height, FTrees(i).hc, FTrees(i).dcrm, _ dbh, Hscale, df, pA i = i + 1 X_sol = Measurement.X Y_sol = Measurement.Y Loop ReDim Preserve FTrees(1 To i - 1) As TreeVect Dim offset As Double ReDim Wave(1 To 256) As Byte ReDim wfsingle(1 To 256) As Single Dim L1 As Line3D, l2 As Line3D atm = 1# ' accounts for the varying output power and atmospheric attenuation Rref = 1: a1 = -0.000690979: a2 = 0.243645961: a3 = -18.08813852: offset = 11.4 Dim dirv As Vector3D For k = 1 To NHA Found = False dist_3d = 99 Rem Start Looping the canopy pulses' Or LiDRi(k).PosLiDAR.z < 2500 Or LiDRi(k).PosLiDAR.z < 2500 If LiDri(k).pulseCount <> 1 Then GoTo Nextpulse e.X = LiDri(k).Returns(4).X: e.Y = LiDri(k).Returns(4).Y: e.z = LiDri(k).Returns(4).z: l.X = LiDri(k).PosLidar.X: l.Y = LiDri(k).PosLidar.Y: l.z = LiDri(k).PosLidar.z range = Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2 + (e.z - l.z) ^ 2) maxradi = 1000 Zmaaf = getheight(LiDri(k).Returns(4).X, LiDri(k).Returns(4).Y) H = LiDri(k).Returns(4).z - Zmaaf Hlast = LiDri(k).Returns(1).z - getheight(LiDri(k).Returns(1).X, LiDri(k).Returns(1).Y) HoriZDev = Sqr((LiDri(k).Returns(4).X - LiDri(k).Returns(1).X) ^ 2 + (LiDri(k).Returns(4).Y - LiDri(k).Returns(1).Y) ^ 2) If H < 8 Then GoTo Nextpulse ' First from canopy, last For ll = 1 To UBound(FTrees) ' Loop all trees to find the closest and compute the 2D distance a crown base Rem Solve Pulse coordinates for Z at crown base Zint = (FTrees(ll).Ztop - FTrees(ll).Zdem) * 0.6 + FTrees(ll).Zdem If Zint < LiDri(k).Returns(4).z Then ' omit below crown-base points dirv.X = l.X - e.X: dirv.Y = l.Y - e.Y: dirv.z = l.z - e.z Call normalize(dirv) kk = (Zint - e.z) / dirv.z ' kk = (FTrees(ll).Ztop - e.z) / dirv.z ' top EdgeX = e.X + kk * dirv.X EdgeY = e.Y + kk * dirv.Y EdgeZ = Zint ' EdgeZ = e.z + kk * dirv.z kk = (FTrees(ll).Zdem - e.z) / dirv.z ' top gndx = e.X + kk * dirv.X gndy = e.Y + kk * dirv.Y gndz = e.z + kk * dirv.z raditop = Sqr((EdgeX - FTrees(ll).X) ^ 2 + (EdgeY - FTrees(ll).Y) ^ 2) radignd = Sqr((gndx - FTrees(ll).X) ^ 2 + (gndy - FTrees(ll).Y) ^ 2) ' Compute the distance to the trunk radi = Sqr((EdgeX - FTrees(ll).X) ^ 2 + (EdgeY - FTrees(ll).Y) ^ 2) L1.p0.X = LiDri(k).Returns(1).X: L1.p0.Y = LiDri(k).Returns(1).Y: L1.p0.z = LiDri(k).Returns(1).z L1.p0.X = gndx: L1.p0.Y = gndy: L1.p0.z = gndz L1.p1.X = l.X: L1.p1.Y = l.Y: L1.p1.z = l.z: l2.p0.X = FTrees(ll).X: l2.p0.Y = FTrees(ll).Y: l2.p0.z = FTrees(ll).Zdem l2.p1.X = FTrees(ll).X: l2.p1.Y = FTrees(ll).Y: l2.p1.z = FTrees(ll).Ztop dist = dist3D_Line_to_Line(L1, l2) dist_3d = Min(dist, dist_3d) If radi > FTrees(ll).dcrm * 1 Then GoTo NextTree ' omit if the cho is far away If radi < maxradi Then ' we are near a tree, analyse maxradi = radi lval = ll Found = True End If End If NextTree: Next ll If Found = False Then GoTo Nextpulse If maxradi > FTrees(lval).dcrm * 0.8 Then GoTo Nextpulse ' Solve the Z for the minimum heigt mindist = 10 For Zx = FTrees(lval).Ztop To FTrees(lval).Zdem Step -0.1 kk = (Zx - e.z) / dirv.z ' top px = e.X + kk * dirv.X py = e.Y + kk * dirv.Y pz = e.z + kk * dirv.z L1.p0.X = px: L1.p0.Y = py: L1.p0.z = pz L1.p1.X = l.X: L1.p1.Y = l.Y: L1.p1.z = l.z: l2.p0.X = FTrees(lval).X: l2.p0.Y = FTrees(lval).Y: l2.p0.z = FTrees(lval).Zdem l2.p1.X = FTrees(lval).X: l2.p1.Y = FTrees(lval).Y: l2.p1.z = FTrees(lval).Ztop dist = dist3D_Line_to_Line(L1, l2) If dist < mindist Then mindist = dist pxx = px pyy = py pzz = pz hrel = (FTrees(lval).Ztop - pzz) / (FTrees(lval).Ztop - FTrees(lval).Zdem) End If Next Zx ' We have found the closest tree, now process the WF If LiDri(k).Fileoffset > 1 Then Open LiDARBinPath & FN1 & "_" & FN2 & "_256.bin" For Binary As 100 Get #100, LiDri(k).Fileoffset + 1, Wave() Close (100) End If pikosecs = LiDri(k).range(4) ' Solve offset to ground For kk = 1 To 200 EdgeX = e.X - (kk * 0.15) * dirv.X EdgeY = e.Y - (kk * 0.15) * dirv.Y EdgeZ = e.z - (kk * 0.15) * dirv.z If Abs(EdgeZ - getheight(EdgeX, EdgeY)) < 0.15 Then Exit For Next kk Gnd = (pikosecs / 1000) + 1 + kk scan_zenith = pi / 2 - MYFUNC_ATAN((l.z - e.z) / Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2)) atm = 1 If l.z > 2400 Then atm = 4.54045287428403E-02 If 1300 < l.z And l.z < 2400 Then atm = 7.73328125117215E-02 If 750 < l.z And l.z < 1300 Then atm = 0.280683361328588 scalef = 0.000007 ' Just to scale the amplitude values back to 0...100 range GAIN = LiDri(k).Res1 offset = 11.4 wfsum = 0 For i = Gnd To Gnd wfsingle(i) = CDbl(Wave(i)) If Wave(i) < offset Then wfsingle(i) = offset + 0.0001 wfsingle(i) = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (wfsingle(i) - offset)) * atm / (1 + (1 * (Cos(scan_zenith) - 1)))) * scalef wfsum = wfsum + wfsingle(i) Next i intensity1 = LiDri(k).intensity(4) intensity1 = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (intensity1 + 25)) * atm / (1 + (1 * (Cos(scan_zenith) - 1)))) * scalef If Found = True And wfsum > 6 Then If l.z < 800 Then Open "c:\temp\Ku_PseudoGND_500.txt" For Append As 2 If l.z > 2400 Then Open "c:\temp\Ku_PseudoGND_2700.txt" For Append As 2 If 1300 < l.z And l.z < 2400 Then Open "c:\temp\Ku_PseudoGND_2000.txt" For Append As 2 If 750 < l.z And l.z < 1300 Then Open "c:\temp\Ku_PseudoGND_1000.txt" For Append As 2 dcrm = FTrees(lval).dcrm Print #2, LiDri(k).Returns(4).X, LiDri(k).Returns(4).Y, mindist, hrel, maxradi, dcrm / 2, maxradi / (dcrm / 2), range, scan_zenith, wfsum, intensity1 Close (2) 'Exit Sub End If Nextpulse: If k Mod 1000 = 0 Then Form1.Caption = k: DoEvents End If Next k Close (2) Close (1) 'MsgBox (A1 & A2 & A3 & A4 & A5 & A6 & A7) Close (100) Exit Sub ErrorInPlot2007: Close (All) MsgBox ("Some error!") End Sub Public Sub read_set_file_for_an_image(i As Long) Input #1, image_info(i).Imagetype ' FRAME ADS L0, ADS L1 'Input #1, image_info(i).Imagetype ' FRAME ADS L0, ADS L1 'Exit Sub 'image_info(i).Imagetype = "FRAME" If (image_info(i).Imagetype) = "ADS L0" Or image_info(i).Imagetype = "ADS L1" Then Input #1, image_info(i).ADSCAMFILENAME Call Read_ADS40_Cam_File(image_info(i).ADSCAMFILENAME, ADSCam(), ADSPixels(), i) Input #1, image_info(i).ADSODFFILENAME Call Read_ADS40_ODF_File(image_info(i).ADSODFFILENAME, i) Input #1, image_info(i).ADSSUPFILENAME Call Read_ADS40_SUP_File(image_info(i).ADSSUPFILENAME, i) Input #1, image_info(i).ADSADSFILENAME Call Read_ADS40_ADS_File(image_info(i).ADSADSFILENAME, i) End If Input #1, image_info(i).ImageCode ' Image long integer code Input #1, image_info(i).sub_width ' sub-image (to be stored in an array) width Input #1, image_info(i).sub_height ' sub-image height Input #1, image_info(i).FileName ' filename to be opened, containing raw-data (RGB) 'image_info(i).FileName = Replace$(Trim(image_info(i).FileName), "l:\aerial_images\2012\Images\", "f:\hyde_backup\aerial_images\2012\Images\", 1, 1, vbTextCompare) image_info(i).FileName = Replace$(image_info(i).FileName, "o:\", "Q:\") image_info(i).FileName = Replace$(image_info(i).FileName, "O:\", "q:\") Input #1, image_info(i).Color ' 1 for 24-bit color, 0 for greyscale 'Exit Sub Input #1, image_info(i).sub_c_col ' sub-image will be centered at this col when program initiates Input #1, image_info(i).sub_c_row ' sub-image will be centered at this row when program initiates Input #1, image_info(i).o_col ' the col value for the sub-image origo, in the main image coord. system with Y(row)-axis pointing down Input #1, image_info(i).o_row ' the row value for the sub-image origo, in the main image coord. system Input #1, image_info(i).Width ' width of the main image Input #1, image_info(i).Height ' heigth of the main image Input #1, image_info(i).c ' camera constant Input #1, image_info(i).x_ps ' in FC-coordinates the x-coordinate of the PPA-point (principal point) Input #1, image_info(i).y_ps ' in FC-coordinates the y-coordinate of the PPA-point Input #1, image_info(i).lambda ' Helmert rotation-angle, [rad] Input #1, image_info(i).alpha ' Helmert scale factor Input #1, image_info(i).mean_x ' Helmert mean x of camera coords Input #1, image_info(i).mean_y ' Helmert mean y of camera coords Input #1, image_info(i).X_mean ' Helmert mean ROW of image coords Input #1, image_info(i).Y_mean ' Helmert mean COL of image coords Input #1, image_info(i).a_ ' Affine a Input #1, image_info(i).b_ ' Affine b Input #1, image_info(i).c_ ' Affine c Input #1, image_info(i).d_ ' Affine d Input #1, image_info(i).e_ ' Affine e Input #1, image_info(i).f_ ' Affine f Input #1, image_info(i).omega ' ext. orientation angle omega (X) Input #1, image_info(i).phi ' ext. orientation angle phi (Y) Input #1, image_info(i).kappa ' ext. orientation angle kappa (Z) Input #1, image_info(i).Xo ' proj. center X-coord. Input #1, image_info(i).Yo ' proj. center Y-coord. Input #1, image_info(i).Zo ' proj. center Z-coord. Input #1, image_info(i).Sun_azimuth ' azimuth (direction clockwise from KKJ-North in radians) Input #1, image_info(i).Sun_elevation ' sun's elevation in radians over horizon Input #1, image_info(i).StartOf_string ' Starting row for additional exposures Input #1, image_info(i).Num_of_addit_expos ' Number of additional exposures Rem If we have more exposures, we read types, sizes and locations of them If image_info(i).Num_of_addit_expos > 0 Then For j = 1 To image_info(i).Num_of_addit_expos Input #1, image_info(i).AdditType(j) ' 0 = BW 8-byte,1 = RGB 8-byte,2 = BW 16-byte, 3 = RGBIR 16-byte Input #1, image_info(i).AdditFileName(j) ' Image location Input #1, image_info(i).AdditWidth(j) ' width in pixels of aerial photo (main image) Input #1, image_info(i).AdditHeight(j) ' height in pixels of aerial photo Next j End If Imagesdisplayed(i) = AER_IMA Call r_transform_matrix(i) End Sub Public Sub GetEightDigitLong(ByRef DigitString As String) Rem DigitString has 8 chars Dim NameLong As Long NameLong = Int(Rnd() * 100000000#) DigitString = Format$(NameLong, "00000000") End Sub Public Sub Press_F1() Form1.SetFocus End Sub Public Sub set_window_sizes() If NumOfImages > 0 And NumOfImages < 4 Then Rem There'll be just one row of images (picture-boxes), make their width an even number and height equal to width If (((Form1.ScaleWidth - 80) / NumOfImages)) < (Form1.ScaleHeight - 80) Then win_h = (Form1.ScaleWidth - 80) / NumOfImages win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h Else win_h = (Form1.ScaleHeight - 80) win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h End If End If If NumOfImages > 3 And NumOfImages < 7 Then Rem There'll be two rows of images on the main program window If (((Form1.ScaleWidth - 140) / 3)) < ((Form1.ScaleHeight - 140) / 2) Then win_h = (Form1.ScaleWidth - 140) / 3 win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h Else win_h = ((Form1.ScaleHeight - 140) / 2) win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h End If End If If NumOfImages > 6 And NumOfImages < 10 Then Rem There'll be three rows of images If (((Form1.ScaleWidth - 140) / 3)) < ((Form1.ScaleHeight - 140) / 3) Then win_h = (Form1.ScaleWidth - 140) / 3 win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h Else win_h = ((Form1.ScaleHeight - 200) / 3) win_h = win_h + (win_h * 3) Mod 4 Win_w = win_h End If End If End Sub Public Sub center_to_Sub_c() Dim i As Long, j As Long, length As Long Dim startcol As Long, startrow As Long, endcol As Long, endrow As Long On Error GoTo Error_in_center_to_sub_c Form1.MousePointer = 11 DoEvents For i = 0 To NumOfImages - 1 Call calculate_region(i, image_info(i).sub_c_col, image_info(i).sub_c_row, CInt(1 / win_info(i).pan_x * Win_w), CInt(1 / win_info(i).pan_y * win_h), startcol, startrow, endcol, endrow, win_info(i).pan_x, win_info(i).pan_y) win_info(i).win_o_col = startcol win_info(i).win_o_row = startrow win_info(i).win_width = Win_w win_info(i).win_height = win_h If image_info(i).Color = 1 Then length = Stringlength(image_info(i).FileName) ReDim filename_in(0 To length) As Byte For j = 0 To length - 1 filename_in(j) = CByte(Asc(Mid$(image_info(i).FileName, j + 1, 1))) Next j filename_in(length) = 0 FileOut = "c:\data\pic" & CStr(i) & ".bmp" length = Len(FileOut) ReDim filename_out(0 To length) As Byte For j = 0 To length - 1 filename_out(j) = CByte(Asc(Mid$(FileOut, j + 1, 1))) Next j filename_out(length) = 0 Call create_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) Call create_bmp_header(FileOut, CLng(Win_w), CLng(win_h)) ' apu = MYFUNC_CREATEBMP(CLng(i), CLng(startcol), CLng(startrow), CLng(endcol), CLng(endrow), filename_in(0), filename_out(0), CDbl(win_info(i).pan_x), CDbl(win_info(i).pan_y), CLng(win_h), CLng(Win_w), CLng(image_info(i).sub_width)) ElseIf image_info(i).Color = 0 Then Call create_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If ' Label10.Caption = CStr(startcol) & "," & CStr(startrow) & "," & CStr(endcol) & "," & CStr(endrow) Form1.Picture1(i).Picture = LoadPicture("c:\data\pic" & CStr(i) & ".bmp") Form1.Picture1(i).DrawWidth = 1 DoEvents Next i Form1.MousePointer = 1 Exit Sub Error_in_center_to_sub_c: MsgBox ("An error occurred in sub Error_in_center_to_sub_c_Click() ") Close (10) End Sub Public Sub center_to_pan_center() Dim i As Long, j As Long, k As Long, N As Long, l As Long, m As Long Dim Ix As Long, jx As Long, kX As Long, lx As Long, mx As Long, nx As Long, num As Long Dim Num_of_ima As Long, c_col As Long, c_row As Long Dim Cam(0 To MAXIMA) As Long Dim startcol As Long, startrow As Long, endcol As Long, endrow As Long, length As Long Dim p_x As Double, p_y As Double On Error GoTo Error_in_center_to_pan_center X_ini = X_cen Y_ini = Y_cen Z_ini = Z_cen ' Check from which images there are observations Form1.MousePointer = 11 DoEvents For i = 0 To NumOfImages - 1 Call r_transform_ground_to_pixel(i, X_ini, Y_ini, Z_ini, p_x, p_y) c_col = p_x - (image_info(i).o_col) c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) Call calculate_region(i, c_col, c_row, 1 / win_info(i).pan_x * Win_w, 1 / win_info(i).pan_y * win_h, startcol, startrow, endcol, endrow, win_info(i).pan_x, win_info(i).pan_y) win_info(i).win_o_col = startcol win_info(i).win_o_row = startrow win_info(i).win_width = Win_w win_info(i).win_height = win_h If image_info(i).Color = 1 Then length = Stringlength(image_info(i).FileName) ReDim filename_in(0 To length) As Byte For j = 0 To length - 1 filename_in(j) = CByte(Asc(Mid$(image_info(i).FileName, j + 1, 1))) Next j filename_in(length) = 0 FileOut = "c:\data\pic" & CStr(i) & ".bmp" length = Len(FileOut) ReDim filename_out(0 To length) As Byte For j = 0 To length - 1 filename_out(j) = CByte(Asc(Mid$(FileOut, j + 1, 1))) Next j filename_out(length) = 0 Call create_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) 'Call create_bmp_header(FileOut, CLng(Win_w), CLng(win_h)) 'apu = MYFUNC_CREATEBMP(CLng(i), CLng(startcol), CLng(startrow), CLng(endcol), CLng(endrow), filename_in(0), filename_out(0), CDbl(win_info(i).pan_x), CDbl(win_info(i).pan_y), CLng(win_h), CLng(Win_w), CLng(image_info(i).sub_width)) 'ElseIf image_info(i).Color = 0 Then ' Call create_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\temp\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If ' Label10.Caption = CStr(startcol) & "," & CStr(startrow) & "," & CStr(endcol) & "," & CStr(endrow) Form1.Picture1(i).Picture = LoadPicture("c:\data\pic" & CStr(i) & ".bmp") Form1.Picture1(i).DrawWidth = 1 For l = -1 To 1 For m = -1 To 1 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - m, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - l), RGB(0, 255, 0) Next m Next l DoEvents Next i Form1.MousePointer = 1 Exit Sub Error_in_center_to_pan_center: MsgBox ("An error occurred in sub Center_to_pan_center_Click() ") Close (10) End Sub Public Sub center_to_xyz() Dim i As Long, j As Long, l As Long, m As Long Dim startcol As Long, startrow As Long, endcol As Long, endrow As Long Dim c_col As Long, c_row As Long, length As Long Dim p_x As Double, p_y As Double For i = 0 To NumOfImages - 1 Imagesdisplayed(i) = AER_IMA Next i aa = Num_of_images 'If SolutionExists = False Then GoTo Error_in_GCP_space_intersection2 X_ini = X_sol Y_ini = Y_sol Z_ini = Z_sol 'Check from which images there are observations Form1.MousePointer = 11 DoEvents Dim lp As ads40_image_point_struct, f As ads40_image_point_struct Dim gp As Point3d For i = 0 To NumOfImages - 1 If image_info(i).Imagetype = "FRAME" Then Call r_transform_ground_to_pixel(i, X_ini, Y_ini, Z_ini, p_x, p_y) If p_x > 32000 Then p_x = 32000 If p_x < -32000 Then p_x = -32000 c_col = p_x - (image_info(i).o_col) If Abs((image_info(i).Height - 1) - p_y - (image_info(i).o_row)) > 32000 Then c_row = 0 Else c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) End If End If If image_info(i).Imagetype = "ADS L0" Then Call KKJ_to_LSR(i, X_sol, Y_sol, Z_sol, gp.X, gp.Y, gp.z) apu = grnd2lp(i, gp, lp) c_col = lp.Sample c_row = lp.Line End If If image_info(i).Imagetype = "ADS L1" Then Call KKJ_to_LSR(i, X_sol, Y_sol, Z_sol, gp.X, gp.Y, gp.z) apu = grnd2lp(CLng(i), gp, lp) apu = lp2f(i, lp, f) ADSOBS(i).xy.Y = f.Line: ADSOBS(i).xy.X = f.Sample ADSOBS(i).lp.Line = lp.Line: ADSOBS(i).lp.Sample = lp.Sample Call ADS_SOLVE_XYZ_from_Z_x_y(i, lp.Line, ADSSUP(i).RECT_HEIGHT, gp.X, gp.Y, f.Sample, f.Line) Ps = ADSSUP(i).RECT_SCALE * (gp.X * Cos(ADSSUP(i).RECT_ROTATION) - gp.Y * Sin(ADSSUP(i).RECT_ROTATION)) - ADSSUP(i).RECT_XOFFSET Pl = ADSSUP(i).LINES - (ADSSUP(i).RECT_SCALE * (gp.X * Sin(ADSSUP(i).RECT_ROTATION) + gp.Y * Cos(ADSSUP(i).RECT_ROTATION)) - ADSSUP(i).RECT_YOFFSET) ' apu = grnd2lp(i, gp, lp) c_col = Ps c_row = Pl End If Call calculate_region(i, c_col, c_row, 1 / win_info(i).pan_x * Win_w, 1 / win_info(i).pan_y * win_h, startcol, startrow, endcol, endrow, win_info(i).pan_x, win_info(i).pan_y) win_info(i).win_o_col = startcol win_info(i).win_o_row = startrow win_info(i).win_width = Win_w win_info(i).win_height = win_h If image_info(i).Color = 1 Then length = Stringlength(image_info(i).FileName) ReDim filename_in(0 To length) As Byte For j = 0 To length - 1 filename_in(j) = CByte(Asc(Mid$(image_info(i).FileName, j + 1, 1))) Next j filename_in(length) = 0 FileOut = "c:\data\pic" & CStr(i) & ".bmp" length = Len(FileOut) ReDim filename_out(0 To length) As Byte For j = 0 To length - 1 filename_out(j) = CByte(Asc(Mid$(FileOut, j + 1, 1))) Next j filename_out(length) = 0 Call create_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ' Call create_bmp_header(FileOut, CLng(Win_w), CLng(win_h)) ' apu = MYFUNC_CREATEBMP(CLng(i), CLng(startcol), CLng(startrow), CLng(endcol), CLng(endrow), filename_in(0), filename_out(0), CDbl(win_info(i).pan_x), CDbl(win_info(i).pan_y), CLng(win_h), CLng(Win_w), CLng(image_info(i).sub_width)) ElseIf image_info(i).Color = 0 Then Call create_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 2 Then ' 16 bit PAN image Call create_ADS40_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 4 Then Call create_DMC_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 3 Then Call create_DMC16_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If If image_info(i).Color = 2 Then Call create_ADS40_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If ' Label10.Caption = CStr(startcol) & "," & CStr(startrow) & "," & CStr(endcol) & "," & CStr(endrow) Form1.Picture1(i).Picture = LoadPicture("c:\data\pic" & CStr(i) & ".bmp") Form1.Picture1(i).DrawWidth = 1 Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(10, 200, 10) If image_info(i).Imagetype <> "FRAME" Then Form1.Picture1(i).PSet ((c_col - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, (c_row - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 10) Form1.Picture1(i).DrawWidth = 2 Form1.Picture1(i).FillStyle = 1 Form1.Picture1(i).DrawStyle = 0 Form1.Picture1(i).Circle (Form1.Picture1(i).CurrentX, Form1.Picture1(i).CurrentY), 20 End If Rem Here added an option to plot a circle of 25 cm width 'GoTo SkipCross: For l = -25 To 25 m = 0 If Abs(l) > 7 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x + m, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y + l), RGB(255, 255, 255) End If Next l For m = -25 To 25 l = 0 If Abs(m) > 7 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x + m, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y + l), RGB(10, 255, 10) End If Next m SkipCross: Form1.Picture1(i).CurrentX = Form1.Picture1(i).CurrentX + 20 Form1.Picture1(i).CurrentY = Form1.Picture1(i).CurrentY + 20 Form1.Picture1(i).FontSize = 18 Form1.Picture1(i).FontBold = True Form1.Picture1(i).Font = "Arial" Form1.Picture1(i).ForeColor = RGB(255, 255, 255) 'Form1.Picture1(i).Print Measurement.FieldNumber Form1.Picture1(i).FontSize = 20 Form1.Picture1(i).FontBold = True Form1.Picture1(i).Font = "Arial" Form1.Picture1(i).CurrentX = 5 Form1.Picture1(i).CurrentY = 5 'Form1.Picture1(i).Print image_info(i).ImageCode & " 1:" & Format$((image_info(i).Zo - Z_sol) / image_info(i).c, "0") DoEvents Next i Form1.MousePointer = 1 'Form1.Label10.Caption = "Images centered to given XYZ" Dim key As String 'key = "N" 'For lm = 1 To 10 'Move_By_Step (key) 'Next lm 'key = "S" 'For lm = 1 To 10 'Move_By_Step (key) 'Next lm ' NCounter = NCounter + 1 ' SavePicture Form1.Picture1(0).Image, "c:\temp\AVI\" & Format$(NCounter, "0000") & ".bmp" Exit Sub Error_in_GCP_space_intersection2: MsgBox ("An error occurred in sub Center_to_xyz_Click() ") Form1.Label10.Caption = "Image centering failed" Close (10) End Sub Public Sub Place_Objects_On_The_Main_Form() Rem This routine puts objects: picture1(i) -boxes that will hold image patches (image observations, superimposing) Rem text1(i) -boxes assiciated with a picture to hold photocoords (used) Rem Label1(i) for writing pixel coordinates (debugging) Rem Check(i) -boxes to indicate if an image is used (space intersection, matching..) Dim addition As Integer Dim i As Integer, j As Integer For i = 0 To NumOfImages - 1 If i >= 0 And i <= 2 Then j = 0 If i >= 3 And i <= 5 Then j = 1 If i >= 6 And i <= 8 Then j = 2 If j > 0 Then addition = 40 Rem Pixture-boxes that hold the sub-images Form1.Picture1(i).Visible = True Form1.Picture1(i).Enabled = True Form1.Picture1(i).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 Form1.Picture1(i).Top = 96 + j * (win_h) + j * addition Form1.Picture1(i).Width = Win_w + 4 Form1.Picture1(i).Height = win_h + 4 Rem Labels that hold the image / camera coords for each sub-image Form1.Label1(i).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 Form1.Label1(i).Top = Form1.Picture1(i).Top - 20 Rem Check-boxes that are used the define if an image is used or not in calculating space intersection Form1.Check1(i).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 + 200 Form1.Check1(i).Top = Form1.Picture1(i).Top - 25 Form1.Check1(i).Width = 200 Form1.Check1(i).Caption = "Use: " & image_info(i).ImageCode Rem Text-boxes that will hold the camera coords of the mouse-pointed image points Form1.Text1(i * 2).Top = Form1.Picture1(i).Top - 40 Form1.Text1((i * 2) + 1).Top = Form1.Picture1(i).Top - 40 Form1.Text1(i * 2).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 Form1.Text1((i * 2) + 1).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 + 60 Form1.Label1(i).Width = Form1.Text1(i).Width * 3 Rem Text-boxes that will hold the widths Form1.Text12(i).Top = Form1.Picture1(i).Top - 40 Form1.Text12(i).Left = 3 + (i Mod 3) * Win_w + (i Mod 3) * 3 + 2 * Form1.Text1(i * 2).Width Form1.Text12(i).Height = Form1.Text1(i).Height Form1.Text12(i).Width = Form1.Text1(i).Width Form1.Text12(i).Visible = True Rem Enable & make visible (by default these objects are not in use, because we don't know their number or location untill Rem we know the number of images Form1.Label1(i).Enabled = True Form1.Label1(i).Visible = True Form1.Text1(i * 2).Enabled = True Form1.Text1(i * 2).Visible = True Form1.Text1((i * 2) + 1).Enabled = True Form1.Text1((i * 2) + 1).Visible = True Form1.Check1(i).Enabled = True Form1.Check1(i).Visible = True Form1.Label2.Caption = "Measurement number: " & CStr(MeasurementCounter) DoEvents Next i Rem Make the visibility of unnecessary objects false (just to be sure it happens) For i = NumOfImages To MAXIMA - 1 Form1.Picture1(i).Visible = False Form1.Text1(i * 2).Visible = False Form1.Text1(i * 2 + 1).Visible = False Form1.Text12(i).Visible = False Form1.Check1(i).Visible = False Form1.Label1(i).Visible = False Next i End Sub Public Sub Check_parameter_sanity(ByVal i As Integer) Rem This routine checks that the parameters given in the set file are OK Rem (!! To some degree only) Dim A As Integer 'If image_info(i).sub_width < 0 Or image_info(i).sub_width > 2 ^ 15 Then MsgBox ("Image (0-(N-1)): " & CStr(i) & "Parameter: Sub-image width:" & CStr(image_info(i).sub_width) & " in set file?") ' sub-image (to be stored in an array) width 'If image_info(i).sub_height < 0 Or image_info(i).sub_height > 2 ^ 15 Then MsgBox ("Image (0-(N-1)): " & CStr(i) & "Parameter: Sub-image height:" & CStr(image_info(i).sub_height) & " in set file?") ' sub-image height Rem image_info(i).filename ' filename to be opened, containing raw-data (RGB) 'If image_info(i).Color < 0 Or image_info(i).Color > 1 Then MsgBox ("Image (0-(N-1)): " & CStr(i) & "Parameter: image color:" & CStr(image_info(i).Color) & " in set file should be 1 (color) or 0 (grayscale)?") ' 1 for 24-bit color, 0 for greyscale 'Input #1, image_info(i).sub_c_col ' sub-image will be centered at this col when program initiates 'Input #1, image_info(i).sub_c_row ' sub-image will be centered at this row when program initiates 'Input #1, image_info(i).o_col ' the col value for the sub-image origo, in the main image coord. system with Y(row)-axis pointing down 'Input #1, image_info(i).o_row ' the row value for the sub-image origo, in the main image coord. system 'Input #1, image_info(i).width ' width of the main image 'Input #1, image_info(i).height ' heigth of the main image 'Input #1, image_info(i).c ' camera constant 'Input #1, image_info(i).x_ps ' in FC-coordinates the x-coordinate of the PPA-point (principal point) 'Input #1, image_info(i).y_ps ' in FC-coordinates the y-coordinate of the PPA-point 'Input #1, image_info(i).lambda ' Helmert rotation-angle, [rad] 'Input #1, image_info(i).alpha ' Helmert scale factor 'Input #1, image_info(i).mean_x ' Helmert mean x of camera coords 'Input #1, image_info(i).mean_y ' Helmert mean y of camera coords 'Input #1, image_info(i).X_mean ' Helmert mean ROW of image coords 'Input #1, image_info(i).Y_mean ' Helmert mean COL of image coords 'Input #1, image_info(i).a_ ' Affine a 'Input #1, image_info(i).b_ ' Affine b 'Input #1, image_info(i).c_ ' Affine c 'Input #1, image_info(i).d_ ' Affine d 'Input #1, image_info(i).e_ ' Affine e 'Input #1, image_info(i).f_ ' Affine f 'Input #1, image_info(i).omega ' ext. orientation angle omega (X) 'Input #1, image_info(i).phi ' ext. orientation angle phi (Y) 'Input #1, image_info(i).kappa ' ext. orientation angle kappa (Z) 'Input #1, image_info(i).Xo ' proj. center X-coord. 'Input #1, image_info(i).Yo ' proj. center Y-coord. 'Input #1, image_info(i).Zo ' proj. center Z-coord. 'Input #1, image_info(i).Sun_azimuth 'Input #1, image_info(i).Sun_elevation End Sub Public Sub CheckAccuracy(DigitString As String, TreeFile As String) Exit Sub Rem This Routine finds Rem Rem (1) Number of found trees; for a cluster there exists a match in the Data Rem - Trees are listed, and statistics computed Rem Rem (2) Number of commission errors; a cluster is not found a match, within the circular plot + buffer Rem - Clusters are listed, and statistics computed Rem Rem (3) Number of omission errors; a tree falling within the circular plot is not found a match Rem - Trees are listed, and statistics computed Rem Rem Arguments: Rem Rem DigitString has the ######### -eight numbers Rem TreeFile contains measured tree-data (filename) Rem Height-diameter curve parameters h = 1.3 + d^2/(a+b*d)^2 Rem Open the file with the ground truth Rem Clusters are in global storage: clus() -array Rem ************************************************************************************************* Rem Find MATCHES -section; here we take a cluster, and try to find a match for it in the ground truth Dim MatchZdist As Double, MatchZrmse As Double Dim N_tree_inside As Integer Dim N_trees_in_plot As Integer Dim MeanHeightField As Double Dim N_tree_inside_border As Integer Dim Match2Ddist As Double, MatchXYrmse As Double ReDim ClusMatchStruct(1 To mC) As ClusMatchStruct Dim i As Integer Rem Maximum allowed XY-distance in meters between field measured tree top and candidate tree top Match2Ddist = 1.3 Rem Maximum allowed XY-distance in meters between field measured tree top and candidate tree top MatchZdist = 3 OV.XYMatchDist = Match2Ddist OV.ZMatchDist = MatchZdist Rem *********************************************************************************** Rem *** First, lets read all trees, and count the number of trees within the plot area, Rem *** and in the ring defined by the Match2Dist Rem TreeFile = "c:\data\maku_vis_trees.txt" TreeFile = "c:\data\ma4_vis_trees.txt" TreeFile = "c:\data\mk_vis_trees.txt" N_tree_inside_border = 0 N_tree_inside = 0 MeanHeightField = 0# ReDim TreeMatchStruct(1 To 350) As TreeMatchStruct Open TreeFile For Input As 44 'Exit Sub Dim angle As Double, X_origo As Double, Y_origo As Double, Z_origo As Double Dim X_shift As Double, Y_shift As Double, Z_shift As Double, X As Double, Y As Double, z As Double Dim sina As Double, cosa As Double, lx As Integer, jx As Integer, kX As Integer Dim d2_dist As Double Input #44, angle: Input #44, X_origo: Input #44, Y_origo: Input #44, Z_origo Input #44, X_shift: Input #44, Y_shift: Input #44, Z_shift angle = angle * TO_RADIANS: cosa = Cos(angle): sina = Sin(angle) Do Until EOF(44) lx = lx + 1 Input #44, X, Y, z, FTrees(lx).d13, FTrees(lx).Height, FTrees(lx).num, FTrees(lx).Species, FTrees(lx).Status FTrees(lx).X = cosa * X - sina * Y + X_origo + X_shift FTrees(lx).Y = sina * X + cosa * Y + Y_origo + Y_shift FTrees(lx).Zbutt = z + Z_origo + Z_shift FTrees(lx).Ztop = FTrees(lx).Zbutt + FTrees(lx).Height 'FTrees(lx).Zdem = getTINheight(FTrees(lx).x, FTrees(lx).y, CLng(0)) FTrees(lx).Zdem = getheight(FTrees(lx).X, FTrees(lx).Y) Rem Check if the tree falls inside circular plot's XY-extent d2_dist = sqrt((FTrees(lx).X - PlotCenter.X) ^ 2 + (FTrees(lx).Y - PlotCenter.Y) ^ 2) If d2_dist <= (Plotradius + Match2Ddist) Then N_tree_inside_border = N_tree_inside_border + 1 kX = N_tree_inside_border ' Number of trees inside the plot TreeMatchStruct(kX).num = FTrees(lx).num: TreeMatchStruct(kX).Spec = FTrees(lx).Species TreeMatchStruct(kX).Status = FTrees(lx).Status: TreeMatchStruct(kX).d13 = FTrees(lx).d13 TreeMatchStruct(kX).H = FTrees(lx).Height: TreeMatchStruct(kX).X = FTrees(lx).X TreeMatchStruct(kX).Y = FTrees(lx).Y: TreeMatchStruct(kX).z = FTrees(lx).Ztop TreeMatchStruct(kX).ZbuttDEM = FTrees(lx).Zdem: TreeMatchStruct(kX).ZButtTach = FTrees(lx).Zbutt TreeMatchStruct(kX).NclusInCylinder = 0 TreeMatchStruct(kX).IndexMatchClus = 0: TreeMatchStruct(kX).Dist3D = -1# TreeMatchStruct(kX).IsMatch = False: TreeMatchStruct(kX).IsOmission = False TreeMatchStruct(kX).Xclus = 0: TreeMatchStruct(kX).Yclus = 0 TreeMatchStruct(kX).Zclus = 0 TreeMatchStruct(kX).IsInside = False End If Rem Check if the tree falls inside the plot border If d2_dist < Plotradius Then N_tree_inside = N_tree_inside + 1 ' N of field trees within plotradius MeanHeightField = MeanHeightField + FTrees(lx).Ztop TreeMatchStruct(kX).IsInside = True End If Loop ' Get the next ground truth tree observation Close (44) N_trees_in_plot = N_tree_inside Form1.Label10.Caption = "Field plot trees read " & lx & " trees" Dim MeanHeightFoto As Double MatchXYrmse = 0#: MeanHeightFoto = 0#: MatchZrmse = 0# MeanHeightField = MeanHeightField / CDbl(N_tree_inside) 'Exit Sub Rem Looping thru Clusters Dim N_cand_inside As Integer Dim N_cand_inside_border As Integer Dim j As Integer Dim xp As Double, yp As Double, zp As Double For i = 1 To mC xp = cluscoords(i).X / (atausum(i)) yp = cluscoords(i).Y / (atausum(i)) zp = cluscoords(i).z / (atausum(i)) d2_dist = ((xp - PlotCenter.X) ^ 2 + (yp - PlotCenter.Y) ^ 2) ^ 0.5 If d2_dist <= (Plotradius + Match2Ddist) Then N_cand_inside_border = N_cand_inside_border + 1 j = N_cand_inside_border MeanHeightFoto = MeanHeightFoto + zp ClusMatchStruct(j).IsInside = False ClusMatchStruct(j).X = xp ClusMatchStruct(j).Y = yp ClusMatchStruct(j).z = zp ClusMatchStruct(j).Index = j ClusMatchStruct(j).IsMatch = False ClusMatchStruct(j).IsCommission = True End If If d2_dist < (Plotradius) Then N_cand_inside = N_cand_inside + 1 ClusMatchStruct(j).IsInside = True End If Next i ' Next cluster found Rem The mean height (elevation) of the candidates within the plot MeanHeightFoto = MeanHeightFoto / CDbl(N_cand_inside) Rem ************************************************************************ Rem *** FINDING MATCHES FOR THE FIELD TREES --> CANDIDATE WITHIN THE PLOT*** Rem ************************************************************************ Rem 1) For each tree and cluster, compute the number of clusters and Treetops in their Rem Match-Cylinders (loop clusters and loop trees, O(N^2)), compute closest pairs (minimum distances) Rem Rem Loop through Trees, On the first round Mark the with 0 c / 0 t and 1 c / 1 tree cases Rem to be SURE omission-errors and Matches Rem Rem At this point we are left with tree tops that have cases (1 c / > 1 t) and (>1 c / >1 t) Rem clusters that have 0 trees in their Match-cylinder Rem Rem Loop thru clusters (within boundary) and Mark 0 t -cases as commission errors Rem Rem For the (> 1 t / 1 c) cases check for that tree, that Rem it is matched with a cluster closest to it, and mark other trees Rem missed. Rem Loop thru the clusters: Rem For the (>1 t / > 1c) we have clusters with multiple trees in their match-cylinder, trees Rem which have multiple clusters in their matching cylinder. Rem Rem Processed or NOT ? Rem Dim minXYZdist As Double, NinMatchCyl As Integer, NTreeInClusCyl As Integer, d3_dist As Double Rem Loop thru candidates within radius + border (N_cand_inside) Dim NCluswithzerotrees As Integer, NCluswithonetree As Integer, NCluswithmanytrees As Integer For j = 1 To N_cand_inside_border minXYZdist = 50: NTreeInClusCyl = 0 xp = ClusMatchStruct(j).X yp = ClusMatchStruct(j).Y zp = ClusMatchStruct(j).z For jx = 1 To N_tree_inside_border d2_dist = sqrt((xp - TreeMatchStruct(jx).X) ^ 2 + (yp - TreeMatchStruct(jx).Y) ^ 2) d3_dist = sqrt((xp - TreeMatchStruct(jx).X) ^ 2 + (yp - TreeMatchStruct(jx).Y) ^ 2 + (zp - TreeMatchStruct(jx).z) ^ 2) If d2_dist < Match2Ddist And Abs(zp - TreeMatchStruct(jx).z) < MatchZdist Then NTreeInClusCyl = NTreeInClusCyl + 1 ClusMatchStruct(j).Dist2dToTreesInCyl(NTreeInClusCyl) = d3_dist ClusMatchStruct(j).IndecesTreesInCyl(NTreeInClusCyl) = jx TreeMatchStruct(jx).NclusInCylinder = TreeMatchStruct(jx).NclusInCylinder + 1 TreeMatchStruct(jx).IndecesClusInCyl(TreeMatchStruct(jx).NclusInCylinder) = j TreeMatchStruct(jx).Dist2dToClusInCyl(TreeMatchStruct(jx).NclusInCylinder) = d3_dist End If If d3_dist <= minXYZdist Then minXYZdist = d3_dist ' new minimum Rem At this point we store the minimum tree number and distance ClusMatchStruct(j).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(j).Dist3D = minXYZdist End If Rem We have also use for the number of trees in a clusters match-cylinder ClusMatchStruct(j).NTreesInCylinder = NTreeInClusCyl Next jx If NTreeInClusCyl = 0 Then NCluswithzerotrees = NCluswithzerotrees + 1 If NTreeInClusCyl = 1 Then NCluswithonetree = NCluswithonetree + 1 If NTreeInClusCyl > 1 Then NCluswithmanytrees = NCluswithmanytrees + 1 Next j Dim Ntreeswithzeroclus As Integer, Ntreeswithoneclus As Integer, Ntreeswithmanyclus As Integer For jx = 1 To N_tree_inside_border If TreeMatchStruct(jx).IsInside = True Then If TreeMatchStruct(jx).NclusInCylinder = 0 Then Ntreeswithzeroclus = Ntreeswithzeroclus + 1 If TreeMatchStruct(jx).NclusInCylinder = 1 Then Ntreeswithoneclus = Ntreeswithoneclus + 1 If TreeMatchStruct(jx).NclusInCylinder > 1 Then Ntreeswithmanyclus = Ntreeswithmanyclus + 1 End If Next jx Dim min_n As Integer, min_d As Double, min_h As Double, min_stat As Integer, min_spec As Integer Dim NTreesindorderZone As Integer, N_match_field_cand As Integer kX = 0: N_match_field_cand = 0: jx = 0 Dim minXYdist As Double, min_x As Double, min_y As Double, min_z As Double Dim Nin As Integer, NClusWith1to1 As Integer Rem LOOP THRU TREES TO FIND 0/0 and 1/1 CASES Dim N_omis As Integer, N_match As Integer For kX = 1 To N_tree_inside_border If TreeMatchStruct(kX).IsInside = True Then If TreeMatchStruct(kX).NclusInCylinder = 0 Then Rem A SURE OMISSION ERROR TreeMatchStruct(kX).IsOmission = True N_omis = N_omis + 1 GoTo NextTreeForCheck End If If TreeMatchStruct(kX).NclusInCylinder = 1 And ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).NTreesInCylinder = 1 Then Rem A SURE MATCH N_match = N_match + 1 GoTo markamatch End If GoTo NextTreeForCheck markamatch: TreeMatchStruct(kX).IndexMatchClus = TreeMatchStruct(kX).IndecesClusInCyl(1) TreeMatchStruct(kX).Dist3D = TreeMatchStruct(kX).Dist2dToClusInCyl(1) TreeMatchStruct(kX).IsMatch = True TreeMatchStruct(kX).Xclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).X TreeMatchStruct(kX).Yclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Y TreeMatchStruct(kX).Zclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).z Rem Recall to mark the cluster ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).IsMatch = True ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).IsCommission = False ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeNum = TreeMatchStruct(kX).num ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeSpec = TreeMatchStruct(kX).Spec ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeStat = TreeMatchStruct(kX).Status ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreed13 = TreeMatchStruct(kX).d13 ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeh = TreeMatchStruct(kX).H ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeZbuttDem = TreeMatchStruct(kX).ZbuttDEM ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeZbuttTach = TreeMatchStruct(kX).ZButtTach ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Xtree = TreeMatchStruct(kX).X ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).YTree = TreeMatchStruct(kX).Y ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Ztree = TreeMatchStruct(kX).z ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Dist3D = minXYZdist ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Npoints = clus(TreeMatchStruct(kX).IndecesClusInCyl(1), 1) ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Rvalue = atausum(TreeMatchStruct(kX).IndecesClusInCyl(1)) / clus(TreeMatchStruct(kX).IndecesClusInCyl(1), 1) NClusWith1to1 = NClusWith1to1 + 1 End If NextTreeForCheck: Next kX Dim op As Integer, apu As Long, ind As Long op = N_cand_inside_border Dim m As Integer, l As Integer, NT As Integer, nc As Integer, add As Integer For jx = 1 To N_tree_inside_border ' Loop Trees inside, allow a match from border! If TreeMatchStruct(jx).NclusInCylinder > 1 And TreeMatchStruct(jx).IsMatch = False Then ' This is a tree that has several clusters in it's cylinder ' If jx = 103 Then MsgBox ("103") minXYZdist = 50 apu = 0 For j = 1 To TreeMatchStruct(jx).NclusInCylinder ind = TreeMatchStruct(jx).IndecesClusInCyl(j) apu = apu + ClusMatchStruct(ind).NTreesInCylinder ' If ClusMatchStruct(ind).Index = 50 Then MsgBox ("50") If TreeMatchStruct(jx).Dist2dToClusInCyl(j) < minXYZdist Then minXYZdist = TreeMatchStruct(jx).Dist2dToClusInCyl(j) min_n = TreeMatchStruct(jx).IndecesClusInCyl(j) End If Next j If apu = TreeMatchStruct(jx).NclusInCylinder Then Rem This tree has only clusters which on their part have just one tree, choose Rem the tree to attach the cluster with, it is the (min_n) -tree, make other trees missed! Rem There are N=apu clusters to choose from TreeMatchStruct(jx).IndexMatchClus = min_n TreeMatchStruct(jx).Dist3D = minXYZdist TreeMatchStruct(jx).IsMatch = True TreeMatchStruct(jx).Xclus = ClusMatchStruct(min_n).X TreeMatchStruct(jx).Yclus = ClusMatchStruct(min_n).Y TreeMatchStruct(jx).Zclus = ClusMatchStruct(min_n).z Rem Recall to mark the cluster ClusMatchStruct(min_n).IsMatch = True ClusMatchStruct(min_n).IsCommission = False ClusMatchStruct(min_n).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(min_n).MatchTreeSpec = TreeMatchStruct(jx).Spec ClusMatchStruct(min_n).MatchTreeStat = TreeMatchStruct(jx).Status ClusMatchStruct(min_n).MatchTreed13 = TreeMatchStruct(jx).d13 ClusMatchStruct(min_n).MatchTreeh = TreeMatchStruct(jx).H ClusMatchStruct(min_n).MatchTreeZbuttDem = TreeMatchStruct(jx).ZbuttDEM ClusMatchStruct(min_n).MatchTreeZbuttTach = TreeMatchStruct(jx).ZButtTach ClusMatchStruct(min_n).Xtree = TreeMatchStruct(jx).X ClusMatchStruct(min_n).YTree = TreeMatchStruct(jx).Y ClusMatchStruct(min_n).Ztree = TreeMatchStruct(jx).z ClusMatchStruct(min_n).Dist3D = minXYZdist ClusMatchStruct(min_n).Npoints = clus(min_n, 1) ClusMatchStruct(min_n).Rvalue = atausum(min_n) / clus(min_n, 1) GoTo NextMTreeToCheck End If Rem Check if This cluster is used Rem We have now NT trees with > 2 clus If ClusMatchStruct(min_n).IsMatch = True Then MsgBox ("Duplicate!") TreeMatchStruct(jx).IndexMatchClus = min_n TreeMatchStruct(jx).Dist3D = minXYZdist TreeMatchStruct(jx).IsMatch = True TreeMatchStruct(jx).Xclus = ClusMatchStruct(min_n).X TreeMatchStruct(jx).Yclus = ClusMatchStruct(min_n).Y TreeMatchStruct(jx).Zclus = ClusMatchStruct(min_n).z Rem Recall to mark the cluster ClusMatchStruct(min_n).IsMatch = True ClusMatchStruct(min_n).IsCommission = False ClusMatchStruct(min_n).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(min_n).MatchTreeSpec = TreeMatchStruct(jx).Spec ClusMatchStruct(min_n).MatchTreeStat = TreeMatchStruct(jx).Status ClusMatchStruct(min_n).MatchTreed13 = TreeMatchStruct(jx).d13 ClusMatchStruct(min_n).MatchTreeh = TreeMatchStruct(jx).H ClusMatchStruct(min_n).MatchTreeZbuttDem = TreeMatchStruct(jx).ZbuttDEM ClusMatchStruct(min_n).MatchTreeZbuttTach = TreeMatchStruct(jx).ZButtTach ClusMatchStruct(min_n).Xtree = TreeMatchStruct(jx).X ClusMatchStruct(min_n).YTree = TreeMatchStruct(jx).Y ClusMatchStruct(min_n).Ztree = TreeMatchStruct(jx).z ClusMatchStruct(min_n).Dist3D = minXYZdist End If NextMTreeToCheck: Next jx Rem Now remains to polish the Clusters-commission errors for which there lie's Rem a tree outside the circular plot area. These clusters must lie in the bor- Rem dering zone: (radius-match2ddist) - (radius) Dim NborderMatches As Integer For j = 1 To N_cand_inside_border ' loop clusters If ClusMatchStruct(j).NTreesInCylinder > 0 And ClusMatchStruct(j).IsMatch = False Then Rem We have a case with NON-matched cluster If TreeMatchStruct(ClusMatchStruct(j).IndecesTreesInCyl(1)).NclusInCylinder > 0 Then Rem A tree has been found for the border cluster ind = ClusMatchStruct(j).IndecesTreesInCyl(1) If TreeMatchStruct(ind).IsMatch = False Then GoTo matchthisclus If TreeMatchStruct(ind).IsMatch = True Then m = 1 incresem: If m < ClusMatchStruct(j).NTreesInCylinder Then m = m + 1 ind = ClusMatchStruct(j).IndecesTreesInCyl(m) If TreeMatchStruct(ind).IsMatch = False Then GoTo matchthisclus GoTo incresem End If End If GoTo NextCand matchthisclus: TreeMatchStruct(ind).IndexMatchClus = j TreeMatchStruct(ind).Dist3D = ClusMatchStruct(j).Dist3D TreeMatchStruct(ind).IsMatch = True TreeMatchStruct(ind).Xclus = ClusMatchStruct(j).X TreeMatchStruct(ind).Yclus = ClusMatchStruct(j).Y TreeMatchStruct(ind).Zclus = ClusMatchStruct(j).z ClusMatchStruct(j).IsMatch = True ClusMatchStruct(j).IsCommission = False ClusMatchStruct(j).MatchTreeNum = TreeMatchStruct(ind).num ClusMatchStruct(j).MatchTreeSpec = TreeMatchStruct(ind).Spec ClusMatchStruct(j).MatchTreeStat = TreeMatchStruct(ind).Status ClusMatchStruct(j).MatchTreed13 = TreeMatchStruct(ind).d13 ClusMatchStruct(j).MatchTreeh = TreeMatchStruct(ind).H ClusMatchStruct(j).MatchTreeZbuttDem = TreeMatchStruct(ind).ZbuttDEM ClusMatchStruct(j).MatchTreeZbuttTach = TreeMatchStruct(ind).ZButtTach ClusMatchStruct(j).Xtree = TreeMatchStruct(ind).X ClusMatchStruct(j).YTree = TreeMatchStruct(ind).Y ClusMatchStruct(j).Ztree = TreeMatchStruct(ind).z ClusMatchStruct(j).Dist3D = TreeMatchStruct(ind).Dist3D ClusMatchStruct(j).Npoints = clus(ClusMatchStruct(j).Index, 1) ClusMatchStruct(j).Rvalue = atausum(ClusMatchStruct(j).Index) / ClusMatchStruct(j).Npoints NborderMatches = NborderMatches + 1 End If End If NextCand: Next j DoEvents For i = 0 To NumOfImages - 1 ' Loop images Form1.Picture1(i).Cls Next i DoEvents Rem Let's plot matches, omissions and comissions Dim p_x As Double, p_y As Double Dim dXave As Double, dYave As Double, dZave As Double Dim CountMatches As Integer, Countomissions As Integer Dim ZmatchedmeanTrees As Double, ZmatchedmeanClus As Double Dim Colorpix As Long CountMatches = 0: Countomissions = 0: ZmatchedmeanTrees = 0: ZmatchedmeanClus = 0 dXave = 0: dYave = 0: dZave = 0: Colorpix = RGB(255, 255, 255) For j = 1 To N_tree_inside_border ' Loop thru trees If TreeMatchStruct(j).IsInside = True Then ZmatchedmeanTrees = ZmatchedmeanTrees + TreeMatchStruct(j).z Select Case TreeMatchStruct(j).IsMatch Case True CountMatches = CountMatches + 1 dXave = dXave + (TreeMatchStruct(j).X - TreeMatchStruct(j).Xclus) dYave = dYave + (TreeMatchStruct(j).Y - TreeMatchStruct(j).Yclus) dZave = dZave + (TreeMatchStruct(j).z - TreeMatchStruct(j).Zclus) Case False Countomissions = Countomissions + 1 End Select For i = 0 To NumOfImages - 1 ' Loop images Form1.Picture1(i).DrawWidth = 1 Select Case TreeMatchStruct(j).IsMatch Case True Colorpix = RGB(0, 255, 41) Call r_transform_ground_to_pixel(i, TreeMatchStruct(j).Xclus, TreeMatchStruct(j).Yclus, TreeMatchStruct(j).Zclus, p_x, p_y) For l = -6 To 6 For m = -6 To 6 If Abs(m) > 4 Or Abs(l) > 4 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix End If Next m Next l Case False Colorpix = RGB(0, 10, 255) Call r_transform_ground_to_pixel(i, TreeMatchStruct(j).X, TreeMatchStruct(j).Y, TreeMatchStruct(j).z, p_x, p_y) For l = -1 To 1 For m = -7 To 7 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -7 To 7 For m = -1 To 1 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -7 To 7 For m = -7 To 7 If Abs(m) > 5 Or Abs(l) > 5 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix End If Next m Next l End Select Next i End If Next j dXave = dXave / CountMatches: dYave = dYave / CountMatches: dZave = dZave / CountMatches 'Close (All) 'Exit Sub Dim CountCommissions As Integer CountCommissions = 0 For j = 1 To N_cand_inside_border ' Loop thru clusters If ClusMatchStruct(j).IsInside = True Then ZmatchedmeanClus = ZmatchedmeanClus + ClusMatchStruct(j).z If ClusMatchStruct(j).IsCommission = True And ClusMatchStruct(j).IsInside = True Then CountCommissions = CountCommissions + 1 End If For i = 0 To NumOfImages - 1 ' Loop images If ClusMatchStruct(j).IsCommission = True And ClusMatchStruct(j).IsInside = True Then Colorpix = RGB(255, 0, 0) Form1.Picture1(i).DrawWidth = 1 Call r_transform_ground_to_pixel(i, ClusMatchStruct(j).X, ClusMatchStruct(j).Y, ClusMatchStruct(j).z, p_x, p_y) For l = -7 To 7 For m = -1 To 1 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -1 To 1 For m = -7 To 7 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l Form1.Picture1(i).DrawWidth = 1 End If Next i Next j ZmatchedmeanTrees = ZmatchedmeanTrees / CDbl(N_tree_inside) ZmatchedmeanClus = ZmatchedmeanClus / CDbl(N_cand_inside) Dim Zbias As Double Zbias = ZmatchedmeanTrees - ZmatchedmeanClus Form1.Label10.Caption = "Cs: " & N_cand_inside & " Ts: " & N_tree_inside & " Hs: " & CountMatches & " Os: " & Countomissions & " Cs: " & CountCommissions & " AI-%: " & Format$(((N_tree_inside - CountCommissions - Countomissions) / N_tree_inside) * 100, "#.0") & "% Zbias: " & Format$(dZave, "#.00 m") ' MsgBox (Format$(dXave, "#.00 m") & " " & Format$(dYave, "#.00 m") & " " & Format$(dZave, "#.00 m")) 'OV.NtreesInside = N_tree_inside_border 'OV.NClusInside = N_cand_inside_border OV.NtreesInside = N_tree_inside OV.NClusInside = N_cand_inside OV.Nmatched = CountMatches OV.Nomission = Countomissions OV.NCommission = CountCommissions OV.MatchP = (CountMatches / N_tree_inside) * 100# OV.Mrate = ((N_tree_inside - CountCommissions - Countomissions) / N_tree_inside) * 100 OV.ZbiasMatched = dZave OV.ZbiasAll = Zbias OV.Xbiasmatched = dXave OV.Ybiasmatched = dYave Rem ****************************************************************************** Rem RESULTS FILE-PRINTING SECTION; DigitString-holds a unique 8-digit for strorage Rem Parameters are stored in global vars, or as locals of this procedure Rem Rem Rem Open in Append mode Call PrintResults Exit Sub End Sub Public Sub CheckAccuracyForPoly(DigitString As String, TreeFile As String) Rem This Routine finds Rem Rem (1) Number of found trees; for a cluster there exists a match in the Data Rem - Trees are listed, and statistics computed Rem Rem (2) Number of commission errors; a cluster is not found a match, within the circular plot + buffer Rem - Clusters are listed, and statistics computed Rem Rem (3) Number of omission errors; a tree falling within the circular plot is not found a match Rem - Trees are listed, and statistics computed Rem Rem Arguments: Rem Rem DigitString has the ######### -eight numbers Rem TreeFile contains measured tree-data (filename) Rem Height-diameter curve parameters h = 1.3 + d^2/(a+b*d)^2 Rem Open the file with the ground truth Rem Clusters are in global storage: clus() -array Rem ************************************************************************************************* Rem Find MATCHES -section; here we take a cluster, and try to find a match for it in the ground truth Dim MatchZdist As Double, MatchZrmse As Double Dim N_tree_inside As Integer Dim N_trees_in_plot As Integer Dim MeanHeightField As Double Dim N_tree_inside_border As Integer Dim Match2Ddist As Double, MatchXYrmse As Double ReDim ClusMatchStruct(1 To mC) As ClusMatchStruct Dim i As Integer Rem Maximum allowed XY-distance in meters between field measured tree top and candidate tree top Match2Ddist = 1.3 Rem Maximum allowed XY-distance in meters between field measured tree top and candidate tree top MatchZdist = 3 OV.XYMatchDist = Match2Ddist OV.ZMatchDist = MatchZdist Rem *********************************************************************************** Rem *** First, lets read all trees, and count the number of trees within the plot area, Rem *** and in the ring defined by the Match2Dist Rem TreeFile = "c:\data\maku_vis_trees.txt" N_tree_inside_border = 0 N_tree_inside = 0 MeanHeightField = 0# ReDim TreeMatchStruct(1 To 450) As TreeMatchStruct Open TreeFile For Input As 44 'Close (44) 'Exit Sub Dim angle As Double, X_origo As Double, Y_origo As Double, Z_origo As Double Dim X_shift As Double, Y_shift As Double, Z_shift As Double, X As Double, Y As Double, z As Double Dim sina As Double, cosa As Double, lx As Integer, jx As Integer, kX As Integer Dim d2_dist As Double Input #44, angle: Input #44, X_origo: Input #44, Y_origo: Input #44, Z_origo Input #44, X_shift: Input #44, Y_shift: Input #44, Z_shift angle = angle * TO_RADIANS: cosa = Cos(angle): sina = Sin(angle) Dim piste As Point Do Until EOF(44) lx = lx + 1 Input #44, X, Y, z, FTrees(lx).d13, FTrees(lx).Height, FTrees(lx).num, FTrees(lx).Species, FTrees(lx).Status FTrees(lx).X = cosa * X - sina * Y + X_origo + X_shift FTrees(lx).Y = sina * X + cosa * Y + Y_origo + Y_shift FTrees(lx).Zbutt = z + Z_origo + Z_shift FTrees(lx).Ztop = FTrees(lx).Zbutt + FTrees(lx).Height 'FTrees(lx).Zdem = getTINheight(FTrees(lx).x, FTrees(lx).y, CLng(0)) FTrees(lx).Zdem = getheight(FTrees(lx).X, FTrees(lx).Y) Rem Check if the tree falls inside circular plot's XY-extent 'd2_dist = sqrt((FTrees(lx).x - Plotcenter.x) ^ 2 + (FTrees(lx).y - Plotcenter.y) ^ 2) piste.X = FTrees(lx).X piste.Y = FTrees(lx).Y If InsidePolygon(KuvioRaj, UBound(KuvioRaj) - 1, piste) = Inside Then 'If d2_dist <= (Plotradius + Match2Ddist) Then N_tree_inside_border = N_tree_inside_border + 1 kX = N_tree_inside_border ' Number of trees inside the plot TreeMatchStruct(kX).num = FTrees(lx).num: TreeMatchStruct(kX).Spec = FTrees(lx).Species 'Exit Sub TreeMatchStruct(kX).Status = FTrees(lx).Status: TreeMatchStruct(kX).d13 = FTrees(lx).d13 TreeMatchStruct(kX).H = FTrees(lx).Height: TreeMatchStruct(kX).X = FTrees(lx).X TreeMatchStruct(kX).Y = FTrees(lx).Y: TreeMatchStruct(kX).z = FTrees(lx).Ztop TreeMatchStruct(kX).ZbuttDEM = FTrees(lx).Zdem: TreeMatchStruct(kX).ZButtTach = FTrees(lx).Zbutt TreeMatchStruct(kX).NclusInCylinder = 0 TreeMatchStruct(kX).IndexMatchClus = 0: TreeMatchStruct(kX).Dist3D = -1# TreeMatchStruct(kX).IsMatch = False: TreeMatchStruct(kX).IsOmission = False TreeMatchStruct(kX).Xclus = 0: TreeMatchStruct(kX).Yclus = 0 TreeMatchStruct(kX).Zclus = 0 TreeMatchStruct(kX).IsInside = False End If Rem Check if the tree falls inside the plot border ' If d2_dist < Plotradius Then N_tree_inside = N_tree_inside + 1 ' N of field trees within plotradius MeanHeightField = MeanHeightField + FTrees(lx).Ztop TreeMatchStruct(kX).IsInside = True ' End If Loop ' Get the next ground truth tree observation Close (44) N_trees_in_plot = N_tree_inside Form1.Label10.Caption = "Field plot trees read " & lx & " trees" Dim MeanHeightFoto As Double MatchXYrmse = 0#: MeanHeightFoto = 0#: MatchZrmse = 0# MeanHeightField = MeanHeightField / CDbl(N_tree_inside) 'Exit Sub Rem Looping thru Clusters Dim N_cand_inside As Integer Dim N_cand_inside_border As Integer Dim j As Integer Dim xp As Double, yp As Double, zp As Double For i = 1 To mC xp = cluscoords(i).X / (atausum(i)) yp = cluscoords(i).Y / (atausum(i)) zp = cluscoords(i).z / (atausum(i)) piste.X = xp piste.Y = yp ' d2_dist = ((xp - Plotcenter.x) ^ 2 + (yp - Plotcenter.y) ^ 2) ^ 0.5 If InsidePolygon(KuvioRaj, UBound(KuvioRaj) - 1, piste) = Inside Then ' If d2_dist <= (Plotradius + Match2Ddist) Then N_cand_inside_border = N_cand_inside_border + 1 j = N_cand_inside_border MeanHeightFoto = MeanHeightFoto + zp ClusMatchStruct(j).IsInside = False ClusMatchStruct(j).X = xp ClusMatchStruct(j).Y = yp ClusMatchStruct(j).z = zp ClusMatchStruct(j).Index = j ClusMatchStruct(j).IsMatch = False ClusMatchStruct(j).IsCommission = True End If 'If d2_dist < (Plotradius) Then N_cand_inside = N_cand_inside + 1 ClusMatchStruct(j).IsInside = True 'End If Next i ' Next cluster found Rem The mean height (elevation) of the candidates within the plot MeanHeightFoto = MeanHeightFoto / CDbl(N_cand_inside) Rem ************************************************************************ Rem *** FINDING MATCHES FOR THE FIELD TREES --> CANDIDATE WITHIN THE PLOT*** Rem ************************************************************************ Rem 1) For each tree and cluster, compute the number of clusters and Treetops in their Rem Match-Cylinders (loop clusters and loop trees, O(N^2)), compute closest pairs (minimum distances) Rem Rem Loop through Trees, On the first round Mark the with 0 c / 0 t and 1 c / 1 tree cases Rem to be SURE omission-errors and Matches Rem Rem At this point we are left with tree tops that have cases (1 c / > 1 t) and (>1 c / >1 t) Rem clusters that have 0 trees in their Match-cylinder Rem Rem Loop thru clusters (within boundary) and Mark 0 t -cases as commission errors Rem Rem For the (> 1 t / 1 c) cases check for that tree, that Rem it is matched with a cluster closest to it, and mark other trees Rem missed. Rem Loop thru the clusters: Rem For the (>1 t / > 1c) we have clusters with multiple trees in their match-cylinder, trees Rem which have multiple clusters in their matching cylinder. Rem Rem Processed or NOT ? Rem Dim minXYZdist As Double, NinMatchCyl As Integer, NTreeInClusCyl As Integer, d3_dist As Double Rem Loop thru candidates within radius + border (N_cand_inside) Dim NCluswithzerotrees As Integer, NCluswithonetree As Integer, NCluswithmanytrees As Integer For j = 1 To N_cand_inside_border minXYZdist = 50: NTreeInClusCyl = 0 xp = ClusMatchStruct(j).X yp = ClusMatchStruct(j).Y zp = ClusMatchStruct(j).z For jx = 1 To N_tree_inside_border d2_dist = sqrt((xp - TreeMatchStruct(jx).X) ^ 2 + (yp - TreeMatchStruct(jx).Y) ^ 2) d3_dist = sqrt((xp - TreeMatchStruct(jx).X) ^ 2 + (yp - TreeMatchStruct(jx).Y) ^ 2 + (zp - TreeMatchStruct(jx).z) ^ 2) If d2_dist < Match2Ddist And Abs(zp - TreeMatchStruct(jx).z) < MatchZdist Then NTreeInClusCyl = NTreeInClusCyl + 1 ClusMatchStruct(j).Dist2dToTreesInCyl(NTreeInClusCyl) = d3_dist ClusMatchStruct(j).IndecesTreesInCyl(NTreeInClusCyl) = jx TreeMatchStruct(jx).NclusInCylinder = TreeMatchStruct(jx).NclusInCylinder + 1 TreeMatchStruct(jx).IndecesClusInCyl(TreeMatchStruct(jx).NclusInCylinder) = j TreeMatchStruct(jx).Dist2dToClusInCyl(TreeMatchStruct(jx).NclusInCylinder) = d3_dist End If If d3_dist <= minXYZdist Then minXYZdist = d3_dist ' new minimum Rem At this point we store the minimum tree number and distance ClusMatchStruct(j).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(j).Dist3D = minXYZdist End If Rem We have also use for the number of trees in a clusters match-cylinder ClusMatchStruct(j).NTreesInCylinder = NTreeInClusCyl Next jx If NTreeInClusCyl = 0 Then NCluswithzerotrees = NCluswithzerotrees + 1 If NTreeInClusCyl = 1 Then NCluswithonetree = NCluswithonetree + 1 If NTreeInClusCyl > 1 Then NCluswithmanytrees = NCluswithmanytrees + 1 Next j Dim Ntreeswithzeroclus As Integer, Ntreeswithoneclus As Integer, Ntreeswithmanyclus As Integer For jx = 1 To N_tree_inside_border If TreeMatchStruct(jx).IsInside = True Then If TreeMatchStruct(jx).NclusInCylinder = 0 Then Ntreeswithzeroclus = Ntreeswithzeroclus + 1 If TreeMatchStruct(jx).NclusInCylinder = 1 Then Ntreeswithoneclus = Ntreeswithoneclus + 1 If TreeMatchStruct(jx).NclusInCylinder > 1 Then Ntreeswithmanyclus = Ntreeswithmanyclus + 1 End If Next jx Dim min_n As Integer, min_d As Double, min_h As Double, min_stat As Integer, min_spec As Integer Dim NTreesindorderZone As Integer, N_match_field_cand As Integer kX = 0: N_match_field_cand = 0: jx = 0 Dim minXYdist As Double, min_x As Double, min_y As Double, min_z As Double Dim Nin As Integer, NClusWith1to1 As Integer Rem LOOP THRU TREES TO FIND 0/0 and 1/1 CASES Dim N_omis As Integer, N_match As Integer For kX = 1 To N_tree_inside_border If TreeMatchStruct(kX).IsInside = True Then If TreeMatchStruct(kX).NclusInCylinder = 0 Then Rem A SURE OMISSION ERROR TreeMatchStruct(kX).IsOmission = True N_omis = N_omis + 1 GoTo NextTreeForCheck End If If TreeMatchStruct(kX).NclusInCylinder = 1 And ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).NTreesInCylinder = 1 Then Rem A SURE MATCH N_match = N_match + 1 GoTo markamatch End If GoTo NextTreeForCheck markamatch: TreeMatchStruct(kX).IndexMatchClus = TreeMatchStruct(kX).IndecesClusInCyl(1) TreeMatchStruct(kX).Dist3D = TreeMatchStruct(kX).Dist2dToClusInCyl(1) TreeMatchStruct(kX).IsMatch = True TreeMatchStruct(kX).Xclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).X TreeMatchStruct(kX).Yclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Y TreeMatchStruct(kX).Zclus = ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).z Rem Recall to mark the cluster ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).IsMatch = True ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).IsCommission = False ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeNum = TreeMatchStruct(kX).num ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeSpec = TreeMatchStruct(kX).Spec ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeStat = TreeMatchStruct(kX).Status ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreed13 = TreeMatchStruct(kX).d13 ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeh = TreeMatchStruct(kX).H ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeZbuttDem = TreeMatchStruct(kX).ZbuttDEM ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).MatchTreeZbuttTach = TreeMatchStruct(kX).ZButtTach ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Xtree = TreeMatchStruct(kX).X ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).YTree = TreeMatchStruct(kX).Y ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Ztree = TreeMatchStruct(kX).z ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Dist3D = minXYZdist ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Npoints = clus(TreeMatchStruct(kX).IndecesClusInCyl(1), 1) ClusMatchStruct(TreeMatchStruct(kX).IndecesClusInCyl(1)).Rvalue = atausum(TreeMatchStruct(kX).IndecesClusInCyl(1)) / clus(TreeMatchStruct(kX).IndecesClusInCyl(1), 1) NClusWith1to1 = NClusWith1to1 + 1 End If NextTreeForCheck: Next kX Dim op As Integer, apu As Long, ind As Long op = N_cand_inside_border Dim m As Integer, l As Integer, NT As Integer, nc As Integer, add As Integer For jx = 1 To N_tree_inside_border ' Loop Trees inside, allow a match from border! If TreeMatchStruct(jx).NclusInCylinder > 1 And TreeMatchStruct(jx).IsMatch = False Then ' This is a tree that has several clusters in it's cylinder ' If jx = 103 Then MsgBox ("103") minXYZdist = 50 apu = 0 For j = 1 To TreeMatchStruct(jx).NclusInCylinder ind = TreeMatchStruct(jx).IndecesClusInCyl(j) apu = apu + ClusMatchStruct(ind).NTreesInCylinder ' If ClusMatchStruct(ind).Index = 50 Then MsgBox ("50") If TreeMatchStruct(jx).Dist2dToClusInCyl(j) < minXYZdist Then minXYZdist = TreeMatchStruct(jx).Dist2dToClusInCyl(j) min_n = TreeMatchStruct(jx).IndecesClusInCyl(j) End If Next j If apu = TreeMatchStruct(jx).NclusInCylinder Then Rem This tree has only clusters which on their part have just one tree, choose Rem the tree to attach the cluster with, it is the (min_n) -tree, make other trees missed! Rem There are N=apu clusters to choose from TreeMatchStruct(jx).IndexMatchClus = min_n TreeMatchStruct(jx).Dist3D = minXYZdist TreeMatchStruct(jx).IsMatch = True TreeMatchStruct(jx).Xclus = ClusMatchStruct(min_n).X TreeMatchStruct(jx).Yclus = ClusMatchStruct(min_n).Y TreeMatchStruct(jx).Zclus = ClusMatchStruct(min_n).z Rem Recall to mark the cluster ClusMatchStruct(min_n).IsMatch = True ClusMatchStruct(min_n).IsCommission = False ClusMatchStruct(min_n).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(min_n).MatchTreeSpec = TreeMatchStruct(jx).Spec ClusMatchStruct(min_n).MatchTreeStat = TreeMatchStruct(jx).Status ClusMatchStruct(min_n).MatchTreed13 = TreeMatchStruct(jx).d13 ClusMatchStruct(min_n).MatchTreeh = TreeMatchStruct(jx).H ClusMatchStruct(min_n).MatchTreeZbuttDem = TreeMatchStruct(jx).ZbuttDEM ClusMatchStruct(min_n).MatchTreeZbuttTach = TreeMatchStruct(jx).ZButtTach ClusMatchStruct(min_n).Xtree = TreeMatchStruct(jx).X ClusMatchStruct(min_n).YTree = TreeMatchStruct(jx).Y ClusMatchStruct(min_n).Ztree = TreeMatchStruct(jx).z ClusMatchStruct(min_n).Dist3D = minXYZdist ClusMatchStruct(min_n).Npoints = clus(min_n, 1) ClusMatchStruct(min_n).Rvalue = atausum(min_n) / clus(min_n, 1) GoTo NextMTreeToCheck End If Rem Check if This cluster is used Rem We have now NT trees with > 2 clus If ClusMatchStruct(min_n).IsMatch = True Then MsgBox ("Duplicate!") TreeMatchStruct(jx).IndexMatchClus = min_n TreeMatchStruct(jx).Dist3D = minXYZdist TreeMatchStruct(jx).IsMatch = True TreeMatchStruct(jx).Xclus = ClusMatchStruct(min_n).X TreeMatchStruct(jx).Yclus = ClusMatchStruct(min_n).Y TreeMatchStruct(jx).Zclus = ClusMatchStruct(min_n).z Rem Recall to mark the cluster ClusMatchStruct(min_n).IsMatch = True ClusMatchStruct(min_n).IsCommission = False ClusMatchStruct(min_n).MatchTreeNum = TreeMatchStruct(jx).num ClusMatchStruct(min_n).MatchTreeSpec = TreeMatchStruct(jx).Spec ClusMatchStruct(min_n).MatchTreeStat = TreeMatchStruct(jx).Status ClusMatchStruct(min_n).MatchTreed13 = TreeMatchStruct(jx).d13 ClusMatchStruct(min_n).MatchTreeh = TreeMatchStruct(jx).H ClusMatchStruct(min_n).MatchTreeZbuttDem = TreeMatchStruct(jx).ZbuttDEM ClusMatchStruct(min_n).MatchTreeZbuttTach = TreeMatchStruct(jx).ZButtTach ClusMatchStruct(min_n).Xtree = TreeMatchStruct(jx).X ClusMatchStruct(min_n).YTree = TreeMatchStruct(jx).Y ClusMatchStruct(min_n).Ztree = TreeMatchStruct(jx).z ClusMatchStruct(min_n).Dist3D = minXYZdist End If NextMTreeToCheck: Next jx Rem Now remains to polish the Clusters-commission errors for which there lie's Rem a tree outside the circular plot area. These clusters must lie in the bor- Rem dering zone: (radius-match2ddist) - (radius) Dim NborderMatches As Integer For j = 1 To N_cand_inside_border ' loop clusters If ClusMatchStruct(j).NTreesInCylinder > 0 And ClusMatchStruct(j).IsMatch = False Then Rem We have a case with NON-matched cluster If TreeMatchStruct(ClusMatchStruct(j).IndecesTreesInCyl(1)).NclusInCylinder > 0 Then Rem A tree has been found for the border cluster ind = ClusMatchStruct(j).IndecesTreesInCyl(1) If TreeMatchStruct(ind).IsMatch = False Then GoTo matchthisclus If TreeMatchStruct(ind).IsMatch = True Then m = 1 incresem: If m < ClusMatchStruct(j).NTreesInCylinder Then m = m + 1 ind = ClusMatchStruct(j).IndecesTreesInCyl(m) If TreeMatchStruct(ind).IsMatch = False Then GoTo matchthisclus GoTo incresem End If End If GoTo NextCand matchthisclus: TreeMatchStruct(ind).IndexMatchClus = j TreeMatchStruct(ind).Dist3D = ClusMatchStruct(j).Dist3D TreeMatchStruct(ind).IsMatch = True TreeMatchStruct(ind).Xclus = ClusMatchStruct(j).X TreeMatchStruct(ind).Yclus = ClusMatchStruct(j).Y TreeMatchStruct(ind).Zclus = ClusMatchStruct(j).z ClusMatchStruct(j).IsMatch = True ClusMatchStruct(j).IsCommission = False ClusMatchStruct(j).MatchTreeNum = TreeMatchStruct(ind).num ClusMatchStruct(j).MatchTreeSpec = TreeMatchStruct(ind).Spec ClusMatchStruct(j).MatchTreeStat = TreeMatchStruct(ind).Status ClusMatchStruct(j).MatchTreed13 = TreeMatchStruct(ind).d13 ClusMatchStruct(j).MatchTreeh = TreeMatchStruct(ind).H ClusMatchStruct(j).MatchTreeZbuttDem = TreeMatchStruct(ind).ZbuttDEM ClusMatchStruct(j).MatchTreeZbuttTach = TreeMatchStruct(ind).ZButtTach ClusMatchStruct(j).Xtree = TreeMatchStruct(ind).X ClusMatchStruct(j).YTree = TreeMatchStruct(ind).Y ClusMatchStruct(j).Ztree = TreeMatchStruct(ind).z ClusMatchStruct(j).Dist3D = TreeMatchStruct(ind).Dist3D ClusMatchStruct(j).Npoints = clus(ClusMatchStruct(j).Index, 1) ClusMatchStruct(j).Rvalue = atausum(ClusMatchStruct(j).Index) / ClusMatchStruct(j).Npoints NborderMatches = NborderMatches + 1 End If End If NextCand: Next j DoEvents For i = 0 To NumOfImages - 1 ' Loop images Form1.Picture1(i).Cls Next i DoEvents Rem Let's plot matches, omissions and comissions Dim p_x As Double, p_y As Double Dim dXave As Double, dYave As Double, dZave As Double Dim CountMatches As Integer, Countomissions As Integer Dim ZmatchedmeanTrees As Double, ZmatchedmeanClus As Double Dim Colorpix As Long CountMatches = 0: Countomissions = 0: ZmatchedmeanTrees = 0: ZmatchedmeanClus = 0 dXave = 0: dYave = 0: dZave = 0: Colorpix = RGB(255, 255, 255) For j = 1 To N_tree_inside_border ' Loop thru trees If TreeMatchStruct(j).IsInside = True Then ZmatchedmeanTrees = ZmatchedmeanTrees + TreeMatchStruct(j).z Select Case TreeMatchStruct(j).IsMatch Case True CountMatches = CountMatches + 1 dXave = dXave + (TreeMatchStruct(j).X - TreeMatchStruct(j).Xclus) dYave = dYave + (TreeMatchStruct(j).Y - TreeMatchStruct(j).Yclus) dZave = dZave + (TreeMatchStruct(j).z - TreeMatchStruct(j).Zclus) Case False Countomissions = Countomissions + 1 End Select For i = 0 To NumOfImages - 1 ' Loop images Form1.Picture1(i).DrawWidth = 1 Select Case TreeMatchStruct(j).IsMatch Case True ' Colorpix = RGB(0, 255, 41) Call r_transform_ground_to_pixel(i, TreeMatchStruct(j).Xclus, TreeMatchStruct(j).Yclus, TreeMatchStruct(j).Zclus, p_x, p_y) For l = -6 To 6 For m = -6 To 6 If Abs(m) > 4 Or Abs(l) > 4 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix End If Next m Next l Case False Call r_transform_ground_to_pixel(i, TreeMatchStruct(j).X, TreeMatchStruct(j).Y, TreeMatchStruct(j).z, p_x, p_y) For l = -1 To 1 For m = -7 To 7 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -7 To 7 For m = -1 To 1 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -7 To 7 For m = -7 To 7 If Abs(m) > 5 Or Abs(l) > 5 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix End If Next m Next l End Select Next i End If Next j dXave = dXave / CountMatches: dYave = dYave / CountMatches: dZave = dZave / CountMatches 'Close (All) 'Exit Sub Dim CountCommissions As Integer CountCommissions = 0 For j = 1 To N_cand_inside_border ' Loop thru clusters If ClusMatchStruct(j).IsInside = True Then ZmatchedmeanClus = ZmatchedmeanClus + ClusMatchStruct(j).z If ClusMatchStruct(j).IsCommission = True And ClusMatchStruct(j).IsInside = True Then CountCommissions = CountCommissions + 1 End If For i = 0 To NumOfImages - 1 ' Loop images If ClusMatchStruct(j).IsCommission = True And ClusMatchStruct(j).IsInside = True Then Colorpix = RGB(255, 255, 255) Form1.Picture1(i).DrawWidth = 1 Call r_transform_ground_to_pixel(i, ClusMatchStruct(j).X, ClusMatchStruct(j).Y, ClusMatchStruct(j).z, p_x, p_y) For l = -7 To 7 For m = -1 To 1 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l For l = -1 To 1 For m = -7 To 7 ' If Abs(m) >= 0 And Abs(l) = 0 Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 + l, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 + m), Colorpix 'End If Next m Next l Form1.Picture1(i).DrawWidth = 1 End If Next i Next j ZmatchedmeanTrees = ZmatchedmeanTrees / CDbl(N_tree_inside) ZmatchedmeanClus = ZmatchedmeanClus / CDbl(N_cand_inside) Dim Zbias As Double Zbias = ZmatchedmeanTrees - ZmatchedmeanClus Form1.Label10.Caption = "Cs: " & N_cand_inside & " Ts: " & N_tree_inside & " Mcs: " & CountMatches & " msd: " & Countomissions & " Cms: " & CountCommissions & " M-Rate: " & Format$(((N_tree_inside - CountCommissions - Countomissions) / N_tree_inside) * 100, "#.0") & "% Z-bias: " & Format$(dZave, "#.00 m") ' MsgBox (Format$(dXave, "#.00 m") & " " & Format$(dYave, "#.00 m") & " " & Format$(dZave, "#.00 m")) OV.NtreesInside = N_tree_inside_border OV.NClusInside = N_cand_inside_border OV.Nmatched = CountMatches OV.Nomission = Countomissions OV.NCommission = CountCommissions OV.MatchP = (CountMatches / N_tree_inside) * 100# OV.ZbiasMatched = dZave OV.ZbiasAll = Zbias OV.Xbiasmatched = dXave OV.Ybiasmatched = dYave Rem ****************************************************************************** Rem RESULTS FILE-PRINTING SECTION; DigitString-holds a unique 8-digit for strorage Rem Parameters are stored in global vars, or as locals of this procedure Rem Rem Rem Open in Append mode Call PrintResults Exit Sub End Sub Public Sub PrintResults() Rem Vector OV and arrays ClusMatchStruct, TreeMatchStruct are printed Rem ** Compute here the Zer = a + b * TreeHeight Dim Zer As Double, Xval As Integer, Yval As Integer Dim VolMissed As Double, VolMatch As Double Dim sx As Double, sy As Double, st2 As Double, aa As Double, bb As Double Dim siga As Double, sigb As Double, ss As Double Dim Vol As Double, XYer As Double, RMSEXY As Double, RMSEZ As Double Dim i As Integer, k As Integer Dim Ymean As Double For i = 1 To OV.NtreesInside ' Loop thru trees inside the plot area Vol = 0.011197 * ((TreeMatchStruct(i).d13 / 10) ^ 2.10253) * (0.986 ^ (TreeMatchStruct(i).d13 / 10)) * (TreeMatchStruct(i).H ^ 3.98519) * ((TreeMatchStruct(i).H - 1.3) ^ (-2.659)) Select Case TreeMatchStruct(i).Spec Case 1 Vol = 0.036089 * ((TreeMatchStruct(i).d13 / 10) ^ 2.01395) * (0.99676 ^ (TreeMatchStruct(i).d13 / 10)) * (TreeMatchStruct(i).H ^ 2.07025) * ((TreeMatchStruct(i).H - 1.3) ^ (-1.07209)) Case 2 Vol = 0.022927 * ((TreeMatchStruct(i).d13 / 10) ^ 1.91505) * (0.99146 ^ (TreeMatchStruct(i).d13 / 10)) * (TreeMatchStruct(i).H ^ 2.82541) * ((TreeMatchStruct(i).H - 1.3) ^ (-1.53547)) End Select If TreeMatchStruct(i).IsMatch = True And TreeMatchStruct(i).IsInside = True Then Zer = (TreeMatchStruct(i).z - TreeMatchStruct(i).Zclus) XYer = sqrt((TreeMatchStruct(i).Y - TreeMatchStruct(i).Yclus) ^ 2 + (TreeMatchStruct(i).X - TreeMatchStruct(i).Xclus) ^ 2) RMSEXY = RMSEXY + XYer RMSEZ = RMSEZ + (Zer ^ 2) sx = sx + TreeMatchStruct(i).H sy = sy + Zer Ymean = Ymean + Zer VolMatch = VolMatch + Vol k = k + 1 End If If TreeMatchStruct(i).IsMatch = False And TreeMatchStruct(i).IsInside = True Then VolMissed = VolMissed + Vol k = k + 1 End If Next i RMSEXY = sqrt(RMSEXY / (OV.Nmatched - 1)) 'Exit Sub RMSEZ = sqrt(RMSEZ / (OV.Nmatched - 1)) Dim sx0ss As Double, t As Double, sx2 sx0ss = sx / OV.Nmatched Ymean = Ymean / OV.Nmatched For i = 1 To OV.NtreesInside ' Loop thru trees inside the plot area If TreeMatchStruct(i).IsMatch = True And TreeMatchStruct(i).IsInside = True Then t = (TreeMatchStruct(i).H - sx0ss) st2 = st2 + t * t bb = bb + t * (TreeMatchStruct(i).z - TreeMatchStruct(i).Zclus) End If Next i bb = bb / st2 aa = (sy - sx * bb) / OV.Nmatched siga = sqrt((1# + sx * sx / (OV.Nmatched * st2)) / (OV.Nmatched)) sigb = sqrt((1 / st2) / (OV.Nmatched - 2)) Dim ssres As Double, ssreg As Double For i = 1 To OV.NtreesInside ' Loop thru trees inside the plot area If TreeMatchStruct(i).IsMatch = True And TreeMatchStruct(i).IsInside = True Then ssres = ssres + ((TreeMatchStruct(i).z - TreeMatchStruct(i).Zclus) - (aa + bb * TreeMatchStruct(i).H)) ^ 2 ssreg = ssreg + ((aa + bb * TreeMatchStruct(i).H) - Ymean) ^ 2 End If Next i Dim r2 As Double, sres As Double, seb As Double r2 = ssreg / (ssreg + ssres) sres = sqrt(ssres / (OV.Nmatched - 2)) seb = sres / sqrt(st2) Open "c:\data\ma4res.txt" For Append As 1 Dim CO As String CO = OV.PlotCode & "," CO = CO & OV.Date & "," CO = CO & OV.Time & "," CO = CO & Format$(OV.NImagesInMatch, "0") & "," CO = CO & Format$(OV.ModelTreeNum, "0000") & "," CO = CO & Format$(OV.ModelTreeX, "#.00") & "," CO = CO & Format$(OV.ModelTreeY, "#.00") & "," CO = CO & Format$(OV.ModelTreeZ, "#.00") & "," CO = CO & Format$(OV.Rlimit, "#.000") & "," CO = CO & Format$(OV.XYthin, "#.00") & "," CO = CO & Format$(OV.XYMatchDist, "#.00") & "," CO = CO & Format$(OV.ZMatchDist, "#.00") & "," CO = CO & Format$(OV.TWidth, "#.00") & "," CO = CO & Format$(OV.EllZasym, "#.00") & "," CO = CO & Format$(OV.Zdiff, "#.00") & "," CO = CO & Format$(OV.ZDepth, "#.00") & "," CO = CO & Format$(OV.Zasym, "#.00") & "," CO = CO & Format$(OV.Meshdist, "#.00") & "," CO = CO & Format$(OV.Meanheight, "#.00") & "," CO = CO & Format$(OV.Plotradius, "#.00") & "," CO = CO & Format$(OV.PlotCenterX, "#.00") & "," CO = CO & Format$(OV.PlotCenterY, "#.00") & "," CO = CO & Format$(OV.PlotCenterZ, "#.00") & "," CO = CO & Format$(OV.DigString, "00000000") & "," CO = CO & Format$(OV.NtreesInside, "000") & "," 'CO = CO & Format$(k, "000") & "," CO = CO & Format$(OV.NClusInside, "000") & "," CO = CO & Format$(OV.Nmatched, "000") & "," CO = CO & Format$(OV.Nomission, "000") & "," CO = CO & Format$(OV.NCommission, "000") & "," CO = CO & Format$(OV.MatchP, "#.00") & "," CO = CO & Format$(OV.Mrate, "#.00") & "," CO = CO & Format$(OV.ZbiasMatched, "#.00") & "," CO = CO & Format$(OV.ZbiasAll, "#.00") & "," CO = CO & Format$(OV.Xbiasmatched, "#.00") & "," CO = CO & Format$(OV.Ybiasmatched, "#.00") & "," CO = CO & Format$(RMSEXY, "#.00") & "," CO = CO & Format$(RMSEZ, "#.00") & "," CO = CO & Format$(aa, "#.0000") & "," CO = CO & Format$(bb, "#.0000") & "," CO = CO & Format$(seb, "#.0000") & "," CO = CO & Format$(r2, "#.0000") & "," CO = CO & Format$(VolMatch, "#.0000") & "," CO = CO & Format$(VolMissed, "#.0000") Print #1, CO Close (1) Rem Check If the user wants the Cluster-data and tree-data to be stored in the OV.DigString-file 'If Form1.Check2.Value = 1 Then Open "c:\data\" & OV.DigString & ".tr" For Output As 1 For i = 1 To OV.NtreesInside ' Loop thru trees inside the plot area CO = "" CO = CO & Format$(TreeMatchStruct(i).num, "0000") & "," CO = CO & Format$(TreeMatchStruct(i).Spec, "00") & "," CO = CO & Format$(TreeMatchStruct(i).Status, "00") & "," CO = CO & Format$(TreeMatchStruct(i).d13, "000") & "," CO = CO & Format$(TreeMatchStruct(i).H, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).X, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).Y, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).z, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).ZbuttDEM, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).ZButtTach, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).NclusInCylinder, "000") & "," CO = CO & Format$(TreeMatchStruct(i).IndexMatchClus, "000") & "," CO = CO & Format$(TreeMatchStruct(i).Dist3D, "#.00") & "," CO = CO & Format$(Abs(TreeMatchStruct(i).IsMatch), "0") & "," CO = CO & Format$(Abs(TreeMatchStruct(i).IsOmission), "0") & "," CO = CO & Format$(Abs(TreeMatchStruct(i).IsInside), "0") & "," CO = CO & Format$(TreeMatchStruct(i).Xclus, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).Yclus, "#.00") & "," CO = CO & Format$(TreeMatchStruct(i).Zclus, "#.00") & "," Print #1, CO Next i Close (1) Open "c:\data\" & OV.DigString & ".cl" For Output As 1 For i = 1 To mC ' Loop thru all clusters CO = "" CO = CO & Format$(ClusMatchStruct(i).Index, "000") & "," CO = CO & Format$(Abs(ClusMatchStruct(i).IsMatch), "0") & "," CO = CO & Format$(Abs(ClusMatchStruct(i).IsInside), "0") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeNum, "0000") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeSpec, "00") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeStat, "00") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreed13, "000") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeh, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).Xtree, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).YTree, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).Ztree, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeZbuttDem, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).MatchTreeZbuttTach, "#.00") & "," CO = CO & Format$(Abs(ClusMatchStruct(i).IsCommission), "0") & "," CO = CO & Format$(ClusMatchStruct(i).Dist3D, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).NTreesInCylinder, "000") & "," CO = CO & Format$(ClusMatchStruct(i).X, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).Y, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).z, "#.00") & "," CO = CO & Format$(ClusMatchStruct(i).Rvalue, "#.000") & "," CO = CO & Format$(ClusMatchStruct(i).Npoints, "000") Print #1, CO Next i Close (1) 'End If End Sub Public Sub SWAP(ByRef A As Point3d, ByRef B As Point3d, ByRef t As Point3d) t.X = A.X t.Y = A.Y t.z = A.z A.X = B.X A.Y = B.Y A.z = B.z B.X = t.X B.Y = t.Y B.z = t.z End Sub Public Function LEXGREATER(ByRef A As Point3d, ByRef B As Point3d) As Boolean test1 = 0 test2 = 0 test3 = 0 test4 = 0 If (A.Y > B.Y) Then test1 = -1 If (A.Y = B.Y) Then test2 = -1 If (A.X > B.X) Then test3 = -1 If test2 <> 0 And test3 <> 0 Then test4 = 1 If test4 = 0 And test1 = 0 Then LEXGREATER = False If test4 <> 0 Or test1 <> 0 Then LEXGREATER = True End Function Public Function Stringlength(ByRef A As String) As Integer Dim i As Integer For i = 0 To 100 If (Mid$(A, i + 1, 1)) = "" Then Stringlength = i - 1 Exit Function End If Next i End Function Public Function sqrt(ByVal Ar As Double) As Double Rem square root If Ar < 0 Then MsgBox ("Square root of negative argument!") sqrt = 0.0001 Exit Function End If sqrt = Ar ^ 0.5 End Function Public Sub vector_cross_product(X As Vector3D, Y As Vector3D, XxY As Vector3D) Rem Using the determinant, compute cross product [X x Y] for a 3D vector (only defined for such) XxY.X = X.Y * Y.z - X.z * Y.Y XxY.Y = X.z * Y.X - X.X * Y.z XxY.z = X.X * Y.Y - X.Y * Y.X End Sub Public Function vector_length(ByRef vector As Vector3D) As Double Rem calculates euclidian lenght of a 3D vector vector_length = (vector.X ^ 2 + vector.Y ^ 2 + vector.z ^ 2) ^ 0.5 End Function Public Function vector_angle(vec1 As Vector3D, vec2 As Vector3D) As Double Rem compute angle between two vectors Rem angle=acos(inner_product / length*length) vector_angle = MYFUNC_ACOS((vec1.X * vec2.X + vec1.Y * vec2.Y + vec1.z * vec2.z) / (vector_length(vec1) * vector_length(vec2))) End Function Public Function getCHMTINheight(Xm As Double, Ym As Double, ByRef i As Long) As Double Dim P As Point If TINCHMModelReady = False Then ' MsgBox ("Read the TIN model!") End If P.X = Xm P.Y = Ym Rem Check if previous Triangle is still valid If i > 0 Then apu = InsidePolygon(CHM_Tri(CHM_TRI_east_IND(i) - 1).poly(), 3, P) If apu = Inside Then getCHMTINheight = (1 - CHM_Tri(CHM_TRI_east_IND(i) - 1).A * (CHM_Tri(CHM_TRI_east_IND(i) - 1).xmin - P.X) - CHM_Tri(CHM_TRI_east_IND(i) - 1).B * (CHM_Tri(CHM_TRI_east_IND(i) - 1).Ymin - P.Y)) / CHM_Tri(CHM_TRI_east_IND(i) - 1).c GoTo CHMTIN_valmis End If End If Dim j As Long, StartInd As Long ' For j = 1 To N_CHM_tri ' If (CHM_Tri(CHM_TRI_east_IND(j) - 1).xmin - p.x) > -21 Then ' StartInd = CHM_TRI_east_IND(j) - 1 ' GoTo FindCHMTIN ' End If ' Next j FindCHMTIN: ' For i = StartInd To N_CHM_tri For i = 1 To N_CHM_tri apu = InsidePolygon(CHM_Tri(CHM_TRI_east_IND(i) - 1).poly(), 3, P) 'Exit Function If apu = Inside Then getCHMTINheight = (1 - CHM_Tri(CHM_TRI_east_IND(i) - 1).A * (CHM_Tri(CHM_TRI_east_IND(i) - 1).xmin - P.X) - CHM_Tri(CHM_TRI_east_IND(i) - 1).B * (CHM_Tri(CHM_TRI_east_IND(i) - 1).Ymin - P.Y)) / CHM_Tri(CHM_TRI_east_IND(i) - 1).c GoTo CHMTIN_valmis End If Next i CHMTIN_valmis: If getCHMTINheight = 0 Then i = -99 ' MsgBox ("zero elevation") End If End Function Public Function getTIN_Optimized(Xm As Double, Ym As Double, ByRef i As Long) As Double Dim P As Point getTIN_Optimized = 0 P.X = Xm P.Y = Ym Rem Check bounding box If P.X < MinX1 Or P.X > MaxX1 Then getTIN_Optimized = -99 End If If P.Y < MinY1 Or P.Y > MaxY1 Then getTIN_Optimized = -99 End If Rem 1-hectare Dim FN1 As String * 3, FN2 As String * 3 FN1 = Format$(Int((P.X - MinX1) / 100), "000") FN2 = Format$(Int((P.Y - MinY1) / 100), "000") Rem Check if previous Triangle is still valid Rem Recall indexing differences (1 to N_tri) and (0 to N_tri-1) Dim NHA As Long, j As Long If i > 0 And i < N_tri Then apu = InsidePolygon(Tri(i).poly(), 3, P) If apu = Inside Then getTIN_Optimized = (1 - Tri(i).A * (Tri(i).xmin - P.X) - Tri(i).B * (Tri(i).Ymin - P.Y)) / Tri(i).c Close (11) Exit Function End If End If capu = Dir("c:\data\Tris\" & FN1 & FN2 & ".bin") If capu <> "" Then Open "c:\data\Tris\" & FN1 & FN2 & ".bin" For Binary As 11 Get #11, 1, NHA For k = 1 To NHA 'Exit Function Get #11, 1 + k * 4, j apu = InsidePolygon(Tri(j).poly(), 3, P) If apu = Inside Then getTIN_Optimized = (1 - Tri(j).A * (Tri(j).xmin - P.X) - Tri(j).B * (Tri(j).Ymin - P.Y)) / Tri(j).c Close (11) Exit Function End If Next k Close (11) Rem We did not get elevation, check all For j = 1 To N_tri apu = InsidePolygon(Tri(j).poly(), 3, P) If apu = Inside Then getTIN_Optimized = (1 - Tri(j).A * (Tri(j).xmin - P.X) - Tri(j).B * (Tri(j).Ymin - P.Y)) / Tri(j).c Close (11) Exit Function End If Next j End If getTIN_Optimized = -99 End Function Public Function getTINheight(Xm As Double, Ym As Double, ByRef i As Long) As Double Dim P As Point getTINheight = 0 If TINModelReady = False Then ' MsgBox ("Read the TIN model!") End If P.X = Xm P.Y = Ym Rem Check if previous Triangle is still valid Rem Recall indexing differences (1 to N_tri) and (0 to N_tri-1) If i > 0 And i < N_tri Then apu = InsidePolygon(Tri(East_IND(i) - 1).poly(), 3, P) 'Exit Function If apu = Inside Then getTINheight = (1 - Tri(East_IND(i) - 1).A * (Tri(East_IND(i) - 1).xmin - P.X) - Tri(East_IND(i) - 1).B * (Tri(East_IND(i) - 1).Ymin - P.Y)) / Tri(East_IND(i) - 1).c GoTo TIN_valmis End If End If StartInd = 1 GoTo FindTIN Dim j As Long For j = 1 To N_tri Step 10 If (Tri(East_IND(j) - 1).xmin - P.X) > -120 Then ' Exit Function StartInd = j GoTo FindTIN End If Next j Rem if we don't find it, start from 1 FindTIN: For i = StartInd To N_tri ' For i = 1 To N_tri apu = InsidePolygon(Tri(East_IND(i) - 1).poly(), 3, P) ' Exit Function If apu = Inside Then getTINheight = (1 - Tri(East_IND(i) - 1).A * (Tri(East_IND(i) - 1).xmin - P.X) - Tri(East_IND(i) - 1).B * (Tri(East_IND(i) - 1).Ymin - P.Y)) / Tri(East_IND(i) - 1).c GoTo TIN_valmis End If Next i TIN_valmis: If getTINheight = 0 Then getTINheight = -99 i = 0 ' MsgBox ("Zground -99 m") End If End Function Public Sub MAKE3DPOINTSET(origoX As Double, origoY As Double, origoZ As Double, gridXextent As Double, gridYextent As Double, gridZextent As Double, gridXtess As Double, gridYtess As Double, gridZtess As Double, XYrotangle As Double, Zasymmetry As Double, Meanheight As Double) Rem This is an alternative routine for creating the 3-D search space Rem DATA is stored in an array (instead of writing it sequentally on disk file for subsequent read) Rem Compute storage need, (Xextent/Xtess+1)*(Yextent/Ytess+1)*(Zextent/Ztess+1) 'On Error GoTo Error_In_MAKE3DPOINTSET Dim Upperlimit As Long Dim l As Long Dim X As Double, Y As Double, z As Double Dim XCELLS As Long, YCELLS As Long, ZCELLS As Long XCELLS = CInt((gridXextent / gridXtess)) + 1 YCELLS = CInt((gridYextent / gridYtess)) + 1 ZCELLS = CInt((gridZextent / gridZtess)) + 1 Dim i As Long, j As Long Rem This is the maximum storage Upperlimit = XCELLS * YCELLS * ZCELLS ' CLng((CLng(gridXextent / gridXtess) + 1) * (CLng(gridYextent / gridYtess) + 1) * (CLng(gridZextent / gridZtess) + 1)) ' If RasterModelReady = False Then ' MsgBox ("Read height model first!") ' Exit Sub ' End If 'Form1.Picture1(1).CurrentX = 5 'Form1.Picture1(1).CurrentY = 5 'Form1.Picture1(1).Print "GND + canopy points" ReDim SearchSpaceData(0 To Upperlimit - 1) As Point3d Dim XYrotangle_cos As Double, XYrotangle_sin As Double Dim fHDOM As Double Dim HDepth As Double fHDOM = CDbl(Form1.Text8.Text) HDepth = CDbl(Form1.Text9.Text) XYrotangle_cos = Cos(XYrotangle) XYrotangle_sin = Sin(XYrotangle) l = 0 m = 0 Dim piste As Point Dim Xm As Double, Ym As Double, Hmean As Double Dim lask As Long, Nlask As Long Dim p_x As Double, p_y As Double 'Open "c:\depth.txt" For Append As 10 For X = -gridXextent / 2# To (gridXextent / 2# + 0.001) Step gridXtess ' lask = lask + 1 For Y = -gridYextent / 2# To (gridYextent / 2# + 0.001) Step gridYtess Rem Take the MAX of CHM and the DTM, loop Xm = XYrotangle_cos * X - XYrotangle_sin * Y + origoX Ym = XYrotangle_sin * X + XYrotangle_cos * Y + origoY 'Minz = getTINheight(Xm, Ym, i) 'Maxz = getCHMTINheight(Xm, Ym, j) 'Exit Sub Minz = getheight(Xm, Ym) maxZ = getCHMheight(Xm, Ym) maxZ = Minz + 28 maxZ = Minz + fHDOM * (maxZ - Minz) ' ' If lask Mod 10 = 0 Then ' For i = 0 To NumOfImages - 1 ' Call r_transform_ground_to_pixel(i, Xm, Ym, MinZ, p_x, p_y) ' Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 255) ' DoEvents ' Next i ' End If ' Hmean = 24 ' MaxZ = Minz + fHDOM * Hmean ' If MaxZ - Minz < 13 Then ' MaxZ = Minz + 10 ' End If 'Exit Sub 'Print #10, Format$(Xm, "#.00") & "," & Format$(Ym, "#.00") & "," & Format$(Maxz, "#.00") & "," & Format$(Minz, "#.00") For z = Minz + (maxZ - Minz) * HDepth To maxZ Step gridZtess ' Nlask = Nlask + 1 'SearchSpaceData(l).z = getheight(SearchSpaceData(l).x, SearchSpaceData(l).y) + Meanheight + Zasymmetry + z Rem SearchSpaceData(l).X = Xm SearchSpaceData(l).Y = Ym SearchSpaceData(l).z = z ' If lask Mod 10 = 0 Then ' For i = 0 To NumOfImages - 1 ' Call r_transform_ground_to_pixel(i, Xm, Ym, z, p_x, p_y) ' Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 0) ' If Nlask Mod 100 = 0 Then 'SavePicture Form1.Picture1(1).Image, "c:\temp\AVI\" & Format$(lask, "000000") & ".bmp" ' End If ' Next i ' DoEvents ' End If ' If lask Mod 10 = 0 And Nlask Mod 100 = 0 Then ' SavePicture Form1.Picture1(1).Image, "c:\temp\AVI\" & Format$(Nlask, "000000") & ".bmp" ' End If If l = UBound(SearchSpaceData) - 1 Then ReDim Preserve SearchSpaceData(0 To UBound(SearchSpaceData) + 10000) As Point3d End If l = l + 1 Next z Next Y Next X Close (10) ReDim Preserve SearchSpaceData(0 To l - 1) As Point3d 'If l <> Upperlimit Then MsgBox (l & " ? = ? " & Upperlimit) Form1.Label10.Caption = "3D-Point mesh creation succesfully done" 'MsgBox (SearchSpaceData(66372).y) Exit Sub Error_In_MAKE3DPOINTSET: MsgBox ("An error occurred in trying to create 3D search space point mesh!") Form1.Label10.Caption = "3D-Point mesh creation failed" End Sub Public Sub Draw_Epipolar_line() Dim Xvll As Double, Yvll As Double, Zvll As Double, Zv As Double Dim p_x As Double, p_y As Double Dim i As Long, j As Long, m As Long, l As Long Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double, Xr As Double, Yr As Double, Zr As Double Dim r11 As Double, r12 As Double, r13 As Double, r21 As Double, r22 As Double, r23 As Double, r31 As Double, r32 As Double, r33 As Double Dim lp As ads40_image_point_struct Dim f As ads40_image_point_struct If LastImageClicked = -1 Or SolutionExists = False Then Form1.Label10.Caption = "Cannot draw epipolar line, either solution is lacking or LastImageClicked = -1" Exit Sub End If j = LastImageClicked Rem the case for a pinhole camera r11 = A(1, 1, j): r12 = A(1, 2, j): r13 = A(1, 3, j) r21 = A(2, 1, j): r22 = A(2, 2, j): r23 = A(2, 3, j) r31 = A(3, 1, j): r32 = A(3, 2, j): r33 = A(3, 3, j) x1 = CDbl(Form1.Text1(j * 2).Text) y1 = CDbl(Form1.Text1(j * 2 + 1).Text) Xvll = X_sol Yvll = Y_sol Zvll = Z_sol Rem this is the direction of a ray cast from point p_x, p_y in the film plane Dim gp As Point3d Call KKJ_to_LSR(j, Xvll, Yvll, Zvll, gp.X, gp.Y, gp.z) Dim kkj_x As Double, kkj_y As Double, kkj_z As Double DrawCylinder = False ' For Zv = Zvll - Epi_Depth To Zvll + Epi_Depth Step Epi_Depth / 100 If image_info(j).Imagetype = "FRAME" Then Xr = image_info(j).Xo + (Zv - image_info(j).Zo) * ((x1 * r11 + y1 * r12 - r13 * image_info(j).c) / (x1 * r31 + y1 * r32 - r33 * image_info(j).c)) Yr = image_info(j).Yo + (Zv - image_info(j).Zo) * ((x1 * r21 + y1 * r22 - r23 * image_info(j).c) / (x1 * r31 + y1 * r32 - r33 * image_info(j).c)) Zr = Zv End If If image_info(j).Imagetype = "ADS L0" Or image_info(j).Imagetype = "ADS L1" Then Rem We have clicked an L0 image, in (lp.line, lp.sample) Rem Here is the solution - height gp.z Call KKJ_to_LSR(j, X_sol, Y_sol, Zv, gp.X, gp.Y, gp.z) Call ADS_SOLVE_XYZ_from_Z_x_y(j, ADSOBS(j).lp.Line, gp.z, Xr, Yr, ADSOBS(j).xy.X, ADSOBS(j).xy.Y) Call LSR_TO_KKJ(j, Xr, Yr, gp.z, kkj_x, kkj_y, kkj_z) Xr = kkj_x Yr = kkj_y Zr = kkj_z End If Dim p_x1 As Double, p_y1 As Double Dim cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D, ray As Vector3D, Pc As Vector3D For i = 0 To NumOfImages - 1 If image_info(i).Imagetype = "FRAME" Then p_x = x1: p_y = y1 Call DefineCameraVector(j, cam_vec_x, cam_vec_y, cam_vec_z) ' Direction components ray.X = p_x * cam_vec_x.X + p_y * cam_vec_y.X + z * cam_vec_z.X ray.Y = p_x * cam_vec_x.Y + p_y * cam_vec_y.Y + z * cam_vec_z.Y ray.z = p_x * cam_vec_x.z + p_y * cam_vec_y.z + z * cam_vec_z.z Call normalize(ray) ' Camera Pc.X = image_info(j).Xo: Pc.Y = image_info(j).Yo: Pc.z = image_info(j).Zo RayLen = Sqr((Pc.X - Xr) ^ 2 + (Pc.Y - Yr) ^ 2 + (Pc.z - Zr) ^ 2) Form1.Picture1(i).DrawWidth = 2 Call r_transform_ground_to_pixel(i, Xr, Yr, Zr, p_x, p_y) If Imagesdisplayed(i) = AER_IMA Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 255) alku_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x alku_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y loppu_x = (p_x1 - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x loppu_y = ((image_info(i).Height - 1) - p_y1 - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y 'Form1.Picture1(i).Line (alku_x, alku_y)-(loppu_x, loppu_y) End If End If 'Rotate If DrawCylender = True Then For Theta = -pi To pi + 0.1 Step pi / 36 ' For Theta = 0 To 0 + 0.1 Step pi / 36 rad = 1 Xri = Xr + rad * Cos(Theta) Yri = Yr + rad * Sin(Theta) Xri1 = Xri Yri1 = Yri 'For Theta = -pi To pi Step pi / 36 ' We are at elevation Zv and can compute X,Y for that. Now, make a circle that rotates around the ray. ' Sqr(dx^2+dy^2+dz^2) = radius, dz on pieni 'Xr = image_info(j).Xo + (Zv - image_info(j).Zo) * ((x1 * r11 + y1 * r12 - r13 * image_info(j).c) / (x1 * r31 + y1 * r32 - r33 * image_info(j).c)) 'Yr = image_info(j).Yo + (Zv - image_info(j).Zo) * ((x1 * r21 + y1 * r22 - r23 * image_info(j).c) / (x1 * r31 + y1 * r32 - r33 * image_info(j).c)) Zri = Zr Zri1 = Zr + Epi_Depth / 30 Call r_transform_ground_to_pixel(i, Xri, Yri, Zri, p_x, p_y) ' Call r_transform_ground_to_pixel(i, Xri1, Yri1, Zri1, p_x1, p_y1) Form1.Picture1(i).DrawWidth = 1 If Imagesdisplayed(i) = AER_IMA Then Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 0) alku_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x alku_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y ' If Abs(Theta Mod 2) < 0.01 Then ' loppu_x = (p_x1 - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x ' loppu_y = ((image_info(i).Height - 1) - p_y1 - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y ' Form1.Picture1(i).Line (alku_x, alku_y)-(loppu_x, loppu_y) ' End If End If If Imagesdisplayed(i) = CORR_IMA Then Form1.Picture1(i).PSet ((p_x - (cor_ima_info(i).o_col + cor_win_info(i).win_o_col)) * cor_win_info(i).pan_x, ((cor_ima_info(i).Height - 1) - p_y - (cor_ima_info(i).o_row + cor_win_info(i).win_o_row)) * cor_win_info(i).pan_y - l), RGB(0, 255, 0) End If Next Theta End If If image_info(i).Imagetype = "ADS L0" Then Call KKJ_to_LSR(CLng(i), Xr, Yr, Zr, gp.X, gp.Y, gp.z) apu = grnd2lp(CLng(i), gp, lp) c_col = lp.Sample c_row = lp.Line Form1.Picture1(i).DrawWidth = 2 Colorpix = RGB(255, 0, 0) If apu = 0 Then Colorpix = RGB(255, 255, 255) Form1.Picture1(i).PSet ((c_col - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - m, (c_row - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), Colorpix End If If image_info(i).Imagetype = "ADS L1" Then Call KKJ_to_LSR(CLng(i), Xr, Yr, Zr, gp.X, gp.Y, gp.z) apu = grnd2lp(CLng(i), gp, lp) apu = lp2f(CLng(i), lp, f) Call ADS_SOLVE_XYZ_from_Z_x_y(CLng(i), lp.Line, ADSSUP(i).RECT_HEIGHT, gp.X, gp.Y, f.Sample, f.Line) c_col = ADSSUP(i).RECT_SCALE * (gp.X * Cos(ADSSUP(i).RECT_ROTATION) - gp.Y * Sin(ADSSUP(i).RECT_ROTATION)) - ADSSUP(i).RECT_XOFFSET c_row = ADSSUP(i).LINES - (ADSSUP(i).RECT_SCALE * (gp.X * Sin(ADSSUP(i).RECT_ROTATION) + gp.Y * Cos(ADSSUP(i).RECT_ROTATION)) - ADSSUP(i).RECT_YOFFSET) Form1.Picture1(i).PSet ((c_col - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - m, (c_row - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 0, 0) End If If Imagesdisplayed(i) = AER_IMA Then ' Form1.Picture1(i).PSet ((p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x, ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y), RGB(255, 255, 255) End If Next i Next Zv Rem 1.6. koe ' NCounter = NCounter + 1 ' SavePicture Form1.Picture1(3).Image, "c:\temp\AVI\" & Format$(NCounter, "0000") & ".bmp"p End Sub Public Sub aZoom(ByVal i As Integer, ByVal pan_x As Double, ByVal pan_y As Double) Dim startcol As Long Dim startrow As Long Dim endcol As Long Dim endrow As Long Dim length As Long, j As Long Dim X As Double, Y As Double, x_apu As Double, y_apu As Double Dim p_x As Double, p_y As Double 'On Error GoTo ErrorInaZoom If Imagesdisplayed(i) = CORR_IMA Then MsgBox ("Zoom not alowed for correlation images!") Exit Sub End If Rem For ADS-images we need a different approach!! X = CDbl(Form1.Text1(i * 2).Text): Y = CDbl(Form1.Text1(i * 2 + 1).Text) 'Exit Sub Call a_transform_affine(i, 0, X, Y, p_x, p_y) x_apu = p_x - image_info(i).o_col y_apu = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) win_info(i).pan_x = pan_x win_info(i).pan_y = pan_y win_info(i).win_width = Win_w win_info(i).win_height = win_h ' Call create_bmp(i, image_info(i).sub_width, image_info(i).sub_height, kuva(), "c:\temp\pic" & CStr(i) & ".bmp") ' calculate window area, define start_col, start_row, end_col, end_row Call calculate_region(i, CLng(x_apu), CLng(y_apu), CLng((1 / win_info(i).pan_x) * Win_w), CLng((1 / win_info(i).pan_y) * win_h), startcol, startrow, endcol, endrow, win_info(i).pan_x, win_info(i).pan_y) If image_info(i).Color = 1 Then Rem Wrapper for filenames length = Stringlength(image_info(i).FileName) ReDim filename_in(0 To length) As Byte For j = 0 To length - 1 filename_in(j) = CByte(Asc(Mid$(image_info(i).FileName, j + 1, 1))) Next j filename_in(length) = 0 FileOut = "c:\data\pic" & CStr(i) & ".bmp" length = Len(FileOut) ReDim filename_out(0 To length) As Byte For j = 0 To length - 1 filename_out(j) = CByte(Asc(Mid$(FileOut, j + 1, 1))) Next j filename_out(length) = 0 Call create_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ' Call create__Vexcel_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ' Call create_bmp_header(FileOut, CLng(Win_w), CLng(win_h)) ' apu = MYFUNC_CREATEBMP(CLng(i), CLng(startcol), CLng(startrow), CLng(endcol), CLng(endrow), filename_in(0), filename_out(0), CDbl(win_info(i).pan_x), CDbl(win_info(i).pan_y), CLng(win_h), CLng(Win_w), CLng(image_info(i).sub_width)) ElseIf image_info(i).Color = 0 Then Call create_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 4 Then Call create_DMC_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 2 Then Call create_ADS40_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) ElseIf image_info(i).Color = 3 Then ' 16 bit RGBN image Call create_DMC16_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If ' Call Create_Bitmap(i, StartCol, StartRow, EndCol, EndRow, kuva(), "c:\temp\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) Form1.Picture1(i).Picture = LoadPicture("c:\data\pic" & CStr(i) & ".bmp") Form1.Label1(i).Caption = Form1.Label1(i).Caption & Format$(win_info(i).pan_x, "#.00") & " " & Format$(win_info(i).win_o_col, "#") & " " & Format$(win_info(i).win_o_row, "#") DoEvents 'Call Plot_Tie_Points Exit Sub ErrorInaZoom: MsgBox ("Error in aZoom-function. Image observation missing? (xy-coords. Click a ref. point first)") Exit Sub End Sub Public Sub c_corA(ima1() As Byte, ima2() As Byte, r As Double) Dim os As Double, nim1 As Double, nim2 As Double, meanA As Double, meanB As Double os = 0# nim1 = 0# nim2 = 0# meanA = 0# meanB = 0# Dim i As Long, j As Long, N As Long N = 0 For i = 0 To UBound(ima1, 1) For j = 0 To UBound(ima1, 2) If ima1(i, j) <> 0 Then meanA = meanA + ima1(i, j) meanB = meanB + ima2(i, j) N = N + 1 End If Next j Next i meanA = meanA / (N) meanB = meanB / (N) For i = 0 To UBound(ima1, 1) For j = 0 To UBound(ima1, 2) If ima1(i, j) <> 0 Then os = os + (CDbl(ima1(i, j)) - meanA) * (CDbl(ima2(i, j)) - meanB) nim1 = nim1 + (CDbl(ima1(i, j)) - meanA) * (CDbl(ima1(i, j)) - meanA) nim2 = nim2 + (CDbl(ima2(i, j)) - meanB) * (CDbl(ima2(i, j)) - meanB) End If Next j Next i If ((nim1 * nim2) < 0.002) Then r = -2# Exit Sub End If r = 1 * os / Sqr(nim1 * nim2) End Sub Public Sub c_cor(ima1() As RGBtriplet, ima2() As RGBtriplet, r As Double) Dim os As Double, nim1 As Double, nim2 As Double, meanA As Double, meanB As Double os = 0# nim1 = 0# nim2 = 0# meanA = 0# meanB = 0# Dim i As Long, j As Long If UBound(ima1, 1) <> UBound(ima2, 1) Then MsgBox ("Templates are of unequal size!") End If For i = 0 To UBound(ima1, 1) For j = 0 To UBound(ima1, 2) meanA = meanA + ima1(i, j).G meanB = meanB + ima2(i, j).G Next j Next i meanA = meanA / (UBound(ima1, 1) * UBound(ima1, 2)) meanB = meanB / (UBound(ima2, 1) * UBound(ima2, 2)) For i = 0 To UBound(ima1, 1) For j = 0 To UBound(ima1, 2) os = os + (CDbl(ima1(i, j).G) - meanA) * (CDbl(ima2(i, j).G) - meanB) nim1 = nim1 + (CDbl(ima1(i, j).G) - meanA) * (CDbl(ima1(i, j).G) - meanA) nim2 = nim2 + (CDbl(ima2(i, j).G) - meanB) * (CDbl(ima2(i, j).G) - meanB) Next j Next i If ((nim1 * nim2) < 0.002) Then r = -2# Exit Sub End If r = 1 * os / Sqr(nim1 * nim2) End Sub Public Sub create_DMC_bmp(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer, padding As Integer, lx As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long H_byte_array = win_h W_byte_array = Win_w Dim IsCIR As Boolean IsCIR = True On Error GoTo error_in_creating_bmp_file Close (1) Open FileName For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim b_array(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBN ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-100 To (W_byte_array - 1) + 100 + (padding), -100 To H_byte_array - 1 + 100) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi Dim LOWL As Integer, HIGHL As Integer LOWL = 12 HIGHL = 21 Put #1, , filehederi Put #1, , hederi ' 40 Bytes Rem For applying contrast enhancement by means of GAmma Correction Dim gamma As Double Dim Gcorr As Double Dim ApplyConstrastEnhancement As Boolean ApplyConstrastEnhancement = False If Form1.Gamma_1.Checked = True Then gamma = 0.4 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_2.Checked = True Then gamma = 0.5 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_3.Checked = True Then gamma = 0.6 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_4.Checked = True Then gamma = 1.4 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_5.Checked = True Then gamma = 2 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_6.Checked = True Then gamma = 3 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As RGBN Rem Testing contrast enhancement Close (2) Open image_info(Index).FileName For Binary As 2 k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(4) + CLng(startcol) * 4 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then ' MsgBox ("In create BMP: exceeding allowed indeces") bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If If ApplyConstrastEnhancement = False Then Select Case IsCIR Case False bkuva(j, i).r = RROW(l).r bkuva(j, i).G = RROW(l).G bkuva(j, i).B = RROW(l).B Case True bkuva(j, i).r = RROW(l).N bkuva(j, i).G = RROW(l).r bkuva(j, i).B = RROW(l).G End Select End If If ApplyConstrastEnhancement = True Then Select Case IsCIR Case False bkuva(j, i).r = CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr) bkuva(j, i).G = CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr) bkuva(j, i).B = CByte(CDbl(RROW(l).B) ^ (gamma) * Gcorr) Case True bkuva(j, i).r = CByte(CDbl(RROW(l).N) ^ (gamma) * Gcorr) bkuva(j, i).G = CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr) bkuva(j, i).B = CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr) End Select End If Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As RGBN Close (2) Open image_info(Index).FileName For Binary As 2 i_step = -1 For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 4 + CLng(startcol) * 4 Get #2, paikka + 1, RROW() Rem Parse it Select Case IsCIR Case False For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).r ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).G ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).B Next l Next k Next j Case True For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).N ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).r ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).G Next l Next k Next j End Select Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 If ApplyConstrastEnhancement = False Then bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B End If If ApplyConstrastEnhancement = True Then bkuva(i, j).r = CByte(CDbl(ckuva(i, j).r) ^ (gamma) * Gcorr) bkuva(i, j).G = CByte(CDbl(ckuva(i, j).G) ^ (gamma) * Gcorr) bkuva(i, j).B = CByte(CDbl(ckuva(i, j).B) ^ (gamma) * Gcorr) End If Next j Next i Close (2) GoTo loppu pan_x_1: ReDim RROW(0 To (endcol - startcol)) As RGBN Close (2) Open image_info(Index).FileName For Binary As 2 k = -1 For i = startrow To endrow k = k + 1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 4 + CLng(startcol) * 4 Rem Read a row Get #2, paikka + 1, RROW() Select Case IsCIR Case False For m = 0 To (endcol - startcol) If ApplyConstrastEnhancement = False Then bkuva(m, k).r = RROW(m).r bkuva(m, k).G = RROW(m).G bkuva(m, k).B = RROW(m).B End If If ApplyConstrastEnhancement = True Then bkuva(m, k).r = CByte(CDbl(RROW(m).r) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m).G) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m).B) ^ (gamma) * Gcorr) End If Next m Case True For m = 0 To (endcol - startcol) If ApplyConstrastEnhancement = False Then bkuva(m, k).r = RROW(m).N bkuva(m, k).G = RROW(m).r bkuva(m, k).B = RROW(m).G End If If ApplyConstrastEnhancement = True Then bkuva(m, k).r = CByte(CDbl(RROW(m).N) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m).r) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m).G) ^ (gamma) * Gcorr) End If Next m End Select Rem Code above for measurement of fiducial marks with high contrast enhancement! Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_DMC16_bmp(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem For Screen I/O of 4 x 2 byte RGBN images Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer, padding As Integer, lx As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long H_byte_array = win_h W_byte_array = Win_w Dim IsCIR As Boolean ' what 3 channels do we want to dispaly IsCIR = True DivN = 20: DivR = 12: DivG = 12: DivB = 12 'On Error GoTo error_in_creating_bmp_file Close (1) Open FileName For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim b_array(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBN ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-100 To (W_byte_array - 1) + 100 + (padding), -100 To H_byte_array - 1 + 100) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi Dim LOWL As Integer, HIGHL As Integer LOWL = 12 HIGHL = 21 Put #1, , filehederi Put #1, , hederi ' 40 Bytes Rem For applying contrast enhancement by means of GAmma Correction Dim gamma As Double Dim Gcorr As Double Dim ApplyConstrastEnhancement As Boolean ApplyConstrastEnhancement = False If Form1.Gamma_1.Checked = True Then gamma = 0.4 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_2.Checked = True Then gamma = 0.5 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_3.Checked = True Then gamma = 0.6 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_4.Checked = True Then gamma = 1.4 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_5.Checked = True Then gamma = 2 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_6.Checked = True Then gamma = 3 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As RGBNIR ' 4 x integer Rem Testing contrast enhancement Close (2) Open image_info(Index).FileName For Binary As 2 k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(8) + CLng(startcol) * 8 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then ' MsgBox ("In create BMP: exceeding allowed indeces") bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If If ApplyConstrastEnhancement = False Then Select Case IsCIR Case False bkuva(j, i).r = RROW(l).r / DivR bkuva(j, i).G = RROW(l).G / DivG bkuva(j, i).B = RROW(l).B / DivB Case True On Error Resume Next bkuva(j, i).r = RROW(l).NIR / DivN bkuva(j, i).G = RROW(l).r / DivR bkuva(j, i).B = RROW(l).G / DivG End Select End If If ApplyConstrastEnhancement = True Then Select Case IsCIR Case False bkuva(j, i).r = (CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr)) / DivR bkuva(j, i).G = (CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr)) / DivG bkuva(j, i).B = (CByte(CDbl(RROW(l).B) ^ (gamma) * Gcorr)) / DivB Case True On Error Resume Next bkuva(j, i).r = (CByte(CDbl(RROW(l).NIR) ^ (gamma) * Gcorr)) / DivN bkuva(j, i).G = (CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr)) / DivR bkuva(j, i).B = (CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr)) / DivG End Select End If Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As RGBNIR Close (2) Open image_info(Index).FileName For Binary As 2 i_step = -1 On Error Resume Next For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 8 + CLng(startcol) * 8 Get #2, paikka + 1, RROW() Rem Parse it Select Case IsCIR Case False For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).r / DivR ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).G / DivG ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).B / DivB Next l Next k Next j Case True For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 On Error Resume Next ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).NIR / DivN ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).r / DivR ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).G / DivG Next l Next k Next j End Select Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 If ApplyConstrastEnhancement = False Then bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B End If If ApplyConstrastEnhancement = True Then bkuva(i, j).r = CByte(CDbl(ckuva(i, j).r) ^ (gamma) * Gcorr) bkuva(i, j).G = CByte(CDbl(ckuva(i, j).G) ^ (gamma) * Gcorr) bkuva(i, j).B = CByte(CDbl(ckuva(i, j).B) ^ (gamma) * Gcorr) End If Next j Next i Close (2) GoTo loppu pan_x_1: ReDim RROW(0 To (endcol - startcol)) As RGBNIR Close (2) Open image_info(Index).FileName For Binary As 2 'Exit Sub k = -1 For i = startrow To endrow k = k + 1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 8 + CLng(startcol) * 8 Rem Read a row Get #2, paikka + 1, RROW() Select Case IsCIR Case False For m = 0 To (endcol - startcol) If ApplyConstrastEnhancement = False Then bkuva(m, k).r = RROW(m).r / DivR bkuva(m, k).G = RROW(m).G / DivG bkuva(m, k).B = RROW(m).B / DivB End If If ApplyConstrastEnhancement = True Then bkuva(m, k).r = CByte(CDbl(RROW(m).r) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m).G) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m).B) ^ (gamma) * Gcorr) End If Next m Case True For m = 0 To (endcol - startcol) If ApplyConstrastEnhancement = False Then On Error Resume Next bkuva(m, k).r = RROW(m).NIR / DivN bkuva(m, k).G = RROW(m).r / DivR bkuva(m, k).B = RROW(m).G / DivG End If If ApplyConstrastEnhancement = True Then On Error Resume Next bkuva(m, k).r = CByte(CDbl(RROW(m).NIR) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m).r) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m).G) ^ (gamma) * Gcorr) End If Next m End Select Rem Code above for measurement of fiducial marks with high contrast enhancement! Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_ADS40_BW_bmp(ByVal Index As Long, ByVal startcol As Long, ByVal startrow As Long, ByVal endcol As Long, ByVal endrow As Long, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem Ths routine will read a 16-bit greyscale image & make it into a 24-color greyscale BMP-image for display Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Long, j As Long, k As Long, l As Long, m As Long, N As Long, lisa As Long Dim W_byte_array As Long, H_byte_array As Long Dim i_step As Long Dim j_step As Long Dim isum As Long, apusum As Long, maxh As Long Dim paikka As Long Rem 16-8 division Dim divisor As Long If Left(ADSCam(Index).SensorLine, 3) = "NIR" Then divisor = 50 Else divisor = 25 End If Dim gamma As Double Dim Gcorr As Double Dim ApplyConstrastEnhancement As Boolean ApplyConstrastEnhancement = False If Form1.Gamma_1.Checked = True Then gamma = 0.4 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_2.Checked = True Then gamma = 0.5 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_3.Checked = True Then gamma = 0.6 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_4.Checked = True Then gamma = 1.4 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_5.Checked = True Then gamma = 2 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_6.Checked = True Then gamma = 3 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If H_byte_array = win_h W_byte_array = Win_w Close (1) Open FileName For Binary As 1 Dim padding As Integer lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-30 To (W_byte_array - 1) + 30 + (padding), -30 To H_byte_array - 1 + 30) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi Put #1, , filehederi Put #1, , hederi ' 40 Bytes Rem Skip the Color Table! ' Flip Image upside-down for proper BMP-syntax ' MsgBox ("b_array has a value: " & CStr(b_array(233, 4))) ' Resize image assuming pan_x = pan_y image N*N ' Flip upside down at the same time If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As Integer Open image_info(Index).FileName For Binary As 2 Dim lx As Long k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(2) + startcol * 2 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If bkuva(j, i).r = 255 bkuva(j, i).G = 255 bkuva(j, i).B = 255 If RROW(l) / divisor < -1 Then bkuva(j, i).G = 0 bkuva(j, i).B = 0 End If If RROW(l) / divisor <= 255 And RROW(l) / divisor > -1 Then If ApplyConstrastEnhancement = False Then bkuva(j, i).r = RROW(l) / divisor bkuva(j, i).G = RROW(l) / divisor bkuva(j, i).B = RROW(l) / divisor Else bkuva(j, i).r = CByte(CDbl(RROW(l) / divisor) ^ (gamma) * Gcorr) bkuva(j, i).G = CByte(CDbl(RROW(l) / divisor) ^ (gamma) * Gcorr) bkuva(j, i).B = CByte(CDbl(RROW(l) / divisor) ^ (gamma) * Gcorr) End If End If Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As Integer Open image_info(Index).FileName For Binary As 2 i_step = -1 For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * (image_info(Index).sub_width) * CLng(2) + startcol * 2 Get #2, paikka + 1, RROW() Rem Parse the read row For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = 255 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = 255 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = 255 If RROW(j_step) / divisor <= 255 And RROW(j_step) / divisor > -1 Then If ApplyConstrastEnhancement = False Then ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step) / divisor ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step) / divisor ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step) / divisor Else ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = CByte(CDbl(RROW(j_step) / divisor) ^ (gamma) * Gcorr) ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = CByte(CDbl(RROW(j_step) / divisor) ^ (gamma) * Gcorr) ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = CByte(CDbl(RROW(j_step) / divisor) ^ (gamma) * Gcorr) End If End If Next l Next k Next j Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B Next j Next i Close (2) GoTo loppu pan_x_1: ReDim RROW(0 To (endcol - startcol)) As Integer Open image_info(Index).FileName For Binary As 2 k = -1 For i = startrow To endrow k = k + 1 paikka = CLng(i) * (image_info(Index).sub_width) * 2 + startcol * 2 Rem Read a row Get #2, paikka + 1, RROW() For m = 0 To (endcol - startcol) bkuva(m, k).r = 255 bkuva(m, k).G = 255 bkuva(m, k).B = 255 If RROW(m) / divisor <= 255 And RROW(m) / divisor > -1 Then If ApplyConstrastEnhancement = True Then bkuva(m, k).r = CByte(CDbl(RROW(m) / divisor) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m) / divisor) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m) / divisor) ^ (gamma) * Gcorr) Else bkuva(m, k).r = RROW(m) / divisor bkuva(m, k).G = RROW(m) / divisor bkuva(m, k).B = RROW(m) / divisor End If End If Next m Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Close (2) Exit Sub error_in_creating_bmp_file: Close (1) Close (2) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_BW_bmp(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem Tihs routine will read a greyscale image & make it into a 24-color greyscale BMP-image for display Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long H_byte_array = win_h W_byte_array = Win_w 'On Error GoTo error_in_creating_bmp_file Close (1) Open FileName For Binary As 1 'Exit Sub ' Debugging parameter-values received ' MsgBox ("W_byte_array: " & CStr(W_byte_array)) ' MsgBox ("H_byte_array: " & CStr(H_byte_array)) ' MsgBox ("Filename: " & CStr(filename)) Dim padding As Integer lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-30 To (W_byte_array - 1) + 30 + (padding), -30 To H_byte_array - 1 + 30) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 ' filehederi.bfOffBits = &H43A ' (if a color table) 43A=1082 ' Offset from the BitMapFileheader to the Bitmap Bits filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi ' isohederi.bmiColors = bmicolor ' MsgBox (Seek(1)) ' 14 Bytes Put #1, , filehederi ' MsgBox (Seek(1)) Put #1, , hederi ' 40 Bytes ' Put #1, , isohederi ' 40 Bytes + size of rgbquad 4 ' MsgBox (Seek(1)) ' 1078 (1078+4)= 1082! = H43A ' Put #1, , varitaulu Rem Skip the Color Table! ' Flip Image upside-down for proper BMP-syntax ' MsgBox ("b_array has a value: " & CStr(b_array(233, 4))) ' Resize image assuming pan_x = pan_y image N*N ' Flip upside down at the same time If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As Byte Open image_info(Index).FileName For Binary As 2 Dim lx As Integer k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(1) + startcol * 1 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then 'MsgBox ("In create BMP: exceeding allowed indeces") bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If bkuva(j, i).r = RROW(l) bkuva(j, i).G = RROW(l) bkuva(j, i).B = RROW(l) Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As Byte Open image_info(Index).FileName For Binary As 2 i_step = -1 For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * (image_info(Index).sub_width) * 1 + startcol * 1 Get #2, paikka + 1, RROW() Rem Parse it For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step) ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step) ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step) Next l Next k Next j Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B Next j Next i Close (2) GoTo loppu pan_x_1: ReDim RROW(0 To (endcol - startcol)) As Byte Open image_info(Index).FileName For Binary As 2 k = -1 'Exit Sub For i = startrow To endrow k = k + 1 paikka = CLng(i) * (image_info(Index).sub_width) * 1 + startcol * 1 Rem Read a row Get #2, paikka + 1, RROW() For m = 0 To (endcol - startcol) bkuva(m, k).r = RROW(m) bkuva(m, k).G = RROW(m) bkuva(m, k).B = RROW(m) Next m Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) Close (2) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_bmp_header(ByVal File As String, ByVal Win_w As Long, ByVal win_h As Long) Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim W_byte_array As Integer, H_byte_array As Integer Dim lisa As Integer, padding As Integer H_byte_array = win_h W_byte_array = Win_w Open File For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 ' filehederi.bfOffBits = &H43A ' (if a color table) 43A=1082 ' Offset from the BitMapFileheader to the Bitmap Bits filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 ' MsgBox (Seek(1)) ' 14 Bytes Put #1, , filehederi ' MsgBox (Seek(1)) Put #1, , hederi ' 40 Bytes Close (1) End Sub Public Sub normalize(ByRef vector As Vector3D) Rem Returns a normalized version of the supplied 3D-vector Dim length As Double Dim apu length = vector_length(vector) vector.X = vector.X / length vector.Y = vector.Y / length vector.z = vector.z / length End Sub Public Sub normalize15(ByRef vector As Vector3D) Rem Returns a normalized (1 nanosecond light travel) version of the supplied 3D-vector Dim length As Double Dim apu length = vector_length(vector) vector.X = 0.15 * vector.X / length vector.Y = 0.15 * vector.Y / length vector.z = 0.15 * vector.z / length End Sub Public Function NormDev(expectance As Double, variance As Double) As Double Dim rsq As Double, v1 As Double, v2 As Double rsq = 2# Do v1 = 2# * Rnd - 1# v2 = 2# * Rnd - 1# rsq = v1 * v1 + v2 * v2 If (rsq < 1# And rsq > 0) Then GoTo exithere Loop exithere: fac = Sqr(-2# * Log(rsq) / rsq) If Rnd > 0.5 Then NormDev = v2 * fac * Sqr(variance) + expectance Else NormDev = v1 * fac * Sqr(variance) + expectance End If End Function Public Sub old_create_bmp(Shift As Long, W_byte_array As Long, H_byte_array As Long, b_array() As Byte, FileName As String) Rem This subroutine receives a byte array (intensity image 8-bits / pixel) and calculates then need for byte padding Rem (4-byte segments / line ) and Creates the BMP-file in filename Rem Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER Dim varitaulu(0 To 255) As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER Dim i As Integer, j As Integer, lisa As Integer Rem Error Handling ' On Error GoTo error_in_creating_bmp_file Rem Open the BMP-file Open FileName For Binary As 1 Dim padding As Integer Rem Compute need for posiible padding (of zeros at scan line ends) lisa = (W_byte_array Mod 4) If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Declare storage to hold a copy of the image ReDim bkuva(1 To W_byte_array + (padding), H_byte_array) As Byte Rem Prepare the BMP-file's HEADER For i = 0 To 255 varitaulu(i).rgbblue = CByte(i) varitaulu(i).rgbGreen = CByte(i) varitaulu(i).rgbred = CByte(i) varitaulu(i).rgbreserved = CByte(0) Next i filehederi.bfType = &H4D42 ' 19778 in decimal filehederi.bfSize = (W_byte_array * H_byte_array) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 filehederi.bfOffBits = &H43A ' 1082 BYTE offset! hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(H_byte_array) ' 4 hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(8) ' 2 hederi.biCompression = CLng(0) ' 4 hederi.biSizeImage = CLng(0) ' 4 hederi.biXPelsPerMeter = CLng(0) ' 4 hederi.biYPelsPerMeter = CLng(0) ' 4 hederi.biClrUsed = CLng(256) ' 4 hederi.biClrImportant = CLng(256) ' 4 isohederi.bmiHeader = hederi Rem Write the HEADER of the BMP-file Put #1, , filehederi Put #1, , isohederi Put #1, , varitaulu Rem Flip the image upside-down for. Store this version in bkuva()-array Rem Since b_array is indexed starting from (0,0), make shift 1 'MsgBox (Seek(1)) Shift = 1 For i = 1 To W_byte_array For j = 1 To H_byte_array bkuva(i, H_byte_array + 1 - j) = b_array(i - Shift, j - Shift) Next j Next i Rem Write this array to the BMP-file loppu: Put #1, , bkuva Rem Close the file Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file! ( sub create_bmp() )") Exit Sub End Sub Public Sub create_orto_bmp(orthoimage() As RGBtriplet) Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer, padding As Integer, lx As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long 'orthoimage(0 To N_ortho_columns - 1, 0 To N_ortho_rows - 1) H_byte_array = UBound(orthoimage, 2) + 1 W_byte_array = UBound(orthoimage, 1) + 1 'Exit Sub ' On Error GoTo error_in_creating_bmp_file Close (1) Open "C:\Data\Orto.bmp" For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim b_array(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBtriplet ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-100 To (W_byte_array - 1) + 100 + (padding), -100 To H_byte_array - 1 + 100) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 ' Offset from the BitMapFileheader to the Bitmap Bits filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi ' isohederi.bmiColors = bmicolor ' MsgBox (Seek(1)) ' 14 Bytes Put #1, , filehederi ' MsgBox (Seek(1)) Put #1, , hederi ' 40 Bytes ' Put #1, , isohederi ' 40 Bytes + size of rgbquad 4 ' MsgBox (Seek(1)) ' 1078 (1078+4)= 1082! = H43A ' Put #1, , varitaulu Rem Skip the Color Table! pan_x_1: k = -1 For i = 0 To UBound(orthoimage, 1) k = k + 1 Rem Read a row For m = 0 To UBound(orthoimage, 2) bkuva(m, k).r = orthoimage(i, m).r bkuva(m, k).G = orthoimage(i, m).G bkuva(m, k).B = orthoimage(i, m).B Next m Next i GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_bmp(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem Declarations Needed for BMP-printing Rem This subroutine receives a byte array (intensity image 8-bits / pixel) Rem Calculates need for byte padding (4-byte segments / line ) Rem Creates the file// E:\ilkka_smoothed.bmp // Rem Dim byteapu As Byte Dim hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer, padding As Integer, lx As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long H_byte_array = win_h W_byte_array = Win_w ' On Error GoTo error_in_creating_bmp_file Close (1) Open FileName For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim b_array(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBtriplet ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-100 To (W_byte_array - 1) + 100 + (padding), -100 To H_byte_array - 1 + 100) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 ' filehederi.bfOffBits = &H43A ' (if a color table) 43A=1082 ' Offset from the BitMapFileheader to the Bitmap Bits filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) Rem aking Dib - bitmap , header is defined here hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 Rem By making Height negative we assume (WINDOWS programs assume) it's a BMP with Low-left corner on first scan-line!! hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi ' isohederi.bmiColors = bmicolor Dim LOWL As Integer, HIGHL As Integer LOWL = 12 HIGHL = 21 ' MsgBox (Seek(1)) ' 14 Bytes Put #1, , filehederi ' MsgBox (Seek(1)) Put #1, , hederi ' 40 Bytes ' Put #1, , isohederi ' 40 Bytes + size of rgbquad 4 ' MsgBox (Seek(1)) ' 1078 (1078+4)= 1082! = H43A ' Put #1, , varitaulu Rem Skip the Color Table! ' Flip Image upside-down for proper BMP-syntax ' MsgBox ("b_array has a value: " & CStr(b_array(233, 4))) ' Resize image assuming pan_x = pan_y image N*N ' Flip upside down at the same time 'MsgBox (EndCol - StartCol + 1 & " Cols") 'MsgBox (EndRow - StartRow + 1 & " Rows") Rem For applying contrast enhancement by means of GAmma Correction Dim gamma As Double Dim Gcorr As Double Dim ApplyConstrastEnhancement As Boolean ApplyConstrastEnhancement = False If Form1.Gamma_1.Checked = True Then gamma = 0.4 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_2.Checked = True Then gamma = 0.5 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_3.Checked = True Then gamma = 0.6 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_4.Checked = True Then gamma = 1.4 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_5.Checked = True Then gamma = 2 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_6.Checked = True Then gamma = 3 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As RGBtriplet Rem Testing contrast enhancement 'ReDim RROWa(0 To (endcol - startcol), 0 To H_byte_array - 1) As RGBtriplet 'Open image_info(Index).FileName For Binary As 2 Close (2) Open image_info(Index).FileName For Binary As 2 k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(3) + CLng(startcol) * 3 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then ' MsgBox ("In create BMP: exceeding allowed indeces") bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If If ApplyConstrastEnhancement = False Then bkuva(j, i).r = RROW(l).r 'Exit Sub bkuva(j, i).G = RROW(l).G bkuva(j, i).B = RROW(l).B ' NDVI view ' bkuva(j, i).R = 125 + (CDbl(RROW(l).R) - CDbl(RROW(l).G)) / (CDbl(RROW(l).R) + CDbl(RROW(l).G)) * 125 ' bkuva(j, i).G = bkuva(j, i).R ' bkuva(j, i).B = bkuva(j, i).R End If If ApplyConstrastEnhancement = True Then bkuva(j, i).r = CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr) bkuva(j, i).G = CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr) bkuva(j, i).B = CByte(CDbl(RROW(l).B) ^ (gamma) * Gcorr) ' bkuva(j, i).r = 255 ' bkuva(j, i).G = 255 ' bkuva(j, i).B = 255 End If Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As RGBtriplet 'Open image_info(Index).filename For Binary As 2 Close (2) Open image_info(Index).FileName For Binary As 2 'Exit Sub i_step = -1 For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 3 + CLng(startcol) * 3 Get #2, paikka + 1, RROW() Rem Parse it For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).r ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).G ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).B Next l Next k Next j Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 ' If ckuva(i, j).g > LOWL And ckuva(i, j).g < HIGHL Then ' bkuva(i, j).R = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(i, j).g = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(i, j).b = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' Else ' bkuva(i, j).R = 0 ' bkuva(i, j).g = 0 ' bkuva(i, j).b = 0 ' End If If ApplyConstrastEnhancement = False Then bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B End If If ApplyConstrastEnhancement = True Then bkuva(i, j).r = CByte(CDbl(ckuva(i, j).r) ^ (gamma) * Gcorr) bkuva(i, j).G = CByte(CDbl(ckuva(i, j).G) ^ (gamma) * Gcorr) bkuva(i, j).B = CByte(CDbl(ckuva(i, j).B) ^ (gamma) * Gcorr) End If Next j Next i Close (2) GoTo loppu pan_x_1: ReDim RROW(0 To (endcol - startcol)) As RGBtriplet Close (2) Open image_info(Index).FileName For Binary As 2 'Exit Sub k = -1 For i = startrow To endrow k = k + 1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 3 + CLng(startcol) * 3 Rem Read a row Get #2, paikka + 1, RROW() For m = 0 To (endcol - startcol) If ApplyConstrastEnhancement = False Then Rem NDVI-view 'bkuva(m, k).r = 125 + (CDbl(RROW(m).r) - CDbl(RROW(m).G)) / (CDbl(RROW(m).r) + CDbl(RROW(m).G)) * 125 'bkuva(m, k).G = bkuva(m, k).r 'bkuva(m, k).B = bkuva(m, k).r bkuva(m, k).r = RROW(m).r bkuva(m, k).G = RROW(m).G bkuva(m, k).B = RROW(m).B End If If ApplyConstrastEnhancement = True Then bkuva(m, k).r = CByte(CDbl(RROW(m).r) ^ (gamma) * Gcorr) bkuva(m, k).G = CByte(CDbl(RROW(m).G) ^ (gamma) * Gcorr) bkuva(m, k).B = CByte(CDbl(RROW(m).B) ^ (gamma) * Gcorr) End If ' If RROW(m).g > LOWL And RROW(m).g < HIGHL Then ' bkuva(m, k).R = (Log(((RROW(m).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(m, k).g = (Log(((RROW(m).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(m, k).b = (Log(((RROW(m).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' Else ' bkuva(m, k).R = 0 ' bkuva(m, k).g = 0 ' bkuva(m, k).b = 0 ' End If Rem Code above for measurement of fiducial marks with high contrast enhancement! Next m Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create__Vexcel_bmp(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem Declarations Needed for BMP-printing Rem Dim byteapu As Byte, hederi As BITMAPINFOHEADER ' 40 bytes Dim varitaulu(0 To 255) As RGBQUAD Dim bmicolor As RGBQUAD Dim isohederi As BITMAPINFO Dim filehederi As BITMAPFILEHEADER ' 14 bytes Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, N As Integer, lisa As Integer Dim W_byte_array As Integer, H_byte_array As Integer Dim i_step As Integer Dim j_step As Integer, padding As Integer, lx As Integer Dim isum As Integer, apusum As Integer, maxh As Integer Dim paikka As Long H_byte_array = win_h W_byte_array = Win_w Close (1) Open FileName For Binary As 1 lisa = (W_byte_array * 3) Mod 4 If lisa = 0 Then padding = 0 Else padding = 4 - lisa End If Rem Note the order of BMP-files ! It is not RGB but BGR! ReDim b_array(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBtriplet ReDim bkuva(0 To (W_byte_array - 1) + (padding), 0 To H_byte_array - 1) As RGBQ Rem ckuva is used (temporary) to make sure we don't accidentally go outside OK indeces ReDim ckuva(-100 To (W_byte_array - 1) + 100 + (padding), -100 To H_byte_array - 1 + 100) As RGBQ filehederi.bfType = &H4D42 filehederi.bfSize = (CLng(W_byte_array + padding) * CLng(H_byte_array) * CLng(3)) filehederi.bfReserved1 = &H0 filehederi.bfReserved2 = &H0 filehederi.bfOffBits = &H36 ' 55 (54 byte offset, read 55th as first data-byte) hederi.biSize = CLng(40) ' 4 bytes hederi.biWidth = CLng(W_byte_array) ' 4 hederi.biHeight = CLng(-H_byte_array) ' 4 hederi.biPlanes = CInt(1) ' 2 hederi.biBitCount = CInt(24) '2 hederi.biCompression = CLng(0) '4 hederi.biSizeImage = CLng(0) '4 hederi.biXPelsPerMeter = CLng(0) '4 hederi.biYPelsPerMeter = CLng(0) '4 hederi.biClrUsed = CLng(0) '4 hederi.biClrImportant = CLng(0) '4 isohederi.bmiHeader = hederi Dim LOWL As Integer, HIGHL As Integer LOWL = 12 HIGHL = 21 Put #1, , filehederi Put #1, , hederi ' 40 Bytes ' Flip Image upside-down for proper BMP-syntax ' MsgBox ("b_array has a value: " & CStr(b_array(233, 4))) ' Resize image assuming pan_x = pan_y image N*N ' Flip upside down at the same time Rem For applying contrast enhancement by means of GAmma Correction Dim gamma As Double, Gcorr As Double Dim ApplyConstrastEnhancement As Boolean ApplyConstrastEnhancement = False If Form1.Gamma_1.Checked = True Then gamma = 0.4 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_2.Checked = True Then gamma = 0.5 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_3.Checked = True Then gamma = 0.6 Gcorr = (255 / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_4.Checked = True Then gamma = 1.4 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_5.Checked = True Then gamma = 2 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If Form1.Gamma_6.Checked = True Then gamma = 3 Gcorr = (255# / (255# ^ gamma)) ApplyConstrastEnhancement = True End If If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: Rem This is the N --> 1 case ReDim RROW(0 To (endcol - startcol)) As RGBtriplet Rem Testing contrast enhancement 'ReDim RROWa(0 To (endcol - startcol), 0 To H_byte_array - 1) As RGBtriplet Open image_info(Index).FileName For Binary As 2 k = -1 lx = -CInt(1 / pan_y) For i = 0 To H_byte_array - 1 lx = lx + CInt(1 / pan_y) paikka = CLng(startrow + lx) * (image_info(Index).sub_width) * CLng(3) + CLng(startcol) * 3 Get #2, paikka + 1, RROW() l = -CInt(1 / pan_x) For j = 0 To W_byte_array - 1 l = l + CInt(1 / pan_x) m = startcol + i * CInt(1 / pan_x) N = startrow + j * CInt(1 / pan_y) If m < 0 Or N < 0 Or m > image_info(Index).sub_width Or N > image_info(Index).sub_height Then ' MsgBox ("In create BMP: exceeding allowed indeces") bkuva(i, j).r = 255: bkuva(i, j).G = 255: bkuva(i, j).B = 255: GoTo Ohita End If If ApplyConstrastEnhancement = False Then bkuva(j, i).r = RROW(l).r bkuva(j, i).G = RROW(l).G bkuva(j, i).B = RROW(l).B End If If ApplyConstrastEnhancement = True Then bkuva(j, i).r = CByte(CDbl(RROW(l).r) ^ (gamma) * Gcorr) bkuva(j, i).G = CByte(CDbl(RROW(l).G) ^ (gamma) * Gcorr) bkuva(j, i).B = CByte(CDbl(RROW(l).B) ^ (gamma) * Gcorr) End If Ohita: Next j Next i Close (2) GoTo loppu ZoomIn: Rem The 1->N Case ReDim RROW(0 To (endcol - startcol)) As RGBtriplet 'Open image_info(Index).filename For Binary As 2 Close (2) Open image_info(Index).FileName For Binary As 2 'Exit Sub i_step = -1 For i = startrow To endrow i_step = i_step + 1 j_step = -1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 3 + CLng(startcol) * 3 Get #2, paikka + 1, RROW() Rem Parse it For j = startcol To endcol j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).r = RROW(j_step).r ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).G = RROW(j_step).G ckuva(j_step * CInt(pan_x) + l, i_step * CInt(pan_y) + k).B = RROW(j_step).B Next l Next k Next j Next i For i = 0 To Win_w - 1 For j = 0 To win_h - 1 ' If ckuva(i, j).g > LOWL And ckuva(i, j).g < HIGHL Then ' bkuva(i, j).R = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(i, j).g = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' bkuva(i, j).b = (Log(((ckuva(i, j).g - LOWL) / HIGHL + 0.01)) + 4.6) * 55 ' Else ' bkuva(i, j).R = 0 ' bkuva(i, j).g = 0 ' bkuva(i, j).b = 0 ' End If If ApplyConstrastEnhancement = False Then bkuva(i, j).r = ckuva(i, j).r bkuva(i, j).G = ckuva(i, j).G bkuva(i, j).B = ckuva(i, j).B End If If ApplyConstrastEnhancement = True Then bkuva(i, j).r = CByte(CDbl(ckuva(i, j).r) ^ (gamma) * Gcorr) bkuva(i, j).G = CByte(CDbl(ckuva(i, j).G) ^ (gamma) * Gcorr) bkuva(i, j).B = CByte(CDbl(ckuva(i, j).B) ^ (gamma) * Gcorr) End If Next j Next i Close (2) GoTo loppu pan_x_1: 'ReDim RROW(0 To (endcol - startcol)) As RGBtriplet Close (2) 'Open image_info(Index).AdditFileName(2) For Binary As 2 Exit Sub ReDim introw(0 To (endcol - startcol)) As RGBNIR k = -1 For i = startrow To endrow k = k + 1 paikka = CLng(i) * CLng(image_info(Index).sub_width) * 8 + CLng(startcol) * 8 Rem Read a row Get #2, paikka + 1, introw() For m = 0 To (endcol - startcol) NDVI = (introw(m).NIR - introw(m).r) / (introw(m).NIR + introw(m).r) DistToVarjo = -29.16669 - 0.01344 * introw(m).NIR + 112.30577 * NDVI - 0.04629 * introw(m).G + 0.04315 * introw(m).r + 0.09224 * introw(m).B DistToValo = -31.19741 - 0.00224 * introw(m).NIR + 91.8792 * NDVI - 0.05914 * introw(m).G + 0.0555 * introw(m).r + 0.07218 * introw(m).B DistTo1 = -61.61135 + 226.81656 * NDVI + 0.00605 * introw(m).G + 0.11186 * introw(m).r + -0.04165 * introw(m).B + -0.0299 * introw(m).NIR DistTo2 = -63.13928 + 227.0751 * NDVI + 0.000231 * introw(m).G + 0.1113 * introw(m).r + -0.03141 * introw(m).B + -0.02858 * introw(m).NIR DistTo3 = -53.1311 + 207.56906 * NDVI + -0.02007 * introw(m).G + 0.11379 * introw(m).r + -0.00805 * introw(m).B + -0.02659 * introw(m).NIR If DistTo1 > DistTo2 And DistTo1 > DistTo3 Then MinD = 1 If DistTo2 > DistTo1 And DistTo2 > DistTo3 Then MinD = 2 If DistTo3 > DistTo1 And DistTo3 > DistTo2 Then MinD = 3 Rem If introw(m).NIR < 2550 Then bkuva(m, k).r = introw(m).NIR / 10 Else bkuva(m, k).r = introw(m).NIR / 20 End If If introw(m).r < 2040 Then bkuva(m, k).G = introw(m).r / 8 Else bkuva(m, k).G = introw(m).r / 30 End If If introw(m).G < 2040 Then bkuva(m, k).B = introw(m).G / 8 Else bkuva(m, k).B = introw(m).G / 25 End If 'GoTo skipped If (DistToVarjo - 1 > DistToValo) Then bkuva(m, k).r = 255 bkuva(m, k).G = 255 bkuva(m, k).B = 255 GoTo skipped End If Select Case MinD Case 1 bkuva(m, k).r = 255 bkuva(m, k).G = 0 bkuva(m, k).B = 0 Case 2 bkuva(m, k).G = 255 bkuva(m, k).r = 0 bkuva(m, k).B = 0 Case 3 bkuva(m, k).B = 255 bkuva(m, k).r = 0 bkuva(m, k).G = 0 End Select skipped: Next m Next i Close (2) GoTo loppu loppu: Put #1, , bkuva Close (1) Exit Sub error_in_creating_bmp_file: Close (1) MsgBox ("Error in creating the bmp-file!") Exit Sub End Sub Public Sub create_vector(ByRef vector As Vector3D, ByVal dimx As Double, ByVal dimy As Double, ByVal dimz As Double) Rem Assigns values & returns the vector vector.X = dimx vector.Y = dimy vector.z = dimz End Sub Public Sub Create_Bitmap(ByVal Index As Integer, ByVal startcol As Integer, ByVal startrow As Integer, ByVal endcol As Integer, ByVal endrow As Integer, b_array() As Byte, FileName As String, ByVal pan_x As Double, ByVal pan_y As Double) Rem Creates a Bitmap and displays it using SetBitMapPixels API-function Dim bm As BITMAP Rem Retrieve values GetObject Form1.Picture1(Index).Image, Len(bm), bm ReDim bkuva(0 To bm.bmWidth - 1, 0 To bm.bmHeight - 1) As RGBQUAD1 Dim H_byte_array As Integer, W_byte_array As Integer Dim i As Integer, j As Integer, k As Integer, m As Integer, N As Integer H_byte_array = win_h W_byte_array = Win_w If pan_x > 0.99 And pan_x < 1.1 Then GoTo pan_x_1 If pan_x < 1 Then GoTo ZoomOut If pan_x > 1 Then GoTo ZoomIn ZoomOut: k = -1 For i = 0 To W_byte_array - 1 For j = 0 To H_byte_array - 1 m = startcol + i * CInt(1 / pan_x) + (1 / pan_x) / 2 'Step N = startrow + j * CInt(1 / pan_y) + CInt(1 / pan_y) / 2 'isum = 0 'apusum = 0 'For k = (-1 / pan_x) / 2 To ((1 / pan_x) - 1) / 2 ' For l = (-1 / pan_x) / 2 To ((1 / pan_x) - 1) / 2 ' apusum = apusum + CInt(b_array(StartCol + m + k, EndRow - n + l, Index)) ' isum = isum + 1 ' Next l ' Next k bkuva(i, j).r = b_array(m, N, Index) bkuva(i, j).G = b_array(m, N, Index) bkuva(i, j).B = b_array(m, N, Index) bkuva(i, j).N = 0 Next j Next i GoTo loppu Dim i_step As Integer, lisaysc As Integer, lisaysr As Integer, j_step As Integer Dim l As Integer ZoomIn: k = -1 i_step = -1 lisaysc = (endcol - startcol) Mod 2 + 1 lisaysr = (endrow - startrow) Mod 2 + 1 For i = startcol To (endcol - lisaysc - 1) i_step = i_step + 1 j_step = -1 For j = (startrow + lisaysr + 1) To endrow j_step = j_step + 1 For k = 0 To CInt(pan_x) - 1 For l = 0 To CInt(pan_y) - 1 bkuva(i_step * CInt(pan_x) + k, j_step * CInt(pan_y) + l).r = b_array(i, j, Index) bkuva(i_step * CInt(pan_x) + k, j_step * CInt(pan_y) + l).G = b_array(i, j, Index) bkuva(i_step * CInt(pan_x) + k, j_step * CInt(pan_y) + l).B = b_array(i, j, Index) bkuva(i_step * CInt(pan_x) + k, j_step * CInt(pan_y) + l).N = 0 Next l Next k Next j Next i GoTo loppu pan_x_1: k = -1 For i = startcol To endcol l = -1 k = k + 1 For j = startrow To endrow l = l + 1 bkuva(k, l).r = b_array(i, j, Index) bkuva(k, l).G = b_array(i, j, Index) bkuva(k, l).B = b_array(i, j, Index) bkuva(k, l).N = 0 Next j Next i GoTo loppu loppu: SetBitmapBits Form1.Picture1(Index).Image, bm.bmWidthBytes * CLng(win_h), bkuva(0, 0) Form1.Picture1(Index).Refresh Exit Sub error_in_creating_bitmap: MsgBox ("Error in creating the bitmap for display!") Exit Sub End Sub Public Sub Clear_all_images() Dim i As Integer For i = 0 To NumOfImages - 1 Form1.Check1(i).Value = 0 Form1.Text1(i * 2).Text = "" Form1.Text12(i).Text = "" Form1.Text1((i * 2) + 1).Text = "" Form1.Picture1(i).Cls LastImageClicked = -1 Next i End Sub Public Sub ConnectedCompLabel(Dem() As Single, mean As Double, Nhummocks As Double, Compactness As Double, Meansize) Dim Nrows As Long, Ncols As Long Nrows = UBound(Dem, 1) Ncols = UBound(Dem, 2) ReDim labels(0 To Ncols + 1, 0 To Nrows + 1) As String Rem Di the Binary marking first For i = 0 To Ncols + 1 For j = 0 To Nrows + 1 labels(i, j) = "B" If (i > 0 And i <= Ncols) And (j > 0 And j <= Nrows) Then If Dem(i, j) < mean Then labels(i, j) = "B" Dem(i, j) = 0 Else labels(i, j) = "T" End If End If Next j Next i lab = 0 10 lab = lab + 1 Label = CStr(lab) Foundnew = 0 For X = 1 To Nrows For Y = 1 To Ncols If labels(X, Y) = "T" Then labels(X, Y) = Label Foundnew = 1 If labels(X - 1, Y - 1) = "T" Then labels(X - 1, Y - 1) = Label End If If labels(X, Y - 1) = "T" Then labels(X, Y - 1) = Label End If If labels(X + 1, Y - 1) = "T" Then labels(X + 1, Y - 1) = Label End If If labels(X - 1, Y) = "T" Then labels(X - 1, Y) = Label End If If labels(X + 1, Y) = "T" Then labels(X + 1, Y) = Label End If If labels(X - 1, Y + 1) = "T" Then labels(X - 1, Y + 1) = Label End If If labels(X, Y + 1) = "T" Then labels(X, Y + 1) = Label End If If labels(X + 1, Y + 1) = "T" Then labels(X + 1, Y + 1) = Label End If GoTo 20 End If Next Y Next X If Foundnew = 0 Then GoTo loppu 20 Findall: Label = CStr(lab) Foundnew = 0 For X = 1 To Nrows For Y = 1 To Ncols If labels(X, Y) = "T" Then If labels(X - 1, Y - 1) = Label Or _ labels(X, Y - 1) = Label Or _ labels(X + 1, Y - 1) = Label Or _ labels(X - 1, Y) = Label Or _ labels(X + 1, Y) = Label Or _ labels(X - 1, Y + 1) = Label Or _ labels(X, Y + 1) = Label Or _ labels(X + 1, Y + 1) = Label Then labels(X, Y) = Label Foundnew = 1 If labels(X - 1, Y - 1) = "T" Then labels(X - 1, Y - 1) = Label End If If labels(X, Y - 1) = "T" Then labels(X, Y - 1) = Label End If If labels(X + 1, Y - 1) = "T" Then labels(X + 1, Y - 1) = Label End If If labels(X - 1, Y) = "T" Then labels(X - 1, Y) = Label End If If labels(X + 1, Y) = "T" Then labels(X + 1, Y) = Label End If If labels(X - 1, Y + 1) = "T" Then labels(X - 1, Y + 1) = Label End If If labels(X, Y + 1) = "T" Then labels(X, Y + 1) = Label End If If labels(X + 1, Y + 1) = "T" Then labels(X + 1, Y + 1) = Label End If End If End If Next Y Next X If Foundnew = 1 Then GoTo 20 Else GoTo 10 End If loppu: ReDim areatau(1 To lab) As Long rajasum = 0 For i = 1 To Ncols For j = 1 To Nrows If labels(i, j) <> "B" Then Dem(i, j) = Val(labels(i, j)) If labels(i - 1, j) = "B" Then rajasum = rajasum + 1 If labels(i + 1, j) = "B" Then rajasum = rajasum + 1 If labels(i, j - 1) = "B" Then rajasum = rajasum + 1 If labels(i, j + 1) = "B" Then rajasum = rajasum + 1 End If ' For ix = -1 To 1 ' For jx = -1 To 1 ' If labels(i, j) <> CStr(k) Then GoTo NextPixel ' Next jx ' Next ix ' areatau(k) = areatau(k) + 1 NextPixel: Next j Next i areasum = 0 For k = 1 To lab For i = 1 To Ncols For j = 1 To Nrows If labels(i, j) <> CStr(k) Then GoTo NextPixeli areatau(k) = areatau(k) + 1 NextPixeli: Next j Next i areasum = areasum + areatau(k) Next k 'Next k Nhummocks = lab - 1 Meansize = areasum / (lab - 1) Compactness = rajasum Exit Sub End Sub Public Sub Calc_dX_dY_dZ_dx_dy(Cam As Long, X_ini As Double, Y_ini As Double, Z_ini As Double, dx_dU_K As Double, dy_dU_K As Double, dx_dV_K As Double, dy_dV_K As Double, dx_dW_K As Double, dy_dW_K As Double, dX As Double, dY As Double, X As Double, Y As Double) ' This subroutine calculates the differential quotiens needed in the calculation of space ' intersection and (approximation - obs) residuals ' (elements of normal vector) ' dx_dUK, dy_dU_K,....,dy_dW_K, dx, dy ' cam stores index to image info ' _ini, Y_ini, Z_ini (initial / iteratively improved) XYZ-coordinates Dim omega, phi, kappa As Double Dim u As Double, v As Double, w As Double, U0 As Double, v0 As Double, W0 As Double Dim z As Double, z0 As Double, x0 As Double, y0 As Double, x_k As Double, y_k As Double 'Dim x, y as bouble Dim Zx As Double, Zy As Double, N As Double, c As Double Dim i As Long, c_index As Long Rem Initial approximations u = X_ini: v = Y_ini: w = Z_ini If image_info(Cam).Imagetype = "FRAME" Then omega = image_info(Cam).omega: phi = image_info(Cam).phi: kappa = image_info(Cam).kappa X = CDbl(Form1.Text1(Cam * 2).Text): Y = CDbl(Form1.Text1(Cam * 2 + 1).Text) z = 0# x0 = 0#: y0 = 0#: z0 = image_info(Cam).c U0 = image_info(Cam).Xo: v0 = image_info(Cam).Yo: W0 = image_info(Cam).Zo Zx = A(1, 1, Cam) * (u - U0) + A(2, 1, Cam) * (v - v0) + A(3, 1, Cam) * (w - W0) Zy = A(1, 2, Cam) * (u - U0) + A(2, 2, Cam) * (v - v0) + A(3, 2, Cam) * (w - W0) N = A(1, 3, Cam) * (u - U0) + A(2, 3, Cam) * (v - v0) + A(3, 3, Cam) * (w - W0) c = (z - z0) dx_dU_K = (-c / (N ^ 2)) * (N * A(1, 1, Cam) - Zx * A(1, 3, Cam)) dy_dU_K = (-c / (N ^ 2)) * (N * A(1, 2, Cam) - Zy * A(1, 3, Cam)) dx_dV_K = (-c / (N ^ 2)) * (N * A(2, 1, Cam) - Zx * A(2, 3, Cam)) dy_dV_K = (-c / (N ^ 2)) * (N * A(2, 2, Cam) - Zy * A(2, 3, Cam)) dx_dW_K = (-c / (N ^ 2)) * (N * A(3, 1, Cam) - Zx * A(3, 3, Cam)) dy_dW_K = (-c / (N ^ 2)) * (N * A(3, 2, Cam) - Zy * A(3, 3, Cam)) ' Calculate the image coordinates from the ground point x_k = x0 + (z - z0) * (A(1, 1, Cam) * (u - U0) + A(2, 1, Cam) * (v - v0) + A(3, 1, Cam) * (w - W0)) / (A(1, 3, Cam) * (u - U0) + A(2, 3, Cam) * (v - v0) + A(3, 3, Cam) * (w - W0)) y_k = y0 + (z - z0) * (A(1, 2, Cam) * (u - U0) + A(2, 2, Cam) * (v - v0) + A(3, 2, Cam) * (w - W0)) / (A(1, 3, Cam) * (u - U0) + A(2, 3, Cam) * (v - v0) + A(3, 3, Cam) * (w - W0)) ' calculate error (residual) dX = x_k - X dY = y_k - Y End If If image_info(Cam).Imagetype = "ADS L0" Or image_info(Cam).Imagetype = "ADS L1" Then Rem Image coordinates ' Call KKJ_to_LSR(CLng(Cam), X_ini, Y_ini, Z_ini, u, v, w) X = ADSOBS(Cam).xy.X: Y = ADSOBS(Cam).xy.Y z = 0# x0 = 0#: y0 = 0#: z0 = ADSCam(Cam).FocalLength U0 = ODFs(ADSOBS(Cam).lp.Line, Cam).X: v0 = ODFs(ADSOBS(Cam).lp.Line, Cam).Y: W0 = ODFs(ADSOBS(Cam).lp.Line, Cam).z Zx = ODFs(ADSOBS(Cam).lp.Line, Cam).a00 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a01 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a02 * (w - W0) Zy = ODFs(ADSOBS(Cam).lp.Line, Cam).a10 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a11 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a12 * (w - W0) N = ODFs(ADSOBS(Cam).lp.Line, Cam).a20 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a21 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a22 * (w - W0) c = (z - z0) dx_dU_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a00 - Zx * ODFs(ADSOBS(Cam).lp.Line, Cam).a20) dy_dU_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a10 - Zy * ODFs(ADSOBS(Cam).lp.Line, Cam).a20) dx_dV_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a01 - Zx * ODFs(ADSOBS(Cam).lp.Line, Cam).a21) dy_dV_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a11 - Zy * ODFs(ADSOBS(Cam).lp.Line, Cam).a21) dx_dW_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a02 - Zx * ODFs(ADSOBS(Cam).lp.Line, Cam).a22) dy_dW_K = (-c / (N ^ 2)) * (N * ODFs(ADSOBS(Cam).lp.Line, Cam).a12 - Zy * ODFs(ADSOBS(Cam).lp.Line, Cam).a22) ' Calculate the image coordinates from the ground point x_k = x0 + (z - z0) * (ODFs(ADSOBS(Cam).lp.Line, Cam).a00 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a01 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a02 * (w - W0)) / (ODFs(ADSOBS(Cam).lp.Line, Cam).a20 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a21 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a22 * (w - W0)) y_k = y0 + (z - z0) * (ODFs(ADSOBS(Cam).lp.Line, Cam).a10 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a11 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a12 * (w - W0)) / (ODFs(ADSOBS(Cam).lp.Line, Cam).a20 * (u - U0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a21 * (v - v0) + ODFs(ADSOBS(Cam).lp.Line, Cam).a22 * (w - W0)) ' a = ODFs(Index, j).a00 * dX + ODFs(Index, j).a01 * dY + ODFs(Index, j).a02 * dZ ' B = ODFs(Index, j).a10 * dX + ODFs(Index, j).a11 * dY + ODFs(Index, j).a12 * dZ ' N_ = ODFs(Index, j).a20 * dX + ODFs(Index, j).a21 * dY + ODFs(Index, j).a22 * dZ ' focal coordinates ' xy.Sample = -c * a / N_ ' xy.line = -c * B / N_ ' calculate error (residual) dX = x_k - X dY = y_k - Y End If End Sub Function det_cal2(e() As Double) As Double ' This function calculates the determinant of a 2x2 matrix (E) Dim term1, term2 As Double term1 = e(1, 1) * e(2, 2) term2 = e(2, 1) * e(1, 2) det_cal2 = term1 - term2 End Function Public Sub MATINV3(CC() As Double, DD() As Double) Rem CC 3x3 input, inverted version DD 3x3 ReDim EE(1 To 2, 1 To 2) As Double ReDim el(1 To 4) As Double Rem here starts Cramers rule (with 2x2 sub determinants) For Ix = 1 To 3: For jx = 1 To 3 num = 0 For kX = 1 To 3: For lx = 1 To 3 mx = kX: nx = lx Rem Choose elements of subdeterminants If lx = jx Then GoTo bypasscolumn If kX = Ix Then GoTo bypassrow num = num + 1 Rem by columns el(num) = CC(kX, lx) bypasscolumn: Next lx bypassrow: Next kX EE(1, 1) = el(1): EE(1, 2) = el(2): EE(2, 1) = el(3): EE(2, 2) = el(4) DD(jx, Ix) = (1 / det_D) * det_cal2(EE()) If (jx + Ix) Mod 2 <> 0 Then DD(jx, Ix) = -DD(jx, Ix) End If Next jx Next Ix End Sub Function det_cal3(e() As Double) As Double ' This function calculates the determinant of a 3x3 ' matrix (E) Dim term1, term2, term3, term4, term5, term6 As Double term1 = e(1, 1) * e(2, 2) * e(3, 3) term2 = e(2, 1) * e(3, 2) * e(1, 3) term3 = e(3, 1) * e(1, 2) * e(2, 3) term4 = e(1, 1) * e(3, 2) * e(2, 3) term5 = e(2, 1) * e(1, 2) * e(3, 3) term6 = e(3, 1) * e(2, 2) * e(1, 3) det_cal3 = term1 + term2 + term3 - term4 - term5 - term6 End Function Public Sub solve_3D_X_Y_from_Z_x_y(ByVal q As Integer, ByVal Z_gnd As Double, ByVal X As Double, ByVal Y As Double, ByRef X_Gnd As Double, ByRef Y_Gnd As Double) Dim c As Double ' camera constant Dim k As Double ' denominator in inverse collinear eq. c = -image_info(q).c k = A(3, 1, q) * X + A(3, 2, q) * Y + A(3, 3, q) * c If k <> 0# Then X_Gnd = image_info(q).Xo + (Z_gnd - image_info(q).Zo) * ((A(1, 1, q) * (X) + A(1, 2, q) * (Y) + A(1, 3, q) * (c)) / k) Y_Gnd = image_info(q).Yo + (Z_gnd - image_info(q).Zo) * ((A(2, 1, q) * (X) + A(2, 2, q) * (Y) + A(2, 3, q) * (c)) / k) End If End Sub Public Sub r_transform_3D(ByVal q As Integer, ByVal X As Double, ByVal Y As Double, ByVal z As Double, p_x, p_y) Rem Calculates 3D --> 2D transformation, for image q Dim k As Double ' inverse of this number is the scale factor If (image_info(q).c <> 0#) Then k = (A(1, 3, q) * (X - image_info(q).Xo) + A(2, 3, q) * (Y - image_info(q).Yo) + A(3, 3, q) * (z - image_info(q).Zo)) Else k = 0# End If If (k <> 0) Then p_x = -image_info(q).c * (A(1, 1, q) * (X - image_info(q).Xo) + A(2, 1, q) * (Y - image_info(q).Yo) + A(3, 1, q) * (z - image_info(q).Zo)) / k p_y = -image_info(q).c * (A(1, 2, q) * (X - image_info(q).Xo) + A(2, 2, q) * (Y - image_info(q).Yo) + A(3, 2, q) * (z - image_info(q).Zo)) / k Else p_x = p_y = 0# End If End Sub Public Sub r_transform_ground_to_pixel(ByVal q As Integer, ByVal X As Double, ByVal Y As Double, ByVal z As Double, p_x As Double, p_y As Double) Rem from ground coordinates to Pixel values (imagecoordinates) Dim camera_x As Double, camera_y As Double Rem MsgBox ("X,Y,Z in transform ground to pixel: " & Format$(X, "0.00 ") & Format$(Y, "0.00 ") & Format$(Z, "0.00 ")) Call r_transform_3D(q, X, Y, z, camera_x, camera_y) ' MsgBox ("camera x & y returned from 3D->2D :" & Format$(camera_x * 100#, "0.000000000 cm") & Format$(camera_y * 100#, "0.00000000 cm")) Call a_transform_affine(q, 0, camera_x, camera_y, p_x, p_y) ' MsgBox ("image x & y returned from 3D->2D :" & Format$(p_x, "0.00 ") & Format$(p_y, "0.00 ")) End Sub Public Sub rotate_xyz_about_vector_abc_uvw_by_S(xyz As Vector3D, abc As Vector3D, uvw As Vector3D, s As Double, retvec As Vector3D) Dim A As Double, B As Double, c As Double Dim u As Double, v As Double, w As Double Dim X As Double, Y As Double, z As Double A = abc.X: B = abc.Y: c = abc.z u = uvw.X: v = uvw.Y: w = uvw.z X = xyz.X: Y = xyz.Y: z = xyz.z retvec.X = (A * (v ^ 2 + w ^ 2) - u * (B * v + c * w - u * X - v * Y - w * z)) * (1 - Cos(s)) + X * Cos(s) + (-c * v + B * w - w * Y + v * z) * Sin(s) retvec.Y = (B * (u ^ 2 + w ^ 2) - v * (A * u + c * w - u * X - v * Y - w * z)) * (1 - Cos(s)) + Y * Cos(s) + (c * u + A * w - w * X - u * z) * Sin(s) retvec.z = (c * (u ^ 2 + v ^ 2) - w * (A * u + B * v - u * X - v * Y - w * z)) * (1 - Cos(s)) + z * Cos(s) + (-B * u + A * v - v * X + v * Y) * Sin(s) End Sub Public Sub r_transform_matrix(ByVal q As Integer) Rem Rotation matrix for image q A(1, 1, q) = Cos(image_info(q).phi) * Cos(image_info(q).kappa): A(1, 2, q) = -Cos(image_info(q).phi) * Sin(image_info(q).kappa): A(1, 3, q) = Sin(image_info(q).phi) A(2, 1, q) = Cos(image_info(q).omega) * Sin(image_info(q).kappa) + Sin(image_info(q).omega) * Sin(image_info(q).phi) * Cos(image_info(q).kappa): A(2, 2, q) = Cos(image_info(q).omega) * Cos(image_info(q).kappa) - Sin(image_info(q).omega) * Sin(image_info(q).phi) * Sin(image_info(q).kappa): A(2, 3, q) = -Sin(image_info(q).omega) * Cos(image_info(q).phi) A(3, 1, q) = Sin(image_info(q).omega) * Sin(image_info(q).kappa) - Cos(image_info(q).omega) * Sin(image_info(q).phi) * Cos(image_info(q).kappa): A(3, 2, q) = Sin(image_info(q).omega) * Cos(image_info(q).kappa) + Cos(image_info(q).omega) * Sin(image_info(q).phi) * Sin(image_info(q).kappa): A(3, 3, q) = Cos(image_info(q).omega) * Cos(image_info(q).phi) End Sub Public Sub a_transform_collinear(ByVal x_in As Double, ByVal y_in As Double, ByVal z_in As Double, ByVal c As Double, ByRef Rij() As Double, ByRef x_out As Double, ByRef y_out As Double) x_out = -c * (Rij(1, 1) * x_in + Rij(1, 2) * y_in - Rij(1, 3) * z_in) / (Rij(3, 1) * x_in + Rij(3, 2) * y_in - Rij(3, 3) * z_in) y_out = -c * (Rij(2, 1) * x_in + Rij(2, 2) * y_in - Rij(2, 3) * z_in) / (Rij(3, 1) * x_in + Rij(3, 2) * y_in - Rij(3, 3) * z_in) End Sub Public Sub a_transform_helmert(ByVal q As Integer, ByVal direction As Integer, X, Y, p_x, p_y) Rem ***************************************************************************** Rem a_transform_helmert Rem Transforms according to parameters given Rem q = image number Rem direction 0 (x,y) -> (col,row), 1 (row,col)-> (x,y) Rem ***************************************************************************** Dim x_ori, y_ori As Double x_ori = X ' arguments x,y are not allowed to change their value inside this Sub y_ori = Y Select Case direction Case 0 ' From camera coordinates to image cordinates (pixels) X = X - image_info(q).mean_x Y = Y - image_info(q).mean_y p_x = image_info(q).X_mean + image_info(q).lambda * Cos(image_info(q).alpha) * X - image_info(q).lambda * Sin(image_info(q).alpha) * Y p_y = image_info(q).Y_mean + image_info(q).lambda * Sin(image_info(q).alpha) * X + image_info(q).lambda * Cos(image_info(q).alpha) * Y X = x_ori Y = y_ori Case 1 ' From image coordinates (pixels) to camera cordinates (mm) X = X - image_info(q).X_mean Y = Y - image_info(q).Y_mean p_x = image_info(q).mean_x + (1# / image_info(q).lambda) * Cos(-image_info(q).alpha) * X - (1# / image_info(q).lambda) * Sin(-image_info(q).alpha) * Y p_y = image_info(q).mean_y + (1# / image_info(q).lambda) * Sin(-image_info(q).alpha) * X + (1# / image_info(q).lambda) * Cos(-image_info(q).alpha) * Y X = x_ori Y = y_ori End Select End Sub Rem Add more images to the set Public Sub add_an_image(hdrname As String) Dim startrow As Long, startcol As Long, endrow As Long, endcol As Long Dim i As Long, length As Long, j As Long Dim FileOut As String Rem Set the Initialize Boolean To FALSE initialize = False Rem Error handling at line 'On Error GoTo Error_in_adding_to_a_set Open hdrname For Input As 1 Rem Read a line to get the number of images in the set & display it If NumOfImages > MAXIMA Then MsgBox ("At the moment cannot allow more than " & MAXIMA & " images (three rows of Picture-boxes to hold the images!)") Close (1) Exit Sub End If NumOfImages = NumOfImages + 1 Form1.MousePointer = 11 DoEvents Rem Form1, the main window is maximized by default and has pixel-metrics. Get it's scalewidth & scaleheight to determine Rem individual image window widths and heights (win_w & win_h). There'll be images in a row. Call set_window_sizes Rem Read the individual image i = NumOfImages - 1 Call read_set_file_for_an_image(CLng(i)) Rem Check the sanity of parameters for image i Call Check_parameter_sanity(i) Rem Close the HDR-file as we've read all information Close (1) Call r_transform_matrix(i) Rem Make the mouse pointer into a "tiimalasi" wait-state -one Form1.MousePointer = 11 Rem Update label10 Form1.Label10.Caption = CStr(0) & "/" & CStr(NumOfImages) & " images read" 'DoEvents Rem There'll be (NumOfImages-1) "gimmicks" on the main window, give them their locations in pixel-metrics Call Place_Objects_On_The_Main_Form Rem Assign values to following integer-VARS startrow = 0: startcol = 0 endrow = 0: endcol = 0 Rem Now starts the section where we display each sub-image cenetered at their .sub_c_col and .sub_c_row Rem image coordinates i = NumOfImages - 1 Rem To start with we assume zooming (pan) factor 1 Rem Assign global vars ("pan" should really say "Zoom"), win_info(i).pan_x = 1 win_info(i).pan_y = 1 Rem Assign the global vars with window widths & heights win_info(i).win_width = Win_w win_info(i).win_height = win_h If SolutionExists = True Then Call center_to_xyz Exit Sub End If Rem calculate the region from which in the sub-image (StartCol, StartRow, EndCol, EndRow) consists Rem Centering at (sub_c_col, sub_c_row) Call calculate_region(i, image_info(i).sub_c_col, image_info(i).sub_c_row, CInt(1 / win_info(i).pan_x * Win_w), CInt(1 / win_info(i).pan_y * win_h), startcol, startrow, endcol, endrow, win_info(i).pan_x, win_info(i).pan_y) Rem Call create_bmp to make the BMP-file to be displayed. Rem Check if it is a greyscale (0) image or color (1) If image_info(i).Color = 1 Then Rem It's a color image Rem Wrapper for filename to be passed to the C-routine length = Stringlength(image_info(i).FileName) ReDim filename_in(0 To length) As Byte For j = 0 To length - 1 filename_in(j) = CByte(Asc(Mid$(image_info(i).FileName, j + 1, 1))) Next j filename_in(length) = 0 FileOut = "c:\data\pic" & CStr(i) & ".bmp" length = Len(FileOut) ReDim filename_out(0 To length) As Byte For j = 0 To length - 1 filename_out(j) = CByte(Asc(Mid$(FileOut, j + 1, 1))) Next j filename_out(length) = 0 Rem create_bmp written in VB Call create_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) Rem Alternatively call a C-function (it is not any faster!!) Rem Header is created separately if C-routine is used ' Call create_bmp_header(FileOut, CLng(Win_w), CLng(win_h)) Rem MYFUNC_CREATEDBMP resides in a C-dll ' apu = MYFUNC_CREATEBMP(CLng(i), CLng(startcol), CLng(startrow), CLng(endcol), CLng(endrow), filename_in(0), filename_out(0), CDbl(win_info(i).pan_x), CDbl(win_info(i).pan_y), CLng(win_h), CLng(Win_w), CLng(image_info(i).sub_width)) ElseIf image_info(i).Color = 0 Then Call create_BW_bmp(i, startcol, startrow, endcol, endrow, "c:\data\pic" & CStr(i) & ".bmp", win_info(i).pan_x, win_info(i).pan_y) End If Rem Load the image Form1.Picture1(i).Picture = LoadPicture("c:\data\pic" & CStr(i) & ".bmp") Label10.Caption = CStr(i + 1) & "/" & CStr(NumOfImages) & " images read" Form1.MousePointer = 1 DoEvents Rem Make the R-matrix for image i Call r_transform_matrix(i) Rem Make the picture-box visible Form1.Picture1(i).Enabled = True Form1.Picture1(i).Visible = True Rem Next image Rem Assign values to X_start (if space intersection failes this will became the initial solution) X_start = CStr(image_info(0).Xo + 5#) Y_start = CStr(image_info(0).Yo + 2#) Z_start = CStr(200#) Rem cen-point is for panning the images at the wanted XYZ-point X_cen = X_start Y_cen = Y_start Z_cen = Z_start Rem Make the mousepointer into an arrow Form1.MousePointer = 1 initialize = True Rem Exit not to run the error-handling code Exit Sub Rem Error handling section Error_in_adding_to_a_set: Form1.MousePointer = 1 MsgBox ("An error ocurred in Open_a_set_Click_Routine") Close (1) Exit Sub End Sub Public Sub Remove_all_images() RemoveAll: NumOfImages = 0 LastImageClicked = -1 Call set_window_sizes Call Place_Objects_On_The_Main_Form SolutionExists = False Form1.Label10.Caption = "Removed all images from the set succesfully" End Sub Public Sub Create_LiDAR_Surface() Dim NHA As Long Get #100, , NHA If NHA = 0 Then Exit Sub ReDim Lidr(1 To NHA) As LidarRecord Dim H_arr(0 To 200, 0 To 200, 40) As Single Dim Int_arr(0 To 200, 0 To 200, 40) As Single Dim Sum_arr(0 To 200, 0 To 200) As Byte Get #100, 1, NHA Get #100, 5, Lidr For k = 1 To NHA For l = 1 To 4 col = Int((Lidr(k).Returns(l).X - 2516900) / 0.5) row = Int((Lidr(k).Returns(l).Y - 6858400) / 0.5) If col >= 0 And col <= 200 And row >= 0 And row <= 200 Then Sum_arr(col, row) = Sum_arr(col, row) + 1 j = Sum_arr(col, row) Zmaaf = Lidr(k).Returns(l).z - getheight(Lidr(k).Returns(l).X, Lidr(k).Returns(l).Y) 'H_arr(col, row, j) = Zmaaf Exit Sub If Zmaaf > H_arr(col, row, 40) Then H_arr(col, row, 40) = Zmaaf ' max H End If Next l Next k ReDim Hmax(0 To 200, 0 To 200) As Single For i = 0 To 200 For j = 0 To 200 Hmax(i, j) = H_arr(i, j, 40) Next j Next i Open "c:\temp\Hmax_100m_100m_200_200_Single_2516900_6858400.raw" For Binary As 101 Put #101, , Hmax Close (100) Close (101) End Sub Public Sub Get_value_from_16_byte_image(ImaNum As Long, X As Double, Y As Double, z As Double, additnum As Long, PointNum As Integer, imdata As RGBNIR, Pan_mean As Double, Pan_Max As Double, Pan_Min As Double, Pan_SD As Double) Rem Dim p_x As Double Dim p_y As Double Call r_transform_ground_to_pixel(ImaNum, X, Y, z, p_x, p_y) p_y = (image_info(ImaNum).Height - 1) - p_y p_x = Int(p_x * (image_info(ImaNum).AdditWidth(additnum) / image_info(ImaNum).Width)) p_y = Int(p_y * (image_info(ImaNum).AdditHeight(additnum) / image_info(ImaNum).Height)) On Error Resume Next Open image_info(ImaNum).AdditFileName(2) For Binary As 20 Rem Find right pixel values from 16-bit RGBIR-image 3680 x 2400 Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2, imdata.r Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 2, imdata.G Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 4, imdata.B Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 6, imdata.NIR Close (20) Rem Find right pixel values from 16-bit BW-image 11500 x 7500 Sum = 0 Dim Min As Long, Max As Long ReDim Pan_Win(1 To 3, 1 To 3) As Integer Pan_Min = 32000 Pan_Max = 0 Open image_info(ImaNum).AdditFileName(1) For Binary As 20 additnum = 1 For j = -1 To 1 For k = -1 To 1 Get #20, 1 + (p_y + k) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x + j) * 2, Pan_Win(j + 2, k + 2) Sum = Sum + CDbl(Pan_Win(j + 2, k + 2)) If Pan_Win(j + 2, k + 2) > Pan_Max Then Pan_Max = Pan_Win(j + 2, k + 2) If Pan_Win(j + 2, k + 2) < Pan_Min Then Pan_Min = Pan_Win(j + 2, k + 2) Next k Next j Pan_mean = Sum / 9# Rem Compute SD of PAN values Sum = 0 For j = -1 To 1 For k = -1 To 1 Sum = Sum + CDbl(Pan_Win(j + 2, k + 2) - Pan_mean) ^ 2 Next k Next j Pan_SD = Sqr(Sum / 8#) Close (20) End Sub Public Sub Geti_value_from_16_byte_image(ImaNum As Long, X As Double, Y As Double, z As Double, additnum As Long, imdata As RGBNIRPAN) Dim p_x As Double, p_y As Double Call r_transform_ground_to_pixel(ImaNum, X, Y, z, p_x, p_y) p_y = (image_info(ImaNum).Height - 1) - p_y p_x = Int(p_x * (image_info(ImaNum).AdditWidth(additnum) / image_info(ImaNum).Width)) p_y = Int(p_y * (image_info(ImaNum).AdditHeight(additnum) / image_info(ImaNum).Height)) Open image_info(ImaNum).AdditFileName(additnum) For Binary As 20 Rem Find right pixel values from 16-bit RGBIR-image 3680 x 2400 If image_info(ImaNum).AdditType(additnum) = 3 Then Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2, imdata.r Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 2, imdata.G Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 4, imdata.B Get #20, 1 + ((p_y) * 4) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 4 * 2 + 6, imdata.NIR If imdata.r < 1 Then MsgBox ("!") Close (20) Exit Sub End If Rem Find right pixel values from 16-bit BW-image 11500 x 7500 Dim Min As Long, Max As Long If image_info(ImaNum).AdditType(additnum) = 2 Then Get #20, 1 + (p_y) * image_info(ImaNum).AdditWidth(additnum) * 2 + (p_x) * 2, imdata.PAN End If Close (20) End Sub Public Sub MOMENTS(data() As Double, N As Long, ave As Double, adev As Double, sdev As Double, var As Double, skew As Double, curt As Double) Dim j As Long Dim ep As Double, s As Double, P As Double ep = 0# If (N <= 1) Then Exit Sub s = 0# For j = 1 To N s = s + data(j) Next j ave = s / N adev = 0 var = 0 skew = 0 curt = 0 For j = 1 To N s = data(j) - ave adev = adev + Abs(data(j) - (ave)) P = s * s var = var + P P = P * s skew = skew + P P = P * s curt = curt + P Next j adev = adev / N var = (var - ep * ep / N) / (N - 1) sdev = Sqr(var) If (var <> 0) Then skew = skew / (N * (var) * (sdev)) curt = (curt) / (N * (var) * (var)) - 3# Else kurt = -99 skew = -99 End If End Sub Public Sub MOMENTIT(data() As Double, N As Long, ByRef mean As Double, ByRef stdev As Double) If (N <= 1) Then Exit Sub Sum = 0 sum2 = 0 For j = 1 To N Sum = Sum + data(j) Next j ave = Sum / N mean = CDbl(ave) For j = 1 To N sum2 = sum2 + (data(j) - ave) ^ 2 Next j ave2 = sum2 / N stdev = CDbl(Sqr(ave2)) End Sub Public Sub INSTRUCT_MOMENTS(data() As IntStruct, N As Long, ave As IntStruct, adev As IntStruct, sdev As IntStruct, var As IntStruct, skew As IntStruct, curt As IntStruct) Dim j As Long Dim ep As Double, s As IntStruct, P As IntStruct ep = 0# If (N <= 1) Then Exit Sub s.IntRaw = 0# s.IntRange = 0# s.IntFused = 0# For j = 1 To N s.IntRaw = s.IntRaw + data(j).IntRaw s.IntRange = s.IntRange + data(j).IntRange s.IntFused = s.IntFused + data(j).IntFused Next j ave.IntRaw = s.IntRaw / N: ave.IntRange = s.IntRange / N: ave.IntFused = s.IntFused / N adev.IntRaw = 0: adev.IntRange = 0: adev.IntFused = 0 var.IntRaw = 0: var.IntRange = 0: var.IntFused = 0 skew.IntRaw = 0: skew.IntRange = 0: skew.IntFused = 0: curt.IntRaw = 0: curt.IntRange = 0: curt.IntFused = 0 For j = 1 To N s.IntRaw = data(j).IntRaw - ave.IntRaw: s.IntRange = data(j).IntRange - ave.IntRange: s.IntFused = data(j).IntFused - ave.IntFused adev.IntRaw = adev.IntRaw + Abs(data(j).IntRaw - (ave.IntRaw)): adev.IntRange = adev.IntRange + Abs(data(j).IntRange - (ave.IntRange)): adev.IntFused = adev.IntFused + Abs(data(j).IntFused - (ave.IntFused)) P.IntRaw = s.IntRaw * s.IntRaw: P.IntRange = s.IntRange * s.IntRange: P.IntFused = s.IntFused * s.IntFused var.IntRaw = var.IntRaw + P.IntRaw: var.IntRange = var.IntRange + P.IntRange: var.IntFused = var.IntFused + P.IntFused P.IntRaw = P.IntRaw * s.IntRaw: P.IntRange = P.IntRange * s.IntRange: P.IntFused = P.IntFused * s.IntFused skew.IntRaw = skew.IntRaw + P.IntRaw: skew.IntRange = skew.IntRange + P.IntRange: skew.IntFused = skew.IntFused + P.IntFused P.IntRaw = P.IntRaw * s.IntRaw: P.IntRange = P.IntRange * s.IntRange: P.IntFused = P.IntFused * s.IntFused curt.IntRaw = curt.IntRaw + P.IntRaw: curt.IntRange = curt.IntRange + P.IntRange: curt.IntFused = curt.IntFused + P.IntFused Next j adev.IntRaw = adev.IntRaw / N: adev.IntRange = adev.IntRange / N: adev.IntFused = adev.IntFused / N var.IntRaw = (var.IntRaw - ep * ep / N) / (N - 1): var.IntRange = (var.IntRange - ep * ep / N) / (N - 1): var.IntFused = (var.IntFused - ep * ep / N) / (N - 1) sdev.IntRaw = Sqr(var.IntRaw): sdev.IntRange = Sqr(var.IntRange): sdev.IntFused = Sqr(var.IntFused) If (var.IntRaw <> 0) Then skew.IntRaw = skew.IntRaw / (N * (var.IntRaw) * (sdev.IntRaw)) curt.IntRaw = (curt.IntRaw) / (N * (var.IntRaw) * (var.IntRaw)) - 3# Else curt.IntRaw = -99 skew.IntRaw = -99 End If If (var.IntRange <> 0) Then skew.IntRange = skew.IntRange / (N * (var.IntRange) * (sdev.IntRange)) curt.IntRange = (curt.IntRange) / (N * (var.IntRange) * (var.IntRange)) - 3# Else curt.IntRange = -99 skew.IntRange = -99 End If If (var.IntFused <> 0) Then skew.IntFused = skew.IntFused / (N * (var.IntFused) * (sdev.IntFused)) curt.IntFused = (curt.IntFused) / (N * (var.IntFused) * (var.IntFused)) - 3# Else curt.IntFused = -99 skew.IntFused = -99 End If End Sub Public Sub LiDAR_Features(data() As IntStruct, N As Long, TreeH As Double, Hscale As Double, rmse As Double, Res As ResultStruct) Rem This routine computes the height deciles (min, 1, 2, 9, max) Rem Mean and SD of intensities for the whole crown; and the near surface hits If N < 2 Then Exit Sub ReDim IntRaw(1 To N) As Single ReDim IntRange(1 To N) As Single ReDim IntFused(1 To N) As Single ReDim d_intraw(1 To N) As Double ReDim d_IntRange(1 To N) As Double ReDim d_IntFused(1 To N) As Double ReDim SurfIntraw(1 To N) As Double ReDim SurfIntrange(1 To N) As Double ReDim SurfIntfused(1 To N) As Double ReDim IDXRaw(1 To N) As Long ReDim IDXRange(1 To N) As Long ReDim IDXFused(1 To N) As Long ReDim heights(1 To N) As Single ReDim IDXHeights(1 To N) As Long N_surf = 0 For i = 1 To N IntRaw(i) = data(i).IntRaw IntRange(i) = data(i).IntRange IntFused(i) = data(i).IntFused d_intraw(i) = data(i).IntRaw d_IntRange(i) = data(i).IntRange d_IntFused(i) = data(i).IntFused If (Abs(data(i).XYdist) < 1.2 * rmse) Then Nsurf = Nsurf + 1 SurfIntraw(Nsurf) = data(i).IntRaw SurfIntrange(Nsurf) = data(i).IntRange SurfIntfused(Nsurf) = data(i).IntFused End If heights(i) = data(i).Zdist Next i Res.p_surface = (Nsurf / N) Call indexx(N, IntRaw, IDXRaw) Call indexx(N, IntRange, IDXRange) Call indexx(N, IntFused, IDXFused) Call indexx(N, heights, IDXHeights) Dim ave As Double, adev As Double, sdev As Double, var As Double, skew As Double, curt As Double Call MOMENTS(SurfIntrange(), CLng(Nsurf), ave, adev, sdev, var, skew, curt) Res.mean_surface.IntRange = ave Res.SD_surface.IntRange = sdev Res.curt_surface.IntRange = curt Res.skew_surface.IntRange = skew ReDim Ps(1 To 10) As Integer, Int_ps(1 To 10) As IntStruct ReDim H_ps(1 To 10) As Double, psh(1 To 10) As Integer ReDim layersum(1 To 10) As Double ReDim layers(0 To 10) As Double layers(0) = 0: For i = 1 To 10 layers(i) = (1 - Hscale) / 10 * i Next i For i = 1 To N For k = 1 To 10 If heights(IDXHeights(i)) / Tree.H < layers(k) Then layersum(k) = layersum(k) + 1 End If Next k Next i Sum = 0 For k = 10 To 2 Step -1 layersum(k) = layersum(k) - layersum(k - 1) Sum = Sum + layersum(k) layers(k) = layersum(k) / N Next k Sum = Sum + layersum(1) layers(1) = layersum(1) / N For k = 1 To 10 Step 1 For i = k To 1 Step -1 Res.hd(k) = Res.hd(k) + layers(i) Next i Next k 'If Abs(Sum - N) > 1 Then MsgBox ("Problem in Routine LiDAR_features") Rem ******* INTENSITY/HEIGHT PERCENTILES *********** If N > 3 Then For k = 1 To 10 Ps(k) = CInt(k / 10# * N) Res.pint(k).IntRaw = IntRaw(IDXRaw(Ps(k))) Res.pint(k).IntRange = IntRange(IDXRange(Ps(k))) Res.pint(k).IntFused = IntFused(IDXFused(Ps(k))) Res.ph(k) = heights(IDXHeights(Ps(k))) / (Tree.H) Next k End If k_start = 1 Rem How many points in different layers Rem compute the average intensities in 25% sclices ReDim Ints(1 To 4) As Double ReDim kX(1 To 4) As Double kX(1) = 0: kX(2) = 0: kX(3) = 0: kX(4) = 0 For i = 1 To CInt(N) If heights(IDXHeights(i)) < 0.1 * TreeH Then Res.int1234(1).IntRaw = Res.int1234(1).IntRaw + IntRaw(IDXHeights(i)) Res.int1234(1).IntRange = Res.int1234(1).IntRange + IntRange(IDXHeights(i)) Res.int1234(1).IntFused = Res.int1234(1).IntFused + IntFused(IDXHeights(i)) kX(1) = kX(1) + 1 End If If heights(IDXHeights(i)) >= 0.1 * TreeH And heights(IDXHeights(i)) < 0.2 * TreeH Then Res.int1234(2).IntRaw = Res.int1234(2).IntRaw + IntRaw(IDXHeights(i)) Res.int1234(2).IntRange = Res.int1234(2).IntRange + IntRange(IDXHeights(i)) Res.int1234(2).IntFused = Res.int1234(2).IntFused + IntFused(IDXHeights(i)) kX(2) = kX(2) + 1 End If If heights(IDXHeights(i)) >= 0.2 * TreeH And heights(IDXHeights(i)) < 0.3 * TreeH Then Res.int1234(3).IntRaw = Res.int1234(3).IntRaw + IntRaw(IDXHeights(i)) Res.int1234(3).IntRange = Res.int1234(3).IntRange + IntRange(IDXHeights(i)) Res.int1234(3).IntFused = Res.int1234(3).IntFused + IntFused(IDXHeights(i)) kX(3) = kX(3) + 1 End If If heights(IDXHeights(i)) >= 0.3 * TreeH Then Res.int1234(4).IntRaw = Res.int1234(4).IntRaw + IntRaw(IDXHeights(i)) Res.int1234(4).IntRange = Res.int1234(4).IntRange + IntRange(IDXHeights(i)) Res.int1234(4).IntFused = Res.int1234(4).IntFused + IntFused(IDXHeights(i)) kX(4) = kX(4) + 1 End If Next i For i = 1 To 4 If kX(i) <> 0 Then Res.int1234(i).IntRaw = Res.int1234(i).IntRaw / kX(i) Res.int1234(i).IntRange = Res.int1234(i).IntRange / kX(i) Res.int1234(i).IntFused = Res.int1234(i).IntFused / kX(i) End If Next i End Sub Public Sub Print_LiDAR_Header(sens As String, echo As String) c_var = sens & echo & "cr_mean_IRaw," & sens & echo & "cr_mean_IRan," & sens & echo & "cr_mean_IFus," c_var = c_var & sens & echo & "cr_sdev_IRaw," & sens & echo & "cr_sdev_IRan," & sens & echo & "cr_sdev_IFus," c_var = c_var & sens & echo & "cr_skew_IRaw," & sens & echo & "cr_skew_IRan," & sens & echo & "cr_skew_IFus," c_var = c_var & sens & echo & "cr_kurt_IRaw," & sens & echo & "cr_kurt_IRan," & sens & echo & "cr_kurt_IFus," c_var = c_var & sens & echo & "su_p_NULL," & sens & echo & "cr_n_NULL," c_var = c_var & sens & echo & "su_mean_IRan," & sens & echo & "su_sdev_IRan," & sens & echo & "su_skew_IRan," & sens & echo & "su_kurt_IRan," c_var = c_var & sens & echo & "u1_mean_IRaw," & sens & echo & "u2_mean_IRaw," & sens & echo & "u3_mean_IRaw," & sens & echo & "u4_mean_IRaw," c_var = c_var & sens & echo & "u1_mean_IRan," & sens & echo & "u2_mean_IRan," & sens & echo & "u3_mean_IRan," & sens & echo & "u4_mean_IRan," c_var = c_var & sens & echo & "u1_mean_IFus," & sens & echo & "u2_mean_IFus," & sens & echo & "u3_mean_IFus," & sens & echo & "u4_mean_IFus," For i = 1 To 10 c_var = c_var & sens & echo & "cr_dd" & Format$(i, "0") & "_h," Next i For i = 1 To 10 c_var = c_var & sens & echo & "cr_d" & Format$(i, "0") & "_h," Next i For i = 1 To 10 c_var = c_var & sens & echo & "cr_d" & Format$(i, "0") & "_IRaw," & sens & echo & "cr_d" & Format$(i, "0") & "_IRan," & sens & echo & "cr_d" & Format$(i, "0") & "_IFus," Next i Open "c:\temp\" & sens & echo & "data.txt" For Append As 111 Print #111, c_var c_var = "" Close (111) End Sub Public Sub Print_Lidar_Features(N As Long, sens As String, echo As String, c_var As String, ccpu As String, ave As IntStruct, adev As IntStruct, sdev As IntStruct, var As IntStruct, skew As IntStruct, curt As IntStruct, Res As ResultStruct) 'If N < 4 Then MsgBox ("Just 4 points?") ccpu = ccpu & Format$(ave.IntRaw, "0.0") & "," & Format$(ave.IntRange, "0.0") & "," & Format$(ave.IntFused, "0.0") & "," ccpu = ccpu & Format$(sdev.IntRaw, "0.0") & "," & Format$(sdev.IntRange, "0.0") & "," & Format$(sdev.IntFused, "0.0") & "," ccpu = ccpu & Format$(skew.IntRaw, "0.000") & "," & Format$(skew.IntRange, "0.000") & "," & Format$(skew.IntFused, "0.000") & "," ccpu = ccpu & Format$(curt.IntRaw, "0.000") & "," & Format$(curt.IntRange, "0.000") & "," & Format$(curt.IntFused, "0.000") & "," ccpu = ccpu & Format$(Res.p_surface, "0.000") & "," & Format$(N, "0") & "," ccpu = ccpu & Format$(Res.mean_surface.IntRange, "0.0") & "," & Format$(Res.SD_surface.IntRange, "0.0") & "," & Format$(Res.curt_surface.IntRange, "0.000") & "," & Format$(Res.skew_surface.IntRange, "0.000") & "," ccpu = ccpu & Format$(Res.int1234(1).IntRaw, "0.0") & "," & Format$(Res.int1234(2).IntRaw, "0.0") & "," & Format$(Res.int1234(3).IntRaw, "0.0") & "," & Format$(Res.int1234(4).IntRaw, "0.0") & "," ccpu = ccpu & Format$(Res.int1234(1).IntRange, "0.0") & "," & Format$(Res.int1234(2).IntRange, "0.0") & "," & Format$(Res.int1234(3).IntRange, "0.0") & "," & Format$(Res.int1234(4).IntRange, "0.0") & "," ccpu = ccpu & Format$(Res.int1234(1).IntFused, "0.0") & "," & Format$(Res.int1234(2).IntFused, "0.0") & "," & Format$(Res.int1234(3).IntFused, "0.0") & "," & Format$(Res.int1234(4).IntFused, "0.0") & "," For i = 1 To 10 ccpu = ccpu & Format$(Res.hd(i), "0.000") & "," Next i For i = 1 To 10 ccpu = ccpu & Format$(Res.ph(i), "0.0000") & "," Next i For i = 1 To 10 ccpu = ccpu & Format$(Res.pint(i).IntRaw, "0.0") & "," ccpu = ccpu & Format$(Res.pint(i).IntRange, "0.0") & "," ccpu = ccpu & Format$(Res.pint(i).IntFused, "0.0") & "," Next i Open "c:\temp\" & sens & echo & "data.txt" For Append As 111 Print #111, ccpu ccpu = "" Close (111) End Sub Public Sub Find_images_for_a_Riegl_pulse(k As Long, X_dir As Double, Y_dir As Double, Z_dir As Double, X_lid As Double, Y_lid As Double, Z_lid As Double, xp As Double, yp As Double, zp As Double, echocount As Byte, intensity As Byte, AGC As Byte, Fileoffset As Long, range As Single, wavetype As Integer, FileO As String) 'Open "c:\data\LK3_cam_data.csv" For Input As 1 'Open "c:\data\A1_cam_data.csv" For Input As 1 Open "c:\data\A2_cam_data.csv" For Input As 1 Dim N_image As Long Dim C_image As String ReDim Ar(1 To 3, 1 To 3) As Double Dim hdrname As String Dim k_ As Double ' inverse of this number is the scale factor Dim vec1 As Vector3D, vec2 As Vector3D vec1.X = 0: vec1.Y = 0: vec1.z = -1000 vec2.X = X_dir: vec2.Y = Y_dir: vec2.z = Z_dir 'On Error Resume Next Do Until EOF(1) Input #1, N_image, Ndummy, c_, omega, phi, kappa, Xo, Yo, Zo, C_image, hdrname, c_year Ar(1, 1) = Cos(phi) * Cos(kappa): Ar(1, 2) = -Cos(phi) * Sin(kappa): Ar(1, 3) = Sin(phi) Ar(2, 1) = Cos(omega) * Sin(kappa) + Sin(omega) * Sin(phi) * Cos(kappa) Ar(2, 2) = Cos(omega) * Cos(kappa) - Sin(omega) * Sin(phi) * Sin(kappa) Ar(2, 3) = -Sin(omega) * Cos(phi) Ar(3, 1) = Sin(omega) * Sin(kappa) - Cos(omega) * Sin(phi) * Cos(kappa) Ar(3, 2) = Sin(omega) * Cos(kappa) + Cos(omega) * Sin(phi) * Sin(kappa) Ar(3, 3) = Cos(omega) * Cos(phi) Rem check that the camera is actually pointing up enough, +/- 15 degrees from the plumb line Dim cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D Dim ray As Vector3D, x1 As Vector3D, p_x As Double, p_y As Double p_x = 0# ' image center point (~ base of optical axis) p_y = 0# z = -c_ cam_vec_x.X = Ar(1, 1): cam_vec_x.Y = Ar(2, 1): cam_vec_x.z = Ar(3, 1) cam_vec_y.X = Ar(1, 2): cam_vec_y.Y = Ar(2, 2): cam_vec_y.z = Ar(3, 2) cam_vec_z.X = Ar(1, 3): cam_vec_z.Y = Ar(2, 3): cam_vec_z.z = Ar(3, 3) ray.X = p_x * cam_vec_x.X + p_y * cam_vec_y.X + z * cam_vec_z.X ray.Y = p_x * cam_vec_x.Y + p_y * cam_vec_y.Y + z * cam_vec_z.Y ray.z = p_x * cam_vec_x.z + p_y * cam_vec_y.z + z * cam_vec_z.z x1.X = image_info(Index).Xo: x1.Y = image_info(Index).Yo: x1.z = image_info(Index).Zo Dim plumb As Vector3D plumb.X = 0: plumb.Y = 0: plumb.z = 1 apu = TO_DEGREES * vector_angle(ray, plumb) If apu > 20 Then GoTo DoneWithThisIma: ' oblique image len_to_cam = (Zo - Z_lid) / Z_dir pulse_X = X_lid + X_dir * len_to_cam Pulse_Y = Y_lid + Y_dir * len_to_cam Pulse_Z = Z_lid + Z_dir * len_to_cam Xhit = pulse_X Yhit = Pulse_Y Zhit = Pulse_Z XYdist = Sqr((Xo - pulse_X) ^ 2 + (Yo - Pulse_Y) ^ 2) If XYdist > 0.5 Then GoTo DoneWithThisIma If (c_ <> 0#) Then k_ = (Ar(1, 3) * (xp - Xo) + Ar(2, 3) * (yp - Yo) + Ar(3, 3) * (zp - Zo)) Else k_ = 0# End If If (k_ <> 0) Then p_x = -c_ * (Ar(1, 1) * (xp - Xo) + Ar(2, 1) * (yp - Yo) + Ar(3, 1) * (zp - Zo)) / k_ p_y = -c_ * (Ar(1, 2) * (xp - Xo) + Ar(2, 2) * (yp - Yo) + Ar(3, 2) * (zp - Zo)) / k_ Else p_x = p_y = 0# End If Rem Camera D300 4288 x 3042, 5.5 um pixels Rem canon has 3072 x 2304, 2.3 um pixels If c_ < 0.008 Then xmin = 0.0000023 * 3072 / 2 Ymin = 0.0000023 * 2304 / 2 End If If c_ > 0.008 Then xmin = 0.0000055 * 4288 / 2 Ymin = 0.0000055 * 3042 / 2 End If If p_x > -xmin And p_x < xmin And p_y > -Ymin And p_y < Ymin Then GoTo Hit Else: GoTo DoneWithThisIma End If Hit: ReDim Wave(1 To wavetype) As Integer Open FileO For Binary As 100 Get #100, 1 + Fileoffset, Wave Close (100) apu = TO_DEGREES * vector_angle(vec1, vec2) Pointer = 0 If wavetype > 0 Then If wavetype <> 80 And wavetype <> 160 Then MsgBox (wavetype) Open "c:\data\imafiles\A2_2011b_waves.bin" For Binary As 111 Dim Npulses As Long Get #111, 1, Npulses Put #111, 5 + (Npulses * 4 + Npulses * (2 * 160)), CLng(k) ' store every pulse in space of 324 bytes Pointer = 5 + (4 + Npulses * (2 * 160 + 4)) Put #111, 5 + (4 + Npulses * (2 * 160 + 4)), Wave Npulses = Npulses + 1 Put #111, 1, Npulses Close (111) End If Open "c:\data\ImaFiles\A2_2011b_pulses.txt" For Append As 2 capu = "" capu = k & "," capu = capu & echocount & "," capu = capu & N_image & "," capu = capu & hdrname & "," capu = capu & Format$(p_x, "0.000000") & "," capu = capu & Format$(p_y, "0.000000") & "," capu = capu & Format$(apu, "0.00") & "," capu = capu & Format$(intensity, "0") & "," capu = capu & Format$(AGC, "0") & "," capu = capu & Format$(X_lid, "0.00") & "," capu = capu & Format$(Y_lid, "0.00") & "," capu = capu & Format$(Z_lid, "0.00") & "," capu = capu & Format$(xp, "0.00") & "," capu = capu & Format$(yp, "0.00") & "," capu = capu & Format$(zp, "0.00") & "," capu = capu & Format$(Xhit, "0.00") & "," capu = capu & Format$(Yhit, "0.00") & "," capu = capu & Format$(Zhit, "0.00") & "," capu = capu & Format$(Xo, "0.00") & "," capu = capu & Format$(Yo, "0.00") & "," capu = capu & Format$(Zo, "0.00") & "," capu = capu & Format$(range, "0.00") & "," capu = capu & Format$(wavetype, "0") & "," capu = capu & Format$(Pointer, "0") Print #2, capu Close (2) DoneWithThisIma: Loop Close (1) End Sub Public Sub find_images_for_a_point() Rem April 22, 2014. This routine finds appropriate images to be dispaleyd for a particular treetop (point) Dim N_image As Long, C_image As String ReDim Ar(1 To 3, 1 To 3) As Double Dim p_x As Double, p_y As Double Dim hdrname As String, k As Double 'Open "c:\data\cam_data_2012_2013.csv" For Input As 22 Open "c:\data\cam_data.csv" For Input As 22 'Open "c:\data\cam_data_Siika.csv" For Input As 22 selection = False ' restrict or all 'Exit Sub On Error Resume Next Kill "c:\data\Imafiles\*.txt" 'On Error GoTo virhe Do Until EOF(22) 'Exit Sub§ Input #22, N_image, Ndummy, c_, omega, phi, kappa, Xo, Yo, Zo, C_image, hdrname, c_year Open hdrname For Input As 1 If selection = True Then If c_year < 2012 Then GoTo DoneWithThisIma End If Call read_set_file_for_an_image(100) Close (1) Close (3) Call r_transform_ground_to_pixel(100, X_sol, Y_sol, Z_sol, p_x, p_y) virhe: 'If Ntimes > 3 And c_year = 2012 Then GoTo DoneWithThisIma If p_x > (image_info(100).Width * 0.2) And p_x < (image_info(100).Width * 0.8) And p_y > (image_info(100).Height * 0.2) And p_y < (image_info(100).Height * 0.8) Then Open "c:\data\ImaFiles\" & c_year & "_" & C_image & ".txt" For Output As 3 Print #3, N_image & "," & hdrname & ","; X_sol & "," & Y_sol & "," & Z_sol Ntimes = Ntimes + 1 Close (3) Call Open_An_image_and_Center_to_XYZ("c:\data\ImaFiles\" & c_year & "_" & C_image & ".txt") If selection = True And Ntimes = 6 Then Exit Do 'End If End If DoneWithThisIma: Loop Close (22) If selection = False Then MsgBox ("Written " & Ntimes & " files in c:\Data\Imafiles") End Sub Public Sub Find_images_for_a_pulse(k As Long, X_dir As Double, Y_dir As Double, Z_dir As Double, X_lid As Double, Y_lid As Double, Z_lid As Double, xp As Double, yp As Double, zp As Double, echocount As Byte, intensity As Byte, AGC As Byte, Fileoffset As Long, range As Double, wavetype As Byte, FileO As String) '(k, Pt.X, Pt.Y, Pt.z, LidR2010(k).PosLiDAR.X, LidR2010(k).PosLiDAR.Y, LidR2010(k).PosLiDAR.z) Rem k is the index for the pulse 'Open "c:\data\LK3_cam_data.csv" For Input As 1 'Open "c:\data\A1_cam_data.csv" For Input As 1 Open "c:\data\A2_cam_data.csv" For Input As 1 Dim N_image As Long Dim C_image As String ReDim Ar(1 To 3, 1 To 3) As Double Dim hdrname As String Dim k_ As Double ' inverse of this number is the scale factor Dim vec1 As Vector3D, vec2 As Vector3D vec1.X = 0: vec1.Y = 0: vec1.z = -1000 vec2.X = X_dir: vec2.Y = Y_dir: vec2.z = Z_dir 'On Error Resume Next Do Until EOF(1) Input #1, N_image, Ndummy, c_, omega, phi, kappa, Xo, Yo, Zo, C_image, hdrname, c_year Ar(1, 1) = Cos(phi) * Cos(kappa): Ar(1, 2) = -Cos(phi) * Sin(kappa): Ar(1, 3) = Sin(phi) Ar(2, 1) = Cos(omega) * Sin(kappa) + Sin(omega) * Sin(phi) * Cos(kappa) Ar(2, 2) = Cos(omega) * Cos(kappa) - Sin(omega) * Sin(phi) * Sin(kappa) Ar(2, 3) = -Sin(omega) * Cos(phi) Ar(3, 1) = Sin(omega) * Sin(kappa) - Cos(omega) * Sin(phi) * Cos(kappa) Ar(3, 2) = Sin(omega) * Cos(kappa) + Cos(omega) * Sin(phi) * Sin(kappa) Ar(3, 3) = Cos(omega) * Cos(phi) Rem check that the camera is actually pointing up enough, +/- 15 degrees from the plumb line Dim cam_vec_x As Vector3D, cam_vec_y As Vector3D, cam_vec_z As Vector3D Dim ray As Vector3D, x1 As Vector3D, p_x As Double, p_y As Double p_x = 0# ' image center point (~ base of optical axis) p_y = 0# z = -c_ cam_vec_x.X = Ar(1, 1): cam_vec_x.Y = Ar(2, 1): cam_vec_x.z = Ar(3, 1) cam_vec_y.X = Ar(1, 2): cam_vec_y.Y = Ar(2, 2): cam_vec_y.z = Ar(3, 2) cam_vec_z.X = Ar(1, 3): cam_vec_z.Y = Ar(2, 3): cam_vec_z.z = Ar(3, 3) ray.X = p_x * cam_vec_x.X + p_y * cam_vec_y.X + z * cam_vec_z.X ray.Y = p_x * cam_vec_x.Y + p_y * cam_vec_y.Y + z * cam_vec_z.Y ray.z = p_x * cam_vec_x.z + p_y * cam_vec_y.z + z * cam_vec_z.z x1.X = image_info(Index).Xo: x1.Y = image_info(Index).Yo: x1.z = image_info(Index).Zo Dim plumb As Vector3D plumb.X = 0: plumb.Y = 0: plumb.z = 1 apu = TO_DEGREES * vector_angle(ray, plumb) If apu > 20 Then GoTo DoneWithThisIma: ' oblique image len_to_cam = (Zo - Z_lid) / Z_dir pulse_X = X_lid + X_dir * len_to_cam Pulse_Y = Y_lid + Y_dir * len_to_cam Pulse_Z = Z_lid + Z_dir * len_to_cam Xhit = pulse_X Yhit = Pulse_Y Zhit = Pulse_Z XYdist = Sqr((Xo - pulse_X) ^ 2 + (Yo - Pulse_Y) ^ 2) If XYdist > 0.5 Then GoTo DoneWithThisIma If (c_ <> 0#) Then k_ = (Ar(1, 3) * (xp - Xo) + Ar(2, 3) * (yp - Yo) + Ar(3, 3) * (zp - Zo)) Else k_ = 0# End If If (k_ <> 0) Then p_x = -c_ * (Ar(1, 1) * (xp - Xo) + Ar(2, 1) * (yp - Yo) + Ar(3, 1) * (zp - Zo)) / k_ p_y = -c_ * (Ar(1, 2) * (xp - Xo) + Ar(2, 2) * (yp - Yo) + Ar(3, 2) * (zp - Zo)) / k_ Else p_x = p_y = 0# End If Rem Camera D300 4288 x 3042, 5.5 um pixels Rem canon has 3072 x 2304, 2.3 um pixels If c_ < 0.008 Then xmin = 0.0000023 * 3072 / 2 Ymin = 0.0000023 * 2304 / 2 End If If c_ > 0.008 Then xmin = 0.0000055 * 4288 / 2 Ymin = 0.0000055 * 3042 / 2 End If If p_x > -xmin And p_x < xmin And p_y > -Ymin And p_y < Ymin Then GoTo Hit Else: GoTo DoneWithThisIma End If Hit: If wavetype = 255 Then ReDim Wave(1 To 256) As Byte If wavetype = 127 Then ReDim Wave(1 To 128) As Byte Open FileO For Binary As 100 Get #100, 1 + Fileoffset, Wave Close (100) apu = TO_DEGREES * vector_angle(vec1, vec2) Pointer = 0 Dim Npulses As Long If wavetype = 255 Then Open "c:\data\imafiles\2011_A2_256_waves.bin" For Binary As 111 Get #111, 1, Npulses Put #111, 5 + (Npulses * 4 + Npulses * 256), CLng(k) Pointer = 5 + (4 + Npulses * 260) Put #111, 5 + (4 + Npulses * 260), Wave Npulses = Npulses + 1 Put #111, 1, Npulses Close (111) End If If wavetype = 127 Then Open "c:\data\imafiles\2011_A2_128_waves.bin" For Binary As 111 Get #111, 1, Npulses Put #111, 5 + (Npulses * 4 + Npulses * 128), CLng(k) Pointer = 5 + (4 + Npulses * 132) Put #111, 5 + (4 + Npulses * 132), Wave Npulses = Npulses + 1 Put #111, 1, Npulses Close (111) End If If wavetype > 0 Then Open "c:\data\ImaFiles\2011_A2_pulses.txt" For Append As 2 capu = "" capu = k & "," capu = capu & echocount & "," capu = capu & N_image & "," capu = capu & hdrname & "," capu = capu & Format$(p_x, "0.000000") & "," capu = capu & Format$(p_y, "0.000000") & "," capu = capu & Format$(apu, "0.00") & "," capu = capu & Format$(intensity, "0") & "," capu = capu & Format$(AGC, "0") & "," capu = capu & Format$(X_lid, "0.00") & "," capu = capu & Format$(Y_lid, "0.00") & "," capu = capu & Format$(Z_lid, "0.00") & "," capu = capu & Format$(xp, "0.00") & "," capu = capu & Format$(yp, "0.00") & "," capu = capu & Format$(zp, "0.00") & "," capu = capu & Format$(Xhit, "0.00") & "," capu = capu & Format$(Yhit, "0.00") & "," capu = capu & Format$(Zhit, "0.00") & "," capu = capu & Format$(Xo, "0.00") & "," capu = capu & Format$(Yo, "0.00") & "," capu = capu & Format$(Zo, "0.00") & "," capu = capu & Format$(range, "0.00") & "," capu = capu & Format$(wavetype, "0") & "," capu = capu & Format$(Pointer, "0") Print #2, capu Close (2) End If DoneWithThisIma: Loop Close (1) End Sub Public Sub Open_An_Image_For_Riegl_Footprint() Rem Nov 22, 2012. This routine walks thru a list of Riegl pulses & images to decied if the footprint is ok. The list has Rem the pulse geometry and a pointer to the waveform, if it exists. The Routine stores the pixels in the footprint. Rem Remome and add an image to the set. Dim startrow As Integer, startcol As Integer, endrow As Integer, endcol As Integer Dim i As Integer, length As Integer, j As Integer Dim FileOut As String Dim p_x As Double, p_y As Double Rem Set the Initialize Boolean To FALSE initialize = False Close (1) Open "c:\data\Imafiles\A2_2011b_pulses.txt" For Input As 1 Rem start from a particular index 'Measurement.num = 627 Rem ******** Parameters that change from site to site ***************** divergence = 0.0003 '* Sqr(2) binFilename = "A2_2011b_waves.bin" maxheight = 24 limitvalue = 30 + 24 / 0.15 acquisition_height = 750 Plot_code = "Spruce_60" 'Exit Sub If Measurement.num < 1 Then Measurement.num = 1 l = 0 Do Until EOF(1) l = l + 1 Input #1, PointNum, echocount, ImageId, HDRfilename, p_x, p_y, angle, intensity, AGC, Xl, yl, zl, xp, yp, zp, Xiht, Yhit, Zhit, Xo, Yo, Zo, Picos, wavetype, Pointer If l = Measurement.num And echocount > 0 Then Exit Do ' Accept the no the l'th row If l = Measurement.num And echocount < 1 Then Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped echo issues" & Measurement.num - 1 Close (1) Exit Sub End If Loop Close (1) If Pointer = 0 Then ' We do not examine pulses without a waveform Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped, no waveform" & Measurement.num - 1 Close (1) Exit Sub End If If (zp - getheight(xp, yp)) < 5 Then ' Too low Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped, too low " & Measurement.num - 1 Close (1) Exit Sub End If Measurement.num = Measurement.num + 1 Rem Set the solution with possible offsets dX = -0#: dY = 0# X_sol = xp + dX: Y_sol = yp + dY: Z_sol = zp Form1.Label4(0).Caption = Format$(X_sol, "#.000") Form1.Label4(1).Caption = Format$(Y_sol, "#.000") Form1.Label4(2).Caption = Format$(Z_sol, "#.000") h_above_gnd = zp - getheight(X_sol, Y_sol) Open HDRfilename For Input As 1 Call Remove_all_images NumOfImages = 1 Form1.MousePointer = 11 DoEvents Rem Code for getting the image on the screen ********************************** Call set_window_sizes i = NumOfImages - 1 Call read_set_file_for_an_image(CLng(i)) Call Check_parameter_sanity(i) Close (1) Call r_transform_matrix(i) Form1.MousePointer = 11 Form1.Label10.Caption = CStr(0) & "/" & CStr(NumOfImages) & " images read" DoEvents Call Place_Objects_On_The_Main_Form startrow = 0: startcol = 0 endrow = 0: endcol = 0 i = NumOfImages - 1 win_info(i).pan_x = 1 win_info(i).pan_y = 1 win_info(i).win_width = Win_w win_info(i).win_height = win_h SolutionExists = True Call center_to_xyz Rem ************ code stops here ************************************************ Rem Code that finds out a perpendicular 3D vector to the pulse vector, used for the 3D circle of the footprint Form1.Picture1(i).DrawWidth = 3 Dim abc As Vector3D, xyz As Vector3D, uvw As Vector3D, rvec As Vector3D, Pt As Vector3D Rem ******************************* abc.X = 0: abc.Y = 0: abc.z = 0 Rem Solve XY's for Z of the images, the ray is Pt.X = ((xp + dX) - Xl) Pt.Y = ((yp + dY) - yl) Pt.z = (zp - zl) length = Sqr(Pt.X ^ 2 + Pt.Y ^ 2 + Pt.z ^ 2) range = length rad = divergence * length / 2# ' footprint radius in meters First_Z = zp Dim LPe As Vector3D, PV As Vector3D Pt.X = Pt.X / length: Pt.Y = Pt.Y / length: Pt.z = Pt.z / length LPe.X = -Pt.X: LPe.Y = -Pt.Y: LPe.z = -Pt.z PV.X = 0: PV.z = 0.2 PV.Y = -(LPe.z * PV.z + LPe.X * PV.X) / LPe.Y LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) PV.X = (PV.X / LenPv) * rad: PV.Y = (PV.Y / LenPv) * rad: PV.z = (PV.z / LenPv) * rad DotP = (LPe.X * PV.X + LPe.Y * PV.Y + LPe.z * PV.z) LenLp = Sqr(LPe.X ^ 2 + LPe.Y ^ 2 + LPe.z ^ 2) LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) Pt.X = (xp + dX) Pt.Y = (yp + dY) Pt.z = (zp) i = 0 Form1.Picture1(0).ForeColor = RGB(255, 0, 0) Call r_transform_ground_to_pixel(0, xp + dX, yp + dY, zp, p_x, p_y) c_col = p_x - (image_info(i).o_row) c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) Dim mins As Point2D, maxs As Point2D mins.X = 10000000000#: mins.Y = 10000000000#: maxs.X = -10000000000#: maxs.Y = -10000000000# Form1.Picture1(i).DrawWidth = 3 For s = 0 To 2 * pi Step 0.1 Call rotate_xyz_about_vector_abc_uvw_by_S(PV, abc, LPe, CDbl(s), rvec) X = Pt.X + rvec.X Y = Pt.Y + rvec.Y z = Pt.z + rvec.z Call r_transform_ground_to_pixel(i, X, Y, z, p_x, p_y) p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 Colorpix = RGB(0, 255, 0) ' sets green If p_x > 0 And p_x < win_info(i).win_width And p_y > 0 And p_y < win_info(i).win_height Then Form1.Picture1(i).PSet (p_x, p_y), Colorpix ' draw the circle / footprint borders End If Next s Rem is the a waveform available, pointer at this point s.b. non-zero If Pointer > 0 Then Open "c:\data\imafiles\" & binFilename For Binary As 100 ReDim Wave(1 To wavetype) As Integer ' here notice this! Get #100, Pointer, Wave NoiseN = 1: NoiseSum = 2 ' we solve the noise level with the tail, there is none in short waveforms! For k = 1 To wavetype Form1.Picture1(0).PSet (k * 2, win_info(0).win_height - 25 - Wave(k)) If k > limitvalue Then NoiseSum = NoiseSum + Wave(k) NoiseN = NoiseN + 1 End If Next k kmax = Int(Picos / 1000) + 1 Form1.Picture1(0).DrawWidth = 5 Form1.Picture1(0).PSet (kmax * 2, win_info(0).win_height - 25 - Wave(kmax)), RGB(0, 255, 0) Form1.Picture1(0).DrawWidth = 3 Form1.Picture1(0).Line (1, win_info(0).win_height - 25 - NoiseSum / NoiseN)-(512, win_info(0).win_height - 25 - NoiseSum / NoiseN), RGB(0, 0, 255) Close (100) End If Rem COMPUTATION of PULSE Width Rem Compute length of first pulse, start from the max both ways until noiselevel + 2 is reached On Error Resume Next updone = False: lowdone = False wavesum = 0 For k = 1 To 100 If Wave(kmax + (k - 1)) > (NoiseSum / NoiseN + 3) And updone = False Then wavesum = wavesum + (Wave(kmax + (k - 1)) - (NoiseSum / NoiseN + 2)) k_up = kmax + k - 1 End If If Wave(kmax + k) < (NoiseSum / NoiseN + 2) Then updone = True If lowdone = False Then If Wave(kmax - (k + 1)) > (NoiseSum / NoiseN + 3) Then wavesum = wavesum + (Wave(kmax - (k + 1)) - (NoiseSum / NoiseN + 2)) k_down = kmax - (k + 1) End If End If If Wave(kmax - (k + 1)) < (NoiseSum / NoiseN + 3) Then lowdone = True End If If updone = True And lowdone = True Then Exit For Next k Form1.Picture1(0).DrawWidth = 5 Form1.Picture1(0).PSet (k_up * 2, win_info(0).win_height - 25 - Wave(k_up)), RGB(0, 255, 255) Form1.Picture1(0).PSet (k_down * 2, win_info(0).win_height - 25 - Wave(k_down)), RGB(0, 255, 255) Form1.Picture1(0).DrawWidth = 3 Form1.Picture1(0).FontSize = 15 If (k_up - k_down) * 0.15 < 4 Then Form1.Picture1(0).ForeColor = RGB(0, 255, 0) If (k_up - k_down) * 0.15 >= 4 And (k_up - k_down) * 0.15 < 5 Then Form1.Picture1(0).ForeColor = RGB(255, 255, 0) If (k_up - k_down) * 0.15 >= 5 Then Form1.Picture1(0).ForeColor = RGB(255, 25, 0) Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = 10 Form1.Picture1(0).Print Format$((k_up - k_down) * 0.15, "0.0 m") & " width wavesum: " & Format$(wavesum, "0.0") Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = 35 Form1.Picture1(0).Print Format$(intensity, "0 ") & Format$(Wave(kmax), "0 ") & " " & Format$(zp - getheight(xp, yp), "0.0 m") & " " & Format$(zl, "0.0 m") apu = MsgBox(echocount & " echoes, height: " & Format(h_above_gnd, "0.0 m") & "; accept for analyses?", vbYesNo) If apu = 7 Then ' Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped " & Measurement.num Exit Sub End If Rem Output the pulse data to a string ************************ capu = "" capu = capu & Plot_code & "," capu = capu & acquisition_height & "," capu = capu & PointNum & "," capu = capu & Pointer & "," capu = capu & intensity & "," capu = capu & AGC & "," capu = capu & Format$(zl, "0.0") & "," capu = capu & Format$(range, "0.0") & "," capu = capu & Wave(kmax) & "," capu = capu & Format$(wavesum, "0.0") & "," capu = capu & Format$((k_up - k_down) * 0.15, "0.0") Ncase = 0 dxx = 0 dyy = 0 ReDim th_apu(169) As String ' stores the silhouettes for each th and dx*dy combination (169) ReDim th_apu2(169) As String ' stores the silhouettes for each th and dx*dy combination (169), no weighting For dX = (-0.3 + dxx) To (0.31 + dxx) Step 0.05 For dY = (-0.3 + dyy) To (0.31 + dyy) Step 0.05 Ncase = Ncase + 1 abc.X = 0: abc.Y = 0: abc.z = 0 Rem Solve XY's for Z of the images, the ray is Pt.X = ((xp + dX) - Xl) Pt.Y = ((yp + dY) - yl) Pt.z = (zp - zl) length = Sqr(Pt.X ^ 2 + Pt.Y ^ 2 + Pt.z ^ 2) rad = divergence * length / 2# First_Z = zp Pt.X = Pt.X / length: Pt.Y = Pt.Y / length: Pt.z = Pt.z / length LPe.X = -Pt.X: LPe.Y = -Pt.Y: LPe.z = -Pt.z PV.X = 0: PV.z = 0.2 PV.Y = -(LPe.z * PV.z + LPe.X * PV.X) / LPe.Y LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) PV.X = (PV.X / LenPv) * rad: PV.Y = (PV.Y / LenPv) * rad: PV.z = (PV.z / LenPv) * rad DotP = (LPe.X * PV.X + LPe.Y * PV.Y + LPe.z * PV.z) LenLp = Sqr(LPe.X ^ 2 + LPe.Y ^ 2 + LPe.z ^ 2) LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) Pt.X = (xp + dX) Pt.Y = (yp + dY) Pt.z = (zp) i = 0 Form1.Picture1(0).ForeColor = RGB(255, 0, 0) Call r_transform_ground_to_pixel(0, xp + dX, yp + dY, zp, p_x, p_y) c_col = p_x - (image_info(i).o_row) c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) mins.X = 10000000000#: mins.Y = 10000000000#: maxs.X = -10000000000#: maxs.Y = -10000000000# Form1.Picture1(i).DrawWidth = 3 For s = 0 To 2 * pi Step 0.1 Call rotate_xyz_about_vector_abc_uvw_by_S(PV, abc, LPe, CDbl(s), rvec) X = Pt.X + rvec.X Y = Pt.Y + rvec.Y z = Pt.z + rvec.z Call r_transform_ground_to_pixel(i, X, Y, z, p_x, p_y) If p_x < mins.X Then mins.X = p_x If p_y < mins.Y Then mins.Y = p_y If p_x > maxs.X Then maxs.X = p_x If p_y > maxs.Y Then maxs.Y = p_y p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 Colorpix = RGB(0, 255, 0) If p_x > 0 And p_x < win_info(i).win_width And p_y > 0 And p_y < win_info(i).win_height Then Form1.Picture1(i).PSet (p_x, p_y), Colorpix End If Next s Form1.Picture1(i).DrawWidth = 3 maxrad = Max(maxs.X - mins.X, maxs.Y - mins.Y) Rem Now, let's have the threshold to take values in a loop Dim th As Long th_case = 0 For th = 250 To 149 Step -10 th_case = th_case + 1 If th_case = 1 Then th_apu(Ncase) = capu & "," & th & "," & Format$(dX, "0.00") & "," & Format$(dY, "0.00") & "," ' put the pulse info at the start and the threshold th_apu2(Ncase) = capu & "," & th & "," & Format$(dX, "0.00") & "," & Format$(dY, "0.00") & "," ' put the pulse info at the start and the threshold, no weight data End If ReDim bkuva(0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)), 0 To (CInt(c_row + maxrad / 2) - CInt(c_row - maxrad / 2))) As RGBtriplet Open image_info(0).FileName For Binary As 2 ReDim RROW(0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2))) As RGBtriplet cr = maxrad / 2 k = -1: Pixsum = 0: WpixSum = 0: InpixSum = 1 W0 = 1# / (Sqr(2) * (rad / 2)) * Exp(-(0) ^ 2 / (2 * (rad / 2) ^ 2)) For i = CInt(c_row - maxrad / 2) To CInt(c_row + maxrad / 2) k = k + 1 paikka = CLng(i) * CLng(image_info(0).sub_width) * 3 + CLng(CInt(c_col - maxrad / 2)) * 3 Get #2, paikka + 1, RROW() For m = 0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)) dist = Sqr((m - cr) ^ 2 + (k - cr) ^ 2) If dist < maxrad / 2 Then dist = dist * rad / (maxrad / 2) Pixsum = Pixsum + 1 bkuva(m, k).r = RROW(m).r bkuva(m, k).G = RROW(m).G bkuva(m, k).B = RROW(m).B If bkuva(m, k).B < th Then Weight = (1# / (Sqr(2) * (rad / 2)) * Exp(-(dist) ^ 2 / (2 * (rad / 2) ^ 2))) / W0 WpixSum = WpixSum + Weight InpixSum = InpixSum + 1 End If Else bkuva(m, k).r = 0 bkuva(m, k).G = 0 bkuva(m, k).B = 0 End If Next m Next i Close (2) Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = Form1.Picture1(0).CurrentY = 55 + 5 Form1.Picture1(0).Print Format$(WpixSum / Pixsum, "0.000") th_apu(Ncase) = th_apu(Ncase) & Format$(WpixSum / Pixsum, "0.0000") & "," th_apu2(Ncase) = th_apu2(Ncase) & Format$(InpixSum / Pixsum, "0.0000") & "," Next th Open "g:\images\" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Append As 1 Print #1, th_apu(Ncase) Close (1) Open "g:\images\No_Weight_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Append As 1 Print #1, th_apu2(Ncase) Close (1) Next dY DoEvents Next dX Print #2, capu Close (2) Exit Sub Rem Error handling section Error_in_adding_to_a_set2: Form1.MousePointer = 1 MsgBox ("An error occurred in Opening an image to a given XYZ point") Close (1) Rem Actually we do not need to store the images any, just let the threshold take values 'Open "g:\images\A1_2012_" & acquisition_height & "_" & PointNum & "_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Output As 1 'Print #1, (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)), (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)) 'Close (1) ' the header 'Open "g:\images\A1_2012_" & acquisition_height & "_" & PointNum & "_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".raw" For Binary As 2 'Put #2, , bkuva 'Close (2) ' the image End Sub Public Sub Open_An_Image_For_Footprint() Rem Oct 30 - Nov 20, 2012. This routine walks thru a list of pulses & images to decied if the footprint is ok. The list has Rem the pulse geometry and a pointer to the waveform, if it exists. The Routine stores the pixels in the footprint. Rem Remome and add an image to the set. Dim startrow As Integer, startcol As Integer, endrow As Integer, endcol As Integer Dim i As Integer, length As Integer, j As Integer Dim FileOut As String Dim p_x As Double, p_y As Double Rem Set the Initialize Boolean To FALSE initialize = False Close (1) 'Open "c:\data\Imafiles\LK3_2010_pulses.txt" For Input As 1 'Open "c:\data\Imafiles\2011_LK3_pulses.txt" For Input As 1 Exit Sub Rem start from a particular index Measurement.num = 319 Rem ******** Parameters that change from site to site ***************** divergence = 0.00022 binFilename = "2011_LK3waves.bin" bin_256_Filename = "2011_A2_256_waves.bin" bin_128_Filename = "2011_A2_128_waves.bin" maxheight = 22 acquisition_height = 900 Plot_code = "A2" LYear = 2011 limitvalue = 30 + 24 / 0.15 If LYear = 2010 Then limitvalue = 15 + 24 / 0.3 'Exit Sub If Measurement.num < 1 Then Measurement.num = 1 l = 0 Do Until EOF(1) l = l + 1 If LYear = 2010 Then Input #1, PointNum, echocount, ImageId, HDRfilename, p_x, p_y, angle, intensity, AGC, Xl, yl, zl, xp, yp, zp, Xiht, Yhit, Zhit, Xo, Yo, Zo, Picos, wavetype, Pointer Else Input #1, PointNum, echocount, ImageId, HDRfilename, p_x, p_y, angle, intensity, AGC, Xl, yl, zl, xp, yp, zp, Xiht, Yhit, Zhit, Xo, Yo, Zo, Picos, Pointer wavetype = 255 End If xp = xp yp = yp If l = Measurement.num And echocount > 0 Then Exit Do ' Accept the no the l'th row If l = Measurement.num And echocount < 1 Then Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped echo issues" & Measurement.num - 1 Close (1) Exit Sub End If Loop Close (1) If Pointer = 0 Then ' We do not examine pulses without a waveform Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped, no waveform" & Measurement.num - 1 Close (1) Exit Sub End If If (zp - getheight(xp, yp)) < 5 Then ' Too low Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped, too low " & Measurement.num - 1 Close (1) Exit Sub End If Measurement.num = Measurement.num + 1 Rem Set the solution with possible offsets dX = -0.1: dY = 0.05 X_sol = xp + dX: Y_sol = yp + dY: Z_sol = zp Form1.Label4(0).Caption = Format$(X_sol, "#.000") Form1.Label4(1).Caption = Format$(Y_sol, "#.000") Form1.Label4(2).Caption = Format$(Z_sol, "#.000") h_above_gnd = zp - getheight(X_sol, Y_sol) Open HDRfilename For Input As 1 Call Remove_all_images NumOfImages = 1 Form1.MousePointer = 11 DoEvents Rem Code for getting the image on the screen ********************************** Call set_window_sizes i = NumOfImages - 1 Call read_set_file_for_an_image(CLng(i)) Call Check_parameter_sanity(i) Close (1) Call r_transform_matrix(i) Form1.MousePointer = 11 Form1.Label10.Caption = CStr(0) & "/" & CStr(NumOfImages) & " images read" DoEvents Call Place_Objects_On_The_Main_Form startrow = 0: startcol = 0 endrow = 0: endcol = 0 i = NumOfImages - 1 win_info(i).pan_x = 1 win_info(i).pan_y = 1 win_info(i).win_width = Win_w win_info(i).win_height = win_h SolutionExists = True Call center_to_xyz Rem ************ code stops here ************************************************ Rem Code that finds out a perpendicular 3D vector to the pulse vector, used for the 3D circle of the footprint Form1.Picture1(i).DrawWidth = 3 Dim abc As Vector3D, xyz As Vector3D, uvw As Vector3D, rvec As Vector3D, Pt As Vector3D Rem ******************************* abc.X = 0: abc.Y = 0: abc.z = 0 Rem Solve XY's for Z of the images, the ray is Pt.X = ((xp + dX) - Xl) Pt.Y = ((yp + dY) - yl) Pt.z = (zp - zl) length = Sqr(Pt.X ^ 2 + Pt.Y ^ 2 + Pt.z ^ 2) range = length rad = divergence * length / 2# ' footprint radius in meters First_Z = zp Dim LPe As Vector3D, PV As Vector3D Pt.X = Pt.X / length: Pt.Y = Pt.Y / length: Pt.z = Pt.z / length LPe.X = -Pt.X: LPe.Y = -Pt.Y: LPe.z = -Pt.z PV.X = 0: PV.z = 0.2 PV.Y = -(LPe.z * PV.z + LPe.X * PV.X) / LPe.Y LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) PV.X = (PV.X / LenPv) * rad: PV.Y = (PV.Y / LenPv) * rad: PV.z = (PV.z / LenPv) * rad DotP = (LPe.X * PV.X + LPe.Y * PV.Y + LPe.z * PV.z) LenLp = Sqr(LPe.X ^ 2 + LPe.Y ^ 2 + LPe.z ^ 2) LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) Pt.X = (xp + dX) Pt.Y = (yp + dY) Pt.z = (zp) i = 0 Form1.Picture1(0).ForeColor = RGB(255, 241, 15) Call r_transform_ground_to_pixel(0, xp + dX, yp + dY, zp, p_x, p_y) c_col = p_x - (image_info(i).o_row) c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) Dim mins As Point2D, maxs As Point2D mins.X = 10000000000#: mins.Y = 10000000000#: maxs.X = -10000000000#: maxs.Y = -10000000000# Form1.Picture1(i).DrawWidth = 3 For s = 0 To 2 * pi Step 0.05 Call rotate_xyz_about_vector_abc_uvw_by_S(PV, abc, LPe, CDbl(s), rvec) X = Pt.X + rvec.X Y = Pt.Y + rvec.Y z = Pt.z + rvec.z Call r_transform_ground_to_pixel(i, X, Y, z, p_x, p_y) p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 Colorpix = RGB(255, 255, 0) ' sets green If p_x > 0 And p_x < win_info(i).win_width And p_y > 0 And p_y < win_info(i).win_height Then Form1.Picture1(i).PSet (p_x, p_y), Colorpix ' draw the circle / footprint borders End If Next s Rem is the a waveform available, pointer at this point s.b. non-zero If Pointer > 0 Then If wavetype = 255 Then ReDim Wave(1 To 256) As Byte Open "c:\data\imafiles\" & bin_256_Filename For Binary As 100 End If If wavetype = 127 Then ReDim Wave(1 To 128) As Byte Open "c:\data\imafiles\" & bin_128_Filename For Binary As 100 End If Get #100, Pointer, Wave NoiseN = 0: NoiseSum = 0# ' we solve the noise level with the tail For k = 1 To wavetype x1 = 10 + k * 2 x2 = 10 + (k + 1) * 2 y1 = win_info(0).win_height - 25 - 2 * Wave(k) y2 = win_info(0).win_height - 25 - 2 * Wave(k + 1) 'Form1.Picture1(0).PSet (10 + k * 2, win_info(0).win_height - 12.5 - 2 * wave(k)), RGB(255, 0, 0) Form1.Picture1(0).Line (x1, y1)-(x2, y2), RGB(255, 247, 100) If k Mod 21 = 0 Then Form1.Picture1(0).CurrentY = win_info(0).win_height - 40 Form1.Picture1(0).CurrentX = x1 - 5 Form1.Picture1(0).FontSize = 12 Form1.Picture1(0).FontBold = True Form1.Picture1(0).Print Format$((k - 1) * 0.15, "0.0") End If If k > limitvalue Then NoiseSum = NoiseSum + Wave(k) NoiseN = NoiseN + 1 End If Next k kmax = Int(Picos / 1000) If wavetype = 127 Then kmax = Int(Picos / 2000) + 1 Form1.Picture1(0).DrawWidth = 1 Form1.Picture1(0).FillStyle = 1 'Form1.Picture1(0).Circle (10 + kmax * 2, win_info(0).win_height - 12.5 - 2 * wave(kmax)), 5, RGB(255, 255, 0) Form1.Picture1(0).DrawWidth = 1 Form1.Picture1(0).Line (10, win_info(0).win_height - 25 - 12.5 - NoiseSum / NoiseN)-((wavetype + 1) * 2, win_info(0).win_height - 25 - 12.5 - NoiseSum / NoiseN), RGB(255, 255, 255) Close (100) End If Rem COMPUTATION of PULSE Width Rem Compute length of first pulse, start from the max both ways until noiselevel + 2 is reached On Error Resume Next updone = False: lowdone = False wavesum = 0 For k = 1 To 100 If Wave(kmax + (k - 1)) > (NoiseSum / NoiseN + 2) And updone = False Then wavesum = wavesum + (Wave(kmax + (k - 1)) - (NoiseSum / NoiseN + 2)) k_up = kmax + k - 1 End If If Wave(kmax + k) < (NoiseSum / NoiseN + 2) Then updone = True If lowdone = False Then If Wave(kmax - (k + 1)) > (NoiseSum / NoiseN + 2) Then wavesum = wavesum + (Wave(kmax - (k + 1)) - (NoiseSum / NoiseN + 2)) k_down = kmax - (k + 1) End If End If If Wave(kmax - (k + 1)) < (NoiseSum / NoiseN + 2) Then lowdone = True End If If updone = True And lowdone = True Then Exit For Next k Form1.Picture1(0).DrawWidth = 1 'Form1.Picture1(0).PSet (10 + k_up * 2, win_info(0).win_height - 12.5 - 2 * wave(k_up)), RGB(0, 255, 255) Form1.Picture1(0).Line (10 + k_up * 2, win_info(0).win_height - 25 - 15)-(10 + k_up * 2, win_info(0).win_height - 12.5 - 70), RGB(255, 255, 255) Form1.Picture1(0).CurrentY = Form1.Picture1(0).CurrentY - 15 Form1.Picture1(0).Print "E" 'Form1.Picture1(0).PSet (10 + k_down * 2, win_info(0).win_height - 12.5 - 2 * wave(k_down)), RGB(0, 255, 255) Form1.Picture1(0).Line (10 + k_down * 2, win_info(0).win_height - 25 - 15)-(10 + k_down * 2, win_info(0).win_height - 12.5 - 70), RGB(255, 255, 255) Form1.Picture1(0).CurrentY = Form1.Picture1(0).CurrentY - 15 Form1.Picture1(0).CurrentX = Form1.Picture1(0).CurrentX - 10 Form1.Picture1(0).Print "S" Form1.Picture1(0).DrawWidth = 3 Form1.Picture1(0).FontSize = 20 stepval = 0.15 If wavetype = 127 Then stepval = 0.3 If (k_up - k_down) * stepval < 4 Then Form1.Picture1(0).ForeColor = RGB(0, 155, 0) If (k_up - k_down) * stepval >= 4 And (k_up - k_down) * stepval < 5 Then Form1.Picture1(0).ForeColor = RGB(255, 255, 0) If (k_up - k_down) * stepval >= 5 Then Form1.Picture1(0).ForeColor = RGB(255, 25, 0) Form1.Picture1(0).ForeColor = RGB(255, 255, 0) Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = 10 Form1.Picture1(0).Print Format$((k_up - k_down) * stepval, "0.0 m") & " width" ' wavesum: " & Format$(wavesum, "0.0") Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = 40 'Form1.Picture1(0).Print Format$(intensity, "0 ") & Format$(wave(kmax), "0 ") & " " & Format$(zp - getheight(xp, yp), "0.0 m") & " " & Format$(zl, "0.0 m") Form1.Picture1(0).Print "Height: " & Format$(zp - getheight(xp, yp), "0.0 m") & " LiDAR: " & Format$(zl, "0.0 m") apu = MsgBox(echocount & " echoes, height: " & Format(h_above_gnd, "0.0 m") & "; accept for analyses?", vbYesNo) If apu = 7 Then ' Measurement.num = Measurement.num + 1 Form1.Label10.Caption = "Skipped " & Measurement.num - 1 Exit Sub End If Rem Output the pulse data to a string ************************ capu = "" capu = capu & Plot_code & "," capu = capu & acquisition_height & "," capu = capu & PointNum & "," capu = capu & Pointer & "," If LYear = 2010 Then capu = capu & wavetype & "," capu = capu & intensity & "," capu = capu & AGC & "," capu = capu & Format$(zl, "0.0") & "," capu = capu & Format$(range, "0.0") & "," capu = capu & Wave(kmax) & "," capu = capu & Format$(wavesum, "0.0") & "," capu = capu & Format$((k_up - k_down) * stepval, "0.0") Ncase = 0 dxx = 0 dyy = 0 ReDim th_apu(169) As String ' stores the silhouettes for each th and dx*dy combination (169) ReDim th_apu2(169) As String ' stores the silhouettes for each th and dx*dy combination (169), no weighting For dX = (-0.3 + dxx) To (0.31 + dxx) Step 0.05 For dY = (-0.3 + dyy) To (0.31 + dyy) Step 0.05 Ncase = Ncase + 1 abc.X = 0: abc.Y = 0: abc.z = 0 Rem Solve XY's for Z of the images, the ray is Pt.X = ((xp + dX) - Xl) Pt.Y = ((yp + dY) - yl) Pt.z = (zp - zl) length = Sqr(Pt.X ^ 2 + Pt.Y ^ 2 + Pt.z ^ 2) rad = divergence * length / 2# First_Z = zp Pt.X = Pt.X / length: Pt.Y = Pt.Y / length: Pt.z = Pt.z / length LPe.X = -Pt.X: LPe.Y = -Pt.Y: LPe.z = -Pt.z PV.X = 0: PV.z = 0.2 PV.Y = -(LPe.z * PV.z + LPe.X * PV.X) / LPe.Y LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) PV.X = (PV.X / LenPv) * rad: PV.Y = (PV.Y / LenPv) * rad: PV.z = (PV.z / LenPv) * rad DotP = (LPe.X * PV.X + LPe.Y * PV.Y + LPe.z * PV.z) LenLp = Sqr(LPe.X ^ 2 + LPe.Y ^ 2 + LPe.z ^ 2) LenPv = Sqr(PV.X ^ 2 + PV.Y ^ 2 + PV.z ^ 2) Pt.X = (xp + dX) Pt.Y = (yp + dY) Pt.z = (zp) i = 0 Form1.Picture1(0).ForeColor = RGB(255, 0, 0) Call r_transform_ground_to_pixel(0, xp + dX, yp + dY, zp, p_x, p_y) c_col = p_x - (image_info(i).o_row) c_row = (image_info(i).Height - 1) - p_y - (image_info(i).o_row) mins.X = 10000000000#: mins.Y = 10000000000#: maxs.X = -10000000000#: maxs.Y = -10000000000# Form1.Picture1(i).DrawWidth = 3 For s = 0 To 2 * pi Step 0.1 Call rotate_xyz_about_vector_abc_uvw_by_S(PV, abc, LPe, CDbl(s), rvec) X = Pt.X + rvec.X Y = Pt.Y + rvec.Y z = Pt.z + rvec.z Call r_transform_ground_to_pixel(i, X, Y, z, p_x, p_y) If p_x < mins.X Then mins.X = p_x If p_y < mins.Y Then mins.Y = p_y If p_x > maxs.X Then maxs.X = p_x If p_y > maxs.Y Then maxs.Y = p_y p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 Colorpix = RGB(0, 255, 0) If p_x > 0 And p_x < win_info(i).win_width And p_y > 0 And p_y < win_info(i).win_height Then Form1.Picture1(i).PSet (p_x, p_y), Colorpix End If Next s Form1.Picture1(i).DrawWidth = 3 maxrad = Max(maxs.X - mins.X, maxs.Y - mins.Y) Rem Now, let's have the threshold to take values in a loop Dim th As Long th_case = 0 For th = 250 To 149 Step -10 th_case = th_case + 1 If th_case = 1 Then th_apu(Ncase) = capu & "," & th & "," & Format$(dX, "0.00") & "," & Format$(dY, "0.00") & "," ' put the pulse info at the start and the threshold th_apu2(Ncase) = capu & "," & th & "," & Format$(dX, "0.00") & "," & Format$(dY, "0.00") & "," ' put the pulse info at the start and the threshold, no weight data End If ReDim bkuva(0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)), 0 To (CInt(c_row + maxrad / 2) - CInt(c_row - maxrad / 2))) As RGBtriplet Open image_info(0).FileName For Binary As 2 ReDim RROW(0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2))) As RGBtriplet cr = maxrad / 2 k = -1: Pixsum = 0: WpixSum = 0: InpixSum = 1 W0 = 1# / (Sqr(2) * (rad / 2)) * Exp(-(0) ^ 2 / (2 * (rad / 2) ^ 2)) For i = CInt(c_row - maxrad / 2) To CInt(c_row + maxrad / 2) k = k + 1 paikka = CLng(i) * CLng(image_info(0).sub_width) * 3 + CLng(CInt(c_col - maxrad / 2)) * 3 Get #2, paikka + 1, RROW() For m = 0 To (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)) dist = Sqr((m - cr) ^ 2 + (k - cr) ^ 2) If dist < maxrad / 2 Then dist = dist * rad / (maxrad / 2) Pixsum = Pixsum + 1 bkuva(m, k).r = RROW(m).r bkuva(m, k).G = RROW(m).G bkuva(m, k).B = RROW(m).B If bkuva(m, k).B < th Then Weight = (1# / (Sqr(2) * (rad / 2)) * Exp(-(dist) ^ 2 / (2 * (rad / 2) ^ 2))) / W0 WpixSum = WpixSum + Weight InpixSum = InpixSum + 1 End If Else bkuva(m, k).r = 0 bkuva(m, k).G = 0 bkuva(m, k).B = 0 End If Next m Next i Close (2) Form1.Picture1(0).CurrentX = 10 Form1.Picture1(0).CurrentY = Form1.Picture1(0).CurrentY = 55 + 5 Form1.Picture1(0).Print Format$(WpixSum / Pixsum, "0.000") th_apu(Ncase) = th_apu(Ncase) & Format$(WpixSum / Pixsum, "0.0000") & "," th_apu2(Ncase) = th_apu2(Ncase) & Format$(InpixSum / Pixsum, "0.0000") & "," Next th Open "g:\images\" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Append As 1 Print #1, th_apu(Ncase) Close (1) Open "g:\images\No_Weight_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Append As 1 Print #1, th_apu2(Ncase) Close (1) Next dY DoEvents Next dX Print #2, capu Close (2) Exit Sub Rem Error handling section Error_in_adding_to_a_set2: Form1.MousePointer = 1 MsgBox ("An error occurred in Opening an image to a given XYZ point") Close (1) Rem Actually we do not need to store the images any, just let the threshold take values 'Open "g:\images\A1_2012_" & acquisition_height & "_" & PointNum & "_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".txt" For Output As 1 'Print #1, (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)), (CInt(c_col + maxrad / 2) - CInt(c_col - maxrad / 2)) 'Close (1) ' the header 'Open "g:\images\A1_2012_" & acquisition_height & "_" & PointNum & "_" & Format$(dX * 100, "000") & "_" & Format$(dY * 100, "000") & ".raw" For Binary As 2 'Put #2, , bkuva 'Close (2) ' the image End Sub Public Sub Open_An_image_and_Center_to_XYZ(PassedFileName) Rem Add more images to the set Dim startrow As Integer, startcol As Integer, endrow As Integer, endcol As Integer Dim i As Integer, length As Integer, j As Integer Dim FileOut As String Rem Set the Initialize Boolean To FALSE initialize = False 'Open PassedFileName For Input As 1 Close (1) Open PassedFileName For Input As 1 Dim HDRfilename As String Dim PointNum As Long Input #1, PointNum, HDRfilename, X_sol, Y_sol, Z_sol Close (1) Measurement.FieldNumber = PointNum Measurement.X = X_sol Measurement.Y = Y_sol Measurement.z = Z_sol Form1.Label4(0).Caption = Format$(X_sol, "#.000") Form1.Label4(1).Caption = Format$(Y_sol, "#.000") Form1.Label4(2).Caption = Format$(Z_sol, "#.000") Open HDRfilename For Input As 1 If NumOfImages > MAXIMA Then ' MsgBox ("At the moment cannot allow more than " & MAXIMA & " images (three rows of Picture-boxes to hold the images!)") Close (1) Exit Sub End If NumOfImages = NumOfImages + 1 Form1.MousePointer = 11 DoEvents Rem Form1, the main window is maximized by default and has pixel-metrics. Get it's scalewidth & scaleheight to determine Rem individual image window widths and heights (win_w & win_h). There'll be images in a row. Call set_window_sizes Rem Read the individual image i = NumOfImages - 1 Call read_set_file_for_an_image(CLng(i)) Rem Check the sanity of parameters for image i Call Check_parameter_sanity(i) Rem Close the HDR-file as we've read all information Close (1) Call r_transform_matrix(i) Rem Make the mouse pointer into a wait-state -one Form1.MousePointer = 11 Rem Update label10 Form1.Label10.Caption = CStr(0) & "/" & CStr(NumOfImages) & " images read" DoEvents Rem There'll be (NumOfImages-1) "gimmicks" on the main window, give them their locations in pixel-metrics Call Place_Objects_On_The_Main_Form Rem Assign values to following integer-VARS startrow = 0: startcol = 0 endrow = 0: endcol = 0 Rem Now starts the section where we display each sub-image cenetered at their .sub_c_col and .sub_c_row Rem image coordinates i = NumOfImages - 1 Rem To start with we assume zooming (pan) factor 1 Rem Assign global vars ("pan" should really say "Zoom"), win_info(i).pan_x = 3 win_info(i).pan_y = 3 Rem Assign the global vars with window widths & heights win_info(i).win_width = Win_w win_info(i).win_height = win_h SolutionExists = True Call center_to_xyz Exit Sub Rem Error handling section Error_in_adding_to_a_set2: Form1.MousePointer = 1 MsgBox ("An error occurred in Opening an image to a given XYZ point") Close (1) End Sub Public Sub FindCollinearPulses() Dim Apu_z As Long, Colorpix As Long, Zmaa As Double, apu As Double, j As Long Dim MaxDTM As Double, MinDTM As Double, i As Long, p_x As Double, p_y As Double Dim FN1(1 To 4) As String * 3, FN2(1 To 4) As String * 3 Dim Xc As Double, Yc As Double, k As Long Dim LiDARBinPath2006 As String, LiDARBinPath2007 As String, LiDARBinPath2008 As String, LiDARBinPath2010 As String Dim Npulses As Long, Nha2006 As Long, Nha2007 As Long, Nha2008 As Long, Nha2010 As Long, Nsum As Long Dim Radius As Double, Height As Double Dim radi As Double, Zero As Double Dim x1 As Point3d, x2 As Point3d, x0 As Point3d, Pt As Point3d, Pl As Point3d Dim Lid As Vector3D, plumb As Vector3D lx = 0 Xs = X_sol: Ys = Y_sol For Xss = X_sol - 50 To X_sol + 50 Step 10 'Exit Sub For Yss = Y_sol - 50 To Y_sol + 50 Step 10 FN1(1) = Format$(Int(((Xss) - 2510000) / 100), "000") FN2(1) = Format$(Int(((Yss) - 6850000) / 100), "000") Xs = Xss 'Int(((Xss) - 2510000) / 100) * 100 + 2510000 + 50 Ys = Yss ' Int(((Yss) - 6850000) / 100) * 100 + 6850000 + 50 'Open "c:\data\als2011a_path.hdr" For Input As 1 Open "c:\data\als2012_path.hdr" For Input As 1 'Open "c:\data\als2013_path.hdr" For Input As 1 'Exit For Input #1, LiDARBinPath2010 Close (1): Close (100) Open LiDARBinPath2010 & FN1(1) & "_" & FN2(1) & ".bin" For Binary As 100 Get #100, , Npulses Close (100) ReDim LidR2010(1 To Npulses) As LidarRecord2010 'Form1.Caption = "Reading hectare " & Xs & " by " & Ys: DoEvents Open LiDARBinPath2010 & FN1(1) & "_" & FN2(1) & ".bin" For Binary As 100 Dim CS As Point2D CS.X = Xs: CS.Y = Ys 'CS(2).X = Xs - 0: CS(2).Y = Ys - 0 'CS(3).X = Xs - 5: CS(3).Y = Ys + 5 'CS(4).X = Xs + 5: CS(4).Y = Ys - 5 'CS(5).X = Xs + 5: CS(5).Y = Ys + 5 plumb.X = 0: plumb.Y = 0: plumb.z = -1: Dim Strips(1 To 29, 1 To 5) As Long For jjj = 1 To 29 For kkk = 1 To 5 Strips(jjj, kkk) = 0 Next kkk Next jjj 'Exit Sub Ncase = 0 Close (7) 'Exit Sub Open "c:\temp\alpha_beta.txt" For Append As 7 For k = 1 To Npulses Step 1 Get #100, 5 + (k - 1) * 207, LidR2010(k) ' Here we read 207-byte records record by record If LidR2010(k).Fileoffset = 0 Or LidR2010(k).PosLidar.z > 3800 Or LidR2010(k).pulseCount < 0 Or LidR2010(k).StripNum > 29 Then GoTo Nextpulse ' Then 'Exit Sub Rem Section for selectingpoints near a cable, the directional vector is here Lid.X = -(LidR2010(k).PosLidar.X - LidR2010(k).Returns(4).X) Lid.Y = -(LidR2010(k).PosLidar.Y - LidR2010(k).Returns(4).Y) Lid.z = -(LidR2010(k).PosLidar.z - LidR2010(k).Returns(4).z) 'For m = 1 To 5 radi = Sqr((LidR2010(k).Returns(4).X - CS.X) ^ 2 + (LidR2010(k).Returns(4).Y - CS.Y) ^ 2) Radius = 2 If radi < Radius Then If Strips(LidR2010(k).StripNum, m) = 1 Then GoTo Nextpulse Exit For End If 'Next m ' H = LidR2010(k).Returns(4).z - getheight(LidR2010(k).Returns(4).X, LidR2010(k).Returns(4).Y) If radi > Radius Then GoTo Nextpulse Ncase = Ncase + 1 Strips(LidR2010(k).StripNum, m) = 1 alpha = TO_DEGREES * vector_angle(Lid, plumb) beta = TO_DEGREES * MYFUNC_ATAN2(Lid.X, Lid.Y) Print #7, Format$(CS.X, "0") & "," & Format$(CS.Y, "0") & "," & Format$(LidR2010(k).PosLidar.z, "0") & "," & LidR2010(k).StripNum & "," & Format$(alpha, "0.000") & "," & Format$(beta, "0.000") Nextpulse: Next k Form1.Caption = Xs & " by " & Ys & " Cases: " & Ncase: DoEvents Close (7) Next Yss Next Xss Close (6): Close (7) Exit Sub ErrorInPlot2006: Close (All) MsgBox ("Some error!") End Sub Public Sub lpfilterwf(wfc() As Single, wfcs() As Single) For i = 4 To UBound(wfc) - 3 wfcs(i) = 0.006 * wfc(i - 3) + 0.061 * wfc(i - 2) + 0.242 * wfc(i - 1) + 0.383 * wfc(i) + 0.242 * wfc(i + 1) + 0.061 * wfc(i + 2) + 0.006 * wfc(i + 3) Next i wfcs(1) = wfc(1): wfcs(2) = 0.2 * wfc(1) + 0.6 * wfc(2) + 0.2 * wfc(3): wfcs(3) = 0.2 * wfc(2) + 0.6 * wfc(3) + 0.26 * wfc(4): wfcs(UBound(wfc) - 2) = 0.2 * wfc(UBound(wfc) - 3) + 0.6 * wfc(UBound(wfc) - 2) + 0.2 * wfc(UBound(wfc) - 1): wfcs(UBound(wfc) - 1) = 0.2 * wfc(UBound(wfc) - 2) + 0.6 * wfc(UBound(wfc) - 1) + 0.2 * wfc(UBound(wfc)): wfcs(UBound(wfc)) = wfc(UBound(wfc)) End Sub Public Sub FindWfPeaks(wfcs() As Single, wfc() As Single, peaks() As Long, noiselevel As Single, Npeaks As Byte, maxA As Double, maxindex As Integer) maxA = 0 Npeaks = 0 For i = 3 To UBound(wfc) - 2 If wfcs(i) >= wfcs(i + 1) And wfcs(i) >= wfcs(i - 1) And wfcs(i) > wfcs(i - 2) And wfcs(i) > wfcs(i + 2) Then If (wfc(i)) > noiselevel Then Npeaks = Npeaks + 1 peaks(Npeaks) = i End If If Int(wfc(i)) > maxA Then maxA = wfc(i) maxindex = i End If End If Next i End Sub Public Sub FirstWfderivate(wfcd() As Single, wfcs() As Single) For i = 1 To UBound(wfcs) - 1 wfcd(i) = wfcs(i + 1) - wfcs(i) Next i End Sub Public Sub Extraxt_WF_attributes(k As Long, range As Double, picosecs As Double, intensity1 As Integer, intensity2 As Integer, echo As Point3d, LiDAR As Point3d, GAIN As Byte, wf() As Integer) Dim e As Vector3D, l As Vector3D kin = k Exit Sub Rem Compute scan zenith angle e.X = echo.X: e.Y = echo.Y: e.z = echo.z: l.X = LiDAR.X: l.Y = LiDAR.Y: l.z = LiDAR.z scan_zenith = pi / 2 - MYFUNC_ATAN((l.z - e.z) / Sqr((e.X - l.X) ^ 2 + (e.Y - l.Y) ^ 2)) beta = TO_DEGREES * MYFUNC_ATAN2(e.X - l.X, e.Y - l.Y) Rem Declare storage for waveform versions ReDim wfsingle(1 To UBound(wf)) As Single ReDim wfc(1 To UBound(wf)) As Single ' the agc-range corrected amplitude data ReDim wfcd(1 To UBound(wf)) As Single ' 1st derivative ReDim wfcdd(1 To UBound(wf)) As Single ' 2nd derivative ReDim wfcs(1 To UBound(wf)) As Single ' smoothed waveform Dim offset As Double Rem Coefficients for range and gain control modeling, 2012 Leica data (multifootprint) Rref = 1: a1 = -0.000690979: a2 = 0.243645961: a3 = -18.08813852: offset = 11.4 '''' TEST 'offset = 12.8 '' TEST atm = 1# ' accounts for the varying output power and atmospheric attenuation If l.z > 2400 Then atm = 4.54045287428403E-02 If 1300 < l.z And l.z < 2400 Then atm = 7.73328125117215E-02 If 750 < l.z And l.z < 1300 Then atm = 0.280683361328588 scalef = 0.000007 ' Just to scale the amplitude values back to 0...100 range 'test 'scalef = scalef * 3.5 Rem 2010 1 km data noise_2 = 12.8 aa = 134.6 bb = 0.04041 Rref = 1195 Rem Range- and gain calibration for the 2012 data For i = 1 To UBound(wf) - 1 wfc(i) = wf(i) ' perform no correction wfsingle(i) = CDbl(wf(i)) ' 2012 'If wf(i) < offset Then wfsingle(i) = offset + 0.0001 'wfc(i) = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (wfsingle(i) - offset)) * atm / (1 + (1 * (Cos(scanzenith) - 1)))) * scalef ' 2010 If wf(i) < noise_2 Then wfsingle(i) = noise_2 + 0.0001 wfc(i) = (range / Rref) ^ 2 * (1 / (1 + (GAIN - aa) * bb)) * (wfsingle(i) - noise_2) Next i 2010 intensity1 = (range / Rref) ^ 2 * (1 / (1 + (GAIN - 134.6) * 0.04041)) * (intensity1 + 15.46) '2012 'intensity1 = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (intensity1 + 25)) * atm / (1 + (1 * (Cos(scanzenith) - 1)))) * scalef intensity2 = ((range / 1) ^ 2 * ((1 / (a3 + a2 * GAIN + a1 * GAIN ^ 2)) * (intensity2 + 25)) * atm / (1 + (1 * (Cos(scanzenith) - 1)))) * scalef Rem Low-pass filtering Call lpfilterwf(wfc, wfcs) Rem Find peaks above noise level. Dim Npeaks As Byte, noiselevel As Single, maxA As Double, peaks(1 To 100) As Long, maxindex As Integer noiselevel = 4.5: Npeaks = 0 Call FindWfPeaks(wfcs, wfc(), peaks(), noiselevel, Npeaks, maxA, maxindex) Rem 1st derivative & print the smoothed wf Call FirstWfderivate(wfcd, wfcs) Rem Draw Y = A lines on for the WF plotting Form1.Picture1(0).DrawWidth = 1 For j = 0 To 10 Step 2 ''Form1.Picture1(0).Line (10, (win_info(0).win_height - (j * 10) * 3 - 30) * 1)-((255 + 1) * 3, (win_info(0).win_height - (j * 10) * 3 - 30) * 1), RGB(255, 255, 255) Next j Rem find three attriutes Dim length(1 To 100) As Single, fwhm(1 To 100) As Single, Softness(1 To 100) As Single, energy(1 To 100) As Single Dim Updir(1 To 100) As Single, downDir(1 To 100) As Single If kin = 68018 Then aa = 1 End If Call Lenght_FWHM_Softness(Npeaks, noiselevel, peaks(), Updir(), downDir(), wfc(), wfcs(), length(), fwhm(), Softness(), energy(), l, e) Dim Segs(1 To 10) As WFsegment, overlap(1 To 100) As Single Rem Prune the segments from duplicates, there are Npeaks elements in the downDir() and UpDir() arrays Rem There should be segments that overlap, measure overlap totalpeaks = 0 ' First segment exists for sure For i = 1 To 10 ' find the first one, there are peaks() = -99 cases! If peaks(i) > 0 Then Segs(1).start = downDir(i): Segs(1).end = Updir(i): Segs(1).Npeaks = 1: Segs(1).peaks(1).Index = i: Segs(1).peaks(1).Ismax = False: Segs(1).energy = energy(i) Segs(1).fwhm = fwhm(i) Segs(1).length = length(i) Segs(1).rise = Softness(i) Segs(1).pA = peaks(i) ik = i totalpeaks = totalpeaks + 1 Exit For End If aa = 1 Next i Startval = i ' Start from the second il = 1: all_done = False Do Until (all_done) ' the following is within same limits, do not increase segment number If Npeaks = ik Then Exit Do ik = ik + 1 overlap(ik) = Abs(downDir(ik) - downDir(ik - 1)) + Abs(Updir(ik) - Updir(ik - 1)) If overlap(ik) < 0.1 And peaks(ik) > 0 And peaks(ik - 1) > 0 Then ' belongs toan existing Segs(il).start = downDir(ik) Segs(il).end = Updir(ik) Segs(il).Npeaks = Segs(il).Npeaks + 1 Segs(il).energy = energy(ik) 'Segs(il).fwhm = fwhm(ik) Segs(il).length = length(ik) Segs(il).pA = peaks(ik) If Segs(il).Npeaks = 1 Then Segs(il).rise = Softness(ik) End If Segs(il).peaks(Segs(il).Npeaks).Index = ik Segs(il).peaks(Segs(il).Npeaks).Ismax = False totalpeaks = totalpeaks + 1 End If If overlap(ik) > 0.1 And peaks(ik) > 0 Then ' a new segment il = il + 1 Segs(il).start = downDir(ik) Segs(il).end = Updir(ik) Segs(il).Npeaks = 1 Segs(il).energy = energy(ik) 'Segs(il).fwhm = fwhm(ik) Segs(il).length = length(ik) Segs(il).pA = peaks(ik) If Segs(il).Npeaks = 1 Then Segs(il).rise = Softness(ik) End If Segs(il).peaks(Segs(il).Npeaks).Index = ik Segs(il).peaks(Segs(il).Npeaks).Ismax = False totalpeaks = totalpeaks + 1 End If If ik = Npeaks Then all_done = True Loop Nsegs = il ' this many segments there are ' find the maxima For il = 1 To Nsegs maxA = 0 ind = -1 For ik = 1 To Segs(il).Npeaks Segs(il).peaks(ik).Ismax = False If wfc(peaks(Segs(il).peaks(ik).Index)) > maxA Then maxA = wfc(peaks(Segs(il).peaks(ik).Index)) ind = ik End If Next ik Segs(il).peaks(ind).Ismax = True Segs(il).maxpeak = ind Segs(il).pA = wfc(peaks(Segs(il).peaks(ind).Index)) Segs(il).fwhm = fwhm(Segs(il).peaks(ind).Index) If Segs(2).pA < 15 And Segs(2).fwhm > 20 Then aa = 1 aa = fwhm(1) aa = fwhm(2) aa = fwhm(3) End If Next il Rem Draw WFs on the screen 'GoTo OhitaGrafiikka Dim p_x As Double, p_y As Double i = 1 Call r_transform_ground_to_pixel(i, e.X, e.Y, e.z, p_x, p_y) Form1.Picture1(i).DrawWidth = 3 p_x = (p_x - (image_info(i).o_col + win_info(i).win_o_col)) * win_info(i).pan_x - 1 p_y = ((image_info(i).Height - 1) - p_y - (image_info(i).o_row + win_info(i).win_o_row)) * win_info(i).pan_y - 1 If p_x > 0 And p_x < win_info(i).win_width And p_y > 0 And p_y < win_info(i).win_height Then ' And Range < 1500 And LidR2010(k).FileOffset > -1 Then Form1.Picture1(i).PSet (p_x, p_y), RGB(255, 0, 0) End If Form1.Picture1(0).DrawWidth = 1: Form1.Picture1(0).FontSize = 8 If Nsegs > 0 Then For j = 1 To Nsegs 'If j > 0 And Segs(1).Npeaks > 0 And Totalpeaks = 2 Then ' nsegs = 2 Then 'If Segs(j).fwhm > 5 And Segs(j).pA > 5 And 'If Segs(j).length > 20 And Segs(j).pA < 50 And TotalPeaks = 4 Then ' Segs(j).length Then If Segs(1).fwhm > 5 And totalpeaks > 0 Then ' And Segs(2).Npeaks = 1 And Segs(3).Npeaks = 1 Then Form1.Picture1(0).DrawWidth = 5 For ij = 1 To Segs(j).Npeaks If Segs(j).peaks(ij).Ismax = True Then Form1.Picture1(0).PSet (peaks(Segs(j).peaks(ij).Index) * 3, (win_info(0).win_height - wfcs(peaks(Segs(j).peaks(ij).Index)) * 3 - 30) * 1), RGB(255, 255, 0) Form1.Picture1(0).Print Int(Segs(j).pA) & " " & Int(Segs(j).fwhm) ' Int(wfc(peaks(Segs(j).peaks(ij).Index))) End If If Segs(j).peaks(ij).Ismax = False Then Form1.Picture1(0).PSet (peaks(Segs(j).peaks(ij).Index) * 3, (win_info(0).win_height - wfcs(peaks(Segs(j).peaks(ij).Index)) * 3 - 30) * 1), RGB(255, 0, 0) End If Next ij Form1.Picture1(0).DrawWidth = 1 Colorpix = RGB(0, 0, 0) Select Case j Case 1 Colorpix = RGB(255, 0, 0) Case 2 Colorpix = RGB(255, 255, 0) Case 3 Colorpix = RGB(255, 0, 255) Case 4 Colorpix = RGB(0, 255, 255) End Select For i = Segs(j).start To Segs(j).end ' UBound(wf) 'Peaks(1) If i > 255 Then i = 255 Form1.Picture1(0).Line (i * 3, (win_info(0).win_height - wfcs(i) * 3 - 30) * 1)-((i + 1) * 3, (win_info(0).win_height - wfcs(i + 1) * 3 - 30) * 1), Colorpix Next i End If NextWFpeak: Next j End If OhitaGrafiikka: On Error Resume Next If Nsegs > 0 Then 'Open "c:\temp\WFs\" & "_" & fwhm(1) & "_" & Softness(1) & "_" & Int(range) & "_" & CStr(Int(wfc(peaks(1)))) & ".txt" For Output As 112 ' Open "c:\temp\WFs\" & Int(Rnd() * 500) & "_" & Int(e.X) & "_" & Int(e.Y) & "_" & Int(range) & ".txt" For Output As 115 Open "c:\temp\WFs\2012_grass_7ns.txt" For Append As 112 Open "c:\temp\test_muistokoivikko_500.txt" For Append As 115 Open "c:\temp\test_muistokoivikko_1000.txt" For Append As 116 'Print #115, Int(range), TO_DEGREES * scan_zenith, beta, picosecs, Segs(1).fwhm, Segs(1).rise, Segs(1).pA, Segs(1).energy, intensity1, e.X, e.Y, e.z, Segs(2).fwhm, Segs(2).rise, Segs(2).pA, Segs(2).energy, intensity2 If range > 300 Then Print #115, Format$(range, "0.0"), TO_DEGREES * scan_zenith, beta, LidR2010(k).GPStime, picosecs, peaks(Segs(1).peaks(1).Index), Segs(1).fwhm, Segs(1).length, Segs(1).rise, Segs(1).pA, Segs(1).energy, intensity1, e.X, e.Y, e.z End If 'If range > 600 Then ' Print #116, Format$(range, "0.0"), TO_DEGREES * scan_zenith, beta, LidR2010(k).GPStime, picosecs, peaks(Segs(1).peaks(1).Index), Segs(1).fwhm, Segs(1).length, Segs(1).rise, Segs(1).pA, Segs(1).energy, intensity1, e.X, e.Y, e.z 'End If ' For i = 1 To 256 ' Print #115, i, wfc(i) ' Next i Close (115) Close (116) If Segs(2).fwhm < 6 Then aa = 1 End If Close (200) ' Solve a polynomialaround the WF peak , maxIndex has the index of wfc() maximum, it's tme is set to zero offset = maxindex Dim DesignMatrix(1 To 11, 1 To 7) As Variant, obs_vector(1 To 11) As Variant j = 0 For i = maxindex - 5 To maxindex + 5 ' we use eleven values j = j + 1 ik = i - offset DesignMatrix(j, 1) = CDbl(ik) ^ 6: DesignMatrix(j, 2) = CDbl(ik) ^ 5 DesignMatrix(j, 3) = CDbl(ik) ^ 4: DesignMatrix(j, 4) = CDbl(ik) ^ 3 DesignMatrix(j, 5) = CDbl(ik) ^ 2: DesignMatrix(j, 6) = CDbl(ik) ^ 1 DesignMatrix(j, 7) = 1 obs_vector(j) = CDbl(wfc(i)) Next i Dim Atb As Variant Dim solution As Variant, At As Variant, Ainv As Variant At = MatMult(MatTran(DesignMatrix), DesignMatrix) Ainv = MatInv(At) Atb = MatMult(MatTran(DesignMatrix), obs_vector) solution = MatMult(Ainv, Atb) maxp = 0 For j = -1 To 1 Step 0.01 amp = solution(1) * j ^ 6 + solution(2) * j ^ 5 + solution(3) * j ^ 4 + solution(4) * j ^ 3 + solution(5) * j ^ 2 + solution(6) * j + solution(7) If amp > maxp Then maxp = amp delta_t = j End If Next j 'For i = 10 To 50 ' Print #112, Int(range), -(offset - i + delta_t), wfc(i) ' Next i Close (112) End If Exit Sub virherivi: MsgBox ("virhe") End Sub Public Sub Lenght_FWHM_Softness(Npeaks As Byte, noiselevel As Single, peaks() As Long, Updir() As Single, downDir() As Single, wfc() As Single, wfcs() As Single, length() As Single, fwhm() As Single, Softness() As Single, energy() As Single, l As Vector3D, e As Vector3D) Rem This routine searhes for the length and width and risetime attributes Rem Define the parts above noise, retain Dim UpLimit As Boolean, DownLimit As Boolean Rem There are Npeaks detected peak-candidates On Error GoTo fwhmvirhe For i = 1 To Npeaks UpLimit = False: DownLimit = False: fwhmdown = False: fwhmup = False Updir(i) = 0: downDir(i) = 0: downindex = 1: upindex = 256 Rem Find the time points at which the signal is at FWHM and Noiselevel For j = 1 To 100 If (peaks(i) - j) < LBound(wfc) And DownLimit = False Then ' look the left, we are at start and sequence has started already DownLimit = True peaks(i) = -99 ' kill a leaking peak, in the beginning length(i) = 0 GoTo NextPeak End If If (peaks(i) + j) > UBound(wfc) And UpLimit = False Then UpLimit = True peaks(i) = -99 ' kill a leaking peak, at the tail length(i) = 0 GoTo NextPeak End If If DownLimit = False Then ' we can actually do the left-testing If (wfc(peaks(i) - j) > noiselevel) Then downDir(i) = j If fwhmdown = False Then 'we have not reached the interval for fwhm computation If (wfc(peaks(i) - j)) > 0.5 * wfc(peaks(i)) Then fwhm(i) = fwhm(i) + 1 If (wfc(peaks(i) - j)) <= 0.5 * wfc(peaks(i)) Then fwhmdownindex = peaks(i) - j fwhmdown = True End If End If If wfc(peaks(i) - j) <= noiselevel Then DownLimit = True downindex = peaks(i) - j End If End If If UpLimit = False Then If (wfc(peaks(i) + j) > noiselevel) Then Updir(i) = j If fwhmup = False Then 'we have not reached the interval If wfc(peaks(i) + j) > 0.5 * wfc(peaks(i)) Then fwhm(i) = fwhm(i) + 1 If wfc(peaks(i) + j) <= 0.5 * wfc(peaks(i)) Then fwhmupindex = peaks(i) + j fwhmup = True End If End If If wfc(peaks(i) + j) <= noiselevel Then UpLimit = True upindex = peaks(i) + j End If End If If UpLimit = True And DownLimit = True Then Exit For Form1.Picture1(0).DrawWidth = 3 'If UpLimit = False And i = 1 Then Form1.Picture1(0).PSet ((Peaks(i) + j) * 3, (win_info(0).win_height - wfcs((Peaks(i) + j)) * 3 - 30) * 1), RGB(255, 0, 255) 'If DownLimit = False And i = 2 Then Form1.Picture1(0).PSet ((Peaks(i) - j) * 3, (win_info(0).win_height - wfcs((Peaks(i) - j)) * 3 - 30) * 1), RGB(255, 255, 0) Next j If Updir(i) < 2 Or downDir(i) < 2 Then peaks(i) = -99 ' kill a peak that does not have amplitude values around it length(i) = 0 GoTo NextPeak End If ' compute the real-valued end points down_i = (noiselevel - wfc(downindex)) / (wfc(downindex + 1) - wfc(downindex)) + downindex up_i = (noiselevel - wfc(upindex)) / (wfc(upindex - 1) - wfc(upindex)) + upindex - 1 ' energy at the end points Part1 = 1 - (down_i - Int(down_i)) Part2 = up_i - Int(up_i) energy(i) = Part1 * wfc(down_i) energy(i) = energy(i) + Part2 * wfc(up_i) For j = Int(down_i) + 1 To Int(up_i) - 1 energy(i) = energy(i) + wfc(j) Next j RiseSolidSurface = -0.000313 * wfc(peaks(i)) ^ 2 + 0.071458 * wfc(peaks(i)) ^ 1 + 5.621676 If l.z < 800 Then RiseSolidSurface = -0.000244 * wfc(peaks(i)) ^ 2 + 0.056733 * wfc(peaks(i)) ^ 1 + 3.362233 Softness(i) = -(down_i - peaks(i)) / RiseSolidSurface If up_i - down_i > 0 Then length(i) = up_i - down_i Updir(i) = up_i downDir(i) = down_i If IsEmpty(fwhmdownindex) Or IsEmpty(fwhmupindex) Or fwhmup = False Or fwhmdown = False Then fwhm(i) = 0 GoTo NextPeak End If Rem real valued fwhm down_i = (wfc(peaks(i)) / 2# - wfc(fwhmdownindex)) / (wfc(fwhmdownindex + 1) - wfc(fwhmdownindex)) + fwhmdownindex up_i = (1 - (wfc(peaks(i)) / 2# - wfc(fwhmupindex)) / (wfc(fwhmupindex - 1) - wfc(fwhmupindex))) + fwhmupindex - 1 fwhm(i) = (up_i - down_i) If fwhm(i) > length(i) Then aa = 1 End If NextPeak: Next i Exit Sub fwhmvirhe: MsgBox ("Virhe aliohjelmassa Length_FWHM_Softness") End Sub Public Function SolvePulsecount(ByRef Lidr As LidarRecord) As Long FirstMissing = False SecondMissing = False ThirdMissing = False LastMissing = False If Lidr.Returns(4).z < 10 Then FirstMissing = True If Lidr.Returns(3).z < 10 Then SecondMissing = True If Lidr.Returns(2).z < 10 Then ThirdMissing = True If Lidr.Returns(1).z < 10 Then LastMissing = True If Lidr.Returns(4).z < 10 Then Lidr.pulseCount = 0 ' there is no first return! ' MsgBox ("No first echo!") GoTo determined End If If Lidr.Returns(4).z > 10 And Lidr.Returns(3).z < 10 And Lidr.Returns(2).z < 10 And Abs(Lidr.Returns(4).z - Lidr.Returns(1).z) < 0.1 Then Lidr.pulseCount = 1 ' there is no second return! GoTo determined End If If Lidr.Returns(4).z > 10 And Lidr.Returns(3).z > 10 And Lidr.Returns(2).z < 10 And Abs(Lidr.Returns(3).z - Lidr.Returns(1).z) < 0.1 Then Lidr.pulseCount = 2 ' there is second but not third GoTo determined End If If Lidr.Returns(4).z > 10 And Lidr.Returns(3).z > 10 And Lidr.Returns(2).z > 10 And Abs(Lidr.Returns(2).z - Lidr.Returns(1).z) < 0.2 Then Lidr.pulseCount = 3 ' last and third are the same GoTo determined End If If Lidr.Returns(4).z > 10 And Lidr.Returns(3).z > 10 And Lidr.Returns(2).z > 10 And Abs(Lidr.Returns(2).z - Lidr.Returns(1).z) > 0.2 Then Lidr.pulseCount = 4 ' last and third are the same GoTo determined End If ' MsgBox ("Should not see this!") Lidr.pulseCount = 0 determined: SolvePulsecount = Lidr.pulseCount End Function Public Function GetApuZ(apu As Variant, MinD As Variant, MaxD As Variant) As Long If apu < MinD Then apu = MinD If apu > MaxD Then apu = MaxD Apu_z = 255 - (255 - (apu - MinD) * 255 / (MaxD - MinD)) If Apu_z < 4 Then Apu_z = 4 If Apu_z > 254 Then Apu_z = 253 GetApuZ = Apu_z / 4 End Function