labelcity.frm

MapInfo 行业应用源代码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form LabelCity 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "绘制边界、河流"
   ClientHeight    =   2208
   ClientLeft      =   348
   ClientTop       =   900
   ClientWidth     =   6276
   ControlBox      =   0   'False
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   11.4
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   FontTransparent =   0   'False
   Icon            =   "LabelCity.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   1  'Arrow
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   184
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   523
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame FrameWords 
      BackColor       =   &H80000001&
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.6
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1932
      Left            =   60
      TabIndex        =   0
      Top             =   120
      Width           =   6132
      Begin VB.CommandButton CommandWordsFile 
         Caption         =   "目录…"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   11.4
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   120
         TabIndex        =   4
         Top             =   360
         Width           =   5892
      End
      Begin VB.CommandButton CommandWordsOK 
         Caption         =   "确定"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   11.4
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   372
         Left            =   4440
         TabIndex        =   3
         Top             =   1200
         Width           =   1572
      End
      Begin VB.CommandButton CommandWordsCancel 
         Caption         =   "放弃"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   11.4
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   2280
         TabIndex        =   2
         Top             =   1200
         Width           =   1572
      End
      Begin VB.CommandButton CommandMark 
         Caption         =   "符号样式"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.8
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   372
         Left            =   120
         TabIndex        =   1
         Top             =   1200
         Width           =   1572
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   120
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
   End
End
Attribute VB_Name = "LabelCity"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim iCX As Integer, bClick As Boolean
Dim DirFile As String

Dim SelectMinM As Single, SelectMaxM As Single, SelectMinTime As Long, SelectMaxTime As Long
Dim MinLat As Single, MaxLat As Single, MinLon As Single, MaxLon As Single
Dim MinH As Single, MaxH As Single
Dim IndexComboMark As Integer
Dim MapInfoAscii As Integer, VbAscii As Integer
Dim MapInfoColor As Long, VbColor As Long
'经纬度参数
Dim FrameWidth As Integer, BorderColor As Integer
Dim LatDelta As Single, LonDelta As Single, LatLonDColor As Integer
Dim LatLonDN As Integer, LatLonDNColor As Integer
Dim iCheckMesh As Integer
Dim bLatLon As Boolean, LatFmt As String, LonFmt As String

Dim II1 As Integer, II2 As Integer, JJ As Integer, IJ As Integer
Dim bChange As Boolean
Dim Cd As Double
Dim TheInPath As String, TheInFile As String

Private Sub CommandMark_Click()
MapInfo.RunMenuCommand 503
End Sub


Private Sub CommandWordsCancel_Click()
bOKCancel = False
Unload Me
End Sub
Private Sub CommandWordsFile_Click()
    Dim I As Integer

    On Error Resume Next
    CommonDialog1.DialogTitle = "从文件中选取资料"
    CommonDialog1.FileName = TheInFile
    CommonDialog1.Filter = "*.Dat;*.TXT|*.Dat;*.TXT"

    CommonDialog1.InitDir = TheInPath
    CommonDialog1.FilterIndex = 0
    CommonDialog1.ShowOpen
    ''UserControl.ForeColor = QBColor(4)
    If (Err = 0) Then '打开文件
        I = InStr(CommonDialog1.FileName, CommonDialog1.FileTitle)
        TheInPath = Left(CommonDialog1.FileName, I - 1)
        TheInFile = UCase(CommonDialog1.FileTitle)
        CommandWordsFile.Caption = CommonDialog1.FileName
    End If

