clipregion.cls

MapInfo 行业应用源代码

                        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
                                MapInfo.Do "Insert Into " & TempTableName(2, I) & "(经纬度刻度,对齐方式,Object) values (""" & StrLonLat & """,""L"",CreatePoint(" & X1 & "," & Y1 & "))"
                            End If
                            If (X2 = MaxX) Then
                                MapInfo.Do "Insert Into " & TempTableName(2, I) & "(经纬度刻度,对齐方式,Object) values (""" & StrLonLat & """,""R"",CreatePoint(" & X2 & "," & Y2 & "))"
                            End If
                        Else '经度
                            If (Y1 = MinY) Then
                                MapInfo.Do "Insert Into " & TempTableName(2, I) & "(经纬度刻度,对齐方式,Object) values (""" & StrLonLat & """,""B"",CreatePoint(" & X1 & "," & Y1 & "))"
                            End If
                            MapInfo.Do "Insert Into " & TempTableName(2, I) & "(经纬度刻度,对齐方式,Object) values (""" & StrLonLat & """,""A"",CreatePoint(" & X2 & "," & Y2 & "))"
                        End If
                    Next J
                    'End在每条经纬度线的两个端点处插入一个标签点
        
                    'Begin创建一个矩形的多边形区域
                    If (MaxX <= -1000000000# Or MinX >= 1000000000# Or MaxY <= -1000000000# Or MinY >= 1000000000#) Then
                    Else
                        MapInfo.Do "Create PLine Into Variable OBJ_Temp 0"
                        MapInfo.Do "Create PLine Into Variable OBJ_Temp 0 Pen MakePen(2, 2,0)"
                        MapInfo.Do "Alter Object OBJ_Temp Node Add (" & MinX & "," & MinY & ")"
                        MapInfo.Do "Alter Object OBJ_Temp Node Add (" & MaxX & "," & MinY & ")"
                        MapInfo.Do "Alter Object OBJ_Temp Node Add (" & MaxX & "," & MaxY & ")"
                        MapInfo.Do "Alter Object OBJ_Temp Node Add (" & MinX & "," & MaxY & ")"
                        MapInfo.Do "Alter Object OBJ_Temp Node Add (" & MinX & "," & MinY & ")"
                        MapInfo.Do "Insert Into " & TempTableName(2, I) & "(经纬度刻度,对齐方式,Object) values (""边框"","" "",OBJ_Temp)"
                    End If
                    'Ends创建一个矩形的多边形区域
                Else
                    MapInfo.Do "Insert Into " & TempTableName(2, I) & "(Object) values (OBJ_Temp1)"
                End If
            End If
            ''Begin对经纬网添加标注点------------
    
            '存储表
            MapInfo.Do "Commit Table " & TempTableName(2, I)
            '压缩表
            MapInfo.Do "Pack Table " & TempTableName(2, I) & " Graphic Data"
            '关闭表
            MapInfo.Do "Close Table """ & TempTableName(2, I) & """"
        End If
    Next I

    '删出旧图层
    For I = 1 To nLayerName
        MapInfo.Do "Close Table """ & TempTableName(0, I) & """"
    Next I

    '添加新图层
    J = 1
    For I = nLayerName To 1 Step -1
        If (TempTableName(1, I) <> "") Then
            J = J + 1
            MapInfo.Do "Open Table """ & TempTableName(1, I) & """ as " & TempTableName(2, I)
            MapInfo.Do "Add Map Layer " & TempTableName(2, I)
        End If
    Next I

    '删出备份装饰图层
    MapInfo.Do "Close Table ""Temp0"""

    '删除装饰图层上的矩形
    MapInfo.Do "Delete from Cosmetic1"

    If (bKill = True) Then
        '删除临时文件
        Kill "C:\TempLSL*.*"
    End If

    Call LatLonDQ
    
    nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
    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)
        
        If (InStr(LayerName, "居民点") > 0) Then
            MapInfo.Do "Set Map Layer " & I & " Label Line None Position Above Font (""宋体"",0,8,0) With 居民点 Auto On Overlap On"
        ElseIf (InStr(LayerName, "县名") > 0) Then
            MapInfo.Do "Set Map Layer " & I & " Label Line None Position Above Font (""宋体"",0,10,0) With 县市名 Auto On Overlap On"
        End If
    Next I
    
    '显示全图
    MapInfo.Do "Set Map Window " & mapWinID & " Zoom Entire"
    MapInfo.Do "Set map redraw on"

    Screen.MousePointer = 0
