frmscaeen.frm

大型商业学分统计系统原代码说明 1.如果在向导设置班级数为8时,此数值为班级总数

    Frame3.Visible = False
    Command4.Visible = False
End Sub
Private Sub Form_Resize()
    On Error Resume Next

    '        Vf.Width = Me.Width - 100
    VP.Height = Me.Height - Toolbar1.Height - 380
    Vf.Top = 150
    '        Vf.Left = 0
    Vf.Width = Me.Width - Frame1.Width - Frame3.Width - 600
    Vf.Height = Frame1.Height + Frame1.Height - 250
    Vf.Left = Frame1.Width + Frame3.Width + 240
End Sub
Private Sub Form_Load()
    On Error Resume Next
    Me.Hide
    Text2.Text = ""
    s = ""
    cmbPercent.ListIndex = 3
    cmbZoomMode.ListIndex = 3
    '    Skin1.LoadSkin App.Path & "\SKIN\6.sk"
    Skin1.ApplySkinByName hwnd, "Form"
    Skin1.ApplySkin Me.hwnd
    DoEvents
    If MAIN.CMD2.filename = "" Then MsgBox "数据文件未载入", 32, "提示": Exit Sub
    Combo1.Clear
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("班级")
    rs.MoveLast
    intRecCount = rs.RecordCount
    rs.MoveFirst
    For intCounter = 1 To intRecCount
        Combo1.AddItem rs![班级]
        rs.MoveNext
    Next intCounter
    Combo1.ListIndex = 0
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("个性")
    rs.MoveLast
    intRecCount = rs.RecordCount
    rs.MoveFirst
    For intCounter = 1 To intRecCount
        Combo2.AddItem rs![个性]
        Combo7.AddItem rs![个性]
        Combo5.AddItem rs![个性]
        Combo6.AddItem rs![个性]
        List1.AddItem rs![个性]
        rs.MoveNext
    Next intCounter
    List1.AddItem "总分"
    List1.AddItem "总分班级名次"
    List1.AddItem "总分年级名次"
    List1.ListIndex = 0
    Combo2.ListIndex = 2
    Combo7.ListIndex = 2
    Combo3.ListIndex = 0
    Combo9.ListIndex = 0
    Combo5.ListIndex = 5
    Combo6.ListIndex = 5
    Combo10.ListIndex = 0
    Text1.Text = ""
    Text3.Text = ""
    Data1.DatabaseName = MAIN.CMD2.filename
End Sub
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    MAIN.Enabled = True
    Unload SCA
    Dim ws As Workspace
    Dim db As Database
    Dim rs As Recordset
    For Each ws In Workspaces
        For Each db In ws.Databases
            For Each rs In db.Recordsets
                rs.Close
                Set rs = Nothing
            Next
            db.Close
            Set db = Nothing
        Next
        ws.Close
        Set ws = Nothing
    Next
End Sub
Private Sub Print_Click()
    On Error Resume Next  '开始打印
    If VP.PageCount > 0 Then VP.PrintDoc
End Sub
Private Sub scrlPage_Change()
    On Error Resume Next   '操作 scrlpage 时同时对下面的当前页显示值进行控制
    scrlPage.SmallChange = VP.PreviewPages
    scrlPage.LargeChange = scrlPage.SmallChange
    VP.PreviewPage = scrlPage.Value
    Dim lp%
    lp = VP.PreviewPage + VP.PreviewPages - 1
    If lp > VP.PageCount Then lp = VP.PageCount
    If lp < VP.PreviewPage Then lp = VP.PreviewPage
    If lp > VP.PreviewPage Then
        lblPage = VP.PreviewPage & " - " & lp & " of " & VP.PageCount
    Else
        lblPage = VP.PreviewPage & " of " & VP.PageCount
    End If
    '操作 scrlpage 时同时对下面的当前页显示值进行控制
End Sub
Private Sub vp_EndPage()
    On Error Resume Next
    '得到总页数,并且 scrlpage 自动适应其状态
    scrlPage.Max = VP.PageCount
    scrlPage.Value = VP.PreviewPage
    scrlPage_Change
    DoEvents
    '得到总页数,并且 scrlpage 自动适应其状态
