georef.frm

pembulatan angka keatas maupun kebawah, ato keduanya, juga fungsi-fungsi yang lain

         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   3720
      Width           =   495
   End
End
Attribute VB_Name = "GeoRef"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' GPS MAP CALIBRATION (GEOREFERENCING) IN VB 6.0
' Created On 15/12/2004
' Last modified On 7/1/2005
' CONTROLS
' Picture1, MSFlexgrid as grid
' lables controls 4
' Lable1, Label2,lblLong, lblLat


Dim dhwnd As Long, dhdc As Long

Dim ZF As Integer
Option Explicit
Private Type aPoint
  X As Double
  Y As Double
  lon As Double
  lat As Double
End Type

Dim p11 As aPoint  ' Min. Longitude
Dim p22 As aPoint  ' Max. Longitude
Dim p33 As aPoint  ' Min. Lat
Dim p44 As aPoint  ' Max. Lat
Dim lon0 As Double
Dim lat0 As Double
Dim delX As Double
Dim delY As Double

Dim fs As New FileSystemObject
Dim f As File
Dim ts As TextStream

Private Sub FindPoints()
' TO FIND X,Y,LONG,LAT AT P11,P22,P33,P44

Dim a As Double
Dim b As Double
Dim c As Double

a = CDbl(grid.TextMatrix(1, 3))
b = CDbl(grid.TextMatrix(2, 3))
c = CDbl(grid.TextMatrix(3, 3))

' Least Longitude as P11
 If a < b And a < c Then
  p11.X = CDbl(grid.TextMatrix(1, 1))
  p11.Y = CDbl(grid.TextMatrix(1, 2))
  p11.lon = CDbl(grid.TextMatrix(1, 3))
  p11.lat = CDbl(grid.TextMatrix(1, 4))
 End If
 
 If b < c And b < a Then
  p11.X = CDbl(grid.TextMatrix(2, 1))
  p11.Y = CDbl(grid.TextMatrix(2, 2))
  p11.lon = CDbl(grid.TextMatrix(2, 3))
  p11.lat = CDbl(grid.TextMatrix(2, 4))
 End If
 
 If c < b And c < a Then
  p11.X = CDbl(grid.TextMatrix(3, 1))
  p11.Y = CDbl(grid.TextMatrix(3, 2))
  p11.lon = CDbl(grid.TextMatrix(3, 3))
  p11.lat = CDbl(grid.TextMatrix(3, 4))
 End If

' Max Longitude as P22
 If a > b And a > c Then
  p22.X = CDbl(grid.TextMatrix(1, 1))
  p22.Y = CDbl(grid.TextMatrix(1, 2))
  p22.lon = CDbl(grid.TextMatrix(1, 3))
  p22.lat = CDbl(grid.TextMatrix(1, 4))
 End If
 
  If b > c And b > a Then
  p22.X = CDbl(grid.TextMatrix(2, 1))
  p22.Y = CDbl(grid.TextMatrix(2, 2))
  p22.lon = CDbl(grid.TextMatrix(2, 3))
  p22.lat = CDbl(grid.TextMatrix(2, 4))
 End If
 
 If c > b And c > a Then
  p22.X = CDbl(grid.TextMatrix(3, 1))
  p22.Y = CDbl(grid.TextMatrix(3, 2))
  p22.lon = CDbl(grid.TextMatrix(3, 3))
  p22.lat = CDbl(grid.TextMatrix(3, 4))
 End If

'---------------------------
a = CDbl(grid.TextMatrix(1, 4))
b = CDbl(grid.TextMatrix(2, 4))
c = CDbl(grid.TextMatrix(3, 4))

' Least Lat as P44
 If a < b And a < c Then
  p44.X = CDbl(grid.TextMatrix(1, 1))
  p44.Y = CDbl(grid.TextMatrix(1, 2))
  p44.lon = CDbl(grid.TextMatrix(1, 3))
  p44.lat = CDbl(grid.TextMatrix(1, 4))
 End If
 
 If b < c And b < a Then
  p44.X = CDbl(grid.TextMatrix(2, 1))
  p44.Y = CDbl(grid.TextMatrix(2, 2))
  p44.lon = CDbl(grid.TextMatrix(2, 3))
  p44.lat = CDbl(grid.TextMatrix(2, 4))
 End If
 
 If c < b And c < a Then
  p44.X = CDbl(grid.TextMatrix(3, 1))
  p44.Y = CDbl(grid.TextMatrix(3, 2))
  p44.lon = CDbl(grid.TextMatrix(3, 3))
  p44.lat = CDbl(grid.TextMatrix(3, 4))
 End If

