gps4ppc.sbp

一个用VB4PPC编的gps应用实例.适合VB入门者下载学习.

Sub cmbZone_SelectionChanged (Index, Value)
	Select Index
		Case 0 'NE
			north = 1
			east = 1
		Case 1 'NW
			north = 1
			east = -1
		Case 2 'SE
			north = -1
			east = 1
		Case 3 'SW
			north = -1
			east = -1
	End Select
	If north = 1 Then Label1.Text = "N" Else Label1.Text = "S"
	If east = 1 Then Label2.Text = "E" Else Label2.Text = "W"	
End Sub

'Converts the Lat/Lon to UTM.
Sub btnToUTM_Click
	UTM() = Converter.LatLonToUTM(Datums(datum).Axis,Datums(datum).F,LatLonFromString(txtLat.Text,north), LatLonFromString(txtLon.Text,east))
	txtXZone.Text = UTM.XZone
	txtUTMx.Text = Round(UTM.X)
	txtUTMy.Text = Round(UTM.Y)
End Sub

'Converts the UTM to Lat/Lon.
Sub btnToLL_Click
	ErrorLabel(btnToLL_err)
	If north = 1 Then n = true Else n = false
	LL() = Converter.UTMToLatLon(Datums(datum).Axis,Datums(datum).F,txtXZone.Text,txtUTMx.Text,n,txtUTMy.Text)
	txtLat.Text = StringFromLatLon(LL.Lat)
	txtLon.Text = StringFromLatLon(LL.Lon)
	btnToLL_err:
End Sub

'Shows frmConvert.
'Some of the controls (including the numpad) are shared between frmConvert and frmCalc.
Sub ImageButton2_Click
	alTextBox.Clear
	alTextBox.Add("txtlat") 'Sets the textboxes the will work with the numpad.
	alTextBox.Add("txtlon")
	alTextBox.Add("txtxzone")
	alTextBox.Add("txtutmx")
	alTextBox.Add("txtutmy")
	flb.ChangeParent("pnlCombo","frmConvert")
	flb.ChangeParent("pnlKeys","frmConvert")
	flb.ChangeParent("btnClearAll","frmConvert")
	focused = alTextBox.Item(0)
	Control(focused).Focus
	frmConvert.Show
End Sub

#Region GPS Form
'GPS methods.

Sub ImageButton3_Click 'Shows frmGPS.
	frmGPS.Show
End Sub

'Updates the comboboxes.
Sub frmGPS_Show
	cmbDatum2.SelectedIndex = datum
	cmbFormat2.SelectedIndex = frmt
End Sub

Sub mnuShowAllPorts_Click
	mnuShowAllPorts.Checked = Not(mnuShowAllPorts.Checked)
End Sub
'Shows the panel that allows the user to select the port.
Sub mnuConnect_Click
	lstPorts.Clear
	FindPorts
	pnlPorts.Top = 30
	pnlPorts.Visible = true 
End Sub


Sub btnCancel_Click
	pnlPorts.Visible = false
End Sub

'Closes the panel and calls ConnectGPS.
Sub btnOK_Click
	If lstPorts.SelectedIndex < 0 Then Return
	s = lstPorts.Item(lstPorts.SelectedIndex)
	If CPPC Then
		i = StrIndexOf(s,":",0)
		If i > -1 Then
			Settings.Port = SubString(s,3,i-3)
		Else 
			Settings.Port = SubString(s,3,StrLength(s)-3)
		End If
	Else
		Settings.Port = SubString(s,3,StrLength(s)-3)
	End If
	pnlPorts.visible = false
	mnuConnectDefault.Enabled = true
	mnuConnectDefault.Text = "Connect: Port " & Settings.Port
	ConnectGPS
End Sub

