table.bas

地震信息系统,是一个gis的二次开发,主要由mapx+vb编写完成,

Attribute VB_Name = "Module2"
Option Explicit
Dim ColumnsN As Integer, Columns() As String, ColumnsType() As String
Dim NoCreateEllipse As Integer
Dim I As Integer
Public TableName As String
Public Function QBColors(I As Integer) 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

Private Sub Ellips(Xo As Single, Yo As Single, A As Single, B As Single, Al As Single, XX() As Single, YY() As Single, Nxy As Integer)
Dim THS As Double, THE As Double
Dim Ts As Double, Te As Double
Dim CA As Double, Sa As Double
Dim CTS As Double, STS As Double, CTE As Double, STE As Double
Dim Af As Double
Dim XE As Double, YE As Double
Dim X As Double, Y As Double
Dim DA As Double, N As Integer, N1 As Integer
Dim Dt As Double, Cd As Double, SD As Double
Dim A1 As Double, A2 As Double, B1 As Double, B2 As Double
Dim I As Integer, CC As Double, SS As Double
Dim X1 As Double, Y1 As Double

THS = 0#
THE = 0#
Af = Al * 0.0174533
Ts = THS * 0.0174533
Te = THE * 0.0174533
CA = Cos(Af)
Sa = Sin(Af)
CTS = Cos(Ts)
STS = Sin(Ts)
CTE = Cos(Te)
STE = Sin(Te)
XE = Xo + A * CTE * CA - B * STE * Sa
YE = Yo + A * CTE * Sa + B * STE * CA
X = Xo + A * CTS * CA - B * STS * Sa
Y = Yo + A * CTS * Sa + B * STS * CA

'Call Plot(X, Y, 3)
X1 = X
Y1 = Y

