mod_define.bas

用VB开发的巡检系统基于MAPINFo用VB开发的巡检系统基于MAPINFo很好的

Attribute VB_Name = "mod_Define"
Option Explicit
Public Declare Sub HMEMCPY Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'Public gMDIFrmMain As New MDIFrmMain

'//调用API函数使窗口保持在最上层
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
    ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_SHOWWINDOWS = &H40

'//去掉关闭按钮
'//第一种方法
Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Const MF_BYPOSITION = &H400&
'//第二种方法
Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Const MF_DISABLED = &H2&

'//关闭窗体
Public Sub Shutdown(Optional ByVal Force As Boolean = False)
    Dim I As Long
    On Error Resume Next
    For I = Forms.Count - 1 To 0 Step -1
        Unload Forms(I)
        If Not Force Then
            If Forms.Count > I Then
                Exit Sub
            End If
        End If
    Next I
    If Force Or (Forms.Count = 0) Then Close
End Sub

'根据记录位置进行对象地图定位
Public Function SearchLocalName(MapInfo As Object, TableName As String, SearchNumber As Integer) As Boolean
    Dim MultiN As Integer
    Dim IsOK As Boolean
    On Error Resume Next
    
    MapInfo.Do "Set Distance Units ""km"""
    'MapInfo.Do "Set CoordSys NonEarth Units ""m"" Bounds (100000, 4200000) (990000, 4800000)"
    MapInfo.Do "Set CoordSys Earth Projection 1,0"
    
    MapInfo.Do "Select * From " & TableName & " where RowID=" & SearchNumber & " into Selection"
    MultiN = Val(MapInfo.Eval("SelectionInfo(3)"))
    
    '搜索到符合的对象
    If (MultiN = 1) Then
        '改变地图窗口
        MapInfo.Do "set map Redraw On"
        MapInfo.Do "Set map Center (" & MapInfo.Eval("CentroidX(Selection.obj)") & "," & MapInfo.Eval("CentroidY(Selection.obj)") & ")"
        MapInfo.Do "set map Zoom 1"
        MapInfo.Do "set map Redraw Off"
        
        '计算面积
        'MsgBox MapInfo.Eval("CartesianArea(Selection.obj, ""sq m"")")
        IsOK = True
    Else
        MsgBox "没有定位到符合的对象！", vbInformation + vbOKOnly, "提示"
        IsOK = False
    End If
    SearchLocalName = IsOK
End Function

'==========================================
'函数功能：根据标志符号分段字符串
'输入参数：源字符串、标志符号、存储分段后字符串
'输出参数：返回分段后段数
'//设 计 者：wcs 2004-02-02
'==========================================
Public Function Get_StringArrayForSymbol(ByVal sT As String, ByVal DestStr As String, strSect() As String) As Integer
    Dim n As Integer, II, Temp_K, Temp_A, Temp_B
    Dim re(65535) As String
    sT = sT & " "
    n = Len(sT)
    For II = 1 To n
      Temp_A = Mid$(sT, II, 1)
      Temp_B = Temp_B + Temp_A
      If Temp_A = DestStr Then
        Temp_K = Temp_K + 1
        re(Temp_K) = Mid$(Temp_B, 1, Len(Temp_B) - 1)
        Temp_B = ""
      End If
    Next
    If Temp_K > 0 Then
      re(Temp_K + 1) = Temp_B
      Temp_K = Temp_K + 1
    End If
    n = 0
    For II = 1 To Temp_K
      If Trim(re(II)) <> "" Then
       n = n + 1
       strSect(n - 1) = re(II)
      End If
    Next
    If n = 0 Then
        strSect(n) = Trim(sT)
    Else
        Get_StringArrayForSymbol = n
    End If
End Function

'//计算面积
Public Function CalArea()
    Dim dblArea As Double
    Dim strTemp As String
    On Error GoTo lab
    If MapInfo.Eval("selectioninfo(" & SEL_INFO_NROWS & ")") <> 1 Then
        MsgBox "请选中一面状对象", vbOKOnly + vbExclamation, "提示"
        Exit Function
    End If
    dblArea = MapInfo.Eval("Area(selection.obj, ""sq km"")")
    strTemp = "选中部分的面积为：" & dblArea & "平方公里" & Chr$(13)
    dblArea = MapInfo.Eval("Area(selection.obj, ""sq m"")")
    strTemp = strTemp & dblArea & "平方米"
    MsgBox strTemp, vbOKOnly + vbExclamation, "提示"
    Exit Function
lab:
    MsgBox Err.Description, vbOKOnly + vbExclamation, "提示"
End Function

'获取巡检目标的图层表
Sub Get_DestinationTableName(ByVal obj As Object)
    Dim rs As New ADODB.Recordset
    rs.Open "select distinct TableName from tbl_Equipment", gblCn, adOpenKeyset, adLockOptimistic, adCmdText
    obj.Clear
    Do Until rs.EOF
        obj.AddItem rs("TableName")
        rs.MoveNext
    Loop
    rs.Close
End Sub

'提取图层名
Sub GetLayerName(ByVal pList As Object)
    Dim nLayers As Integer, I As Integer
    nLayers = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & "," & MAPPER_INFO_LAYERS & ")"))
    pList.Clear
    For I = 1 To nLayers
        pList.AddItem MapInfo.Eval("TableInfo(" & I & "," & TAB_INFO_NAME & ")")
    Next
End Sub

'根据实体类型提取实体名
Function Get_ObjectType(ByVal oType As Integer) As String
    Dim curType As String
    Select Case oType
        Case OBJ_TYPE_ARC    'Arc object
            curType = "Arc"
        Case OBJ_TYPE_ELLIPSE    'Ellipse / circle objects
            curType = "Ellipse"
        Case OBJ_TYPE_LINE   'Line object
            curType = "Line"
        Case OBJ_TYPE_PLINE  'Polyline object
            curType = "Polyline"
        Case OBJ_TYPE_POINT  'Point object
            curType = "Point"
        Case OBJ_TYPE_FRAME  'Layout window Frame object
            curType = "Layout"
        Case OBJ_TYPE_REGION 'Region object
            curType = "Region"
        Case OBJ_TYPE_RECT   'Rectangle object
            curType = "Rectangle"
        Case OBJ_TYPE_ROUNDRECT  'Rounded rectangle object
            curType = "Rounded"
        Case OBJ_TYPE_TEXT   'Text object
            curType = "Text"
    End Select
    Get_ObjectType = curType
End Function