childform.frm

里面有我用VB二次开发MAPGIS的20个例子

VERSION 5.00
Object = "{5A187E03-1FE4-11D3-9C2F-000021DF30C1}#1.0#0"; "EditView.ocx"
Begin VB.Form ChildForm 
   AutoRedraw      =   -1  'True
   ClientHeight    =   5196
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   7260
   FillColor       =   &H80000010&
   Icon            =   "ChildForm.frx":0000
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   5196
   ScaleWidth      =   7260
   Begin VB.PictureBox GisAttEdit 
      Height          =   1215
      Left            =   120
      ScaleHeight     =   1164
      ScaleWidth      =   3804
      TabIndex        =   1
      Top             =   1920
      Width           =   3855
   End
   Begin EDITVIEWLib.EditView EditView 
      Height          =   1455
      Left            =   600
      TabIndex        =   0
      Top             =   120
      Width           =   2895
      _Version        =   65536
      _ExtentX        =   5106
      _ExtentY        =   2566
      _StockProps     =   0
   End
   Begin VB.Line splliter 
      BorderWidth     =   2
      X1              =   120
      X2              =   3960
      Y1              =   1800
      Y2              =   1800
   End
End
Attribute VB_Name = "ChildForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public aiType As Integer    '工作区类型
Public Ai As WorkArea       '工作区对象
'浏览编辑属性标志
Public isBrowAtt As Integer

Private Sub EditView_CurAttElement(ByVal lno As Long)
GisAttEdit.GotoAtt lno
End Sub

Private Sub EditView_LButtonDblClk(ByVal xPos As Double, ByVal yPos As Double)
Dim lai As LinArea
Dim xy As New D_Dot
Dim lno As Long
Dim rcd As Record

If Ai.Type <> gisLIN Then
    Exit Sub
End If

xy.x = xPos
xy.y = yPos
Set lai = Ai            '将Ai赋给线工作区对象lai
lno = lai.Near(xy)      '根据坐标取线号
lai.att.Get lno, rcd    '取属性第lno号线的属性
'......                 进行其它处理

Set rcd = Nothing
Set lai = Nothing
End Sub

Private Sub EditView_MouseLButtonDown(ByVal xPos As Double, ByVal yPos As Double)
Me.SetFocus
End Sub
Private Sub EditView_MouseRButtonUp(ByVal xPos As Double, ByVal yPos As Double)
Me.SetFocus
End Sub

Private Sub EditView_MousePosition(ByVal x_Pos As Double, ByVal y_Pos As Double)

Dim str As String
'设置状态栏文本为当前鼠标位置
str = "X坐标: " & Format(x_Pos, "0.000") & "  Y坐标: " & Format(y_Pos, "0.000")
MainForm.StatusBar.panels(2).Text = str

End Sub


Private Sub EditView_MyDraw(ByVal MpDC As Object)
'显示工作区
Dim mapDC As MapGisDC
Set mapDC = MpDC
mapDC.DispArea Ai
Set mapDC = Nothing
End Sub

Private Sub Form_Load()
'文件路径
If Not Ai Is Nothing Then
    Caption = Ai.Name
End If

'设置右健菜单
EditView.PopMenuControl = 1 '只要放大,缩小...

isBrowAtt = 0
Dim p(5) As Integer
p(0) = 0 & p(1) = 0 & p(2) = 0
p(3) = 0 & p(4) = 0 & p(5) = 0
EditView.SetSysSelectParm p(0), 0
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Ai.Changed Then
'    Dim dlg As New YesNoCan
'    dlg.PropStr = Ai.Name & "文件已改变! 是否保存?"
'    dlg.Show vbModal
'    If dlg.Flag = -1 Then '取消
'        Cancel = 1
'    ElseIf dlg.Flag = 0 Then    '否
'        Ai.Changed = False
'    ElseIf dlg.Flag = 1 Then    '是
'        Ai.Save
'    End If
'    Set dlg = Nothing
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
'释放占用的空间
If Not Ai Is Nothing Then
Set Ai = Nothing
End If
End Sub

Public Sub Form_Resize()
'调整窗口及控件的位置或大小
If isBrowAtt = 0 Then
    If aiType = gisTBL Then
        EditView.Move 0, 0, 0, 0
        splliter.X1 = 0
        splliter.Y1 = 0
        splliter.X2 = 0
        splliter.Y2 = 0
        GisAttEdit.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
    Else
        EditView.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
        splliter.X1 = 0
        splliter.Y1 = 0
        splliter.X2 = 0
        splliter.Y2 = 0
        GisAttEdit.Move 0, 0, 0, 0
    End If
