midmif.bas

采用三角化的方法基于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 Single
Public MIFNo As Integer, MIDNo As Integer, MIFMIDFile As String
Public nMonth As Variant
'将年月日换算为儒略日.
Public Sub DateToRuLo(IY As Integer, IM As Integer, ID As Integer, R As Single)
Dim I As Integer, K As Integer

K = IY Mod 4
If (K = 0) Then
    nMonth(2) = 29
Else
    nMonth(2) = 28
End If
K = 0
For I = 1 To IM - 1
    K = K + nMonth(I)
Next I
R = (IY - 1900#) * 365# + Fix((IY - 1901) / 4) + K + ID + 15019.5
End Sub

Public Sub AxisY(X0c As Double, Y0c As Double, ValueMin As Double, Delta As Double, MaxMarK As Integer, nDec As Integer, Units As String, iColor As Integer, Yleng As Double)
    Dim I As Integer, J As Integer, K As Integer, ValueTemp As Single
    Dim Td As Single, dTd As Single
    Dim maxTicH As Single, minTicH As Single
    Dim TxtNumber As String, TxtnDec As String
    Dim X0 As Single, Y0 As Single
    Dim X0t As Single, Y0t As Single
    Dim V() As String
    Dim mmH As Single, mmW As Single
    
    mmH = 18# * Screen.TwipsPerPixelY / 56.7
    mmW = 9 * Screen.TwipsPerPixelX / 56.7
    
    Call MIFMID_MakeFont("MS Sans Serf", 1.5 * 25, QBColor(iColor), 1, QBColor(15), 0, 0, 0, 0, 0, 0)
    Call MIFMID_MakePen(2, 2, QBColors(10))
    
    ReDim V(1 To ColumnsN)
    For I = 1 To ColumnsN - 1
        V(I) = ""
    Next I
    
    X0 = Xmin0p + X0c
    Y0 = Ymin0p + Y0c
    If (nDec = 0) Then
        TxtnDec = "######0"
    ElseIf (nDec > 0) Then
        TxtnDec = "######0."
        For I = 1 To nDec
            TxtnDec = TxtnDec + "0"
        Next I
    End If
    maxTicH = 5
    minTicH = maxTicH / 2
    '画Y轴线
    Call MIFMID_CreateLine(X0, Y0, X0, Y0 + Yleng)
    Call OutMID(V)
    '画大小刻度线
    dTd = Yleng / (MaxMarK - 1)
    Td = Y0
    '第一个大刻度
    Call MIFMID_CreateLine(X0, Td, X0 - maxTicH, Td)
    Call OutMID(V)

    '标注刻度
    ValueTemp = ValueMin
    TxtNumber = Format(ValueTemp, TxtnDec)
    
    X0t = X0 - maxTicH - mmW * Len(TxtNumber)
    Y0t = Td ' - mmH / 2
    Call MIFMID_CreateText(X0t, Y0t, TxtNumber, 0#)
    For I = 2 To MaxMarK
        '画大刻度
        Td = Td + dTd
        Call MIFMID_CreateLine(X0, Td, X0 - maxTicH, Td)
        Call OutMID(V)
        '标注刻度
        ValueTemp = ValueTemp + Delta
        TxtNumber = Format(ValueTemp, TxtnDec)
        X0t = X0 - maxTicH - mmW * Len(TxtNumber)
        Y0t = Td '-'mmH / 2
        Call MIFMID_CreateText(X0t, Y0t, TxtNumber, 0#)
        Call OutMID(V)
        K = 0
    Next I
    '座标单位
    Call MIFMID_MakeFont("MS Sans Serf", 1.5 * 30, QBColor(iColor), 1, QBColor(15), 0, 0, 0, 0, 0, 0)
    
    If (Len(Units) > 0) Then
        X0t = X0 ' - UserControl.TextWidth(Units) / 2
        Y0t = Td ' - 1.5 * UserControl.TextHeight(Units)
        Call MIFMID_CreateText(X0t, Y0t, Units, 0#)
        Call OutMID(V)
    End If
End Sub
Public Sub AxisT(X0c As Double, Y0c As Double, MinYear As Integer, MinMonth As Integer, MinDate As Integer, MaxYear As Integer, MaxMonth As Integer, MaxDate As Integer, strAxisT As String, strTitle As String, iColor As Integer, Xleng As Single)
    Dim I As Integer, J As Integer, K As Long, value As String, iMod As Integer
    Dim YearTemp As Integer, MonthTemp As Integer
    Dim nDate As Long, Td As Single, dTd As Single, Xt As Single
    Dim maxTicH As Single, minTicH As Single, YMD As Integer
    Dim X0 As Single, Y0 As Single, strTitleTemp As String, bYearMonth As Integer, bYear As Integer
    Dim Xmin As Single, Xmax As Single, DeltaT As Single, bMarkMin As Boolean, DY As Single, DX As Single
    Dim WidthYear As Single, Td0 As Single, Tdn As Single
    Dim XFact As Single
    Dim V() As String
    Dim mmH As Single, mmW As Single
    
    mmH = 18# * Screen.TwipsPerPixelY / 56.7
    mmW = 9 * Screen.TwipsPerPixelX / 56.7
    Call MIFMID_MakeFont("MS Sans Serf", 1.5 * 25, QBColor(iColor), 1, QBColor(15), 0, 0, 0, 0, 0, 0)
    Call MIFMID_MakePen(2, 2, QBColors(10))

    ReDim V(1 To ColumnsN)
    For I = 1 To ColumnsN - 1
        V(I) = ""
    Next I


    strTitleTemp = Trim(strTitle)
    X0 = Xmin0p + X0c
    Y0 = Ymin0p + Y0c

    strAxisT = Trim(strAxisT)
    maxTicH = 5
    minTicH = maxTicH / 2

    nDate = 12# * (MaxYear - MinYear) + MaxMonth - MinMonth + 1
    If (MaxMonth = 2) Then
        iMod = MinYear Mod 4
        If (iMod = 0) Then
            nMonth(2) = 29
        Else
            nMonth(2) = 28
        End If
    End If
    If (nDate = 1) Then         '坐标以日为单位
        YMD = 3
        If (MaxDate > nMonth(MaxMonth)) Then
            MaxDate = nMonth(MaxMonth)
        End If
    ElseIf (nDate > 12) Then    '坐标以年为单位
        YMD = 1
        MinMonth = 1
        MinDate = 1
        MaxMonth = 12
        MaxDate = 31
    Else                         '坐标以月为单位
        YMD = 2
        MinDate = 1
        MaxDate = nMonth(MaxMonth)
    End If

    '画X轴
    Call MIFMID_CreateLine(X0, Y0, X0 + Xleng, Y0)
    Call OutMID(V)
    '画坐标大小刻度
    Td = X0
    Call DateToRuLo(MinYear, MinMonth, MinDate, Xmin)
    Call DateToRuLo(MaxYear, MaxMonth, MaxDate, Xmax)
    Xmax = Xmax + 1
    XFact = Xleng / (Xmax - Xmin)
    DY = 0
    If (YMD = 1) Then                   '年
        dTd = Xleng / (MaxYear - MinYear + 1)
        If (dTd < 2# * mmW) Then
            '第一个大刻度
            Td0 = -10000000000#
            Tdn = X0 + Xleng
            WidthYear = 1.5 * 5 * mmW
            For I = MinYear To MaxYear + 1
                '大刻度--年
                Call DateToRuLo(I, 1, 1, Xt)
                Xt = Xt - 1
                Td = (Xt - Xmin) * XFact + X0
                If (Td - Td0 > WidthYear Or (Tdn - Td > WidthYear And I = MaxYear + 1)) Then
                    '标刻度
                    Call MIFMID_CreateLine(Td, Y0, Td, Y0 - minTicH)
                    Call OutMID(V)
                    '写刻度
                    value = Format(I, "###0")
                    Td = Td - mmW * Len(value) / 2#
                    Call MIFMID_CreateText(Td, Y0 + mmH / 2, value, 0#)
                    Call OutMID(V)
                    Td0 = Td
                End If
            Next I
            '最后一个大刻度
            Call MIFMID_CreateLine(X0 + Xleng, Y0, X0 + Xleng, Y0 - minTicH)
            Call OutMID(V)
        Else
            If (dTd > 5 * mmW) Then
                bYear = 4
            Else
                bYear = 2
            End If
            If (dTd > 1.5 * 5 * mmW) Then
                bMarkMin = True
            Else
                bMarkMin = False
            End If
            '第一个大刻度
            Call MIFMID_CreateLine(X0, Y0, X0, Y0 - maxTicH)
            Call OutMID(V)
            For I = MinYear To MaxYear
                '小刻度--月
                If (bMarkMin = True) Then
                    For J = 1 To 12
                        Call DateToRuLo(I, J, 1, Xt)
    
                        Td = (Xt - Xmin) * XFact + X0
                        Call MIFMID_CreateLine(Td, Y0, Td, Y0 - minTicH)
                        Call OutMID(V)
                    Next J
                End If
                '大刻度--年
                Call DateToRuLo(I, 12, 31, Xt)
                Xt = Xt + 1
                Td = (Xt - Xmin) * XFact + X0
                Call MIFMID_CreateLine(Td, Y0, Td, Y0 - maxTicH)
                Call OutMID(V)
                '写刻度
                If (bYear = 4) Then
                    value = Format(I, "###0")
                Else
                    value = Right(Format(I, "###0"), 2)
                End If
                iMod = I Mod 4
                If (iMod = 0) Then
                    dTd = 366 / 2#
                Else
                    dTd = 365 / 2#
                End If
                Td = X0 + (Xt - dTd - Xmin) * XFact ' + mmW * Len(value) / 2#
                Call MIFMID_CreateText(Td, Y0 - mmH / 2, value, 0#)
                Call OutMID(V)
            Next I
            '最后一个大刻度
            Call MIFMID_CreateLine(X0 + Xleng, Y0, X0 + Xleng, Y0 - maxTicH)
            Call OutMID(V)
        End If
    ElseIf (YMD = 2) Then                '年月
        YearTemp = MinYear
        MonthTemp = MinMonth - 1
        '大刻度--月
        K = 12# * (MaxYear - MinYear) + MaxMonth - MinMonth + 1
        dTd = Xleng / K
        If (dTd >= mmW * 7) Then
            bYearMonth = 6
        ElseIf (dTd >= mmW * 5) Then
            bYearMonth = 4
        ElseIf (dTd > mmW * 2) Then
            bYearMonth = 2
        Else
            bYearMonth = 0
        End If
        '第一个大刻度
        Call MIFMID_CreateLine(X0, Y0, X0, Y0 - maxTicH)
        Call OutMID(V)
        For I = 1 To K
            MonthTemp = MonthTemp + 1
            If (MonthTemp > 12) Then
                MonthTemp = 1
                YearTemp = YearTemp + 1
                iMod = YearTemp Mod 4
                If (iMod = 0) Then
                    nMonth(2) = 29
                Else
                    nMonth(2) = 28
                End If
            End If
            Call DateToRuLo(YearTemp, MonthTemp, 1, Xt)
            Td = (Xt - Xmin) * XFact + X0
            Call MIFMID_CreateLine(Td, Y0, Td, Y0 - minTicH)
            Call OutMID(V)
            '写刻度
            If (bYearMonth = 6) Then
                value = Format(YearTemp, "###0") + Format(MonthTemp, "00")
            ElseIf (bYearMonth = 4) Then
                value = Right(Format(YearTemp, "###0"), 2) + Format(MonthTemp, "00")
            ElseIf (bYearMonth = 2) Then
                value = Format(MonthTemp, "#0")
            End If
            If (bYearMonth > 0) Then
                dTd = nMonth(MonthTemp) / 2#
                Td = X0 + (Xt + dTd - Xmin) * XFact - mmW * Len(value) / 2#
                Call MIFMID_CreateText(Td, Y0 - mmH / 2, value, 0#)
                Call OutMID(V)
            End If
        Next I
        '最后一个大刻度
        Call MIFMID_CreateLine(X0 + Xleng, Y0, X0 + Xleng, Y0 - maxTicH)
        Call OutMID(V)
    Else                                    '日
        '第一个大刻度
        DeltaT = 0#
        DeltaT = XFact
        dTd = mmW * 2
        DY = 0#
        DX = 0.5
        If (DeltaT < dTd) Then
            dTd = 2# * dTd
            DeltaT = 2.1 * dTd
            DY = maxTicH - minTicH
            DX = 0#
        End If
        For J = MinDate To MaxDate
            Call DateToRuLo(MinYear, MinMonth, J, Xt)
            Td = X0 + (Xt - Xmin) * XFact
            DeltaT = DeltaT + XFact
            value = Format(J, "#0")
            If (DeltaT > dTd) Then '写刻度
                Call MIFMID_CreateLine(Td, Y0, Td, Y0 - minTicH - DY)
                Call OutMID(V)
        
                DeltaT = 0#
                Td = X0 + (Xt + DX - Xmin) * XFact - mmW * Len(value) / 2#
                Call MIFMID_CreateText(Td, Y0 - mmH / 2 - DY, value, 0#)
                Call OutMID(V)
            Else
                Call MIFMID_CreateLine(Td, Y0, Td, Y0 - minTicH)
                Call OutMID(V)
            End If
            Xt = Xt + 1
        Next J
        '最后一个刻度
        Call MIFMID_CreateLine(X0 + Xleng, Y0, X0 + Xleng, Y0 - minTicH)
        Call OutMID(V)
    End If
    '座标单位
    If (Len(strAxisT) > 0) Then
        Call MIFMID_CreateText(X0 + Xleng + mmW / 2, Y0, strAxisT, 0#)
        Call OutMID(V)
    End If
    Y0 = Y0 - 2 * mmH

    Call MIFMID_MakeFont("MS Sans Serf", 1.5 * 30, QBColor(iColor), 1, QBColor(15), 0, 0, 0, 0, 0, 0)
    
    Call MIFMID_CreateText(X0 + (Xleng - mmW * Len(strTitleTemp)) / 2, Y0 - DY, strTitleTemp, 0#)
    Call OutMID(V)
End Sub

Public Sub MIFMID_OpenArrow(FileName As String)
Dim I As Integer, MIFFile As String, MIDFile As String
Dim Temp As String


FileName = Trim(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