纯vb 根据excel模版 生成窗体

首先看页面样子，见上图

以下是vb代码

Option Explicit
Public pTags As String
Dim aaa As String
Dim iTags() As String

Dim i, j, k, M, p, T, r As Long
Dim cSql As String
Dim cSql1 As String
Dim cRec As rdoResultset
Dim cRec1 As rdoResultset
Dim cRecT As rdoResultset
Dim cType_Code As String
Dim iType As String
Dim bPact As Boolean
Dim c1 As String
Dim c2 As String
Dim GroupNo As String
Dim Size As String             '广告尺寸
Dim Position As String         '广告位置
Dim sType As String            '广告类型
Dim VarOld, VarNew As Long
Dim var As Long
Dim var2 As Long
Dim a As Long
Dim b As Long
Dim dMin As String     '最小日期
Dim dMax As Long       '最大日期
Dim cMonth As String
Dim dtend As Date             '当前月的最后一天
Dim dtbegin As Date             '当前月的第一天
Dim oldGroup_no As String
Dim newGroup_no As String
Dim price As String     '单价
Dim d1 As Date
Dim d2 As Date

 

Private Sub cmdOk_Click()

        If Option1(0).Value = True Then '同方模版
            TongFang
            fpSpr.SetText 1, 2, "网站"
            fpSpr.SetText 1, 4, "It168"
            fpSpr.SetText 2, 2, "创意形式/尺寸"
            fpSpr.SetText 3, 2, "位置"
            fpSpr.SetText 4, 2, "广告形式"
            fpSpr.SetText 5, 1, "日均"
            fpSpr.SetText 5, 2, "页面流量"
            fpSpr.SetText 5, 3, "(‘000)"
            fpSpr.SetText 6, 1, "计划"
            fpSpr.SetText 6, 2, "浏览量"
            fpSpr.SetText 6, 3, "(‘000)"
            fpSpr.SetText 7, 1, "预计"
            fpSpr.SetText 7, 2, "点击率"
            fpSpr.SetText 7, 3, "%"
            fpSpr.SetText 8, 1, "预计"
            fpSpr.SetText 8, 2, "点击数量"
            fpSpr.SetText 9, 1, "预计"
            fpSpr.SetText 9, 2, "点击成本"
            fpSpr.SetText 9, 3, "RMB"
            fpSpr.SetText k, 2, "总天数"
           
            fpSpr.SetText k + 1, 2, "单价"
            fpSpr.SetText k + 2, 2, "折扣"
            fpSpr.SetText k + 3, 2, "价格/天"
            fpSpr.SetText k + 4, 2, "总计人民币"
           
            fpSpr.ColWidth(1) = 6
            fpSpr.ColWidth(2) = 14
            fpSpr.ColWidth(3) = 14
            fpSpr.ColWidth(4) = 14
            fpSpr.ColWidth(5) = 10
            fpSpr.ColWidth(6) = 9
            fpSpr.ColWidth(7) = 9
            fpSpr.ColWidth(8) = 9
            fpSpr.ColWidth(9) = 10
'            fpSpr.ColWidth(10) = 6
            fpSpr.ColWidth(k) = 6
            fpSpr.ColWidth(k + 1) = 8
            fpSpr.ColWidth(k + 2) = 6
            fpSpr.ColWidth(k + 3) = 6
            fpSpr.ColWidth(k + 4) = 12
        End If
        If Option1(1).Value = True Then
            SanXin
'            bPact = False
            fpSpr.SetText 1, 2, "Media"
            fpSpr.SetText 1, 4, "It168"         'Impression
            fpSpr.SetText 2, 2, "Impression"
            fpSpr.SetText 3, 2, "CTR"
            fpSpr.SetText 4, 2, "Click"
            fpSpr.SetText 5, 2, "Channel"
            fpSpr.SetText 6, 2, "Site"
            fpSpr.SetText 7, 2, "Type"
            fpSpr.SetText 8, 2, "Size"
            fpSpr.SetText 9, 2, "投放天数"
            fpSpr.SetText 10, 2, "单价"
            fpSpr.SetText 11, 2, "折扣"
            fpSpr.SetText 12, 2, "折后价"
            fpSpr.SetText 13, 2, "Total Net Cost"
            fpSpr.SetText k, 2, "URL"

            fpSpr.ColWidth(1) = 6
            fpSpr.ColWidth(2) = 14
            fpSpr.ColWidth(3) = 6
            fpSpr.ColWidth(4) = 8
            fpSpr.ColWidth(5) = 10
            fpSpr.ColWidth(6) = 9
            fpSpr.ColWidth(7) = 9
            fpSpr.ColWidth(8) = 9
            fpSpr.ColWidth(9) = 10
            fpSpr.ColWidth(10) = 6
            fpSpr.ColWidth(11) = 8
            fpSpr.ColWidth(12) = 8
            fpSpr.ColWidth(13) = 8
'        MsgBox "三星模版"
        End If
        If Option1(2).Value = True Then
            HuiPu
