midmif.bas

采用三角化的方法基于mapinfo的等值线算法例子。

Open MIFFile For Output As #MIFNo
Open "C:\TempLSL.MIF" For Input As #10
Do While Temp <> "Data"
    Line Input #10, Temp
    Print #MIFNo, Temp
Loop
Line Input #10, Temp
Print #MIFNo, Temp
Close (10)

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

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

BorderStyle = 1
BorderColor = 0
BorderWidth = 1
End Sub
Public Sub MIFMID_Open(FileName As String, Columns() As String, ColumnsTypeT() As String, ColumnsNt As Integer, mmPaperHeight0 As Variant, mmPaperWidth0 As Variant, mmPaperHeight As Variant, mmPaperWidth As Variant)
    Dim I As Integer, MIFFile As String, MIDFile As String

    ColumnsN = ColumnsNt

    FileName = Trim(FileName)
   '' MsgBox FileName
    I = InStr(FileName, ".")
    If (I > 0) Then
        MIFFile = Left(FileName, I - 1) + ".MIF"
        MIDFile = Left(FileName, I - 1) + ".MID"
        MIFMIDFile = Left(FileName, I - 1)
    Else
        MIFFile = FileName + ".MIF"
        MIDFile = FileName + ".MID"
        MIFMIDFile = FileName
    End If
    
      
    MIDNo = FreeFile
    Call CloseExistTable(FileName)
    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 (mmPaperHeight <> 0 And mmPaperWidth <> 0) Then
        Print #MIFNo, "CoordSys NonEarth Units ""mm"" Bounds (" + Format(mmPaperWidth0, "####0.0###") + "," + Format(mmPaperHeight0, "####0.0###") + ") (" + Format(mmPaperWidth, "####0.0###") + "," + Format(mmPaperHeight, "####0.0###") + ")"
    Else
        Print #MIFNo, "CoordSys Earth Projection 1, 0"
    End If

    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 = 2
    FillForeGround = QBColor(1)
    FillBackGround = 16777215

    BorderStyle = 1
    BorderColor = 0
    BorderWidth = 1
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 Single, Y() As Single, N As Integer, N1 As Integer, N2 As Integer)
Dim I As Integer, Xcentroid As Single, Ycentroid As Single

'输出封闭多边形
If (N1 = 1) Then
    Print #MIFNo, "Region  "; Format(N2, "###0")
End If
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
If (N1 = N2) Then
    '输出边框参数
    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 If
If (N1 = N2) Then
    '输出质心
    Print #MIFNo, "    Center "; Format(Xcentroid, "#####0.000000 "); Format(Ycentroid, "#####0.000000")
End If
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 Single, Y As Single, Text As String, Angle As Single)
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Cd As Single, LenText As Single

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

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 Single, Y As Single)
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 Single, Y1 As Single, X2 As Single, Y2 As Single, Radius As Single)
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 Single, Y1 As Single, X2 As Single, Y2 As Single)
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 Single, Y As Single, RadiusX As Single, RadiusY As Single, StartAngle As Single, EndAngle As Single)
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single

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 Single, Y1 As Single, X2 As Single, Y2 As Single)
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(X As Single, Y As Single, RadiusX As Single, RadiusY As Single)
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single

X1 = X - RadiusX
X2 = X + RadiusX
Y1 = Y - RadiusY
Y2 = Y + RadiusY
Print #MIFNo, "Ellipse "; 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_Tab()
    Dim TheInFile As String, TheOutFile As String, I As Integer
    
    On Error Resume Next
    
    
    TheInFile = MIFMIDFile + ".MIF"
    TheOutFile = MIFMIDFile + ".TAB"
    Call CloseExistTable(TheOutFile)
  
    MapInfo.Do "Import """ & TheInFile & """ Type ""MIF"" Into """ & TheOutFile & """ Overwrite"
   
    
    TheInFile = MIFMIDFile + ".MIF"
    Kill TheInFile
    TheInFile = MIFMIDFile + ".MID"
    Kill TheInFile
    
    For I = Len(MIFMIDFile) To 1 Step -1
        If (Mid(MIFMIDFile, I, 1) = "\") Then Exit For
    Next I
    TableName = Right(MIFMIDFile, Len(MIFMIDFile) - I)
    
    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    ''MsgBox TableName
    If (mapWinID > 0) Then
        MapInfo.Do "Add Map Layer " & TableName
    End If
End Sub