Else
    If aiType = gisTBL Then
        EditView.Move 0, 0, 0, 0
        splliter.X1 = 0
        splliter.Y1 = 0
        splliter.X2 = 0
        splliter.Y2 = 0
        GisAttEdit.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
    Else
        EditView.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight / 3 * 2
    '    splliter.X1 = Me.ScaleHeight / 3 * 2
    '    splliter.Y1 = 0
    '    splliter.X2 = Me.ScaleHeight / 3 * 2
    '    splliter.Y2 = Me.ScaleWidth
        GisAttEdit.Move 0, Me.ScaleHeight / 3 * 2, Me.ScaleWidth, Me.ScaleHeight / 3
    End If
End If
End Sub

Private Sub GisAttEdit_CurRcdFldNo(ByVal rcdNo As Long, ByVal fldNo As Integer)
Me.SetFocus
'属性记录不为空，则转入到当前(焦点所在)记录
If Not GisAttEdit Is Nothing Then
   EditView.GotoElement Ai, rcdNo
End If
End Sub

Public Function BrowOrEditAtt(ByVal aType As Enum_Entity_Type, ByVal Editable As Integer)
'浏览属性
If Not Ai Is Nothing Then
    GisAttEdit.AttachArea Ai, aType
    GisAttEdit.EditEnable = Editable
    EditView.AttachAttWorkArea Ai
    isBrowAtt = 1
    Form_Resize
End If
BrowOrEditAtt = 1
End Function
Public Function BrowOrEditAttStru(ByVal aType As Enum_Entity_Type, ByVal Editable As Integer)
'浏览编辑属性结构
Dim pntAi As PntArea
Dim linAi As LinArea
Dim netAi As NetArea
Dim tblAi As TblArea
Dim regAi As RegArea
Dim stru As Record_Head
Dim StruDlg As AttStruDlg

BrowOrEditAttStru = 0
'根据类型设置当前工作区
If Not Ai Is Nothing Then
    Select Case aiType
        Case gisPNT:
            Set pntAi = Ai
        Case gisLIN:
            Set linAi = Ai
        Case gisREG:
            Set regAi = Ai
        Case gisTBL:
            Set tblAi = Ai
        Case gisNET:
            Set netAi = Ai
        Case Else
            Exit Function
    End Select
    
    Select Case aType
        '根据实体类型设置当前属性结构
        Case gisPNT_ENTITY:
                Set stru = pntAi.att.stru
        Case gisLIN_ENTITY:
            If Not linAi Is Nothing Then
                Set stru = linAi.att.stru.Clone
            ElseIf Not regAi Is Nothing Then
                Set stru = regAi.LinAtt.stru.Clone
            ElseIf Not netAi Is Nothing Then
                Set stru = netAi.LinAtt.stru.Clone
            End If
        Case gisREG_ENTITY:
                Set stru = regAi.RegAtt.stru.Clone
        Case gisTBL_ENTITY:
                Set stru = tblAi.stru.Clone
        Case gisNET_ENTITY
                Set stru = netAi.NetAtt.stru.Clone
        Case gisNOD_ENTITY
            If Not regAi Is Nothing Then
                Set stru = regAi.NodAtt.stru.Clone
            ElseIf Not netAi Is Nothing Then
                Set stru = netAi.NodAtt.stru.Clone
            End If
        Case Else
            Exit Function
    End Select

    '打开浏览或编辑属性结构对话框
    Set StruDlg = New AttStruDlg
    StruDlg.BrowOrEditAttStru stru, Editable
    StruDlg.Show vbModal
    If StruDlg.IsOK Then
        If Editable Then
            Select Case aType
                Case gisPNT_ENTITY: pntAi.att.stru = stru
                       
                Case gisLIN_ENTITY:
                    If Not linAi Is Nothing Then
                        linAi.att.stru = stru
                    ElseIf Not regAi Is Nothing Then
                        regAi.LinAtt.stru = stru
                    ElseIf Not netAi Is Nothing Then
                        netAi.LinAtt.stru = stru
                    End If
                Case gisREG_ENTITY:
                        regAi.RegAtt.stru = stru
                Case gisTBL_ENTITY:
                        tblAi.stru = stru
                Case gisNET_ENTITY
                        netAi.NetAtt.stru = stru
                Case gisNOD_ENTITY
                    If Not regAi Is Nothing Then
                        regAi.NodAtt.stru = stru
                    ElseIf Not netAi Is Nothing Then
                        netAi.NodAtt.stru = stru
                    End If
                Case Else
                    Exit Function
            End Select
        End If
    End If
End If

Set StruDlg = Nothing
Set stru = Nothing
Set pntAi = Nothing
Set netAi = Nothing
Set linAi = Nothing
Set regAi = Nothing
Set tblAi = Nothing
BrowOrEditAttStru = 1
End Function


Public Function SaveFile()
'保存
If Not Ai Is Nothing Then
    Ai.Save
End If
SaveFile = 1
End Function

Public Function SaveFileAs()
'另存
If Not Ai Is Nothing Then
    If Ai.SaveAs Then
        Caption = Ai.Name
    End If
End If

SaveFileAs = 1
End Function