'            bPact = False
            fpSpr.SetText 1, 2, "Website(站点)"
            fpSpr.SetText 1, 4, "It168"
            fpSpr.SetText 2, 2, "Channel/Position"
            fpSpr.SetText 3, 2, "Format"
            fpSpr.SetText 4, 2, "Size"
            fpSpr.SetText 5, 2, "Position"
            fpSpr.SetText 6, 2, "URL"
            fpSpr.SetText 7, 2, "Impression"
            fpSpr.SetText 8, 2, "投放天数"

            fpSpr.SetText k, 2, "刊特价"
            fpSpr.SetText k + 1, 2, "折后价"
            fpSpr.SetText k + 2, 1, "Negotiated Cost Per "
            fpSpr.SetText k + 2, 2, "Spot Local Net Net"
            fpSpr.SetText k + 3, 1, "Cost Per Spot US"
            fpSpr.SetText k + 3, 2, "$ Net Net"
            fpSpr.SetText k + 4, 2, "Total Local Net Net"
            fpSpr.SetText k + 5, 1, "Total Nett Cost "
            fpSpr.SetText k + 5, 2, "(USD)"

            fpSpr.ColWidth(1) = 6
            fpSpr.ColWidth(2) = 14
            fpSpr.ColWidth(3) = 6
            fpSpr.ColWidth(4) = 8
            fpSpr.ColWidth(5) = 10
            fpSpr.ColWidth(6) = 9
            fpSpr.ColWidth(7) = 9
            fpSpr.ColWidth(8) = 9
            fpSpr.ColWidth(k) = 6
            fpSpr.ColWidth(k + 1) = 6
            fpSpr.ColWidth(k + 2) = 14
            fpSpr.ColWidth(k + 3) = 14
            fpSpr.ColWidth(k + 4) = 14
            fpSpr.ColWidth(k + 5) = 14
'        MsgBox "惠普模版"
        End If
        If Option1(3).Value = True Then
            FangZheng
'            bPact = False
            fpSpr.SetText 1, 2, "媒体"
            fpSpr.SetText 1, 4, "It168"
            fpSpr.SetText 2, 2, "位置"
            fpSpr.SetText 3, 2, "广告形式"
            fpSpr.SetText 4, 2, "预估PV"
            fpSpr.SetText 5, 2, "广告规格"
            fpSpr.SetText 6, 2, "单位"
            fpSpr.SetText 7, 2, "数量"
            fpSpr.SetText 8, 2, "单价"
            fpSpr.SetText 9, 2, "折扣"
            fpSpr.SetText 10, 2, "金额"
            fpSpr.SetText k, 2, "预估总PV"
           
            fpSpr.ColWidth(1) = 6
            fpSpr.ColWidth(2) = 14
            fpSpr.ColWidth(3) = 14
            fpSpr.ColWidth(4) = 14
            fpSpr.ColWidth(5) = 10
            fpSpr.ColWidth(6) = 4
            fpSpr.ColWidth(7) = 4
            fpSpr.ColWidth(8) = 6
            fpSpr.ColWidth(9) = 6
            fpSpr.ColWidth(10) = 6
            fpSpr.ColWidth(k) = 9
'        MsgBox "方正模版"
        End If
        If Option1(4).Value = True Then
         DianTong
         fpSpr.SetText 1, 1, "类型"
         fpSpr.SetText 1, 2, "Type"
         fpSpr.SetText 2, 1, "网站"
         fpSpr.SetText 2, 2, "WebSite"
         fpSpr.SetText 2, 4, "It168"
         fpSpr.SetText 3, 1, "广告位置"
         fpSpr.SetText 3, 2, "Position"
         fpSpr.SetText 4, 1, "nb"
         fpSpr.SetText 4, 2, "AD Form"
         fpSpr.SetText 5, 1, "广告规格"
         fpSpr.SetText 5, 2, "Size"
         fpSpr.SetText 6, 1, "投放量"
         fpSpr.SetText 7, 1, "单位"
         fpSpr.SetText 7, 2, "Unit"
         fpSpr.SetText k, 2, "刊例单价"
         fpSpr.SetText k + 1, 2, "刊例总价"
         fpSpr.SetText k + 2, 2, "折扣"
         fpSpr.SetText k + 3, 2, "折后单价"
         fpSpr.SetText k + 4, 2, "折后总价"
         fpSpr.SetText k + 5, 2, "网站总价"
        fpSpr.ColWidth(1) = 8
        fpSpr.ColWidth(2) = 8
        fpSpr.ColWidth(3) = 14
        fpSpr.ColWidth(4) = 14
        fpSpr.ColWidth(5) = 14
        fpSpr.ColWidth(6) = 6
        fpSpr.ColWidth(7) = 6
        fpSpr.ColWidth(k) = 7
        fpSpr.ColWidth(k + 1) = 7
        fpSpr.ColWidth(k + 2) = 7
        fpSpr.ColWidth(k + 3) = 7
        fpSpr.ColWidth(k + 4) = 7
        fpSpr.ColWidth(k + 5) = 7
