Program pre výpočet vzdialeností na Zemi

V predchádzajúcom príklade Sférický trojuholník boli uvedené vzorce, pomocou ktorých je možné priamo v tabuľkovom procesori Excel vypočítať na základe znalosti geodetických súradníc vzdialenosti medzi jednotlivými mestami na Zemi. Teraz uvediem program (makro) vo VBA (Visual Basic pre aplikácie). Program má tú výhodu, že ak raz správne napíšeme program, nemusíme pracne zapisovať vzorce - stačí program len spustiť a behom sekundy máme výpočty hotové hoci aj pre niekoľko sto miest.

Pripravíme si súbor (meno súboru je seizmos.xls) so zoznamom miest a ich geodetickými súradnicami, pre ktoré chceme vypočítať vzdialenosti od iného mesta - v tomto príklade od Bratislavy:


sf1 (17K)

Potom si zapíšeme nasledovné makro:



Option Explicit ' zabezpečí, že všetky premenné musia byť deklarované v danom module

Sub sfer() Dim mesto As String, stat As String, sir As Single, sirR As Single Dim dlz As Single, lamR As Single, cosdelt As Double Dim i As Integer, k As Single, ficR As Single, tgeoc As Single Dim AA1 As Double, BB1 As Double, CC1 As Double, obl1 As Range, obl2 As Range Dim stup As Single, kmt As Single, posr As Integer, posl As Integer Dim AA() As Double, BB() As Double, CC() As Double, zz As Single k = 0.993306 ' sir ...geodetická šírka v stupňoch ' dlz ...geodetická dĺzka v stupňoch ' sirR ..geodetická šírka v radiánoch ' lamR ..geodetická dĺžka v radiánoch ' ficR ..geocentrická šírka v radiánoch 'Prosím, zmeňte v nasledujúcom riadku celú dráhu súboru v ktorom máte 'geografické súradnice zvolených miest Workbooks.Open "C:\Školenie\Excel\sfera\seizmos.xls" ActiveSheet.Select Range("A1").Activate ActiveCell.CurrentRegion.Select 'oblasť oddelená prvým prázdnym riadkom a prvým prázdnym 'stĺpcom posr = ActiveSheet.UsedRange.Rows.Count ' počet riadkov použitej oblasti posl = ActiveSheet.UsedRange.Columns.Count 'počet stĺpcov ReDim AA(posr), BB(posr), CC(posr) 'B r a t i s l a v a určíme vzdialenosti jednotlivých miest od Bratislavy 'ak chcete zistiť vzdialenosti od iného mesta 'zmeňte bunky cells(2,1), cells(2,2), atď. mesto = Cells(2, 1) sir = Cells(2, 2) dlz = Cells(2, 3) stat = Cells(2, 4) sirR = Application.WorksheetFunction.Radians(sir) ' geodetická šírka v radiánoch tgeoc = k * Tan(sirR) ' prevod na geocentrickú šírku - tangens geocentrickej šírky ficR = Atn(tgeoc) ' geocentrická šírka v radiánoch lamR = Application.WorksheetFunction.Radians(dlz) ' geodetická dĺžka v radiánch AA1 = Cos(ficR) * Cos(lamR) BB1 = Cos(ficR) * Sin(lamR) CC1 = Sin(ficR) For i = 3 To posr mesto = Cells(i, 1) sir = Cells(i, 2) dlz = Cells(i, 3) stat = Cells(i, 4) sirR = Application.WorksheetFunction.Radians(sir) tgeoc = k * Tan(sirR) ficR = Atn(tgeoc) lamR = Application.WorksheetFunction.Radians(dlz) AA(i) = Cos(ficR) * Cos(lamR) BB(i) = Cos(ficR) * Sin(lamR) CC(i) = Sin(ficR) cosdelt = AA1 * AA(i) + BB1 * BB(i) + CC1 * CC(i) zz = Application.WorksheetFunction.Acos(cosdelt) stup = Application.WorksheetFunction.Degrees(zz) stup = Format(stup, "#,##0.00") kmt = stup * 111.2 kmt = Format(kmt, "#,##0.00") Cells(i, 6) = mesto Cells(i, 7) = stup Cells(i, 8) = kmt Next i Set obl1 = Range(Cells(3, 6), Cells(posr, 8)) obl1.Select With Selection.Interior .ColorIndex = 12 .Pattern = xlSolid End With Selection.Font.ColorIndex = 52 Set obl2 = Range(Cells(3, 7), Cells(posr, 8)) obl2.Select Selection.NumberFormat = "0.00" With Selection .HorizontalAlignment = xlRight End With End Sub

Po spustení vyššie uvedeného makra zapíšu sa do súboru seizmos.xls mená miest a príslušné vzdialenosti od Bratislavy v stupňoch a aj v kilometroch:

sf2 (6K)

Kontakty

Stránka je v súlade s aktuálnymi normami.

Valid HTML 4.01 Transitional



Domov

©  Klára Mrázová