midmif.bas

MapInfo 行业应用源代码

Attribute VB_Name = "Module3"
Option Explicit
Dim ColumnsN As Integer, ColumnsType() As String
Dim PenWidth As Integer, PenPattern As Integer, PenColor As Long
Dim FillPattern As Integer, FillForeGround As Long, FillBackGround As Long, BorderStyle As Integer, BorderColor As Long, BorderWidth As Integer
Dim TextFont As String, TextSize As Integer, TextColor As Long, TextNoBackgroundColor As Integer, TextBackgroundColor As Long, TextEffects As Integer
Dim SymbolShape As Integer, SymbolColor As Long, SymbolSize As Integer, SymbolFontName As String, SymbolFontStyle As Integer, SymbolRotation As Double
Dim XYFact As Single
Public MIFNo As Integer, MIDNo As Integer, MIFMIDFile As String
Public mapWinID As Long
Public ThePublicOutPath As String
Public bOKCancel As Boolean
Public TableName As String
Public MapInfo As Object

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


Private Sub Ellips(Xo As Double, Yo As Double, A As Double, B As Double, Al As Double, XX() As Double, YY() As Double, 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 MIFMID_Open(FileName As String, Columns() As String, ColumnsTypeT() As String, ColumnsNt As Integer)
Dim I As Integer, MIFFile As String, MIDFile As String

ColumnsN = ColumnsNt

FileName = Trim(FileName)
I = InStr(FileName, ".")
If (I > 0) Then
    MIFFile = Left(FileName, I - 1) + ".MIF"
    MIDFile = Left(FileName, I - 1) + ".MID"
Else
    MIFFile = FileName + ".MIF"
    MIDFile = FileName + ".MID"
End If
Call CloseExistTable(FileName)

MIDNo = FreeFile
Open MIDFile For Output As #MIDNo

MIFNo = FreeFile
Open MIFFile For Output As #MIFNo
Print #MIFNo, "Version 300"
Print #MIFNo, "Charset ""WindowsSimpChinese"""
Print #MIFNo, "Delimiter "","""
''If (ColumnsN <= 1) Then
''    Print #MIFNo, "Index 1"
''Else
''    Print #MIFNo, "Index ";
''    For I = 1 To ColumnsN - 1
''        Print #MIFNo, Format(I, "##0"); ",";
''    Next I
''    Print #MIFNo, Format(ColumnsN, "##0")
''End If
Print #MIFNo, "CoordSys Earth Projection 1, 0"

ReDim ColumnsType(1 To ColumnsN)
If (ColumnsN = 0) Then
    Print #MIFNo, "Columns 1"
    Print #MIFNo, "  NoColumn SmallInt"
Else
    Print #MIFNo, "Columns "; Format(ColumnsN, "#0")
    For I = 1 To ColumnsN
        ColumnsType(I) = UCase(ColumnsTypeT(I))
        Print #MIFNo, "  "; Trim(Columns(I)); " "; Trim(ColumnsTypeT(I))
    Next I
End If
Print #MIFNo, "Data"
Print #MIFNo, " "

'初始化曲线
PenWidth = 1
PenPattern = 2
PenColor = 0

'初始化填充区域
FillPattern = 0
FillForeGround = QBColors(1)
FillBackGround = 16777215

BorderStyle = 2
BorderColor = 0
BorderWidth = 2

End Sub

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

Public Sub MIFMID_CreatePolyLine(X() As Single, Y() As Single, N As Integer, bSmooth As Boolean)
Dim I As Integer

Print #MIFNo, "Pline "; Format(N, "####0")

For I = 1 To N
    Print #MIFNo, Format(X(I), "#####0.000000 "); Format(Y(I), "#####0.000000")
Next I
Print #MIFNo, "    Pen ("; Format(PenWidth, "#0"); ","; Format(PenPattern, "#0"); ","; Format(PenColor, "############0"); ")"
If (bSmooth = True) Then
    Print #MIFNo, "    Smooth"
End If
End Sub

Public Sub MIFMID_MakePen(PenWidthT As Integer, PenPatternT As Integer, PenColorT As Long)
PenWidth = PenWidthT
PenPattern = PenPatternT
PenColor = PenColorT
End Sub