frmexcel.frm

VB编写的中小学监考老师排表软件

VERSION 5.00
Begin VB.Form frmexcel 
   Caption         =   "导出 Excel 表"
   ClientHeight    =   4650
   ClientLeft      =   2790
   ClientTop       =   2040
   ClientWidth     =   5490
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4650
   ScaleWidth      =   5490
   Begin VB.CommandButton Command3 
      Caption         =   "总监考表簿"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   645
      Left            =   2355
      TabIndex        =   2
      Top             =   3045
      Width           =   2625
   End
   Begin VB.CommandButton Command2 
      Caption         =   "教师监考表簿"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   645
      Left            =   2340
      TabIndex        =   1
      Top             =   2010
      Width           =   2625
   End
   Begin VB.CommandButton Command1 
      Caption         =   "班级监考表簿"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   645
      Left            =   2355
      TabIndex        =   0
      Top             =   885
      Width           =   2625
   End
   Begin VB.Menu mnuback 
      Caption         =   "返回"
   End
End
Attribute VB_Name = "frmexcel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim newbiao As bjkcbiao
Private Sub Command1_Click()
On Error Resume Next
Dim xlApp As excel.Application
Dim xlBook, xljsbook, xlzbook As excel.Workbook
Dim xlSheet, xljssheet, xlzsheet, xlzrksheet As excel.Worksheet

Dim bjs As Integer

Dim strcell, strname, strjs As String
Dim b, i, j As Integer

'启动excel
Set xlApp = New excel.Application
xlApp.Visible = True
'GoTo js

'建班级工作簿xlbook
Set xlBook = xlApp.Workbooks.Add

For b = ksbjs To 1 Step -1
newbjitem = bjarr(b)
strname = Left$(newbjitem.njm, 2) + Left(newbjitem.bjh, 2) ' + "班"

'建班级sheet表
Set xlSheet = xlBook.Worksheets.Add
xlSheet.name = strname
xlSheet.Columns.ColumnWidth = xlSheet.Columns.ColumnWidth * 2 '1.25
xlSheet.Columns("a").ColumnWidth = xlSheet.Columns("a").ColumnWidth * 0.3
xlSheet.Columns("b").ColumnWidth = xlSheet.Columns("b").ColumnWidth * 1.2
xlSheet.Columns.HorizontalAlignment = xlCenter
'居中
xlSheet.Columns.HorizontalAlignment = xlCenter
xlSheet.Rows.VerticalAlignment = xlCenter

' 设定表头和线

With xlSheet
'行高
For i = 2 To Class + 2
.Rows(i).RowHeight = TextHeight("语") * 4 'Rows(i).RowHeight * 2.5
Next i
.Rows(1).RowHeight = Rows(1).RowHeight * 2
'首列
For i = 1 To Class
.Cells(i + 2, 1).Value = i
.Cells(i + 2, 1).Borders.LineStyle = xlContinuous ' "xi xian kuang"
.Cells(i + 2, 1).Characters.Font.Size = 18
Next i
.Cells(2, 1).Value = "节"
.Cells(2, 1).Characters.Font.Size = 18

