frmmyallt.frm

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

         Caption         =   "字体设置"
         Height          =   450
         Left            =   2580
         TabIndex        =   18
         Top             =   60
         Width           =   1080
      End
      Begin VB.CommandButton Print 
         Caption         =   "开始打印"
         Height          =   465
         Left            =   8400
         TabIndex        =   17
         Top             =   60
         Width           =   975
      End
      Begin VB.CommandButton SETHARD 
         Caption         =   "设置表头"
         Height          =   465
         Left            =   1410
         TabIndex        =   16
         Top             =   60
         Width           =   1035
      End
      Begin VB.ComboBox Combo2 
         ForeColor       =   &H00FF0000&
         Height          =   300
         ItemData        =   "FRMmyALLt.frx":044E
         Left            =   6300
         List            =   "FRMmyALLt.frx":046A
         Style           =   2  'Dropdown List
         TabIndex        =   15
         Top             =   150
         Width           =   645
      End
   End
End
Attribute VB_Name = "FRMmyALLt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim s As String
Dim nmc As String
Dim db As Database
Dim rs As Recordset
Dim STR As String
Dim intRecCount As Long
Dim intCounter As Long
Dim XSA As String
Dim lo As String
Dim NUM As Long
Private Sub Combo1_Click()
    On Error Resume Next

    Call Command3_Click
End Sub
Private Sub Combo2_Click()
    On Error Resume Next
    VP.Columns = Combo2.Text
    cmbSource
End Sub
Private Sub Combo3_Click()
    On Error Resume Next

    Call Command3_Click
End Sub
Private Sub Command1_Click()
    On Error Resume Next
    Skin1.LoadSkin App.Path & "\SKIN\0.sk"
    Skin1.ApplySkinByName hwnd, "Form"
    Skin1.ApplySkin Me.hwnd
    Vf.Visible = False
    Toolbar2.Visible = False
    VP.Visible = True
    Toolbar1.Visible = True
End Sub
Private Sub Command2_Click()
    On Error Resume Next
    Skin1.LoadSkin App.Path & "\SKIN\4.sk"
    Skin1.ApplySkinByName hwnd, "Form"
    Skin1.ApplySkin Me.hwnd
    Vf.Visible = True
    Toolbar2.Visible = True
    VP.Visible = False
    Toolbar1.Visible = False
End Sub
Private Sub Command3_Click()
    On Error Resume Next
    Dim astr As String
    Dim i As Long
    For i = 0 To List1.ListCount - 1
        If List1.Selected(i) Then
            astr = astr + List1.List(i) + ","
        End If
    Next i
    s = "SELECT 学号,班级,姓名," & astr & " 学籍 FROM 学生 WHERE 班级=" & Combo3.Text & "" & " ORDER BY " & "" & Combo1.Text & ""
    cmbSource
    Dim QQ As Long
    For QQ = 0 To Vf.Cols - 1
        Vf.ColAlignment(QQ) = flexAlignCenterCenter
        ' VSFlexGrid1.CellAlignment = flexAlignCenterCenter
    Next QQ
End Sub
Private Sub Command4_Click()
    On Error Resume Next

    Unload Me
