form1.frm

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

         TabIndex        =   4
         Top             =   600
         Width           =   1335
      End
   End
   Begin VB.Menu file 
      Caption         =   "文件(&F)"
      Begin VB.Menu new 
         Caption         =   "新建(&N)"
         Shortcut        =   ^N
      End
      Begin VB.Menu open 
         Caption         =   "打开(&O)..."
         Shortcut        =   ^O
      End
      Begin VB.Menu shut 
         Caption         =   "关闭(&Q)"
         Shortcut        =   ^Q
      End
      Begin VB.Menu line1 
         Caption         =   "-"
      End
      Begin VB.Menu save 
         Caption         =   "保存(&S)"
         Shortcut        =   ^S
      End
      Begin VB.Menu saveas 
         Caption         =   "另存为(&A)..."
         Shortcut        =   ^I
      End
      Begin VB.Menu mnuS 
         Caption         =   "-"
      End
      Begin VB.Menu quit 
         Caption         =   "退出"
         Shortcut        =   ^{F4}
      End
   End
   Begin VB.Menu edit 
      Caption         =   "编辑(&E)"
      Begin VB.Menu copy 
         Caption         =   "复制"
         Shortcut        =   ^C
      End
      Begin VB.Menu paste 
         Caption         =   "粘贴"
         Shortcut        =   ^V
      End
      Begin VB.Menu cut 
         Caption         =   "剪切"
         Shortcut        =   ^X
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu about 
         Caption         =   "关于..."
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=======================================================================================================
'
'
'实验4：    实现图形的放大、缩小、平移等功能
'
'      1.   实现图形显示的放大、缩小
'
'      2.   图形的平移
'
'      3.   图形充满整个窗口
'
'      4.   图形的定点放大和缩小
'
'
'=======================================================================================================





Dim FunctionID As Integer
Dim tag_pan As Boolean

Private Sub Form_Load()        '初始窗口
    WX_l = -180
    WY_t = 90
    WX_r = 180
    WY_b = -90
    VX_l = Picview.Left
    VY_t = Picview.Top
    VX_r = VX_l + Picview.Width
    VY_b = VY_t + Picview.Height
    tag_pan = False
    Set frmMain.Icon = Nothing
End Sub

Private Sub Form_Resize()        '屏幕大小放缩变换
    Picview.Cls
    Picview.Width = Abs(frmMain.ScaleWidth - 345)
    Picview.Height = Abs(frmMain.ScaleHeight - 1600)
       
    VX_l = Picview.ScaleLeft
    VY_t = Picview.ScaleTop
    VX_r = VX_l + Picview.ScaleWidth
    VY_b = VY_t + Picview.ScaleHeight
    Coodinate_Scale
    DrawGrid
End Sub

Private Sub DrawGrid()  '画网格
    Dim i, j As Integer
    Dim draw_wx, draw_wy As Single
    Dim draw_vxl As Single, draw_vyt As Single
    Dim draw_vxr As Single, draw_vyb As Single
    
    With Picview
        .DrawMode = vbCopyPen
        .DrawStyle = vbSolid
        .DrawWidth = 1
    End With
      
    For i = 0 To 36
        draw_wx = -180 + 10 * i
        draw_wy = 90
        Call WorldToScreen(draw_wx, draw_wy, draw_vxl, draw_vyt)
        draw_wy = -90
        Call WorldToScreen(draw_wx, draw_wy, draw_vxr, draw_vyb)
        Picview.Line (draw_vxl, draw_vyt)-(draw_vxr, draw_vyb)
    Next i
    For j = 0 To 18
        draw_wx = -180
        draw_wy = 90 - 10 * j
        Call WorldToScreen(draw_wx, draw_wy, draw_vxl, draw_vyt)
        draw_wx = 180
        Call WorldToScreen(draw_wx, draw_wy, draw_vxr, draw_vyb)
        Picview.Line (draw_vxl, draw_vyt)-(draw_vxr, draw_vyb)
    Next j
End Sub

'==========================================   鼠标事件   ===========================================

Private Sub Picview_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If tag_pan = False Then
        Select Case FunctionID
            Case 1: ZoomIn
            Case 2: ZoomOut
            Case 3: ZoomInAt X, Y
            Case 4: ZoomOutAt X, Y
            Case 5:
                    firstx = X: firsty = Y
                    tag_pan = True
            Case 6: Fullmap
            Case 7: Picview.DrawMode = vbNotXorPen
                    Picview.ForeColor = vbRed
                    Picview.DrawWidth = 2
                    firstx = X: firsty = Y
                    tag_pan = True
                    endx = firstx: endy = firsty
                    Picview.Line (firstx, firsty)-(endx, endy), , B
        End Select

        If tag_pan = False Then
            Picview.Cls
            DrawGrid
        End If
    End If
End Sub

Private Sub Picview_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim wx As Single, wy As Single

    Call ScreenToWorld(X, Y, wx, wy)
    StatusBar1.Panels(1).Text = "世界坐标：(" + Format(CStr(wx), "0.000") + "," + Format(CStr(wy), "0.000") + ")"
    StatusBar1.Panels(2).Text = "屏幕坐标：(" + CStr(X) + "," + CStr(Y) + ")"

    If FunctionID = 7 And tag_pan = True Then
       Picview.Line (firstx, firsty)-(endx, endy), , B
       Picview.Line (firstx, firsty)-(X, Y), , B
       endx = X: endy = Y
    End If
End Sub

Private Sub Picview_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If tag_pan = True Then
        If FunctionID = 5 Then
            Pan firstx, firsty, X, Y
            tag_pan = False
        ElseIf FunctionID = 7 Then
            ZoomWindow firstx, firsty, X, Y
            tag_pan = False
        End If
        Picview.Cls
        DrawGrid
    End If
End Sub

'============================================   按钮   ============================================

Private Sub ToolbarView_ButtonClick(ByVal Button As MSComctlLib.Button)     '视图工具
    Select Case Button.Index
        Case 2: FunctionID = 1
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\pzoomin.ico")
                ZoomIn
                Picview.Cls
                DrawGrid
        Case 3: FunctionID = 2
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\pzoomout.ico")
                ZoomOut
                Picview.Cls
                DrawGrid
        Case 4: FunctionID = 3
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\zoomin.ico")
        Case 5: FunctionID = 4
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\zoomout.ico")
        Case 6: FunctionID = 5
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\hand.ico")
        Case 7: FunctionID = 6
                Picview.MousePointer = 0
                Fullmap
                Picview.Cls
                DrawGrid
        Case 8: FunctionID = 7
                Picview.MousePointer = 99
                Picview.MouseIcon = LoadPicture(App.Path & "\icon\draw.cur")
    End Select
End Sub