function.vb

这个是电子地图的 原程序 很好的,不错啊 侃侃 ,很有帮助

Option Strict Off
Option Explicit On
'UPGRADE_NOTE: Function 已升级到 Function_Renamed。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"”
Module Function_Renamed
	Public WX_l As Single '座标范围
	Public WY_t As Single
	Public WX_r As Single
	Public WY_b As Single
	Public VX_l As Single '视图范围
	Public VY_t As Single
	Public VX_r As Single
	Public VY_b As Single
	
	Public mapscale As Single '坐标转换比例参数
	Public firstx As Single '起始点
	Public firsty As Single
	Public endx As Single '终止点
	Public endy As Single
	
	'UPGRADE_WARNING: 应用程序将在 Sub Main() 结束时终止。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="E08DDC71-66BA-424F-A612-80AF11498FF8"”
	Public Sub main() '初始弹出框
		frmMain.Show()
	End Sub
	Public Sub Coodinate_Scale() '计算比例
		Dim dy0, scale_y, scale_x, dx0, dx As Object
		Dim dy As Single
		'UPGRADE_WARNING: 未能解析对象 scale_x 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		scale_x = (WX_r - WX_l) / (VX_r - VX_l)
		'UPGRADE_WARNING: 未能解析对象 scale_y 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		scale_y = (WY_t - WY_b) / (VY_b - VY_t)
		
		'UPGRADE_WARNING: 未能解析对象 scale_y 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		'UPGRADE_WARNING: 未能解析对象 scale_x 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		If scale_x < scale_y Then
			'UPGRADE_WARNING: 未能解析对象 scale_y 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
			mapscale = 1 / scale_y
		Else
			'UPGRADE_WARNING: 未能解析对象 scale_x 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
			mapscale = 1 / scale_x
		End If
		
		'UPGRADE_WARNING: 未能解析对象 dx0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		dx0 = (WX_r - WX_l)
		'UPGRADE_WARNING: 未能解析对象 dy0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		dy0 = (WY_t - WY_b)
		
		WX_r = WX_l + (VX_r - VX_l) / mapscale '更新世界坐标范围
		WY_b = WY_t - (VY_b - VY_t) / mapscale
		
		'UPGRADE_WARNING: 未能解析对象 dx 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		dx = (WX_r - WX_l)
		dy = (WY_t - WY_b)
		
		'UPGRADE_WARNING: 未能解析对象 dx0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		'UPGRADE_WARNING: 未能解析对象 dx 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		WX_l = WX_l + (dx - dx0) / 2
		'UPGRADE_WARNING: 未能解析对象 dx0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		'UPGRADE_WARNING: 未能解析对象 dx 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		WX_r = WX_r + (dx - dx0) / 2
		'UPGRADE_WARNING: 未能解析对象 dy0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		WY_t = WY_t + (dy - dy0) / 2
		'UPGRADE_WARNING: 未能解析对象 dy0 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
		WY_b = WY_b + (dy - dy0) / 2
		
	End Sub
	
	Public Sub SetMapExtent(ByRef x1 As Single, ByRef y1 As Single, ByRef x2 As Single, ByRef y2 As Single) '设置范围
		WX_l = x1
		WX_r = x2
		WY_t = y1
		WY_b = y2
		Coodinate_Scale()
	End Sub
	
	Public Sub ZoomIn() '放大
		Dim xx, yy As Single
		xx = (WX_r - WX_l) / 8
		yy = (WY_b - WY_t) / 8
		WX_l = WX_l + xx
		WX_r = WX_r - xx
		WY_t = WY_t + yy
		WY_b = WY_b - yy
		
		SetMapExtent(WX_l, WY_t, WX_r, WY_b)
	End Sub
	
	Public Sub ZoomOut() '缩小
		Dim xx, yy As Single
		xx = (WX_r - WX_l) / 8
		yy = (WY_b - WY_t) / 8
		WX_l = WX_l - xx
		WX_r = WX_r + xx
		WY_t = WY_t - yy
		WY_b = WY_b + yy
		
		SetMapExtent(WX_l, WY_t, WX_r, WY_b)
	End Sub
	
	Public Sub ZoomInAt(ByRef X As Single, ByRef Y As Single) '定点放大
		Dim x1 As Single : Dim y1 As Single
		Dim x2 As Single : Dim y2 As Single
		Dim x0 As Single : Dim y0 As Single
		Dim xx As Single : Dim yy As Single
		Call ScreenToWorld(X, Y, xx, yy)
		x0 = xx : y0 = yy
		Call ZoomIn()
		Call WorldToScreen(x0, y0, xx, yy)
		x1 = xx : y1 = yy
		x2 = (VX_r - VX_l) \ 2
		y2 = (VY_b - VY_t) \ 2
		
		Pan(x1, y1, x2, y2)
	End Sub
	
	Public Sub ZoomOutAt(ByRef X As Single, ByRef Y As Single) '定点缩小
		
		Dim x1 As Single : Dim y1 As Single
		Dim x2 As Single : Dim y2 As Single
		Dim x0 As Single : Dim y0 As Single
		Dim xx As Single : Dim yy As Single
		Call ScreenToWorld(X, Y, xx, yy)
		x0 = xx : y0 = yy
		Call ZoomOut()
		Call WorldToScreen(x0, y0, xx, yy)
		x1 = xx : y1 = yy
		
		x2 = (VX_r - VX_l) \ 2
		y2 = (VY_b - VY_t) \ 2
		
		Pan(x1, y1, x2, y2)
	End Sub
	
	Public Sub Fullmap() '全图显示
		WX_l = -180
		WX_r = 180
		WY_t = -90
		WY_b = 90
		
		SetMapExtent(WX_l, WY_t, WX_r, WY_b)
	End Sub
	
	Public Sub Pan(ByRef x1 As Single, ByRef y1 As Single, ByRef x2 As Single, ByRef y2 As Single) '移动
		Dim xx1, yy1 As Single
		Dim xx2, yy2 As Single
		Dim xx, yy As Single
		
		ScreenToWorld(x1, y1, xx1, yy1)
		ScreenToWorld(x2, y2, xx2, yy2)
		
		xx = xx2 - xx1
		yy = yy2 - yy1
		
		WX_l = WX_l - xx
		WX_r = WX_r - xx
		WY_t = WY_t - yy
		WY_b = WY_b - yy
		SetMapExtent(WX_l, WY_t, WX_r, WY_b)
	End Sub
	
	Public Sub ZoomWindow(ByRef x1 As Single, ByRef y1 As Single, ByRef x2 As Single, ByRef y2 As Single) '开窗放大
		Dim X, Y As Single
		Dim xx1, yy1 As Single
		Dim xx2, yy2 As Single
		
		If (x1 = x2) Or (y1 = y2) Then
			Call ZoomInAt((x1 + x2) \ 2, (y1 + y2) \ 2)
			Exit Sub
		End If
		
		Call ScreenToWorld(x1, y1, xx1, yy1)
		Call ScreenToWorld(x2, y2, xx2, yy2)
		
		If xx1 > xx2 Then
			X = xx1 : xx1 = xx2 : xx2 = X
		End If
		If yy1 < yy2 Then
			Y = yy1 : yy1 = yy2 : yy2 = Y
		End If
		
		Call SetMapExtent(xx1, yy1, xx2, yy2)
	End Sub
	
	
	'屏幕座标到世界座标
	Public Sub ScreenToWorld(ByVal X As Single, ByVal Y As Single, ByRef xx As Single, ByRef yy As Single)
		xx = (X - VX_l) / mapscale + WX_l
		yy = WY_t + (VY_t - Y) / mapscale
	End Sub
	
	'世界座标到屏幕座标
	Public Sub WorldToScreen(ByVal X As Single, ByVal Y As Single, ByRef xx As Single, ByRef yy As Single)
		xx = CSng((X - WX_l) * mapscale) + VX_l
		yy = CSng((WY_t - Y) * mapscale) + VY_t
	End Sub
End Module