' Max Lat as P33
If a > b And a > c Then
  p33.X = CDbl(grid.TextMatrix(1, 1))
  p33.Y = CDbl(grid.TextMatrix(1, 2))
  p33.lon = CDbl(grid.TextMatrix(1, 3))
  p33.lat = CDbl(grid.TextMatrix(1, 4))
 End If
 
  If b > c And b > a Then
  p33.X = CDbl(grid.TextMatrix(2, 1))
  p33.Y = CDbl(grid.TextMatrix(2, 2))
  p33.lon = CDbl(grid.TextMatrix(2, 3))
  p33.lat = CDbl(grid.TextMatrix(2, 4))
 End If
 
 If c > b And c > a Then
  p33.X = CDbl(grid.TextMatrix(3, 1))
  p33.Y = CDbl(grid.TextMatrix(3, 2))
  p33.lon = CDbl(grid.TextMatrix(3, 3))
  p33.lat = CDbl(grid.TextMatrix(3, 4))
 End If
 
 
  End Sub



Private Sub Combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Text4.SetFocus
End If

End Sub

Private Sub Combo2_Change()
Combo2_Click
End Sub

Private Sub Combo2_Click()

Dim rd As Long

Dim rm As Long
Dim rs As Integer

Dim ld As Long
Dim lm As Long
Dim ls As Integer
ld = Val(Text1.Text) * 60 * 60
lm = Val(Text2.Text) * 60
ls = Val(Text3.Text)
rd = Val(Text4.Text) * 60 * 60
rm = Val(Text5.Text) * 60
rs = Val(Text6.Text)

If grid.TextMatrix(1, 3) = "" Then
grid.TextMatrix(1, 4) = rd + rm + rs
grid.TextMatrix(1, 3) = ld + lm + ls

ElseIf grid.TextMatrix(2, 3) = "" Then
grid.TextMatrix(2, 4) = rd + rm + rs
grid.TextMatrix(2, 3) = ld + lm + ls

Else
grid.TextMatrix(3, 4) = rd + rm + rs
grid.TextMatrix(3, 3) = ld + lm + ls

End If

End Sub

Private Sub Command1_Click()
'ts.Close
Set ts = fs.CreateTextFile(cd.FileName & ".dat", True)

' 4 = 2,  3 = 1 for lat
' Max Lat as P33

FindPoints
'CALICULATING delX, delY

delX = (p22.lon - p11.lon) / (p22.X - p11.X)
delY = (p44.lat - p33.lat) / (p44.Y - p33.Y)

' CALICULATING AT PICTUREBOX 0,0
lon0 = p11.lon - (p11.X * delX)
lat0 = p33.lat - (p33.Y * delY)

'MsgBox ("0,0") & vbCrLf & delX & vbCrLf & delY
MsgBox "AT 0,0 " & vbCrLf & lat0 + (delY * 0) & vbCrLf & lon0 + (delX * 0) & vbCrLf & vbCrLf & "AT lower right corner" & vbCrLf & lat0 + (delY * 7185) & vbCrLf & lon0 + (delX * 9585)
ts.WriteLine (Picture1.Name)
ts.WriteLine (Picture1.Name)
ts.WriteLine ("LL, 0 , 0")
ts.WriteLine lats(lon0, lat0)
ts.WriteLine longs(9585, 7185)
End Sub

Private Sub Command2_Click()
grid.Clear
Form_Load
End Sub

Private Sub Command3_Click()
cd.ShowOpen
Picture1.Picture = LoadPicture(cd.FileName)
End Sub



Private Sub Form_Load()
Dim lReigon&, lResult&

cd.Filter = "All Image Files (*.*)|*.*|BMP Files (*.bmp)|*.bmp|JPEG Files (*.jpg)|*.jpg"

grid.TextMatrix(0, 1) = "X"
grid.TextMatrix(0, 2) = "Y"
grid.TextMatrix(0, 3) = "LONG"
grid.TextMatrix(0, 4) = "LAT"

grid.TextMatrix(1, 0) = "P1"
grid.TextMatrix(2, 0) = "P2"
grid.TextMatrix(3, 0) = "P3"

