form1.frm

mapgis二次开发,vb示例 mapgis二次开发,vb示例

VERSION 5.00
Object = "{5A187E03-1FE4-11D3-9C2F-000021DF30C1}#1.0#0"; "EditView.ocx"
Object = "{24075224-9523-41F5-B041-AF891E546822}#1.0#0"; "GisAttEdit.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin GISATTEDITLib.GisAttEdit GisAttEdit 
      Height          =   615
      Left            =   480
      TabIndex        =   1
      Top             =   2520
      Width           =   3735
      _Version        =   65536
      _ExtentX        =   6588
      _ExtentY        =   1085
      _StockProps     =   0
   End
   Begin EDITVIEWLib.EditView EditView 
      Height          =   2295
      Left            =   480
      TabIndex        =   0
      Top             =   0
      Width           =   3735
      _Version        =   65536
      _ExtentX        =   6588
      _ExtentY        =   4048
      _StockProps     =   0
   End
   Begin VB.Menu mnuOpen 
      Caption         =   "打开文件"
   End
   Begin VB.Menu mnuRectAsk 
      Caption         =   "拉框取图元"
   End
   Begin VB.Menu mnuCancel 
      Caption         =   "取消操作"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'简单起见，用区工作区取代工程(其实是一样的)
Dim area As RegArea

'拉框查询图元标志
Dim bRectAsk As Boolean

'左键按下标志
Dim bLeftDown As Boolean

'浏览、编辑的属性是否为记录集标志
Dim bAttIsRcdSt As Boolean

'确定画异或矩形时该矩形两个角的设备坐标
Dim x1 As Variant
Dim y1 As Variant
Dim x2 As Variant
Dim y2 As Variant

'画异或矩形时保存本次的坐标位置，下一次用异或线擦掉(设备坐标)
Dim lastX As Variant
Dim lastY As Variant

Dim lst As IDList           '返回查询实体号

Dim pdc As MapGisDC

Private Sub EditView_CurAttElement(ByVal lNo As Long)
    If Not bAttIsRcdSt Then
        GisAttEdit.GotoAtt lNo
    Else
        GisAttEdit.GotoAtt SemiSearch(0, lst.Count - 1, lNo) + 1
        'GisAttEdit.GotoAtt lNo
    End If
End Sub

Private Sub EditView_MouseLButtonDown(ByVal xPos As Double, ByVal yPos As Double)
    Dim lastmode As Long
    
    If bRectAsk Then
        bLeftDown = True
        
        lastmode = pdc.SetPenMode(7)
        
        pdc.LpToDp xPos, yPos, x1, y1
        
        lastX = x1
        lastY = y1
        
        pdc.RectXY x1, y1, lastX, lastY, EditView.BackgroundColor
        
        Call pdc.SetPenMode(lastmode)
    End If
End Sub

Private Sub EditView_MouseLButtonUp(ByVal xPos As Double, ByVal yPos As Double)
    Dim rc As New D_Rect        '最后形成的查询矩形
    
    Dim myQuery As New Query    '查询对象
    
    Dim rcd As Record           '
    
    Dim rcdst As New Recordset  '记录集
    
    Dim i As Long
    
    Dim flg As Integer
    
    Dim lX1 As Variant
    Dim lY1 As Variant
    Dim lX2 As Variant
    Dim lY2 As Variant
    
    Dim lastmode As Long
    
    If bRectAsk And bLeftDown Then
        bLeftDown = False
        bRectAsk = False
        
        '将画笔设置为“异或”
        lastmode = pdc.SetPenMode(7)    '7 代表异或
        
        '用“异或”矩形擦掉最后一次画的矩形
        '即最后左键弹起时矩形消失
        pdc.RectXY x1, y1, lastX, lastY, EditView.BackgroundColor
                
        '将画笔设置为原来的值，便于以后系统对画笔的调用
        Call pdc.SetPenMode(lastmode)
            
        '将 x1,y1,x2,y2 转成逻辑坐标
        EditView.DpToLp CLng(x1), CLng(y1), lX1, lY1
        EditView.DpToLp CLng(x2), CLng(y2), lX2, lY2
        
        '形成查询矩形
        If lX1 < lX2 Then
            rc.xmin = lX1
            rc.xmax = lX2
        Else
            rc.xmax = lX1
            rc.xmin = lX2
        End If
        
        If lY1 < lY2 Then
            rc.ymin = lY1
            rc.ymax = lY2
        Else
            rc.ymax = lY1
            rc.ymin = lY2
        End If
        
        '调用查询
        myQuery.sourceArea = area
        
        Set lst = myQuery.RectAskToList(gisREG_ENTITY, rc)
            
        For i = 0 To lst.Count - 1
            flg = area.RegAtt.Get(lst(i), rcd)
            
            If flg > 0 Then
                rcdst.Append rcd
            End If
        Next
            
        GisAttEdit.DetachArea
        GisAttEdit.DetachRcds
        
        If rcdst.numbrecord > 0 Then
            GisAttEdit.AttachRcds rcdst     '属性控件绑定记录集
        
            bAttIsRcdSt = True
        
            '拉框后马上闪烁记录集中第一条记录对应的实体
            EditView.GotoElement area, lst(0), gisREG_ENTITY
        End If
    End If
    
    Set rcdst = Nothing
    Set myQuery = Nothing
    Set rc = Nothing