End Sub
Sub RenderRecordset(VP As VSPrinter, rs As Recordset, ByVal maxh As Double)
    On Error GoTo 3464
    Dim arr, i%, j%, wid!
    ' read recordset into an array
    rs.MoveLast
    rs.MoveFirst
    i = rs.RecordCount
    If i = 0 Then Exit Sub
    arr = rs.GetRows(i)
    ' create table header and dummy format
    Dim fmt$, hdr$
    For i = 0 To rs.Fields.Count - 1
        If i > 0 Then hdr = hdr & "|"
        fmt = fmt & "|"
        hdr = hdr & rs.Fields(i).Name
        fmt = fmt & 0
    Next
    ' create table
    VP.StartTable
    VP.AddTableArray fmt, hdr, arr
    ' format table
    For i = 0 To rs.Fields.Count - 1
        ' right-align numbers and dates
        Select Case rs.Fields(i).Type
            Case dbBigInt, dbByte, dbChar, dbCurrency, dbDecimal, dbDouble, dbFloat, dbInteger, dbLong, dbNumeric, dbSingle, dbDate
                VP.TableCell(tcColAlign, , i + 1) = taCenterMiddle
        End Select
        ' set column width
        If rs.Fields(i).Type = dbMemo Then
            VP.TableCell(tcColWidth, , i + 1) = "2.5in"
        Else
            fmt = ""
            For j = 0 To UBound(arr, 2)
                If j > 100 Then Exit For
                If Len(fmt) < Len(arr(i, j)) Then
                    fmt = arr(i, j)
                End If
            Next
            If Len(rs.Fields(i).Name) > Len(fmt) Then fmt = rs.Fields(i).Name
            '                        vp.TableCell(tcColWidth, , i + 1) = vp.TextWidth(fmt) * 13
            VP.TableCell(tcColWidth, , i + 1) = (VP.PageWidth - VP.MarginLeft - VP.MarginRight) / rs.Fields.Count
        End If
    Next
    ' format header row (0)
    VP.TableCell(tcFontBold, 0) = True '设置表关字体的粗细
    VP.TableCell(tcBackColor, 0) = vbYellow '设置表关字体的颜色
    VP.TableCell(tcRowHeight, 0) = VP.TextHeight("Test") * 3.4 '设置表关字体的高度
    VP.TableCell(tcAlign, 0) = taCenterMiddle '设置表格头参数,字体居中
    '
    ' make sure it all fits
    For i = 1 To VP.TableCell(tcCols)
        wid = wid + VP.TableCell(tcColWidth, , i)  '设置左右参数
    Next
    '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    Dim ii As Long
    For ii = 1 To VP.TableCell(tcRows)
        VP.TableCell(tcAlign, ii) = taCenterMiddle   '设置表格内容居中显示
    Next
    '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    VP.GetMargins
    If wid > VP.X2 - VP.X1 Then
        wid = (VP.X2 - VP.X1) / wid * 0.95
        For i = 1 To VP.TableCell(tcCols)
            VP.TableCell(tcColWidth, , i) = wid * VP.TableCell(tcColWidth, , i)
        Next
    End If
    ' honor maximum row height
    If maxh > 0 Then
        For i = 1 To VP.TableCell(tcRows)
            If VP.TableCell(tcRowHeight, i) > maxh Then
                VP.TableCell(tcRowHeight, i) = maxh
            End If
        Next
    End If
    ' done with table
    VP.EndTable
3464:
    Select Case Err.Number
        Case 3464
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = ""
            Text2.Text = ""
            Exit Sub
        Case 3075
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = ""
            Text2.Text = ""
            Exit Sub
        Case 3021
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = ""
            Text2.Text = ""
            Exit Sub
        Case 3061
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = ""
            Text2.Text = ""
            Exit Sub
    End Select