End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If grid.TextMatrix(1, 1) = "" And grid.TextMatrix(1, 2) = "" And grid.TextMatrix(1, 3) = "" And grid.TextMatrix(1, 4) = "" Then
grid.TextMatrix(1, 1) = X
grid.TextMatrix(1, 2) = Y

'grid.TextMatrix(1, 3) = InputBox("Long ")

'grid.TextMatrix(1, 4) = InputBox("Lat ")
Text1.SetFocus


ElseIf grid.TextMatrix(2, 1) = "" And grid.TextMatrix(2, 2) = "" And grid.TextMatrix(2, 3) = "" And grid.TextMatrix(2, 4) = "" Then
grid.TextMatrix(2, 1) = X
grid.TextMatrix(2, 2) = Y

'grid.TextMatrix(2, 3) = InputBox("Long ")
'grid.TextMatrix(2, 4) = InputBox("Lat ")
Text1.SetFocus

ElseIf grid.TextMatrix(3, 1) = "" And grid.TextMatrix(3, 2) = "" And grid.TextMatrix(3, 3) = "" And grid.TextMatrix(3, 4) = "" Then
grid.TextMatrix(3, 1) = X
grid.TextMatrix(3, 2) = Y
'grid.TextMatrix(3, 3) = InputBox("Long ")
'grid.TextMatrix(3, 4) = InputBox("Lat ")
Text1.SetFocus
End If

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    lblLat.Caption = longs(X, Y)
    lblLong.Caption = lats(X, Y)
End Sub

Private Function lats(ByVal X As Single, ByVal Y As Single) As String
Dim d As Double
Dim m As Double
Dim s As Double

Dim lat As Long
Dim lng As Long
Label1.Caption = X
Label2.Caption = Y

' FOR ANY POINT
On Error Resume Next
lat = lat0 + (delY * Y)
d = Fix(lat / (60 * 60))  ' converting into degrees
m = Fix(((lat / (60 * 60)) - d) * 60)       ' into minutes
s = Fix(((((lat / (60 * 60)) - d) * 60) - m) * 60)  ' into seconds

lats = d & "." & m & "." & s & "E"

lng = lon0 + (delX * X)
d = Fix(lng / (60 * 60))  ' converting into degrees
m = Fix(((lng / (60 * 60)) - d) * 60)       ' into minutes
s = Fix(((((lng / (60 * 60)) - d) * 60) - m) * 60)  ' into seconds
lats = lats & d & "." & m & "." & s & " N"
End Function

Private Function longs(ByVal X As Single, ByVal Y As Single) As String
Dim d As Double
Dim m As Double
Dim s As Double

Dim lat As Long
Dim lng As Long
Label1.Caption = X
Label2.Caption = Y

lat = lat0 + (delY * Y)
d = Fix(lat / (60 * 60))  ' converting into degrees
m = Fix(((lat / (60 * 60)) - d) * 60)       ' into minutes
s = Fix(((((lat / (60 * 60)) - d) * 60) - m) * 60)  ' into seconds

longs = d & "." & m & "." & s & "E"

lng = lon0 + (delX * X)
d = Fix(lng / (60 * 60))  ' converting into degrees
m = Fix(((lng / (60 * 60)) - d) * 60)       ' into minutes
s = Fix(((((lng / (60 * 60)) - d) * 60) - m) * 60)  ' into seconds
longs = longs & d & "." & m & "." & s & " N"
End Function

'####################### ###########################

'####################### ##########################

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload Me
End Sub


Private Sub Label1_Click()
Unload Me
End Sub
Private Sub Text1_GotFocus()
Text1.SelLength = Len(Text1.Text)
End Sub
Private Sub Text2_GotFocus()
Text2.SelLength = Len(Text2.Text)
End Sub
Private Sub Text3_GotFocus()
Text3.SelLength = Len(Text3.Text)
End Sub
Private Sub Text4_GotFocus()
Text4.SelLength = Len(Text4.Text)
End Sub
Private Sub Text5_GotFocus()
Text5.SelLength = Len(Text5.Text)
End Sub
Private Sub Text6_GotFocus()
Text6.SelLength = Len(Text6.Text)
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Text2.SetFocus
End If
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Text3.SetFocus
End If
End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Combo1.SetFocus
End If

End Sub

Private Sub Text4_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Text5.SetFocus
End If

End Sub

Private Sub Text5_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Text6.SetFocus
End If
End Sub

Private Sub Text6_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Combo2.SetFocus
End If
End Sub