End Sub

Private Sub EditView_MousePosition(ByVal x_Pos As Double, ByVal y_Pos As Double)
    Dim lastmode As Long
    
    If bRectAsk And bLeftDown Then
        pdc.LpToDp x_Pos, y_Pos, x2, y2
        
        '将画笔设置为“异或”
        lastmode = pdc.SetPenMode(7)    '7 代表异或
        
        '先用“异或”矩形擦掉上一次画的矩形
        pdc.RectXY x1, y1, lastX, lastY, EditView.BackgroundColor
        
        '画出新的矩形
        pdc.RectXY x1, y1, x2, y2, EditView.BackgroundColor
        
        '记录这一次矩形的位置
        lastX = x2
        lastY = y2
        
        '将画笔设置为原来的值，便于以后系统对画笔的调用
        Call pdc.SetPenMode(lastmode)
    End If
End Sub

Private Sub EditView_MouseRButtonUp(ByVal xPos As Double, ByVal yPos As Double)
'    mnuCancel_Click
End Sub

Private Sub Form_Load()
    Set area = New RegArea
    
    EditView.DspBigCross = False    '不显示大十字光标
    EditView.PopMenuControl = 1     '控制弹出菜单
    
    bRectAsk = False
    bLeftDown = False
    bAttIsRcdSt = False
End Sub

Private Sub Form_Resize()
    EditView.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight * 2 / 3
    GisAttEdit.Move 0, EditView.Height, Me.ScaleWidth, Me.ScaleHeight - EditView.Height
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set area = Nothing
End Sub

Private Sub GisAttEdit_CurRcdFldNo(ByVal rcdNo As Long, ByVal fldNo As Integer)
    If Not bAttIsRcdSt Then
        EditView.GotoElement area, rcdNo, gisREG_ENTITY
    Else
        EditView.GotoElement area, lst(rcdNo - 1), gisREG_ENTITY
    End If
End Sub

Private Sub mnuCancel_Click()
    EditView.CancelOperation
    bRectAsk = False
    bAttIsRcdSt = False
    GisAttEdit.AttachArea area, gisREG_ENTITY
End Sub

Private Sub mnuOpen_Click()
    area.Load
    EditView.RegArea = area
    EditView.LinkAttSwitch = True
    EditView.AttachAttWorkArea area, gisREG_ENTITY
    GisAttEdit.AttachArea area, gisREG_ENTITY
End Sub

'拉框取图元
Private Sub mnuRectAsk_Click()
    bRectAsk = True         '鼠标事件判断此标志作出响应
    
    Set pdc = EditView.pMapGisDC
    
    '准备拉框，停止闪烁当前图元
    EditView.StopFlash
End Sub


'折半查找
Private Function SemiSearch(pStart As Long, pEnd As Long, lNo As Long) As Long
    Dim pMid As Long
    Dim rtl As Long
    
    If pEnd - pStart <= 1 Then
        If lst(pStart) = lNo Then
            rtl = pStart
        ElseIf lst(pEnd) = lNo Then
            rtl = pEnd
        Else
            rtl = -1
        End If
    Else
        pMid = (pStart + pEnd) / 2
        
        If lst(pMid) < lNo Then
            rtl = SemiSearch(pMid, pEnd, lNo)
        ElseIf lst(pMid) > lNo Then
            rtl = SemiSearch(pStart, pMid, lNo)
        Else
            rtl = pMid
        End If
    End If
    
    SemiSearch = rtl
End Function