End Sub
Private Sub MIFMID_Temp()
    Dim DirFile As String
    
    On Error Resume Next
    
    Open "C:\Temp0.MIF" For Output As #1
    Print #1, "Version 300"
    Print #1, "Charset ""WindowsSimpChinese"""
    Print #1, "Delimiter "","""
    Print #1, "CoordSys Earth Projection 1, 0"
    Print #1, "Columns 1"
    Print #1, "临时字段 Char(2)"
    Print #1, "Data"
    Print #1,
    Print #1, "Rect "; ClipLonMin & " " & ClipLatMin & " " & ClipLonMax & " " & ClipLatMax
    Print #1, "Pen (1,2,0)"
    Print #1, "Brush (2,16777215,16777215)"
    Close (1)
    
    Open "C:\Temp0.MID " For Output As #1
    Print #1, """"""
    Close (1)
    
    DirFile = MapInfo.Eval("TABLEINFO(Temp0,5)")
    If (DirFile <> "") Then
        MapInfo.Do "Close Table ""Temp0"""
    End If
    
    MapInfo.Do "Import ""C:\Temp0.MIF"" Type ""MIF"" Into ""C:\Temp0.TAB"" Overwrite"
    
    Kill "C:\Temp0.MIF"
    Kill "C:\Temp0.MID"
    
    MapInfo.Do "Add Map Layer Temp0"

End Sub

Private Sub AutoOutTab(LayerName As String, TheOutFile As String)
    Dim I As Integer, DirFile As String

    I = 0
    Do
        I = I + 1
        TheOutFile = "T" + Format(I, "000") + LayerName
        DirFile = Dir(TheMapInfoPath + TheOutFile + ".TAB")
        If (DirFile = "") Then Exit Do
    Loop
End Sub

Private Sub LatLonDQ()
Dim I As Integer, J 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 Index As Integer, LayerName As String, Col1 As String

Screen.MousePointer = 11

On Error Resume Next

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

nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
'Begin判断经纬网是否存在
TableName = ""
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)
    Col1 = UCase(MapInfo.Eval("ColumnInfo(""" & LayerName & """,""col1"",1)"))
    If (InStr(Col1, "经纬度刻度") > 0) Then
        TableName = LayerName
        Index = I
        Exit For
    End If
Next I
'End判断经纬网是否存在

If (TableName = "") Then Exit Sub
Screen.MousePointer = 11
    
MapInfo.Do "Set map redraw off"
Str = "Set Map Layer " & Index & " Label  Font (""Arial"",0,10,0) Object "
RowID = Val(MapInfo.Eval("TableInfo(" & TableName & ",8)"))

For J = 1 To RowID
    MapInfo.Do "Fetch Rec " & J & " From " & TableName
    ABLR = Trim(UCase(MapInfo.Eval(TableName & ".Col2")))
    If (ABLR = "A" Or ABLR = "B" Or ABLR = "L" Or ABLR = "R") Then
        StrLatLon = MapInfo.Eval(TableName & ".Col1")
        DoStr = Str + Format(J, "###0")
        DoStr = DoStr + " Text """ & StrLatLon & """"
        DoStr = DoStr + " Position "
        If (ABLR = "A") Then
            DoStr = DoStr + "Above"
        ElseIf (ABLR = "B") Then
            DoStr = DoStr + "Below"
        ElseIf (ABLR = "L") Then
            DoStr = DoStr + "Left"
        ElseIf (ABLR = "R") Then
            DoStr = DoStr + "Right"
        Else
            DoStr = DoStr + "Center"
        End If
        MapInfo.Do DoStr
    End If
Next J
MapInfo.Do "Set map redraw on"
'End对齐刻度
Screen.MousePointer = 0
End Sub