function.bas

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

Attribute VB_Name = "Function"
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

Public Sub main()          '初始弹出框
     frmMain.Show
End Sub
Public Sub Coodinate_Scale()   '计算比例
    Dim scale_x, scale_y, dx0, dy0, dx, dy As Single
    scale_x = (WX_r - WX_l) / (VX_r - VX_l)
    scale_y = (WY_t - WY_b) / (VY_b - VY_t)
    
    If scale_x < scale_y Then
        mapscale = 1 / scale_y
    Else
        mapscale = 1 / scale_x
    End If
    
    dx0 = (WX_r - WX_l)
    dy0 = (WY_t - WY_b)
    
    WX_r = WX_l + (VX_r - VX_l) / mapscale  '更新世界坐标范围
    WY_b = WY_t - (VY_b - VY_t) / mapscale
    
    dx = (WX_r - WX_l)
    dy = (WY_t - WY_b)
    
    WX_l = WX_l + (dx - dx0) / 2
    WX_r = WX_r + (dx - dx0) / 2
    WY_t = WY_t + (dy - dy0) / 2
    WY_b = WY_b + (dy - dy0) / 2

End Sub

Public Sub SetMapExtent(x1 As Single, y1 As Single, x2 As Single, y2 As Single)     '设置范围
    WX_l = x1
    WX_r = x2
    WY_t = y1
    WY_b = y2
    Coodinate_Scale
End Sub

Public Sub ZoomIn()    '放大
    Dim xx As Single, 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 As Single, 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(X As Single, 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(X As Single, 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(x1 As Single, y1 As Single, x2 As Single, y2 As Single)     '移动
    Dim xx1 As Single, yy1 As Single
    Dim xx2 As Single, yy2 As Single
    Dim xx As Single, 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(x1 As Single, y1 As Single, x2 As Single, y2 As Single)  '开窗放大
    Dim X As Single, Y As Single
    Dim xx1 As Single, yy1 As Single
    Dim xx2 As Single, 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, xx As Single, 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, xx As Single, yy As Single)
    xx = CSng((X - WX_l) * mapscale) + VX_l
    yy = CSng((WY_t - Y) * mapscale) + VY_t
End Sub