'        MsgBox "电通模版"
        End If
        If Option1(5).Value = True Then
        Intel
        fpSpr.SetText 1, 2, "Online"
        fpSpr.SetText 1, 4, "It168"
        fpSpr.SetText 2, 2, "URL(页面地址)"
        fpSpr.SetText 3, 2, "广告尺寸"
        fpSpr.SetText 4, 2, "广告位置"
        fpSpr.SetText 5, 2, "广告类型"
        fpSpr.SetText 6, 1, "Total"
        fpSpr.SetText 6, 2, "Daily Traffic"
        fpSpr.SetText 6, 3, "Pg View(000)"
        fpSpr.SetText 7, 1, "Planned"
        fpSpr.SetText 7, 2, "Total"
        fpSpr.SetText 7, 3, "Imp.(000)"
        fpSpr.SetText 8, 1, "Estimated"
        fpSpr.SetText 8, 2, "CTR*"
        fpSpr.SetText 9, 1, "Projected"
        fpSpr.SetText 9, 2, "Clicks"
        fpSpr.SetText k, 2, "投放天数"
        fpSpr.SetText k + 1, 2, "折扣"
        fpSpr.SetText k + 2, 2, "Cost / Day"
        fpSpr.SetText k + 2, 3, "US$"
        fpSpr.SetText k + 3, 2, "Cost / '000"
        fpSpr.SetText k + 3, 3, "Imp."
        fpSpr.SetText k + 4, 2, "Cost / Click"
        fpSpr.SetText k + 5, 2, "Net Media"
        fpSpr.SetText k + 5, 3, "Total US$"
        fpSpr.SetText k + 6, 2, "Tax  US$"
        fpSpr.SetText k + 7, 2, "Grand Total"
        fpSpr.SetText k + 7, 3, "US$"
        fpSpr.SetText k + 8, 2, "Grand Total"
        fpSpr.SetText k + 8, 3, "RMB"
        fpSpr.SetText k + 9, 2, "Share %"
      
       
        fpSpr.ColWidth(1) = 6
        fpSpr.ColWidth(2) = 10
        fpSpr.ColWidth(3) = 14
        fpSpr.ColWidth(4) = 14
        fpSpr.ColWidth(5) = 14
        fpSpr.ColWidth(6) = 9
        fpSpr.ColWidth(7) = 8
        fpSpr.ColWidth(8) = 8
        fpSpr.ColWidth(9) = 8
        fpSpr.ColWidth(k) = 8
        fpSpr.ColWidth(k + 1) = 4
        fpSpr.ColWidth(k + 2) = 8
        fpSpr.ColWidth(k + 3) = 8
        fpSpr.ColWidth(k + 4) = 8
        fpSpr.ColWidth(k + 5) = 8
        fpSpr.ColWidth(k + 6) = 8
        fpSpr.ColWidth(k + 7) = 9
        fpSpr.ColWidth(k + 8) = 8
        fpSpr.ColWidth(k + 9) = 8
       
'        MsgBox "Intel模版"
        End If
        If Option1(6).Value = True Then
            IBM

            fpSpr.SetText 1, 2, "Titles/Channels/WebSites"
            fpSpr.SetText 1, 4, "It168"
            fpSpr.SetText 2, 2, "广告形式"
            fpSpr.SetText 3, 2, "广告位置"
            fpSpr.SetText 4, 1, "URL/Description"
            fpSpr.SetText 4, 2, "(页面地址)"
            fpSpr.SetText 5, 2, "广告尺寸"
            fpSpr.SetText 6, 2, "广告大小"
            fpSpr.SetText 7, 2, "净价"
            fpSpr.SetText 8, 2, "天数"
            fpSpr.SetText 9, 2, "总价=单价*日期"
            fpSpr.SetText 10, 2, "总额 /RMB"
            fpSpr.SetText 11, 2, "总额/USD"
           
            fpSpr.ColWidth(1) = 18
            fpSpr.ColWidth(2) = 10
            fpSpr.ColWidth(3) = 10
            fpSpr.ColWidth(4) = 12
            fpSpr.ColWidth(5) = 10
            fpSpr.ColWidth(6) = 8
            fpSpr.ColWidth(7) = 8
            fpSpr.ColWidth(8) = 8
            fpSpr.ColWidth(9) = 14
            fpSpr.ColWidth(10) = 8
            fpSpr.ColWidth(11) = 8
'        MsgBox "IBM模版"
        End If
       
End Sub
 