'Reads the ports description from the registry.
Sub FindPorts
	al1.Clear
	If CPPC AND Not(mnuShowAllPorts.Checked) Then 'read the ports from the registry
		Reg.RootKey(Reg.rtLocalMachine)
		subKeys() = Reg.GetSubKeyNames("Drivers\Active") 'Gets the list of active drivers.
		For i = 0 To ArrayLen(SubKeys())-1
			values() = Reg.GetValueNames("Drivers\Active\" & subKeys(i))
			For i2 = 0 To ArrayLen(values())-1
				If values(i2) = "Name" Then 'Checks if Name value exists.
					name = Reg.GetValue("Drivers\Active\" & subKeys(i),"Name")
					If SubString(name,0,3) = "COM" Then 'Checks if the driver name starts with COM.
						key = Reg.GetValue("Drivers\Active\" & subKeys(i),"Key")
						al1.Add(name & ": " & reg.GetValue(key,"FriendlyName")) 'Gets the FriendlyName value.
					End If
					Exit
				End If
			Next
		Next		
		al1.Sort(cCaseUnsensitive) 'Sorts the values.
		For i = 0 To al1.Count-1
			lstPorts.Add(al1.Item(i)) 'Adds the values to the ListBox.
		Next
	Else
		For i = 1 To 16
			lstPorts.Add("COM" & i)
		Next
	End If
End Sub

'Connects to the GPS.
'If the connection is successful, timer1 is enabled. This timer reads the data.
Sub ConnectGPS
	WaitCursor(True)
	ErrorLabel(ConnectGPS_Err)
	Serial.New2(Settings.Port,Settings.BaudRate,"N",8,1)
	Serial.PortOpen = true
	If Serial.PortOpen = false Then
		Msgbox("Error opening port: " & Settings.Port,"GPS4PPC",cMsgboxOK,cMsgboxHand)
	Else
		mnuDisconnect.Enabled = true
		Timer1.Enabled = true
		timeout = 0
		Msgbox("GPS is connected.")
	End If
	WaitCursor(False)
	Return
	ConnectGPS_Err:
	WaitCursor(False)
	Msgbox("Error opening port: " & Settings.Port,"GPS4PPC",cMsgboxOK,cMsgboxHand)
End Sub

'Reads the data from the serial buffer and sends it to GPSStream.
'If there is no data for 5 seconds the GPS will be disconnected.	
Sub Timer1_Tick
	If serial.InBufferCount>0 Then 
		timeout = 0
		GPS.GPSStream(serial.InputString) 'Takes the data received from the GPS to GPSStream.
	Else
		timeout = timeout + 1
		If timeout = 5 Then mnuDisconnect_click
	End If
End Sub

'This event fires when there is enough data to parse the GPS string.
Sub GPS_GPSDecoded
	lblSatellites.Text = GPS.NumberOfSatellites
	If GPS.Status = "V" Then 'V means that the status is invalid.
		lblCord.FontColor = cGray
	Else If GPS.DecimalLatitude <> 0 Then
		lblCord.FontColor = cBlue
		If datum > 0 Then 'If the user chose a datum different than WGS84, the Lat/Lon should be converted.
			dx = Datums(0).Dx - Datums(datum).Dx
			dy = Datums(0).Dy - Datums(datum).Dy
			dz = Datums(0).Dz - Datums(datum).Dz
			ll() = Converter.ChangeDatum(GPS.DecimalLatitude,GPS.DecimalLongitude, Datums(0).Axis,Datums(0).F,Datums(datum).Axis,Datums(datum).F,dx,dy,dz)
		Else
			ll.Lat = GPS.DecimalLatitude
			ll.Lon = GPS.DecimalLongitude
		End If
		If cmbCordType.SelectedIndex = 0 Then 'Lat / Lon
			If ll.Lat > 0 Then N = "N" Else N = "S"
			If ll.Lon > 0 Then E = "E" Else E = "W"
			lblCord.Text = N & " " & StringFromLatLon(ll.Lat) & " " & E & StringFromLatLon(ll.Lon)
		Else 'UTM
			UTM() = Converter.LatLonToUTM(Datums(datum).Axis,Datums(datum).F,ll.Lat,ll.Lon)
			lblCord.Text = UTM.XZone & " " & Round(UTM.X) & "  " & Round(UTM.Y)
		End If
		If GPS.CourseOverGround <> "" Then
			Rotate(GPS.CourseOverGround) 'Rotate the compass arrow.
			lblCourse.Text = Round(GPS.CourseOverGround)
		End If
		If GPS.SpeedOverGround <> "" Then  'Convert the speed to MPH or KMH (from nautical miles).
			If cmbKM.SelectedIndex = 0 Then 
				lblSpeed.Text = Round(GPS.SpeedOverGround * 1.852)
			Else
				lblSpeed.Text = Round(GPS.SpeedOverGround * 1.151)
			End If
		End If
	End If
End Sub

'Disconnects the connection.
Sub mnuDisconnect_Click
	Timer1.Enabled = false
	If Serial.PortOpen Then Serial.PortOpen = false
	lblCord.FontColor = cGray
	Msgbox("GPS disconnected.")
End Sub

'Updates the other comboboxes.
Sub cmbFormat2_SelectionChanged (Index, Value)
	cmbFormat.SelectedIndex = Index
End Sub

Sub cmbDatum2_SelectionChanged (Index, Value)
	cmbDatum.SelectedIndex = Index
End Sub

'Connect using the previous port.
Sub mnuConnectDefault_Click
	ConnectGPS
End Sub

'Rotates the compass arrow.
Sub Rotate (course) 
	frmGPS.FCircle(72,205,60,cPurple,F)
	delta = (course - degree) / 180 * cPI 'Convert to radians
	degree = course
	c = Cos(delta)
	s = Sin(delta)
	For i = 0 To 3
		x = points(i).x - 72
		y = points(i).y - 205
		points(i).x = x * c - y * s + 72
		points(i).y = y * c + x * s + 205
	Next
	frmGPS.FPolygon(points(),0,4,cGray,f)
End Sub

#End Region
#Region Calculator
'Calculator methods.

Sub btnCalc_Click
	alTextBox.Clear
	alTextBox.Add("txtlat") 'Textboxes names. Must be lower case.
	alTextBox.Add("txtlon")
	alTextBox.Add("txtxzone")
	alTextBox.Add("txtutmx")
	alTextBox.Add("txtutmy")
	flb.ChangeParent("pnlCombo","frmCalc")
	flb.ChangeParent("pnlKeys","frmCalc")
	flb.ChangeParent("btnClearAll","frmCalc")
	focused = alTextBox.Item(0)
	Control(focused).Focus
	frmCalc.Show
End Sub

'Sets the 6 textboxes.
Sub mnuUTM_Click
	mnuUTM.Checked = true
	mnuLL.Checked = false
	txtDest1.Visible = true
	txtSrc1.Visible = true
	alTextBox.Clear
	alTextBox.Add("txtsrc1")
	alTextBox.Add("txtsrc2")
	alTextBox.Add("txtsrc3")
	alTextBox.Add("txtdest1")
	alTextBox.Add("txtdest2")
	alTextBox.Add("txtdest3")
	txtSrc2.Focus
End Sub

'Sets the 4 textboxes.
Sub mnuLL_Click
	mnuUTM.Checked = false
	mnuLL.Checked = true
	txtDest1.Visible = false
	txtSrc1.Visible = false
	alTextBox.Clear
	alTextBox.Add("txtsrc2")
	alTextBox.Add("txtsrc3")
	alTextBox.Add("txtdest2")
	alTextBox.Add("txtdest3")
	txtSrc2.Focus
	focused = "txtsrc2"
End Sub

'Reads the coordinates and calls Distance_Course which calculates the distance and the course.
Sub btnCalcDistance_Click
	ErrorLabel(btnCalcDistance_err)
	If mnuUTM.Checked Then
		If north = 1 Then n = true Else n = false
		LL() = Converter.UTMToLatLon(Datums(datum).Axis,Datums(datum).F,txtSrc1.Text,txtSrc2.Text,n,txtSrc3.Text)
		lat1 = LL.Lat
		lon1 = LL.Lon
		LL() = Converter.UTMToLatLon(Datums(datum).Axis,Datums(datum).F,txtDest1.Text,txtDest2.Text,n,txtDest3.Text)
	Else
		lat1 = LatLonFromString(txtSrc2.Text,north)
		lon1 = LatLonFromString(txtSrc3.Text,east)
		LL.Lat = LatLonFromString(txtDest2.Text,north)
		LL.Lon = LatLonFromString(txtDest3.Text,east)
	End If
	Distance_Course(lat1,lon1,LL.Lat,LL.Lon)
	dis() = res()
	If cmbKM.SelectedIndex = 0 Then 
		d = Round(dis.Distance * 1.852,2) & " km"
	Else
		d = Round(dis.Distance * 1.151,2) & " miles"
	End If
	Msgbox("Distance: " & d & crlf & "Course: " & Format(Round(dis.Course),"d3") & " deg")
	Return
	btnCalcDistance_err:
	Msgbox("Error calculating data.")
End Sub

'This sub calculates the distance and course between two Lat/Lon coordinates.
'The formulas are based on this site: http://williams.best.vwh.net/avform.htm (Ed Williams)
Sub Distance_Course (lat1,lon1,lat2,lon2)
	ErrorLabel(Distance_CourseErr)
	lat1 = lat1 * cPI / 180
	lon1 = -lon1 * cPI / 180
	lat2 = lat2 * cPI / 180
	lon2 = -lon2 * cPI / 180
	d = 2 * ASin(Sqrt((Sin((lat1-lat2)/2))^2 + Cos(lat1)*Cos(lat2)*(Sin((lon1-lon2)/2))^2))
	res.Distance = d * 180 * 60 /cPI
	If Cos(lat1) < 1e-7 Then
		If (lat1 > 0) Then 
			tc1 = cpi
		Else
			tc1= 2*cpi 
		End If
	Else
		sn = Sin(lon2-lon1)
		If Abs(sn) < 1e-7 Then
			If lat1 > lat2 Then tc1 = cpi Else tc1 = 2*cpi
		Else If sn < 0 Then        
			tc1=ACos((Sin(lat2)-Sin(lat1)*Cos(d))/(Sin(d)*Cos(lat1)))    
		Else       
			tc1=2*cpi-ACos((Sin(lat2)-Sin(lat1)*Cos(d))/(Sin(d)*Cos(lat1)))
		End If 
	End If
	res.Course = tc1 * 180 / cPI
	Return
	Distance_CourseErr:
	res.Distance = 0
	res.Course = 0
End Sub
#End Region

'Saves the settings to the INI file.
Sub Form1_Close
	ErrorLabel(Form1_Close_err)
	FileOpen(c1,"GPS4PPC.ini",cWrite)
	FileWrite(c1,ver)
	For i = 0 To al2.Count-1
		FileWrite(c1,Control(al2.Item(i)).Text)
	Next
	FileWrite(c1,datum)
	FileWrite(c1,frmt)
	FileWrite(c1,cmbKM.SelectedIndex)
	FileWrite(c1,cmbZone.SelectedIndex)
	FileWrite(c1,mnuUTM.Checked)
	FileWrite(c1,cmbCordType.SelectedIndex)
	FileWrite(c1,Settings.Port)
	FileWrite(c1,Settings.BaudRate)
	FileWrite(c1,mnuShowAllPorts.Checked)
	FileClose(c1)
	Form1_Close_err:
End Sub

'Loads the settings from the INI file.
Sub LoadINIFile
	ErrorLabel(LoadINIFile_err)
	If FileExist("GPS4PPC.ini") Then
		FileOpen(c1,"GPS4PPC.ini",cRead)
		FileRead(c1)
		For i = 0 To al2.Count-1
			s = FileRead(c1)
			If s = EOF Then Goto LoadINIFile_err
			Control(al2.Item(i)).Text = s
		Next
		datum = FileRead(c1)
		frmt = FileRead(c1)
		cmbKM.SelectedIndex = FileRead(c1)
		cmbZone.SelectedIndex = FileRead(c1)
		a = FileRead(c1)
		If Not(a) Then mnuLL_Click
		cmbCordType.SelectedIndex = FileRead(c1)
		Settings.Port = FileRead(c1)
		Settings.BaudRate = FileRead(c1)
		If Settings.Port > 0 Then
			mnuConnectDefault.Enabled = true
			mnuConnectDefault.Text = "Connect: Port " & Settings.Port
		End If
		mnuShowAllPorts.Checked = FileRead(c1)
		FileClose(c1)
	End If
	Return
	LoadINIFile_err:
	FileClose(c1)
End Sub 

Sub btnAbout_Click
	s = "Version: " & ver & crlf & "License: Freeware" & crlf & "Source code and support is available at www.basic4ppc.com"
	Msgbox(s,"GPS4PPC",cMsgboxOK,cMsgboxAsterisk)
End Sub

Sub mnuExit_Click
	AppClose
End Sub