'次列
.Cells(2, 2).Value = "时  间"
.Cells(2, 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
.Cells(2, 2).Characters.Font.Size = 18
For i = 1 To Class
.Cells(i + 2, 2).Value = Trim$(Str$(Fix(sj1(2 * i - 1) / 60))) + ":" + Trim$(Str$(sj1(2 * i - 1) - Fix(sj1(2 * i - 1) / 60) * 60)) + "-" + Trim$(Str$(Fix(sj1(2 * i) / 60))) + ":" + Trim$(Str$(sj1(2 * i) - Fix(sj1(2 * i) / 60) * 60))
.Cells(i + 2, 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
.Cells(i + 2, 2).Characters.Font.Size = 14
Next i
'首行
For j = 1 To Day
.Cells(2, j + 2).Value = Mid$("试期一试期二试期三试期四试期五试期试星期日", (j - 1) * 3 + 1, 3)
.Cells(2, j + 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
.Cells(2, j + 2).Characters.Font.Size = 16
Next j
'格线
For i = 1 To Class
For j = 1 To Day
.Cells(i + 2, j + 2).Borders.LineStyle = xlContinuous
Next j
Next i

For i = 1 To Class + 1
.Cells(i + 1, 1).Borders(xlLeft).Weight = xlMedium
.Cells(i + 1, 2).Borders(xlRight).Weight = xlMedium
.Cells(i + 1, Day + 2).Borders(xlRight).Weight = xlMedium
Next i

For j = 1 To Day + 2
.Cells(2, j).Borders(xlTop).Weight = xlMedium
.Cells(2, j).Borders(xlBottom).Weight = xlMedium
.Cells(Class1 + 2, j).Borders(xlBottom).Weight = xlMedium
.Cells(Class + 2, j).Borders(xlBottom).Weight = xlMedium
Next j

End With
'填班级表
Dim strcell0 As String
For i = 0 To Class - 1
For j = 0 To Day - 1
    If Trim(bjarr(b).ksbiao(i, j)) <> "x" Then
    strcell = Left(bjarr(b).ksbiao(i, j), 2)
    Else
    strcell = " "
    End If
    
    If Trim(bjarr(b).jsbiao1(i, j)) <> "x" Then
    strcell = strcell + Chr(10) + Left(bjarr(b).jsbiao1(i, j), 3)
    Else
    strcell = strcell + " "
    End If
    
    If Trim(bjarr(b).jsbiao2(i, j)) <> "x" Then
    strcell = strcell + Chr(10) + Left(bjarr(b).jsbiao2(i, j), 3)
    Else
    strcell = strcell + " "
    End If
'strcell = Left(bjarr(b).jsbiao1(i, j), 4) + Left(bjarr(b).jsbiao2(i, j), 4) + strcell0  ' & Mid$(newbiao.kcbiao(i, j), 2, 1)+strcell0
xlSheet.Cells(i + 3, j + 3) = strcell ' Left$(newbiao.kcbiao(i, j), 1) & Mid$(newbiao.kcbiao(i, j), 2, 1)
xlSheet.Cells(i + 3, j + 3).Characters.Font.Size = 24
Next j
Next i
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Day + 2)).Merge (True)
xlSheet.Cells(1, 1).Value = strname + "班监考表"
xlSheet.Cells(1, 1).Characters.Font.Size = 18

Next b

xlBook.Worksheets("sheet1").Visible = False
xlBook.Worksheets("sheet2").Visible = False
xlBook.Worksheets("sheet3").Visible = False
'规定窗口及菜单样式
xlApp.Caption = "Excel--Pk10 班级表"
xlApp.Windows.Arrange arrangeStyle:=xlCascade
xlApp.CommandBars(4).Visible = False
xlApp.CommandBars(3).Visible = False
xlApp.CommandBars(1).Visible = True

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub


Private Sub Cmdopenxl_Click()
End Sub

Private Sub Command2_Click()
On Error Resume Next
Dim xlApp As excel.Application
Dim xlBook, xljsbook, xlzbook As excel.Workbook
Dim xlSheet, xljssheet, xlzsheet, xlzrksheet As excel.Worksheet

Dim bjs, js, zjss As Integer
Dim strcell, strname, strjs As String
Dim b, i, j As Integer

js:
'建教师工作簿xljsbook
Set xlApp = New excel.Application
xlApp.Visible = True

Set xljsbook = xlApp.Workbooks.Add

'Open App.Path + "\jsshu.bin" For Binary As #2
'Get #2, 1, zjss ' szjs%  ' 不同名的教师数目
'Close #2
'zjss = szjs%

For b = 1 To 3 'jkjss
Set xljssheet = xljsbook.Worksheets.Add
xljssheet.name = Left$(jsarr(b).jsm, 6)
xljssheet.Columns.ColumnWidth = xljssheet.Columns.ColumnWidth * 1.3
xljssheet.Columns(1).ColumnWidth = xljssheet.Columns.ColumnWidth * 0.3
xljssheet.Columns.HorizontalAlignment = xlCenter

' 设定表头和线

With xljssheet

'居中
.Columns.HorizontalAlignment = xlCenter
.Rows.VerticalAlignment = xlCenter

'行高
For i = 1 To Class + 1
.Rows(i).RowHeight = Rows(i).RowHeight * 1.3
Next i

'首列
For i = 1 To Class
.Cells(i + 1, 1).Value = i
.Cells(i + 1, 1).Borders.LineStyle = xlContinuous ' "xi xian kuang"
Next i
'次列
.Cells(1, 2).Value = "时  间"
.Cells(1, 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
For i = 1 To Class
.Cells(i + 1, 2).Value = Trim$(Str$(Fix(sj1(2 * i - 1) / 60))) + ":" + Trim$(Str$(sj1(2 * i - 1) - Fix(sj1(2 * i - 1) / 60) * 60)) + "-" + Trim$(Str$(Fix(sj1(2 * i) / 60))) + ":" + Trim$(Str$(sj1(2 * i) - Fix(sj1(2 * i) / 60) * 60))
.Cells(i + 1, 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
Next i
'首行
For j = 1 To Day
.Cells(1, j + 2).Value = Mid$("试期一试期二试期三试期四试期五试期六试期日", (j - 1) * 3 + 1, 3)
.Cells(1, j + 2).Borders.LineStyle = xlContinuous ' "xi xian kuang"
Next j
'格线
For i = 1 To Class
For j = 1 To Day
.Cells(i + 1, j + 2).Borders.LineStyle = xlContinuous
Next j
Next i

For i = 1 To Class + 1
.Cells(i, 1).Borders(xlLeft).Weight = xlMedium
.Cells(i, 2).Borders(xlRight).Weight = xlMedium
.Cells(i, Day + 2).Borders(xlRight).Weight = xlMedium
Next i

For j = 1 To Day + 2
.Cells(1, j).Borders(xlTop).Weight = xlMedium
.Cells(1, j).Borders(xlBottom).Weight = xlMedium
.Cells(Class1 + 1, j).Borders(xlBottom).Weight = xlMedium
.Cells(Class + 1, j).Borders(xlBottom).Weight = xlMedium
Next j

End With

'填教师表
For i = 0 To Class - 1
For j = 0 To Day - 1


strcell = Trim$(jsarr(b).jkbiao1(i, j)) 'Left$(newbiao.kcbiao(i, j), 1) & Mid$(newbiao.kcbiao(i, j), 2, 1)
If strcell = "x" Then strcell = " "
'strcell = Left$(strcell, 2) + Mid$(strcell, 7, 5)
xljssheet.Cells(i + 2, j + 3) = strcell ' Left$(newbiao.kcbiao(i, j), 1) & Mid$(newbiao.kcbiao(i, j), 2, 1)
'End If
Next j
Next i

Next b
xljsbook.Worksheets("sheet1").Visible = False
xljsbook.Worksheets("sheet2").Visible = False
xljsbook.Worksheets("sheet3").Visible = False
'规定窗口及菜单样式
xlApp.Caption = "Excel--Pk10 教师表"
xlApp.Windows.Arrange arrangeStyle:=xlCascade
xlApp.CommandBars(4).Visible = False
xlApp.CommandBars(3).Visible = False
xlApp.CommandBars(1).Visible = True

Set xljssheet = Nothing
Set xljsbook = Nothing
Set xlApp = Nothing

End Sub


Private Sub Command3_Click()

On Error Resume Next
Dim xlApp As excel.Application
Dim xlBook, xljsbook, xlzbook As excel.Workbook
Dim xlSheet, xljssheet, xlzsheet, xlzrksheet, xlzshsheet As excel.Worksheet

Dim bjs As Integer
Dim js  As Integer
Dim zjss As Integer
Dim strcell, strname, strjs As String
Dim b, i, j As Integer

'取总教师数
'Open App.Path + "\jsshu.bin" For Binary As #2
'Get #2, 1, zjss  ' 不同名的教师数目
'Close #2
zjss = jkjss 'szjs%

'取班级数
'Open App.Path + "\bjshu.bin" For Binary As #7
'Get #7, 1, bjs
'Close #7
bjs = ksbjs

'启动excel
Set xlApp = New excel.Application
xlApp.Visible = True

'建总课表簿
Set xlzbook = xlApp.Workbooks.Add
'建总课程表
Set xlzsheet = xlzbook.Worksheets.Add
xlzsheet.name = "总监考表"
'居中
xlzsheet.Columns.HorizontalAlignment = xlCenter
xlzsheet.Rows.VerticalAlignment = xlCenter
'列宽