table.bas

用VB6.0MapINfo绘等值线及表面图

Attribute VB_Name = "Module2"
Option Explicit
Dim ColumnsN As Integer, Columns() As String, ColumnsType() As String
Dim NoCreateEllipse As Integer, Size As Single
Dim I As Integer
Public MapInfo As Object, TableName As String
Public mapWinID As Long
Public Sub CheckTabName(TheInFile As String, Index As String)
    Dim I As Integer, TheInFileT As String, Char1 As String * 1
    
    'Begin去掉.*
    I = InStr(TheInFile, ".")
    If (I > 0) Then
        TheInFile = Left(TheInFile, I - 1)
    End If
    'End去掉.*
    
    'Begin第一个子母为数字时,前面加Index
    If (Left(TheInFile, 1) >= "0" And Left(TheInFile, 1) <= "9") Then
        TheInFile = Index + TheInFile
    End If
    'End第一个子母为数字时,前面加EQ

    'Begin去掉连接线-
    TheInFileT = TheInFile
    TheInFile = ""
    For I = 1 To Len(TheInFileT)
        Char1 = Mid(TheInFileT, I, 1)
        If (Char1 = "-") Then Char1 = "_"
        TheInFile = TheInFile + Char1
    Next I
    'End去掉连接线-
End Sub

Public Sub CheckMapInfoFileName(TheInFile As String)
    Dim I As Integer, TheInFileT As String, Char1 As String * 1
    
    Char1 = Left(TheInFile, 1)
    If (Char1 >= "0" And Char1 <= "9") Then
        TheInFileT = "Map" + TheInFile
    Else
        TheInFileT = TheInFile
    End If

    TheInFile = ""
    For I = 1 To Len(TheInFileT)
        Char1 = Mid(TheInFileT, I, 1)
        If (Char1 = "-") Then
            Char1 = "_"
        End If
        TheInFile = TheInFile + Char1
    Next I
End Sub
Public Function QBColors(I As Byte) As Long
Dim R As Integer, G As Integer, B As Integer, Color As Long

Color = QBColor(I)

R = Color Mod 256
G = (Color And &HFF00FF00) / 256&
B = (Color And &HFF0000) / 65536

QBColors = RGB(B, G, R)
End Function