End Sub
'Private Sub Form_Activate()
'        On Error Resume Next
'        Main.Enabled = False
'        List1.Clear
'        Set db = OpenDatabase(Main.CMD2.filename)
'        Set rs = db.OpenRecordset("个性")
'        rs.MoveLast
'        intRecCount = rs.RecordCount
'        rs.MoveFirst
'        For intCounter = 1 To intRecCount
'                List1.AddItem rs![个性]
'                rs.MoveNext
'        Next intCounter
'        List1.AddItem "总分"
'         List1.AddItem "总分班级名次"
'          List1.AddItem "总分年级名次"
'        List1.ListIndex = 0
'        Set db = OpenDatabase(Main.CMD2.filename)
'        Set rs = db.OpenRecordset("个性")
'        NUM = 0
'        rs.MoveFirst
'        Do While Not rs.EOF()
'                NUM = NUM + 1
'                rs.MoveNext
'        Loop
'        '以上代码将总科目数取出
''        Me.Caption = NUM
'End Sub
Private Sub Form_Resize()
    On Error Resume Next

    Toolbar2.Top = 0
    Vf.Width = Me.Width - Toolbar2.Width - 150
    Vf.Height = Me.Height - 500
    Vf.Top = 0
    Vf.Left = Toolbar2.Width
    VP.Width = Me.Width
    VP.Height = Me.Height - Toolbar1.Height - 400
    VP.Top = Toolbar1.Height
    VP.Left = 0
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 Form_Load()
    On Error Resume Next
    Me.Hide
    SCA.Show
    DoEvents
    Skin1.LoadSkin App.Path & "\SKIN\4.sk"
    Skin1.ApplySkinByName hwnd, "Form"
    Skin1.ApplySkin Me.hwnd
    DoEvents
    If MAIN.CMD2.filename = "" Then MsgBox "数据文件未载入", 32, "提示": Exit Sub
    MAIN.Enabled = False
    List1.Clear
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("个性")
    rs.MoveLast
    intRecCount = rs.RecordCount
    rs.MoveFirst
    For intCounter = 1 To intRecCount
        List1.AddItem rs![个性]
        rs.MoveNext
    Next intCounter
    List1.AddItem "总分"
    List1.AddItem "总分班级名次"
    List1.AddItem "总分年级名次"
    List1.ListIndex = 0
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("个性")
    NUM = 0
    rs.MoveFirst
    Do While Not rs.EOF()
        NUM = NUM + 1
        rs.MoveNext
    Loop
    Combo3.Clear
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("班级")
    rs.MoveLast
    intRecCount = rs.RecordCount
    rs.MoveFirst
    For intCounter = 1 To intRecCount
        Combo3.AddItem rs![班级]
        rs.MoveNext
    Next intCounter
    Combo3.ListIndex = 0
    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 = 5
    Combo2.ListIndex = 0
    Set db = OpenDatabase(MAIN.CMD2.filename)
    Set rs = db.OpenRecordset("SELECT * FROM COM WHERE 标记='名称'")
    nmc = rs![代码]
    Me.Caption = "自定义报送条" & "(" & nmc & ")"
    Data1.DatabaseName = MAIN.CMD2.filename
    '对打印的显示百分值进行初始化
    cmbPercent.ListIndex = 0
    cmbZoomMode.ListIndex = 3
    '显示数据库的条件,并且载入打印控件
    '        S = "SELECT * FROM 分析表 WHERR 班级>'0' "
    With VP
        .PaperSize = pprA4
        '                       .Orientation = orLandscape
    End With
    cmbSource
    Call Command3_Click
    Unload SCA
    Me.Show
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()
    '得到总页数,并且 scrlpage 自动适应其状态
    On Error Resume Next

    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 Resume Next
    Dim arr, i%, j%, wid!
    rs.MoveLast
    rs.MoveFirst
    i = rs.RecordCount
    If i = 0 Then Exit Sub
    Dim aree As Long
    For aree = 1 To Vf.Rows - 1
        arr = rs.GetRows(1)
        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
        VP.StartTable
        VP.TextAlign = taCenterMiddle
        VP.Paragraph = ""
        VP.Paragraph = nmc & "分数报送条"
        VP.AddTableArray fmt, hdr, arr
        For i = 0 To rs.Fields.Count - 1
            Select Case rs.Fields(i).Type
                Case dbBigInt, dbByte, dbChar, dbCurrency, dbDecimal, dbDouble, dbFloat, dbInteger, dbLong, dbNumeric, dbSingle, dbDate
                    VP.TableCell(tcColAlign) = taCenterMiddle
            End Select
            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.PageWidth - VP.MarginLeft - VP.MarginRight) / rs.Fields.Count
            End If
        Next
        '################################################################
        VP.TableCell(tcFontBold, 0) = True
        VP.TableCell(tcBackColor, 0) = vbYellow
        VP.TableCell(tcRowHeight, 0) = VP.TextHeight("Test") * 3  '设置表格头的字体宽度等
        VP.TableCell(tcAlign, 0) = taCenterMiddle
        '################################################################
        VP.EndTable
        '                VP.Paragraph = "": VP.Paragraph = "|" & nmc & "名次报送条| "
    Next
End Sub
Sub cmbSource()
    '打印代码从此处载入
    '打印代码从此处载入
    On Error Resume Next
    MousePointer = vbHourglass
    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 = "|" & nmc & "分数报送条| "
        RenderRecordset VP, rs, 0
        .EndDoc
        .ScrollIntoView 0, 0
    End With
    MousePointer = vbDefault
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