clipregion.cls

MapInfo 行业应用源代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Sub ClipRegionDLL(MapInfoT As Object, TheMapInfoPathT As String)
    Dim MapperInfoCoordSys As String, TableInfoCoordSys As String
    Dim TheOutFile As String
    Dim N As Integer, M As Integer, nPolyGons As Integer
    Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
    Dim MinX As Single, MinY As Single, MaxX As Single, MaxY As Single
    Dim StrLonLat As String
    Dim I As Integer, J As Integer, K As Integer, nLayerName As Integer, Temp As Single
    Dim Str As String, DoStr As String, RowID As Integer, ABLR As String * 1, StrLatLon As String
    Dim LayerName As String, TableName As String
    Dim TempTableName() As String, Col1 As String, ColN As String
    Dim bKill As Boolean
    Dim TheLabelInfo As String

    Screen.MousePointer = 11
    On Error Resume Next

    Set MapInfo = MapInfoT
    TheMapInfoPath = TheMapInfoPathT

    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))

    '获取当前显示投影参数
    MapperInfoCoordSys = MapInfo.Eval("MapperInfo(" & mapWinID & ",17)")

    nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
    ReDim TempTableName(0 To 2, 1 To nLayerName)
    For I = 1 To nLayerName
        LayerName = MapInfo.Eval("LayerInfo(" & mapWinID & "," & I & ",1)")
        J = InStr(LayerName, Chr(0))
        If (J > 0) Then LayerName = Left(LayerName, J - 1)
    
        TempTableName(0, I) = LayerName
        Call AutoOutTab(LayerName, TheOutFile)
        TempTableName(1, I) = TheMapInfoPath + TheOutFile + ".TAB"
        TempTableName(2, I) = TheOutFile
    Next I
    
    '选择裁剪区域
    MapInfo.Do "Select * From Cosmetic1 Where Object"

    N = Val(MapInfo.Eval("SelectionInfo(3)"))
    If (N <> 1) Then
        '删除装饰图层上的全部对象
        MapInfo.Do "Set Map Layer 0 Editable ON"
        MapInfo.Do "Delete from Cosmetic1"
        ''MapInfo.RunMenuCommand 810
    
        Screen.MousePointer = 0
        
        MapInfo.Do "Set CoordSys Earth Projection 1,0"
        ClipLon0 = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",3)"))
        ClipLat0 = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",4)"))
        ClipLonMin = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",5)"))
        ClipLatMin = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",6)"))
        ClipLonMax = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",7)"))
        ClipLatMax = Val(MapInfo.Eval("MapperInfo(" & mapWinID & ",8)"))
        
        ClipRegion.Show 1
        
        If (bOKCancel = False) Then Exit Sub
        
        Screen.MousePointer = 11
        
        MapInfo.Do "Set map redraw off"
        
        If (MidLonVer = 1) Then
            MapInfo.Do "Set Map XY Units ""degree"" CoordSys Earth Projection 1, 0"
            '获取当前显示投影参数
            MapperInfoCoordSys = MapInfo.Eval("MapperInfo(" & mapWinID & ",17)")
        End If
        
        Call MIFMID_Temp

        MapInfo.Do "Select * From Temp0"
        MapInfo.Do "OBJ_Temp=Selection.OBJ"
        MapInfo.Do "OBJ_Temp1=Selection.OBJ"
    Else
        MapInfo.Do "Set map redraw off"
        
        MapInfo.Do "OBJ_Temp=Selection.OBJ"
        MapInfo.Do "OBJ_Temp1=Selection.OBJ"

        '存装饰图层的备份
        MapInfo.Do "Commit Table Selection As ""C:\Temp0.TAB"" TYPE NATIVE Charset ""WindowsSimpChinese"" " & MapperInfoCoordSys
        MapInfo.Do "Open Table ""C:\Temp0.TAB"" as Temp0"
        MapInfo.Do "Add Map Layer Temp0"
    End If
    
    'Begin确保数据投影与显示投影相同
    bKill = False
    For I = 1 To nLayerName
        LayerName = TempTableName(0, I)
    
        '当显示投影与数据投影不一致时,改变数据投影方式
        TableInfoCoordSys = MapInfo.Eval("TableInfo(" & LayerName & ",29)")
        If (TableInfoCoordSys <> MapperInfoCoordSys) Then
            '按当前显示投影参数存放临时文件
            TempTableName(0, I) = "TempLSL" + Format(I, "##0")
            TheOutFile = "C:\" + TempTableName(0, I) + ".TAB"
            MapInfo.Do "Commit Table " & LayerName & " As """ & TheOutFile & """ TYPE NATIVE Charset ""WindowsSimpChinese"" " & MapperInfoCoordSys
          
            '打开改变投影后的新表
            MapInfo.Do "Open Table """ & TheOutFile & """ as " & TempTableName(0, I)
            MapInfo.Do "Add Map Layer " & TempTableName(0, I)
        
            '关闭原表
            MapInfo.Do "Close Table """ & LayerName & """"
            bKill = True
        End If
    Next I
    'End确保数据投影与显示投影相同

    'Begin把完全在剪裁区域内或部分在剪裁区域内的对象留下
    For I = 1 To nLayerName
        MapInfo.Do "Select * From " & TempTableName(0, I) & " Where Obj Contains Part OBJ_Temp"
        If (Val(MapInfo.Eval("SelectionInfo(3)")) > 0) Then
            MapInfo.Do "Commit Table Selection As """ & TempTableName(1, I) & """"
        Else
            TempTableName(1, I) = ""
        End If
    Next I
    'End把完全在剪裁区域内或部分在剪裁区域内的对象留下

    For I = 1 To nLayerName
        If (TempTableName(1, I) <> "") Then
            MapInfo.Do "Open Table """ & TempTableName(1, I) & """ as " & TempTableName(2, I)

            '把裁剪区域全部对象设置为目标
            MapInfo.Do "Select * From """ & TempTableName(2, I) & """"
            MapInfo.Do "Set Target On"

            '设置裁剪区域
            MapInfo.Do "Select * From  Temp0"

            N = Val(MapInfo.Eval("TableInfo(" & TempTableName(2, I) & ",4)"))
            ColN = ""
            For J = 1 To N
                Col1 = MapInfo.Eval("ColumnInfo(""" & TempTableName(2, I) & """,""col" & J & """,1)")
                K = InStr(Col1, Chr(0))
                If (K > 0) Then Col1 = Left(Col1, K - 1)
                ColN = ColN + " " + Col1 + "=" + Col1 + ","
            Next J
            ColN = Left(ColN, Len(ColN) - 1)
            '删除裁剪区域外部对象
            MapInfo.Do "Objects Intersect Into Target Data " & ColN
    
            'Begin对经纬网添加标注点------------
            Col1 = UCase(MapInfo.Eval("ColumnInfo(""" & TempTableName(2, I) & """,""col1"",1)"))
            If (InStr(Col1, "经纬度刻度") > 0) Then
                '删除经纬度投影的标注
                MapInfo.Do "Select * From " & TempTableName(2, I) & " Where 对齐方式="""" OR 对齐方式=""A"" or 对齐方式=""B"" or 对齐方式=""L"" or 对齐方式=""R"""
                N = Val(MapInfo.Eval("SelectionInfo(3)"))
                If (N > 0) Then
                    MapInfo.Do "Delete from Selection"
                End If
    
                '选择经纬度线
                MapInfo.Do "Select * From " & TempTableName(2, I) & " Where 经纬度刻度<>"""""
                N = Val(MapInfo.Eval("SelectionInfo(3)"))
        
                If (N > 0) Then
                    MapInfo.Do "Set " & MapperInfoCoordSys
                    MapInfo.Do "Set Style Symbol MakeSymbol(1,0,11)"
        
                    'Begin在每条经纬度线的两个端点处插入一个标签点
                    MinX = 10000000000#
                    MaxX = -MinX
                    MinY = 10000000000#
                    MaxY = -MinY
                    For J = 1 To N
                        MapInfo.Do "Fetch Rec " & J & " From Selection"
                        MapInfo.Do "OBJ_Temp=Selection.OBJ"
    
                        StrLonLat = MapInfo.Eval("Selection.col1")

                        '获取线段的起点和终点坐标
                        Y1 = Val(MapInfo.Eval("ObjectNodeY(OBJ_Temp, 1, 1)"))
                        X1 = Val(MapInfo.Eval("ObjectNodeX(OBJ_Temp, 1, 1)"))
    
                        M = Val(MapInfo.Eval("ObjectInfo(OBJ_Temp,20)"))
                        nPolyGons = Val(MapInfo.Eval("ObjectInfo(OBJ_Temp,21)"))
                        If (nPolyGons = 2) Then
                            M = Val(MapInfo.Eval("ObjectInfo(OBJ_Temp,23)"))
                        End If
                        X2 = Val(MapInfo.Eval("ObjectNodeX(OBJ_Temp," & nPolyGons & "," & M & ")"))
                        Y2 = Val(MapInfo.Eval("ObjectNodeY(OBJ_Temp," & nPolyGons & "," & M & ")"))
                        If (Val(MapInfo.Eval("Selection.col2")) = 1) Then '纬度
                            If (X1 < MinX) Then MinX = X1
                            If (X2 > MaxX) Then MaxX = X2
                        Else '经度
                            If (Y1 < MinY) Then MinY = Y1
                            If (Y2 > MaxY) Then MaxY = Y2
                        End If
                    Next J
                    For J = 1 To N
                        MapInfo.Do "Fetch Rec " & J & " From Selection"
                        MapInfo.Do "OBJ_Temp=Selection.OBJ"
    
                        StrLonLat = MapInfo.Eval("Selection.col1")

                        '获取线段的起点和终点坐标