End Sub
Sub cmbSource()
    '     On Error Resume Next '打印代码从此处载入
    On Error GoTo 3464
    Dim i%
    Data1.RecordSource = s
    Data1.Refresh
    Dim rs As Recordset
    Set rs = Data1.Recordset
    With VP
        .PenColor = RGB(0, 0, 255)
        .StartDoc
        '  NHB = GetPrivateProfileString("学校", "校名", , , , App.Path & "\SET.ini")
        '   Dim strPath As String
        ' strPath = App.Path & "\SET.ini"
        NHB = GetProfile(App.Path & "\SET.ini", "学校", "校名")
        .Footer = "打印日期:" & Format(Date, "Long Date") & "||备注：（学籍中 -1 表示在籍生， 0 表示编外生）"
        .Header = NHB & vbCrLf & vbCrLf & "||当前页 %d"
        RenderRecordset VP, rs, 0
        .EndDoc
        .ScrollIntoView 0, 0
    End With
3464:
    Select Case Err.Number
        Case 3464
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            cmbSource
            Text2.Text = ""
            Exit Sub
        Case 3075
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            cmbSource
            Text2.Text = ""
            Exit Sub
        Case 3061
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            cmbSource
            Text2.Text = ""
            Exit Sub
        Case 3021
            Data1.RecordSource = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            Data1.Refresh
            s = "SELECT 学号,班级,姓名, 学籍 FROM 学生 WHERE 班级=999"
            cmbSource
            Text2.Text = ""
            Exit Sub
    End Select
End Sub
Private Sub btnFont_Click()
    Me.Enabled = False
    On Error Resume Next '设置字体等项目
    With Me.VP
        CommonDialog1.Flags = cdlCFBoth + cdlCFEffects
        CommonDialog1.FontName = .FontName
        CommonDialog1.FontSize = .FontSize
        CommonDialog1.FontBold = .FontBold
        CommonDialog1.FontItalic = .FontItalic
        CommonDialog1.FontUnderline = .FontUnderline
        CommonDialog1.FontStrikethru = .FontStrikethru
        '                CommonDialog1.Color = .PenColor
        CommonDialog1.ShowFont
        .FontName = CommonDialog1.FontName
        .FontSize = CommonDialog1.FontSize
        .FontBold = CommonDialog1.FontBold
        .FontItalic = CommonDialog1.FontItalic
        .FontUnderline = CommonDialog1.FontUnderline
        .FontStrikethru = CommonDialog1.FontStrikethru
        .PenColor = CommonDialog1.Color
        .TextColor = CommonDialog1.Color
    End With
    DoEvents
    cmbSource
    Me.Enabled = True
End Sub
Private Sub SETHARD_Click()
    On Error Resume Next
    Me.Enabled = False
    With Me.VP
        CommonDialog2.Flags = cdlCFBoth + cdlCFEffects
        CommonDialog2.FontName = .HdrFontName
        CommonDialog2.FontSize = .HdrFontSize
        CommonDialog2.FontBold = .HdrFontBold
        CommonDialog2.FontItalic = .HdrFontItalic
        CommonDialog2.FontUnderline = .HdrFontUnderline
        CommonDialog2.FontStrikethru = .HdrFontStrikethru
        CommonDialog2.Color = .HdrColor
        CommonDialog2.ShowFont
        .HdrFontName = CommonDialog2.FontName
        .HdrFontSize = CommonDialog2.FontSize
        .HdrFontBold = CommonDialog2.FontBold
        .HdrFontItalic = CommonDialog2.FontItalic
        .HdrFontUnderline = CommonDialog2.FontUnderline
        .HdrFontStrikethru = CommonDialog2.FontStrikethru
        .HdrColor = CommonDialog2.Color
    End With
    DoEvents
    cmbSource
    Me.Enabled = True
End Sub
Private Sub cmdPageSetup_Click()
    On Error Resume Next   '调出页面设置界面
    Me.Enabled = False
    VP.PrintDialog pdPageSetup
    cmbSource
    Me.Enabled = True
End Sub
Private Sub cmbPercent_Click()
    On Error Resume Next  '进行百分比操作
    VP.Zoom = Val(cmbPercent.List(cmbPercent.ListIndex))
End Sub
Private Sub cmbZoomMode_Click()
    On Error Resume Next '当选择了自定义时,则自定义参数生效
    If cmbZoomMode.ListIndex = 0 Then
        cmbPercent_Click
        cmbPercent.Enabled = True
    Else
        cmbPercent.Enabled = False
        VP.ZoomMode = cmbZoomMode.ListIndex
    End If
End Sub