Public Sub CloseExistTable(TableName As String)
    Dim DirFile As String, TableNameT As String, I As Integer

    On Error Resume Next
    
    I = InStr(TableName, ".")
    If (I > 0) Then
        TableNameT = Left(TableName, I - 1)
    Else
        TableNameT = TableName
    End If
    For I = Len(TableNameT) To 1 Step -1
        If (Mid(TableNameT, I, 1) = "\") Then
            TableNameT = Right(TableNameT, Len(TableNameT) - I)
        End If
    Next I
    DirFile = MapInfo.Eval("TABLEINFO(" & TableNameT & ",5)")
    If (DirFile <> "") Then
        MapInfo.do "Close Table """ & TableNameT & """"
    End If
End Sub

Public Sub ModifyLine(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
Dim I As Long
'MapInfo.do "Fetch First From Selection"
'MapInfo.do "Selection=OBJ_Temp"

MapInfo.do "Alter Object OBJ_Temp Geography 1," & X1
MapInfo.do "Alter Object OBJ_Temp Geography 2," & Y1

MapInfo.do "Alter Object OBJ_Temp Geography 3," & X2
MapInfo.do "Alter Object OBJ_Temp Geography 4," & Y2

I = Val(MapInfo.Eval("TableInfo(" & TableName & ",8)"))
MapInfo.do "UpDate " & TableName & " Set OBJ=OBJ_Temp Where RowID=" & I

End Sub

Public Sub CreateTable(TheOutPathT As String, TableNameT As String, ColumnsT() As String, ColumnsTypeT() As String, ColumnsNt As Integer)
Dim Temp As String, TheOutPath As String

ColumnsN = ColumnsNt
TableName = TableNameT
Call ExistTable(TableName)

If (Right(TheOutPathT, 1) = "\") Then
    TheOutPath = TheOutPathT
Else
    TheOutPath = TheOutPath + "\"
End If

Temp = "Create Table "
Temp = Temp + TableName + "("
ReDim Columns(1 To ColumnsN), ColumnsType(1 To ColumnsN)
For I = 1 To ColumnsN - 1
    Columns(I) = Trim(ColumnsT(I))
    ColumnsType(I) = UCase(Trim(ColumnsTypeT(I)))
    
    Temp = Temp + Columns(I) + " " + ColumnsType(I) + ","
Next I

Columns(ColumnsN) = Trim(ColumnsT(ColumnsN))
ColumnsType(ColumnsN) = UCase(Trim(ColumnsTypeT(ColumnsN)))
   
Temp = Temp + Columns(ColumnsN) + " " + ColumnsType(ColumnsN) + ")"

Temp = Temp + " FILE " + """" + TheOutPath + TableName + """"

Call CloseExistTable(TableName)
'创建一个新表
MapInfo.do Temp

'使表可地图化
MapInfo.do "Create Map For " & TableName & " Coordsys Earth"

'打开一个表
'MapInfo.do "Open Table " & TableName

MapInfo.do "Set Distance Units ""km"""

NoCreateEllipse = 0
End Sub
Private Sub ExistTable(TableName As String)
Dim mapWinID As Long, nLayerName As Integer, I As Integer
Dim bExistTable As Boolean, LayerName As String

bExistTable = False
mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
For I = 1 To nLayerName
    LayerName = MapInfo.Eval("LayerInfo(" & mapWinID & "," & I & ",1)")
    If (InStr(LayerName, TableName) > 0) Then
        bExistTable = True
        Exit For
    End If
Next I

If (bExistTable = True) Then
    MapInfo.do "Close Table """ & TableName & """"
End If
End Sub

Public Sub CreatePLine(X() As Single, Y() As Single, N As Integer, bSmooth As Boolean)

MapInfo.do "Create PLine Into Variable OBJ_Temp 0"

For I = 1 To N
    MapInfo.do "Alter Object OBJ_Temp Node Add (" & X(I) & "," & Y(I) & ")"
Next
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"

End Sub

Public Sub MakePen(PenWidth As Integer, PenPattern As Integer, PenColor As Long)

MapInfo.do "Set Style Pen MakePen(" & PenWidth & "," & PenPattern & "," & PenColor & ")"

End Sub

'创建多变形区域
Public Sub CreateRegion(X() As Single, Y() As Single, N As Integer)

MapInfo.do "Create Region Into Variable OBJ_Temp 0"

For I = 1 To N
    MapInfo.do "Alter Object OBJ_Temp Node Add (" & X(I) & "," & Y(I) & ")"
Next
If (X(1) <> X(N) Or Y(1) <> Y(N)) Then '最后一点与第一点不重合
    MapInfo.do "Alter Object OBJ_Temp Node Add (" & X(1) & "," & Y(1) & ")"
End If
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"

End Sub
Public Sub MakeBrush(FillPattern As Integer, FillForeGround As Long, FillBackGround As Long, BorderStyle As Integer, BorderColor As Long, BorderWidth As Integer)

MapInfo.do "Set Style Pen MakePen(" & BorderWidth & "," & BorderStyle & "," & BorderColor & ")"
MapInfo.do "Set Style Brush MakeBrush(" & FillPattern & "," & FillForeGround & "," & FillBackGround & ")"

End Sub

Public Sub MakeFont(TextFont As String, TextSize As Integer, TextColor As Long, TextNoBackgroundColor As Integer, TextBackgroundColor As Long, iBold As Integer, iUnderline As Integer, iShadow As Integer, iItalic As Integer, iAllCaps As Integer, iExpanded As Integer)
Dim TextEffects As Integer

Size = TextSize
TextEffects = 0
If (TextNoBackgroundColor = 1) Then TextEffects = TextEffects + 256
If (iBold = 1) Then TextEffects = TextEffects + 1
If (iItalic = 1) Then TextEffects = TextEffects + 2
If (iUnderline = 1) Then TextEffects = TextEffects + 4
If (iShadow = 1) Then TextEffects = TextEffects + 32
If (iAllCaps = 1) Then TextEffects = TextEffects + 512
If (iExpanded = 1) Then TextEffects = TextEffects + 1024
MapInfo.do "Set Style Font MakeFont(""" & TextFont & """," & TextEffects & "," & TextSize & "," & TextColor & "," & TextBackgroundColor & ")"

End Sub
Public Sub CreateText(X As Single, Y As Single, Text As String, Angle As Single, Anchor As Integer, Offset As Single)
Dim XYFact As Single, Cd As Single
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, LenText As Integer


XYFact = 50
Cd = Atn(1#) / 45#
LenText = Len(Trim(Text)) / 2
Select Case Anchor
    Case 0 '中中对齐
        X1 = X - (Size * Sin(Angle * Cd) + Size * LenText * Cos(Angle * Cd)) / XYFact / 2
        Y1 = Y + (Size * Cos(Angle * Cd) - Size * LenText * Sin(Angle * Cd)) / XYFact / 2

        X2 = X1 + Size * Len(Trim(Text)) / XYFact
        Y2 = Y1 - Size / XYFact
    Case 1 '上左对齐
    Case 2
    Case 3 '上中对齐
        X1 = X - Size * LenText / XYFact / 2
        Y1 = Y + (Size + Offset) / XYFact
        X2 = X1 + Size * Len(Trim(Text)) / XYFact
        Y2 = Y1 - Size / XYFact
    Case 4
    Case 5
    Case 6
    Case 7
    Case 8
End Select

MapInfo.do "Create Text Into Variable OBJ_Temp """ & Text & """ (" & X1 & "," & Y1 & ")  (" & X2 & "," & Y2 & ") Angle " & Angle
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"
End Sub
Public Sub MakeSymbol(Shape As Integer, Color As Long, Size As Integer)

MapInfo.do "Set Style Symbol MakeSymbol(" & Shape & "," & Color & "," & Size & ")"

End Sub

Public Sub MakeFontSymbol(Shape As Integer, Color As Long, Size As Long, FontName As String, FontStyle As Integer, Rotation As Single)

MapInfo.do "Set Style Font MakeFontSymbol(" & Shape & "," & Color & Size & "," & FontName & "," & FontStyle & "," & Rotation & ")"

End Sub
Public Sub CreateRoundRect(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Radius As Single)
'MapInfo.Do "Dim  OBJ_RoundRect as Object"
MapInfo.do "Create RoundRect Into Variable OBJ_RoundRect(" & X1 & "," & Y1 & ") (" & X2 & "," & Y2 & ") " & Radius & ""
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_RoundRect)"
End Sub
Public Sub CreateRect(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
MapInfo.do "Create Rect Into Variable OBJ_Temp(" & X1 & "," & Y1 & ") (" & X2 & "," & Y2 & ")"
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"
End Sub
Public Sub CreateArc(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, StartAngle As Single, EndAngle As Single)
MapInfo.do "Create ARC Into Variable OBJ_Temp(" & X1 & "," & Y1 & ") (" & X2 & "," & Y2 & ") " & StartAngle & " " & EndAngle & ""
MapInfo.do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"
End Sub
Public Sub CreateLine(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
MapInfo.do "Insert Into " & TableName & "(Object) values (CreateLine(" & X1 & "," & Y1 & "," & X2 & "," & Y2 & "))"
End Sub
'创建椭圆
Public Sub CreateEllipse(Lon As Single, Lat As Single, LongAxis As Single, ShortAxis, Angle As Single)
Dim Loni As Single, Lati As Single
Dim X1 As Single, Y1 As Single
Dim X0 As Single, Y0 As Single
Dim Z1 As Single, Z2 As Single
Dim XX As Single, YY As Single
Dim Pi As Single, Cd As Single
Dim LongAxisT As Single, ShortAxisT As Single, AngleT As Single
Dim S_Col_Name As String, Temp As String
Dim XH As String, jd As String, wd As String, CZ As String, DZ As String, FX As String

Pi = 4 * Atn(1#)
Cd = Pi / 180
AngleT = Angle * Cd - Pi / 2#
Z1 = Cos(AngleT)
Z2 = Sin(AngleT)
LongAxisT = LongAxis / 111.199
ShortAxisT = ShortAxis / 111.199
X0 = Lon + 0.5 * LongAxisT * Z2
Y0 = Lat + 0.5 * LongAxisT * Z1

MapInfo.do "Create Region Into Variable OBJ_Temp 0"
For I = 1 To 360
    XX = 0.5 * LongAxisT * Cos(I * Cd)
    YY = 0.5 * ShortAxisT * Sin(I * Cd)
    Loni = Lon + (XX * Z2 - YY * Z1)
    Lati = Lat + (XX * Z1 + YY * Z2)
    MapInfo.do "Alter Object OBJ_Temp Node Add (" & Loni & "," & Lati & ")"
Next

XH = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col1"",1)")
jd = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col2"",1)")
wd = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col3"",1)")
CZ = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col4"",1)")
DZ = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col5"",1)")
FX = MapInfo.Eval("ColumnInfo(""" & TableName & """,""col6"",1)")
If (XH <> "序号" Or jd <> "经度" Or wd <> "纬度" Or CZ <> "长轴" Or DZ <> "短轴" Or FX <> "方向") Then
    MapInfo.do "Insert Into " & TableName & "(Obj) values (OBJ_Temp)"
Else
    NoCreateEllipse = NoCreateEllipse + 1
    MapInfo.do "Insert Into " & TableName & "(序号,经度,纬度,长轴,短轴,方向,Obj) values (" & NoCreateEllipse & "," & Lon & "," & Lat & "," & LongAxis & "," & ShortAxis & "," & Angle & ",OBJ_Temp)"
End If
End Sub

Public Sub OpenTable(TableName As String)
Dim StrDir As String, TableNameT As String

I = InStr(TableName, ".")
If (I > 0) Then
    TableNameT = TableName
Else
    TableNameT = TableName + ".TAB"
End If
StrDir = Dir(TableNameT)

If (StrDir = "") Then
    I = MsgBox(App.Path & "\" & TableNameT & "不存在！", vbOKOnly, "关于打开表 ")
Else
    MapInfo.do "Open Table """ & TableName & """"
End If

End Sub

'新表存盘
Public Sub SaveTable(TableName As String)

MapInfo.do "Commit Table """ & TableName & """"

End Sub

Public Sub CloseTable(TableName As String)
Dim StrDir As String, TableNameT As String


'I = InStr(TableName, ".")
'If (I > 0) Then
'    TableNameT = TableName
'Else
'    TableNameT = TableName + ".TAB"
'End If
'StrDir = Dir(TableNameT)

'If (StrDir = "") Then
'    I = MsgBox(App.Path & "\" & TableNameT & "不存在！", vbOKOnly, "关于打开表 ")
'Else
    MapInfo.do "Close Table " & TableName & ""
'End If
End Sub

Public Sub CreatePoint(X As Single, Y As Single)
MapInfo.do "Insert Into " & TableName & "(Object) values (CreatePoint(" & X & "," & Y & "))"
End Sub

Public Sub CreateCircle(X As Single, Y As Single, Radius)
MapInfo.do "Insert Into " & TableName & "(Object) values (CreateCircle(" & X & "," & Y & "," & Radius & "))"
End Sub

Public Function RGBS(R As Integer, G As Integer, B As Integer) As Long
RGBS = RGB(B, G, R)
End Function