End Sub
Private Sub LabelCitys(TheCityFile As String, TheOutPath As String)
    Dim Lon As Double, Lat As Double, High As Single, Temp As String
    Dim I As Long, J As Long, K As String * 1
    Dim Shape As Integer, Color As Long, Size As Integer, ComboMarkStrColorWord As Integer
    Dim Columns() As String, ColumnsType() As String, ColumnsN As Integer
    Dim Xmin As Double, Xmax As Double, Ymin As Double, Ymax As Double
    
    On Error GoTo Error
    
    Screen.MousePointer = 11

    ColumnsN = 3
    ReDim Columns(1 To ColumnsN), ColumnsType(1 To ColumnsN)

    Columns(1) = "纬度"
    ColumnsType(1) = "Float"
    
    Columns(2) = "经度"
    ColumnsType(2) = "Float"
    
    Columns(3) = "标注"
    ColumnsType(3) = "Char(30) "

    I = InStrRev(TheCityFile, "\")
    TableName = Right(TheCityFile, Len(TheCityFile) - I)
    Call CheckTabName(TableName, "Map")
    
    Call CreateTable(TheOutPath, TableName, Columns, ColumnsType, ColumnsN)

    'Begin判断经纬度是否颠倒
    Xmin = 10000000000#
    Xmax = -Xmin
    Ymin = 10000000000#
    Ymax = -Ymin
    Open TheCityFile For Input As #1
    Do While Not EOF(1)
        Input #1, Lat, Lon, Temp

        If (Lat > Ymax) Then Ymax = Lat
        If (Lat < Ymin) Then Ymin = Lat
        
        If (Lon > Xmax) Then Xmax = Lon
        If (Lon < Xmin) Then Xmin = Lon
    Loop
    Close (1)
    'End判断经纬度是否颠倒
    
    MapInfo.do "CurSymbol = CurrentSymbol()"
    Open TheCityFile For Input As #1
    If (Ymin >= -180 And Ymax <= 180 And Xmin >= -90 And Xmax <= 90) Then
        Do While Not EOF(1)
            Input #1, Lon, Lat, Temp
            If (InStr(Temp, "北京") > 0) Then
                Call MakeSymbol(35, 16711680, 18)
            Else
                MapInfo.do "Set Style Symbol CurSymbol"
            End If
            MapInfo.do "Insert Into " & TableName & "(纬度,经度,标注,Object) values (" & Lat & "," & Lon & ",""" & Temp & """,CreatePoint(" & Lon & "," & Lat & "))"
        Loop
    Else
        Do While Not EOF(1)
            Input #1, Lat, Lon, Temp
            If (InStr(Temp, "北京") > 0) Then
                Call MakeSymbol(35, 16711680, 18)
                K = "1"
            Else
                MapInfo.do "Set Style Symbol CurSymbol"
                K = "2"
            End If
            MapInfo.do "Insert Into " & TableName & "(纬度,经度,标注,Object) values (" & Lat & "," & Lon & ",""" & Temp & """,CreatePoint(" & Lon & "," & Lat & "))"
        Loop
    End If
    Close (1)

    '新表存盘
    Call SaveTable(TableName)
    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    If (mapWinID > 0) Then
        MapInfo.do "Add Map Layer " & TableName
        MapInfo.do "Set Map Layer 1 Label Auto On Position Above Font(""Arial"",1,10,0,16777215) offset 5"
    End If
    Screen.MousePointer = 0
    bOKCancel = True
    
    Screen.MousePointer = 0
    Exit Sub
Error:
    Close (1)
    Screen.MousePointer = 0
    MsgBox "读文件错误", vbOKOnly, "关于读地名文件"
End Sub

Private Sub CommandWordsOK_Click()
    Dim TheCityFile As String, TheOutPath As String

    TheCityFile = Trim(CommandWordsFile.Caption)
    DirFile = Dir(TheCityFile)
    If (DirFile = "") Then
        bOKCancel = False
        Unload Me
        Exit Sub
    End If
    
    Call LabelCitys(TheCityFile, ThePublicOutPath)
    
    Unload Me
End Sub


Private Sub Form_Load()
TheInPath = ThePublicOutPath + "地图数据\"

CommandWordsFile.Caption = TheInPath + "CityPro.txt"
End Sub