midmif.bas

VB+mapinfo开发的最短路径

Attribute VB_Name = "Module6"
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
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 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

Public Sub MIFMID_CreateRegion(X() As Double, Y() As Double, N As Integer)
Dim I As Integer, Xcentroid As Double, Ycentroid As Double

'输出封闭多边形
Print #MIFNo, "Region  1"
If (X(1) = X(N) And Y(1) = Y(N)) Then '最后一点与第一点重合
    Print #MIFNo, Format(N, "####0")
    Xcentroid = -X(1)
    Ycentroid = -Y(1)
    For I = 1 To N
        Print #MIFNo, Format(X(I), "#####0.000000 "); Format(Y(I), "#####0.000000")
        Xcentroid = Xcentroid + X(I)
        Ycentroid = Ycentroid + Y(I)
    Next I
    Xcentroid = Xcentroid / (N - 1)
    Ycentroid = Ycentroid / (N - 1)
Else '最后一点与第一点不重合
    Print #MIFNo, Format(N + 1, "####0")
    Xcentroid = 0#
    Ycentroid = 0#
    For I = 1 To N
        Print #MIFNo, Format(X(I), "#####0.000000 "); Format(Y(I), "#####0.000000")
        Xcentroid = Xcentroid + X(I)
        Ycentroid = Ycentroid + Y(I)
    Next I
    Print #MIFNo, Format(X(1), "#####0.000000 "); Format(Y(1), "#####0.000000")
    Xcentroid = Xcentroid / N
    Ycentroid = Ycentroid / N
End If
'输出边框参数
Print #MIFNo, "    Pen ("; Format(BorderWidth, "#0"); ","; Format(BorderStyle, "#0"); ","; Format(BorderColor, "############0"); ")"
'输出填充参数
If (FillBackGround = 0) Then '没有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ")"
Else '有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ","; Format(FillBackGround, "############0"); ")"
End If
'输出质心
Print #MIFNo, "    Center "; Format(Xcentroid, "#####0.000000 "); Format(Ycentroid, "#####0.000000")
End Sub
Public Sub MIFMID_MakeBrush(FillPatternT As Integer, FillForeGroundT As Long, FillBackGroundT As Long, BorderStyleT As Integer, BorderColorT As Long, BorderWidthT As Integer)
FillPattern = FillPatternT
FillForeGround = FillForeGroundT
FillBackGround = FillBackGroundT

BorderStyle = BorderStyleT
BorderColor = BorderColorT
BorderWidth = BorderWidthT
End Sub

Public Sub MIFMID_MakeFont(TextFontT As String, TextSizeT As Integer, TextColorT As Long, TextNoBackgroundColorT As Integer, TextBackgroundColorT As Long, iBoldT As Integer, iUnderlineT As Integer, iShadowT As Integer, iItalicT As Integer, iAllCapsT As Integer, iExpandedT As Integer)

TextFont = TextFontT
TextSize = TextSizeT
TextColor = TextColorT

TextNoBackgroundColor = TextNoBackgroundColorT
TextBackgroundColor = TextBackgroundColorT

TextEffects = 0
If (TextNoBackgroundColor = 1) Then TextEffects = TextEffects + 256
If (iBoldT = 1) Then TextEffects = TextEffects + 1
If (iItalicT = 1) Then TextEffects = TextEffects + 2
If (iUnderlineT = 1) Then TextEffects = TextEffects + 4
If (iShadowT = 1) Then TextEffects = TextEffects + 32
If (iAllCapsT = 1) Then TextEffects = TextEffects + 512
If (iExpandedT = 1) Then TextEffects = TextEffects + 1024
End Sub
Public Sub MIFMID_CreateText(X As Double, Y As Double, Text As String, Angle As Double)
Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double, Cd As Double, LenText As Double

Print #MIFNo, "Text"
Print #MIFNo, "    "; """"; Trim(Text); """"

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

Print #MIFNo, "    "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000")
If (TextNoBackgroundColor = 0) Then '没有背景
    Print #MIFNo, "    Font ("; """"; TextFont; """"; ","; Format(TextEffects, "###0"); ",0,"; Format(TextColor, "########0"); ")"
Else
    Print #MIFNo, "    Font ("; """"; TextFont; """"; ","; Format(TextEffects, "###0"); ",0,"; Format(TextColor, "########0"); ","; Format(TextBackgroundColor, "########0"); ")"
End If
Print #MIFNo, "    Angle "; Format(Angle, "###0.00")
Print #MIFNo, ""
End Sub

Public Sub MIFMID_Close()
Close (MIFNo)
Close (MIDNo)
End Sub

Public Sub MIFMID_MakeSymbol(Shape As Integer, Color As Long, Size As Integer)

SymbolShape = Shape
SymbolColor = Color
SymbolSize = Size
SymbolFontName = "MAPINFO 3.0 COMPATIBLE"
'SymbolFontStyle = FontStyle
'SymbolRotation = Rotation

End Sub

Public Sub MIFMID_MakeFontSymbol(Shape As Integer, Color As Long, Size As Long, FontName As String, FontStyle As Integer, Rotation As Double)

SymbolShape = Shape
SymbolColor = Color
SymbolSize = Size
SymbolFontName = FontName
SymbolFontStyle = FontStyle
SymbolRotation = Rotation

End Sub


Public Sub OutMID(V As Variant)
Dim I As Integer

For I = 1 To ColumnsN - 1
    If (InStr(ColumnsType(I), "CHAR(") > 0) Then
        Print #MIDNo, """"; V(I); """,";
    Else
        Print #MIDNo, V(I); ",";
    End If