Sub TongFang() '同方模版
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF
       
        k = 10
        pTags = Left(pTags, Len(pTags) - 0)     'pTags是传过来的字符串
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
         Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 10 To DateDiff("m", dtbegin, dtend) + 10 '日历头显示(月,星期,日)
          
            fpSpr.Col = k
            fpSpr.Row = 1
            cMonth = Format(DateAdd("m", p - 10, dtbegin), "yyyy-mm-dd")
            fpSpr.Text = Format(cMonth, "mm")
            d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
            d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
        '                d1 = DateTime.DateAdd("d", -2, cMonth)
        '                d2 = DateTime.DateAdd("d", 1, cMonth)
            For j = 10 To DateDiff("d", d1, d2) + 10
               fpSpr.Col = k
               fpSpr.Row = 3
               fpSpr.Text = Format(DateAdd("d", j - 10, d1), "dd")
               fpSpr.ColWidth(k) = 2
               k = k + 1
               Select Case Weekday(DateAdd("d", j - 10, d1))
                 Case 7:
                        fpSpr.Row = 2
                        fpSpr.Text = "六"
                        fpSpr.BackColor = &HC0C0FF
                 Case 1:
                        fpSpr.Row = 2
                        fpSpr.Text = "日"
                        fpSpr.BackColor = &HC0C0FF
                 Case 2:
                        fpSpr.Row = 2
                        fpSpr.Text = "一"
                 Case 3:
                        fpSpr.Row = 2
                        fpSpr.Text = "二"
                 Case 4:
                        fpSpr.Row = 2
                        fpSpr.Text = "三"
                 Case 5:
                        fpSpr.Row = 2
                        fpSpr.Text = "四"
                 Case 6:
                        fpSpr.Row = 2
                        fpSpr.Text = "五"
               End Select
            Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
        For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                      M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 10 + var To DateDiff("d", c1, c2) + 10 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      '                  fpSpr.Text = Format(DateAdd("d", a - 11 - var, CDate(c1)), "MM-DD")
                      fpSpr.Text = Format(DateAdd("d", a - 10 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                 Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 10 + var To DateDiff("d", c1, c2) + 10 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                    '                  fpSpr.Text = Format(DateAdd("d", a - 11 - var, CDate(c1)), "MM-DD")
                      fpSpr.Text = Format(DateAdd("d", a - 10 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                End If
'                fpSpr.SetText k, M, T
                oldGroup_no = cRec1("iType_id")
            cRec1.MoveNext
            Wend
           cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
           Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)

            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
                '用一行显示出现的日期
            '            dtbegin = DateSerial(Year(c1), Month(c1), 1)
            '            var = DateDiff("d", dtbegin, c1)
            '            dtend = DateSerial(Year(c1), Month(c1) + 1, 1) - 1
            '            var = Format(DateAdd("m", 0, dtbegin), "mm")
            '            VarOld = Format(DateAdd("m", 0, dtbegin), "mm")
                '              For j = 10 To DateDiff("d", CDate(c1), CDate(c2)) + 10
                '                fpSpr.Col = k
                '                fpSpr.Row = M
                '                fpSpr.Text = Format(DateAdd("d", j - 10, CDate(c1)), "yyyy-mm-dd")
                '                k = k + 1
                '                '周六,周日用不同的颜色显示
                '                If Weekday(DateAdd("d", j - 10, CDate(c1))) = 7 Then
                '                    fpSpr.Text = fpSpr.Text + "(六)"
                '                    fpSpr.Row = M
                '                    fpSpr.BackColor = &HC0C0FF
                '                End If
                '                If Weekday(DateAdd("d", j - 10, CDate(c1))) = 1 Then
                '                    fpSpr.Text = fpSpr.Text + "(日)"
                '                    fpSpr.Row = M
                '                    fpSpr.BackColor = &HC0C0FF
                '                End If
                '                fpSpr.ColWidth(k) = 10
                '              Next j
                fpSpr.SetText 2, M, Size
                fpSpr.SetText 3, M, Position
                fpSpr.SetText 4, M, sType
                fpSpr.SetText k, M, T
                fpSpr.SetText k + 1, M, price

            cRec.MoveNext
            Wend

       Next
        fpSpr.MaxCols = k + 4
        fpSpr.MaxRows = M + 1
End Sub

Sub SanXin() '三星模版
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF   '无色
       
        k = 14
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 14 To DateDiff("m", dtbegin, dtend) + 14 '日历头显示(月,星期,日)
          fpSpr.Col = k
          fpSpr.Row = 1
          cMonth = Format(DateAdd("m", p - 14, dtbegin), "yyyy-mm-dd")
          fpSpr.Text = fun(Format(cMonth, "mm"))
          d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
          d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
          For j = 14 To DateDiff("d", d1, d2) + 14
             fpSpr.Col = k
             fpSpr.Row = 3
             fpSpr.Text = Format(DateAdd("d", j - 14, d1), "dd")
             fpSpr.ColWidth(k) = 2
             k = k + 1
             Select Case Weekday(DateAdd("d", j - 14, d1))
               Case 7:
                      fpSpr.Row = 2
                      fpSpr.Text = "六"
                      fpSpr.BackColor = &HC0C0FF
               Case 1:
                      fpSpr.Row = 2
                      fpSpr.Text = "日"
                      fpSpr.BackColor = &HC0C0FF
               Case 2:
                      fpSpr.Row = 2
                      fpSpr.Text = "一"
               Case 3:
                      fpSpr.Row = 2
                      fpSpr.Text = "二"
               Case 4:
                      fpSpr.Row = 2
                      fpSpr.Text = "三"
               Case 5:
                      fpSpr.Row = 2
                      fpSpr.Text = "四"
               Case 6:
                      fpSpr.Row = 2
                      fpSpr.Text = "五"
             End Select
          Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
        For i = 0 To UBound(iTags)
             iType = iTags(i)
             cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                     & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                     & " from tbl_NetPosition_Group g " _
                     & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                     & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                     & "where  " _
                     & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
             Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
             While Not cRec1.EOF
                    newGroup_no = cRec1("iType_id")
                    If newGroup_no = oldGroup_no Then
                       If M = 3 Then
                           M = 4
                       End If
                       c1 = cRec1("dFrom_date")
                       c2 = cRec1("dTo_Date")
                       var = DateDiff("d", dtbegin, c1)
                       var2 = DateDiff("d", dtbegin, c2)
                       For a = 14 + var To DateDiff("d", c1, c2) + 14 + var
                         fpSpr.Col = a
                         fpSpr.Row = M
                         fpSpr.BackColor = &HFF00&
                         fpSpr.Text = Format(DateAdd("d", a - 14 - var, CDate(c1)), 1)
                         T = T + 1
                       Next a
                    Else
                       T = 0
                       M = M + 1
                       c1 = cRec1("dFrom_date")
                       c2 = cRec1("dTo_Date")
                       var = DateDiff("d", dtbegin, c1)
                       var2 = DateDiff("d", dtbegin, c2)
                       For a = 14 + var To DateDiff("d", c1, c2) + 14 + var
                         fpSpr.Col = a
                         fpSpr.Row = M
                         fpSpr.BackColor = &HFF00&
                         fpSpr.Text = Format(DateAdd("d", a - 14 - var, CDate(c1)), 1)
                         T = T + 1
                       Next a
                    End If
                    fpSpr.SetText 9, M, T
                    oldGroup_no = cRec1("iType_id")
              cRec1.MoveNext
             Wend
             cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                 & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                 & " from tbl_NetPosition_Group g " _
                 & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                 & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                 & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                 & "where  nn.cUnit ='/天' and " _
                 & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
            Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
       
            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
           
                fpSpr.SetText 8, M, Size
                fpSpr.SetText 5, M, Position
                fpSpr.SetText 7, M, sType
                fpSpr.SetText 10, M, price
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k
        fpSpr.MaxRows = M + 1
End Sub

Sub HuiPu()
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF   '无色
'
        k = 9
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 9 To DateDiff("m", dtbegin, dtend) + 9 '日历头显示(月,星期,日)
          fpSpr.Col = k
          fpSpr.Row = 1
          cMonth = Format(DateAdd("m", p - 9, dtbegin), "yyyy-mm-dd")
          fpSpr.Text = fun(Format(cMonth, "mm"))
          d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
          d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
          For j = 9 To DateDiff("d", d1, d2) + 9
             fpSpr.Col = k
             fpSpr.Row = 3
             fpSpr.Text = Format(DateAdd("d", j - 9, d1), "dd")
             fpSpr.ColWidth(k) = 2
             k = k + 1
             Select Case Weekday(DateAdd("d", j - 9, d1))
               Case 7:
                      fpSpr.Row = 2
                      fpSpr.Text = "六"
                      fpSpr.BackColor = &HC0C0FF
               Case 1:
                      fpSpr.Row = 2
                      fpSpr.Text = "日"
                      fpSpr.BackColor = &HC0C0FF
               Case 2:
                      fpSpr.Row = 2
                      fpSpr.Text = "一"
               Case 3:
                      fpSpr.Row = 2
                      fpSpr.Text = "二"
               Case 4:
                      fpSpr.Row = 2
                      fpSpr.Text = "三"
               Case 5:
                      fpSpr.Row = 2
                      fpSpr.Text = "四"
               Case 6:
                      fpSpr.Row = 2
                      fpSpr.Text = "五"
             End Select
          Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
         For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                        M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 9 + var To DateDiff("d", c1, c2) + 9 + var
                        fpSpr.Col = a
                        fpSpr.Row = M
                        fpSpr.BackColor = &HFF00&
                        fpSpr.Text = Format(DateAdd("d", a - 9 - var, CDate(c1)), 1)
                        T = T + 1
                    Next a
                 Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 9 + var To DateDiff("d", c1, c2) + 9 + var
                        fpSpr.Col = a
                        fpSpr.Row = M
                        fpSpr.BackColor = &HFF00&
                        fpSpr.Text = Format(DateAdd("d", a - 9 - var, CDate(c1)), 1)
                        T = T + 1
                    Next a
                End If
                fpSpr.SetText 8, M, T
                oldGroup_no = cRec1("iType_id")
             cRec1.MoveNext
            Wend
                
            cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
           Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
        
                fpSpr.SetText 4, M, Size
                fpSpr.SetText 5, M, Position
                fpSpr.SetText 2, M, Position + "-" + sType
                fpSpr.SetText 3, M, sType
                fpSpr.SetText k, M, price
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k + 5
        fpSpr.MaxRows = M + 1
End Sub

Sub FangZheng()
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF
'
        k = 11
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 11 To DateDiff("m", dtbegin, dtend) + 11 '日历头显示(月,星期,日)
          fpSpr.Col = k
          fpSpr.Row = 1
          cMonth = Format(DateAdd("m", p - 11, dtbegin), "yyyy-mm-dd")
          fpSpr.Text = Format(cMonth, "mm") + "月"
          d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
          d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
          For j = 11 To DateDiff("d", d1, d2) + 11
             fpSpr.Col = k
             fpSpr.Row = 3
             fpSpr.Text = Format(DateAdd("d", j - 11, d1), "dd")
             fpSpr.ColWidth(k) = 2
             k = k + 1
             Select Case Weekday(DateAdd("d", j - 11, d1))
               Case 7:
                      fpSpr.Row = 2
                      fpSpr.Text = "六"
                      fpSpr.BackColor = &HC0C0FF
               Case 1:
                      fpSpr.Row = 2
                      fpSpr.Text = "日"
                      fpSpr.BackColor = &HC0C0FF
               Case 2:
                      fpSpr.Row = 2
                      fpSpr.Text = "一"
               Case 3:
                      fpSpr.Row = 2
                      fpSpr.Text = "二"
               Case 4:
                      fpSpr.Row = 2
                      fpSpr.Text = "三"
               Case 5:
                      fpSpr.Row = 2
                      fpSpr.Text = "四"
               Case 6:
                      fpSpr.Row = 2
                      fpSpr.Text = "五"
             End Select
          Next j
        Next p
         T = 0
         fpSpr.MaxRows = UBound(iTags) + 4
         For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                      M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 11 + var To DateDiff("d", c1, c2) + 11 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      fpSpr.Text = Format(DateAdd("d", a - 11 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 11 + var To DateDiff("d", c1, c2) + 11 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      fpSpr.Text = Format(DateAdd("d", a - 11 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                End If
                fpSpr.SetText 7, M, T
                oldGroup_no = cRec1("iType_id")
             cRec1.MoveNext
            Wend
            cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
           Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
           
                fpSpr.SetText 5, M, Size
                fpSpr.SetText 2, M, Position
                fpSpr.SetText 3, M, sType
                fpSpr.SetText 6, M, "天"
                fpSpr.SetText 8, M, price
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k
        fpSpr.MaxRows = M + 1
End Sub

Sub DianTong()
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF   '无色
'
        k = 8
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 8 To DateDiff("m", dtbegin, dtend) + 8 '日历头显示(月,星期,日)
            fpSpr.Col = k
            fpSpr.Row = 1
            cMonth = Format(DateAdd("m", p - 8, dtbegin), "yyyy-mm-dd")
            fpSpr.Text = Format(cMonth, "mm") + "月"
            d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
            d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
            For j = 8 To DateDiff("d", d1, d2) + 8
               fpSpr.Col = k
               fpSpr.Row = 3
               fpSpr.Text = Format(DateAdd("d", j - 8, d1), "dd")
               fpSpr.ColWidth(k) = 2
               k = k + 1
               Select Case Weekday(DateAdd("d", j - 8, d1))
                 Case 7:
                        fpSpr.Row = 2
                        fpSpr.Text = "六"
                        fpSpr.BackColor = &HC0C0FF
                 Case 1:
                        fpSpr.Row = 2
                        fpSpr.Text = "日"
                        fpSpr.BackColor = &HC0C0FF
                 Case 2:
                        fpSpr.Row = 2
                        fpSpr.Text = "一"
                 Case 3:
                        fpSpr.Row = 2
                        fpSpr.Text = "二"
                 Case 4:
                        fpSpr.Row = 2
                        fpSpr.Text = "三"
                 Case 5:
                        fpSpr.Row = 2
                        fpSpr.Text = "四"
                 Case 6:
                        fpSpr.Row = 2
                        fpSpr.Text = "五"
               End Select
            Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
        For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                      M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 8 + var To DateDiff("d", c1, c2) + 8 + var
                        fpSpr.Col = a
                        fpSpr.Row = M
                        fpSpr.BackColor = &HFF00&
                        fpSpr.Text = Format(DateAdd("d", a - 8 - var, CDate(c1)), 1)
                        T = T + 1
                    Next a
                Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 8 + var To DateDiff("d", c1, c2) + 8 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      fpSpr.Text = Format(DateAdd("d", a - 8 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                End If
                fpSpr.SetText 6, M, T
                oldGroup_no = cRec1("iType_id")
            cRec1.MoveNext
            Wend
            cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
            Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
           
                fpSpr.SetText 5, M, Size
                fpSpr.SetText 3, M, Position
                fpSpr.SetText 4, M, sType
                fpSpr.SetText 7, M, "天"
                fpSpr.SetText k, M, price
                fpSpr.SetText k + 1, M, price * T
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k + 5
        fpSpr.MaxRows = M + 1
End Sub

Sub Intel()
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF   '无色
'
        k = 10
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
        & " from tbl_NetPosition_Group g " _
        & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
        & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
        & "where " _
        & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 10 To DateDiff("m", dtbegin, dtend) + 10 '日历头显示(月,星期,日)
          fpSpr.Col = k
          fpSpr.Row = 1
          cMonth = Format(DateAdd("m", p - 10, dtbegin), "yyyy-mm-dd")
          fpSpr.Text = fun(Format(cMonth, "mm"))
          d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
          d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
          For j = 10 To DateDiff("d", d1, d2) + 10
             fpSpr.Col = k
             fpSpr.Row = 3
             fpSpr.Text = Format(DateAdd("d", j - 10, d1), "dd")
             fpSpr.ColWidth(k) = 2
             k = k + 1
             Select Case Weekday(DateAdd("d", j - 10, d1))
               Case 7:
                      fpSpr.Row = 2
                      fpSpr.Text = "六"
                      fpSpr.BackColor = &HC0C0FF
               Case 1:
                      fpSpr.Row = 2
                      fpSpr.Text = "日"
                      fpSpr.BackColor = &HC0C0FF
               Case 2:
                      fpSpr.Row = 2
                      fpSpr.Text = "一"
               Case 3:
                      fpSpr.Row = 2
                      fpSpr.Text = "二"
               Case 4:
                      fpSpr.Row = 2
                      fpSpr.Text = "三"
               Case 5:
                      fpSpr.Row = 2
                      fpSpr.Text = "四"
               Case 6:
                      fpSpr.Row = 2
                      fpSpr.Text = "五"
             End Select
          Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
        For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
       
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                      M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 10 + var To DateDiff("d", c1, c2) + 10 + var
                    fpSpr.Col = a
                    fpSpr.Row = M
                    fpSpr.BackColor = &HFF00&
                    fpSpr.Text = Format(DateAdd("d", a - 10 - var, CDate(c1)), 1)
                    T = T + 1
                    Next a
                 Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 10 + var To DateDiff("d", c1, c2) + 10 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      fpSpr.Text = Format(DateAdd("d", a - 10 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                End If
                fpSpr.SetText k, M, T
                oldGroup_no = cRec1("iType_id")
             cRec1.MoveNext
            Wend
                
            cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
           Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
           While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
        
                fpSpr.SetText 3, M, Size
                fpSpr.SetText 4, M, Position
                fpSpr.SetText 5, M, sType
               
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k + 9
        fpSpr.MaxRows = M + 1
End Sub
Sub IBM()
        fpSpr.Col = -1
        fpSpr.Row = -1
        fpSpr.Text = ""
        fpSpr.BackColor = &HFFFFFF   '无色
'
        k = 12
        pTags = Left(pTags, Len(pTags) - 0)
        iTags = Split(pTags, ",")
        M = 3
        cSql = " select min(dFrom_date) as dMin,max(dTo_date) as dMax " _
            & " from tbl_NetPosition_Group g " _
            & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
            & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
            & "where " _
            & "r.iReg_no in ( " & pTags & ")  "
        Set cRecT = gData.OpenResultset(cSql, rdOpenKeyset)
        dtbegin = DateSerial(Year(cRecT("dMin")), Month(cRecT("dMin")), 1)
        dtend = DateSerial(Year(cRecT("dMax")), Month(cRecT("dMax")) + 1, 1) - 1
        For p = 12 To DateDiff("m", dtbegin, dtend) + 12 '日历头显示(月,星期,日)
          fpSpr.Col = k
          fpSpr.Row = 1
          cMonth = Format(DateAdd("m", p - 12, dtbegin), "yyyy-mm-dd")
          fpSpr.Text = fun(Format(cMonth, "mm"))
          d1 = DateSerial(Year(cMonth), Month(cMonth), 1)           ' 当月第一天
          d2 = DateSerial(Year(cMonth), Month(cMonth) + 1, 1) - 1    '当月最后一天
          For j = 12 To DateDiff("d", d1, d2) + 12
             fpSpr.Col = k
             fpSpr.Row = 3
             fpSpr.Text = Format(DateAdd("d", j - 12, d1), "dd")
             fpSpr.ColWidth(k) = 2
             k = k + 1
             Select Case Weekday(DateAdd("d", j - 12, d1))
               Case 7:
                      fpSpr.Row = 2
                      fpSpr.Text = "六"
                      fpSpr.BackColor = &HC0C0FF
               Case 1:
                      fpSpr.Row = 2
                      fpSpr.Text = "日"
                      fpSpr.BackColor = &HC0C0FF
               Case 2:
                      fpSpr.Row = 2
                      fpSpr.Text = "一"
               Case 3:
                      fpSpr.Row = 2
                      fpSpr.Text = "二"
               Case 4:
                      fpSpr.Row = 2
                      fpSpr.Text = "三"
               Case 5:
                      fpSpr.Row = 2
                      fpSpr.Text = "四"
               Case 6:
                      fpSpr.Row = 2
                      fpSpr.Text = "五"
             End Select
          Next j
        Next p
        T = 0
        fpSpr.MaxRows = UBound(iTags) + 4
        For i = 0 To UBound(iTags)
            iType = iTags(i)
            cSql1 = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                    & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,n.iType_id " _
                    & " from tbl_NetPosition_Group g " _
                    & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                    & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                    & "where  " _
                    & "r.iReg_no = " & iType & "  order by dFrom_Date,dTo_date"
            Set cRec1 = gData.OpenResultset(cSql1, rdOpenKeyset)
       
            While Not cRec1.EOF
                newGroup_no = cRec1("iType_id")
                If newGroup_no = oldGroup_no Then
                    If M = 3 Then
                      M = 4
                    End If
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 12 + var To DateDiff("d", c1, c2) + 12 + var
                        fpSpr.Col = a
                        fpSpr.Row = M
                        fpSpr.BackColor = &HFF00&
                        fpSpr.Text = Format(DateAdd("d", a - 12 - var, CDate(c1)), 1)
                        T = T + 1
                    Next a
                 Else
                    T = 0
                    M = M + 1
                    c1 = cRec1("dFrom_date")
                    c2 = cRec1("dTo_Date")
                    var = DateDiff("d", dtbegin, c1)
                    var2 = DateDiff("d", dtbegin, c2)
                    For a = 12 + var To DateDiff("d", c1, c2) + 12 + var
                      fpSpr.Col = a
                      fpSpr.Row = M
                      fpSpr.BackColor = &HFF00&
                      fpSpr.Text = Format(DateAdd("d", a - 12 - var, CDate(c1)), 1)
                      T = T + 1
                    Next a
                End If
                fpSpr.SetText 8, M, T
                oldGroup_no = cRec1("iType_id")
             cRec1.MoveNext
            Wend
                
            cSql = " select g.cGroup_No,cast(g.iWidth as char(6))+'*'+cast(g.iHeight as char(6)) as size, " _
                & "g.cPosition , r.dFrom_date, r.dTo_Date, n.cType,nn.iLargess_Invo " _
                & " from tbl_NetPosition_Group g " _
                & "inner join tbl_NetPosition n on N.cGroup_No=G.cGroup_No " _
                & "inner join tbl_Register_Position r on R.iType_Id=N.iType_Id " _
                & "inner join tbl_NetPrice_NoProduct nn on nn.cGroup_No = g.cGroup_No " _
                & "where  nn.cUnit ='/天' and " _
                & "r.iReg_no = " & iType & " order by dFrom_Date,dTo_date"
           Set cRec = gData.OpenResultset(cSql, rdOpenKeyset)
       
            While Not cRec.EOF   '显示选定日期
                GroupNo = cRec(0)
                c1 = cRec("dFrom_date")
                c2 = cRec("dTo_Date")
                Size = cRec("size")
                Position = cRec("cPosition")
                sType = cRec("cType")
                price = cRec("iLargess_Invo")
        
                fpSpr.SetText 5, M, Size
                fpSpr.SetText 3, M, Position
                fpSpr.SetText 2, M, sType
                fpSpr.SetText 7, M, price
                fpSpr.SetText 9, M, price * T
            cRec.MoveNext
            Wend
        Next
        fpSpr.MaxCols = k - 1
        fpSpr.MaxRows = M + 1
End Sub

 
Private Sub Form_Load()
Dim dTags As String
'iTags = Split(pTags, ",")
End Sub

Function fun(sa As String) As String
    Select Case sa
    Case "01":
        fun = "January"
    Case "02":
        fun = "February"
    Case "03":
        fun = "March"
    Case "04":
        fun = "April"
    Case "05":
        fun = "May"
    Case "06":
        fun = "June"
    Case "07":
        fun = "July"
    Case "08":
        fun = "August"
    Case "09":
        fun = "September"
    Case "10":
        fun = "October"
    Case "11":
        fun = "Noverber"
    Case "12":
        fun = "December"
    End Select
End Function

Private Sub Form_Resize()
  
'    If Me.WindowState = 1 Then Exit Sub
'    i = Me.Width - 580
'    If i <= 0 Then i = 1
'    fpSpr.Width = i
'
'     'flexgrid 和 flexgridno 按照3：1显示
'        i = Me.Height - 1500
'        If i < 0 Then
'        Else
'            fpSpr.Height = i / 4 * 4
'            fpSpr.Top = 1000
'            i = Me.Height - fpSpr.Height - 1500
'                If i > 0 Then
'                    fpSpr.Height = i
'                End If
'        End If
       
   '当窗体移动时,设置fpSpr的大小及位置
   '如果窗口状态为最小化,跳出过程
   If Me.WindowState = 1 Then Exit Sub
    With fpSpr
     .Width = IIf(Me.Width - 300 > 1, Me.Width - 300, 10)
     .Height = IIf(Me.Height - 1600 > 1, Me.Height - 1600, 10)
    End With
 
End Sub

根据模版生成的窗体

由于生成窗体太宽，所以分两部分显示，上面是左边，下面是右边

转载于:https://www.cnblogs.com/A-I/archive/2008/06/19/1225699.html