''DA = 1# / (A + B)
''N = Fix((Te - Ts) / DA)
''If (N = 0) Then N = Fix(2# * 3.14159 / DA)
N = 180

Dt = (Te - Ts) / N
If (Dt = 0#) Then Dt = 2# * 3.14159 / N
Cd = Cos(Dt)
SD = Sin(Dt)
A1 = A * SD * CA
A2 = A * SD * Sa
B1 = B * SD * CA
B2 = B * SD * Sa
N1 = N - 1
Nxy = N + 1
ReDim XX(1 To Nxy), YY(1 To Nxy)
XX(1) = XE
YY(1) = YE
XX(2) = X
YY(2) = Y
For I = 1 To N1
    CC = CTS
    SS = STS
    STS = SS * Cd + CC * SD
    CTS = CC * Cd - SS * SD
    X = Xo + (X - Xo) * Cd - A1 * SS - B2 * CC
    Y = Yo + (Y - Yo) * Cd - A2 * SS + B1 * CC
    'Call Plot(X, Y, 2)
    'Picture2.Line (X1, Y1)-(X, Y)
    X1 = X
    Y1 = Y
    XX(I + 2) = X
    YY(I + 2) = Y
Next I
'Call Plot(XE, YE, 2)
'Picture2.Line (X1, Y1)-(XE, YE)
''XX(Nxy) = X
''YY(Nxy) = Y

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

I = InStr(TableNameT, ".")
If (I > 0) Then
    TableName = Left(TableNameT, I - 1)
Else
    TableName = TableNameT
End If
Call CloseExistTable(TableName)

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

Temp = "Create Table " + 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 + """"
'创建一个新表
MapInfo.Do Temp

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

'打开一个表
'Temp = "Open Table " + """" + ThePublicOutPath + TableName + ".Tab" + """"
'MapInfo.Do Temp

MapInfo.Do "Set Distance Units ""km"""
MapInfo.Do "Set CoordSys Earth Projection 1,0"


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 ModifyRegion(Lon() As Single, Lat() As Single, N As Integer)
MapInfo.Do "Fetch First From Selection"
MapInfo.Do "OBJ_Temp=Selection.OBJ"

MapInfo.Do "Create Region Into Variable OBJ_Temp 0"

For I = 1 To N
    MapInfo.Do "Alter Object OBJ_Temp Node Add (" & Lon(I) & "," & Lat(I) & ")"
Next
MapInfo.Do "UpDate Selection Set OBJ=OBJ_Temp"

End Sub
Public Sub ModifyEllipse(StrIndex As String, Lon As Single, Lat As Single, LongAxis As Single, ShortAxis As Single, Angle As Single)
Dim Loni As Single, Lati As Single
Dim Pi As Single, Cd As Single
Dim XX() As Single, YY() As Single, Nxy As Integer

Pi = 4 * Atn(1#)
Cd = Pi / 180
MapInfo.Do "Fetch First From Selection"
MapInfo.Do "OBJ_Temp=Selection.OBJ"
Call Ellips(0#, 0#, LongAxis / 2, ShortAxis / 2, Angle, XX, YY, Nxy)
For I = 1 To Nxy
    Lati = Lat + YY(I) / 111.199
    Loni = Lon + XX(I) / (111.199 * Cos((Lat + Lati) * 0.5 * Cd))
    MapInfo.Do "Alter Object OBJ_Temp Node Set Position 1," & I & "(" & Loni & "," & Lati & ")"
Next I

MapInfo.Do "UpDate Selection Set Col1=""" & StrIndex & """,Col2=" & Lon & ",Col3=" & Lat & ",Col4=" & LongAxis & ",Col5=" & ShortAxis & ",Col6=" & Angle & ",OBJ=OBJ_Temp"
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

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)
Dim XYFact As Double, Cd As Double
Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double, LenText As Integer
Dim TextSize As Integer

TextSize = 16
XYFact = 10
Cd = Atn(1#) / 45#
LenText = Len(Trim(Text)) / 2
X1 = X - (TextSize * Sin(Angle * Cd) + TextSize * LenText * Cos(Angle * Cd)) / XYFact / 2
Y1 = Y + (TextSize * Cos(Angle * Cd) - TextSize * LenText * Sin(Angle * Cd)) / XYFact / 2

X2 = X1 + TextSize * Len(Trim(Text)) / XYFact
Y2 = Y1 - TextSize / XYFact


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 Double)

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 "Create RoundRect Into Variable OBJ_Temp(" & X1 & "," & Y1 & ") (" & X2 & "," & Y2 & ") " & Radius & ""
MapInfo.Do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"
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 ModifyLine(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
MapInfo.Do "Fetch First From Selection"
MapInfo.Do "OBJ_Temp=Selection.OBJ"

MapInfo.Do "Alter Object OBJ_Temp Geography OBJ_GEO_LINEBEGX," & X1
MapInfo.Do "Alter Object OBJ_Temp Geography OBJ_GEO_LINEBEGy," & Y1

MapInfo.Do "Alter Object OBJ_Temp Geography OBJ_GEO_LINEENDX," & X2
MapInfo.Do "Alter Object OBJ_Temp Geography OBJ_GEO_LINEENDy," & Y2

MapInfo.Do "UpDate Selection Set OBJ=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 As Single, Angle As Single)
Dim Loni As Single, Lati As Single
Dim Pi As Single, Cd As Single, XH As String
Dim XX() As Single, YY() As Single, Nxy As Integer

MapInfo.Do "Create Region Into Variable OBJ_Temp 0"

Pi = 4 * Atn(1#)
Cd = Pi / 180
Call Ellips(0#, 0#, LongAxis, ShortAxis, Angle, XX, YY, Nxy)
For I = 1 To Nxy
    Lati = Lat + YY(I) / 111.199
    Loni = Lon + XX(I) / (111.199 * Cos((Lat + Lati) * 0.5 * Cd))
    MapInfo.Do "Alter Object OBJ_Temp Node Add (" & Loni & "," & Lati & ")"
Next I

MapInfo.Do "Insert Into " & TableName & "(Object) values (OBJ_Temp)"
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)
    MapInfo.Do "Close Table " & TableName & ""
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 As Single)
MapInfo.Do "Insert Into " & TableName & "(Object) values (CreateCircle(" & X & "," & Y & "," & Radius & "))"
End Sub