Next I
If (InStr(ColumnsType(ColumnsN), "CHAR(") > 0) Then
    Print #MIDNo, """"; V(I); """"
Else
    Print #MIDNo, V(I)
End If

End Sub
Public Sub MIFMID_CreateSymbol(X As Double, Y As Double)
Dim I As Integer

Print #MIFNo, "Point "; Format(X, "#####0.000000"); " "; Format(Y, "#####0.000000")

If (InStr(UCase(SymbolFontName), "MAPINFO 3.0") > 0 Or Len(Trim(SymbolFontName)) < 2) Then
    Print #MIFNo, "    Symbol ("; Format(SymbolShape, "#0"); ","; Format(SymbolColor, "########0"); ","; Format(SymbolSize, "#0"); ")"
Else
    Print #MIFNo, "    Symbol ("; Format(SymbolShape, "#0"); ","; Format(SymbolColor, "########0"); ","; Format(SymbolSize, "#0"); ","; """"; Trim(SymbolFontName); """"; ","; Format(SymbolFontStyle, "###0"); ","; Format(SymbolRotation, "###0.0"); ")"
End If
''For I = 1 To ColumnsN - 1
''    If (InStr(ColumnsType(I), "CHAR(") > 0) Then
''        Print #MIDNo, """"; """,";
''    Else
''        Print #MIDNo, "0,";
''    End If
''Next I
''If (InStr(ColumnsType(ColumnsN), "CHAR(") > 0) Then
''    Print #MIDNo, """"; """"
''Else
''    Print #MIDNo, "0"
''End If

End Sub


Public Sub MIFMID_CreateRoundrect(X1 As Double, Y1 As Double, X2 As Double, Y2 As Double, Radius As Double)
Print #MIFNo, "Roundrect "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000 "); Format(Radius, "######0.000000")
'输出边框参数
Print #MIFNo, "    Pen ("; Format(BorderWidth, "#0"); ","; Format(BorderStyle, "#0"); ","; Format(BorderColor, "############0"); ")"
'输出填充参数
If (FillBackGround = 0) Then '没有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ")"
Else '有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ","; Format(FillBackGround, "############0"); ")"
End If
End Sub
Public Sub MIFMID_CreateRect(X1 As Double, Y1 As Double, X2 As Double, Y2 As Double)
Print #MIFNo, "Rect "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000")
'输出边框参数
Print #MIFNo, "    Pen ("; Format(BorderWidth, "#0"); ","; Format(BorderStyle, "#0"); ","; Format(BorderColor, "############0"); ")"
'输出填充参数
If (FillBackGround = 0) Then '没有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ")"
Else '有背景
    Print #MIFNo, "    Brush ("; Format(FillPattern, "#0"); ","; Format(FillForeGround, "#########0"); ","; Format(FillBackGround, "############0"); ")"
End If
End Sub


Public Sub MIFMID_CreateArc(X As Double, Y As Double, RadiusX As Double, RadiusY As Double, StartAngle As Double, EndAngle As Double)
Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double

X1 = X - RadiusX
X2 = X + RadiusX
Y1 = Y - RadiusY
Y2 = Y + RadiusY
If (Abs(StartAngle - EndAngle) >= 360#) Then
    Print #MIFNo, "Arc "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000 "); "0 0"
Else
    Print #MIFNo, "Arc "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000 "); Format(StartAngle, "###0.0 "); Format(EndAngle, "###0.0")
End If
'输出边框参数
Print #MIFNo, "    Pen ("; Format(BorderWidth, "#0"); ","; Format(BorderStyle, "#0"); ","; Format(BorderColor, "############0"); ")"
End Sub
Public Sub MIFMID_CreateLine(X1 As Double, Y1 As Double, X2 As Double, Y2 As Double)
Print #MIFNo, "Line "; Format(X1, "######0.000000 "); Format(Y1, "######0.000000 "); Format(X2, "######0.000000 "); Format(Y2, "######0.000000")
'输笔参数
Print #MIFNo, "    Pen ("; Format(PenWidth, "#0"); ","; Format(PenPattern, "#0"); ","; Format(PenColor, "############0"); ")"
End Sub

Public Sub MIFMID_CreateEllipse(EllipsLon As Double, EllipsLat As Double, EllipsAxisShort As Double, EllipsAxisLong As Double, EllipsAngle As Double)
    Dim Loni As Double, Lati As Double
    Dim Pi As Double, Cd As Double
    Dim XX() As Double, YY() As Double, Nxy As Integer, I As Integer
    Dim X0 As Double, Y0 As Double

    Pi = 4 * Atn(1#)
    Cd = Pi / 180

    Call Ellips(0#, 0#, EllipsAxisLong, EllipsAxisShort, EllipsAngle, XX, YY, Nxy)

    Print #MIFNo, "Region  1"
    Print #MIFNo, Format(Nxy, "##0")
    X0 = 0
    Y0 = 0
    For I = 1 To Nxy
        Lati = EllipsLat + YY(I) / 111.199
        Loni = EllipsLon + XX(I) / (111.199 * Cos((EllipsLat + Lati) * 0.5 * Cd))
        Print #MIFNo, Format(Loni, "#####0.000000 "); Format(Lati, "#####0.000000")
        X0 = X0 + Loni
        Y0 = Y0 + Lati
    Next I
    X0 = X0 / Nxy
    Y0 = Y0 / Nxy
    Print #MIFNo, "    Pen (1,2,16711680)"
    Print #MIFNo, "    Brush (1,0,16777215)"
    Print #MIFNo, "    Center "; Format(93.340137, "##0.000000 "); Format(Y0, "##0.000000")
End Sub