初一成绩管理系统VB.doc

一Public Declare Function timeGetTime Lib winmm.dll () As LongPublic Declare Function BitBlt Lib gdi32 (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As LongPublic Declare Function StretchBlt Lib gdi32 (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As LongPublic Declare Function SelectObject Lib gdi32 (ByVal hdc As Long, ByVal hObject As Long) As LongPublic Declare Function DeleteObject Lib gdi32 (ByVal hObject As Long) As LongPublic Declare Function CreateCompatibleDC Lib gdi32 (ByVal hdc As Long) As LongPublic Declare Function GetObject Lib gdi32 Alias GetObjectA (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPublic Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As LongEnd TypePublic Declare Function CreatePatternBrush Lib gdi32 (ByVal hBitmap As Long) As LongPublic Declare Function CreateCompatibleBitmap Lib gdi32 (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongOption ExplicitDim pic As Picture, sX As Single, sY As Single, _ Leij As Single, Hmemdc As Long, bm As BITMAP, _ i As Single, OldDc As LongPrivate Sub Command1_Click()初始化变量Call InstalMoveForm bm.bmHeight, 0, -1, yEnd SubSub delay(ByVal n As Single) Dim tm1 As Long, tm2 As Long tm1 = timeGetTime Do tm2 = timeGetTime If (tm2 - tm1) / 1000 n Then Exit Do DoEvents LoopEnd SubSub MoveForm(Begin As Long, XEnd As Long, Fuhao As String, Zhou As String)Dim i As Single, LS As SinglePicture1.Cls If Zhou = y Then For i = Begin To XEnd Step Fuhao BitBlt Picture1.hdc, 0, i, Picture1.Width, _ Picture1.Height, Hmemdc, 0, 0, vbSrcCopy delay 0.005 延时 Next i End If If Zhou = x Then For i = Begin To XEnd Step Fuhao BitBlt Picture1.hdc, i, 0, Picture1.Width, _ Picture1.Height, Hmemdc, 0, 0, vbSrcCopy delay 0.005 Next i End IfDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 单轴计算的图形载入方式End SubPrivate Sub Command10_Click()Call Instalxiex 0 - Picture1.ScaleWidth, 0, Picture1.ScaleHeight, 0, _ +1, Picture1.ScaleHeight / Picture1.ScaleWidth, 0, 0End SubPrivate Sub Command10_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 斜向载入图形End SubPrivate Sub Command11_Click()Call Instalxiex Picture1.ScaleWidth, 0, 0 - Picture1.ScaleHeight, 0, _ -1, 0 - Picture1.ScaleHeight / Picture1.ScaleWidth, 0, 0End SubPrivate Sub Command11_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 斜向载入图形End SubPrivate Sub Command12_Click()Dim Patten As Picture, hPatten As Long, i As Integer, _ Oldpatten As LongPicture1.ClsCall Instaldelay 1For i = 11 To 18Set Patten = LoadResPicture(i, vbResBitmap)hPatten = CreatePatternBrush(Patten)Oldpatten = SelectObject(Picture1.hdc, hPatten)BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ Hmemdc, 0, 0, &HAC0744SelectObject Picture1.hdc, OldpattenDeleteObject Patten.HandleDeleteObject OldpattenDeleteObject hPattendelay 0.3Next iDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command12_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 运用花色进行光栅运算的淡入End SubPrivate Sub Command13_Click()Dim difX As Single, difY As Single, W As Single, H As Single, _ fen As Integer, LsmemDc As Long, Lsbmp As LongCall InstalLsmemDc = CreateCompatibleDC(Picture1.hdc)Lsbmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)SelectObject LsmemDc, Lsbmp fen = 40 difX = Picture1.ScaleWidth / fen difY = Picture1.ScaleHeight / fen For i = fen To 0 Step -1sX = (Picture1.ScaleWidth - difX * i) / 2sY = (Picture1.ScaleHeight - difY * i) / 2BitBlt LsmemDc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ OldDc, 0, 0, vbBlacknessStretchBlt LsmemDc, sX, sY, difX * i, difY * i, _ Hmemdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopyBitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ LsmemDc, 0, 0, vbSrcCopydelay 0.01Next iDeleteObject LsbmpDeleteObject LsmemDcDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command13_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 由大到小的图形卸载方式End SubPrivate Sub Command14_Click()Dim Patten As Picture, hPatten As Long, i As Integer, _ Oldpatten As Long, LsmemDc As Long, Lsbmp As LongCall InstalBitBlt Hmemdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ OldDc, 0, 0, vbBlacknessFor i = 11 To 18Load patten对象Set Patten = LoadResPicture(i, vbResBitmap)创建Pattenbrush对象hPatten = CreatePatternBrush(Patten)把patten选入PictureboxOldpatten = SelectObject(Picture1.hdc, hPatten)进行光栅运算，并把结果显示在picturebox 上BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ Hmemdc, 0, 0, &HAC0744把Patten保存入 pictureboxSelectObject Picture1.hdc, Oldpatten删除临时DCDeleteObject Patten.HandleDeleteObject OldpattenDeleteObject hPatten延时delay 0.1Next iDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command14_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 运用花色光栅运算的淡出End SubPrivate Sub Command15_Click()Call InstalDim i As Long, iY As LongPicture1.ClsiY = bm.bmWidthi = 0 - bm.bmWidth / 2For i = 0 - bm.bmWidth / 2 - 1 To 0 iY = iY - 1BitBlt Picture1.hdc, iY, 0, Picture1.ScaleWidth / 2 + 1, Picture1.ScaleHeight, _ Hmemdc, bm.bmWidth / 2, 0, vbSrcCopyBitBlt Picture1.hdc, i, 0, Picture1.ScaleWidth / 2, Picture1.ScaleHeight, _ Hmemdc, 0, 0, vbSrcCopy delay 0.005 Next iBitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ Hmemdc, 0, 0, vbSrcCopy DeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command15_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 分成两块X轴的载入方式End SubPrivate Sub Command16_Click()Call InstalDim ILUx As Single, ILUy As Single, IRUx As Single, _ IRUy As Single, ILDx As Single, ILDy As Single, _ IRDx As Single, IRDy As Single, Lsbmp As Long, _ Leij As SinglePicture1.ClsLeij = Picture1.ScaleHeight / Picture1.ScaleWidth制作时的参照ILUx = 0 - bm.bmWidth / 2ILUy = 0 - bm.bmHeight / 2IRUx = bm.bmWidthIRUy = 0 - bm.bmHeight / 2ILDx = 0ILDy = bm.bmHeightIRDx = bm.bmWidth / 2IRDy = bm.bmHeight / 2分别计算四个图块X，Y 轴的运动轨迹For ILUx = 0 - bm.bmWidth / 2 To 0 ILUy = ILUy + Leij IRUx = IRUx - 1 IRUy = IRUy + Leij ILDy = ILDy - Leij直接显示在picturebox上BitBlt Picture1.hdc, ILUx, ILUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, 0, 0, vbSrcCopyBitBlt Picture1.hdc, IRUx, IRUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, bm.bmWidth / 2, 0, vbSrcCopyBitBlt Picture1.hdc, ILUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, 0, bm.bmHeight / 2, vbSrcCopyBitBlt Picture1.hdc, IRUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, bm.bmWidth / 2, bm.bmHeight / 2, vbSrcCopy延时delay 0.01Next ILUx去除接缝BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ Hmemdc, 0, 0, vbSrcCopy删除无用的DCDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command16_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 分成四块的图形载入方式End SubPrivate Sub Command17_Click()Call InstalDim ILUx As Single, ILUy As Single, IRUx As Single, _ IRUy As Single, ILDx As Single, ILDy As Single, _ IRDx As Single, IRDy As Single, Lsbmp As Long, _ Leij As Single, LsmemDc As Long建立与 Picture1相兼容的虚拟DCLsmemDc = CreateCompatibleDC(Picture1.hdc)建立与Picture1相兼容的 BmpLsbmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)把虚拟 Bmp 选进虚拟 DCSelectObject LsmemDc, Lsbmp计算Y轴单位累加数Leij = Picture1.ScaleHeight / Picture1.ScaleWidthILUx = 0ILUy = 0IRUx = bm.bmWidth / 2IRUy = 0ILDx = bm.bmWidth / 2ILDy = bm.bmHeight / 2IRDx = bm.bmWidth / 2IRDy = bm.bmHeight / 2For ILUx = 0 To 0 - bm.bmWidth / 2 Step -1 ILUy = ILUy - Leij IRUx = IRUx + 1 IRUy = IRUy - Leij ILDy = ILDy + Leij把要操作的图象转移进虚拟DCBitBlt LsmemDc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ OldDc, 0, 0, vbBlacknessBitBlt LsmemDc, ILUx, ILUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, 0, 0, vbSrcCopyBitBlt LsmemDc, IRUx, IRUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, bm.bmWidth / 2, 0, vbSrcCopyBitBlt LsmemDc, ILUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, 0, bm.bmHeight / 2, vbSrcCopyBitBlt LsmemDc, IRUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _ Hmemdc, bm.bmWidth / 2, bm.bmHeight / 2, vbSrcCopy把虚拟 DC 显示到 PictureboxBitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ LsmemDc, 0, 0, vbSrcCopydelay 0.01Next ILUx去除接缝BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _ Hmemdc, 0, 0, vbBlackness删除不用的虚拟 DCDeleteObject HmemdcDeleteObject LsbmpDeleteObject LsmemDcDeleteObject OldDcEnd SubPrivate Sub Command17_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 分成四块的图形卸载方式End SubPrivate Sub Command18_Click()Unload MeEnd SubPrivate Sub Command18_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 请按此键退出,下次再见。End SubPrivate Sub Command2_Click()Call InstalMoveForm bm.bmWidth, 0, -1, xEnd SubSub Instal()把图形 Load 入 PicSet pic = LoadResPicture(101, vbResBitmap)获得 Pic 的数据GetObject pic.Handle, Len(bm), bm建立和 picturebox 相兼容的虚拟 DCHmemdc = CreateCompatibleDC(Picture1.hdc)建立以后恢复用的 DCOldDc = CreateCompatibleDC(Picture1.hdc)SelectObject OldDc, Picture1.Picture.Handle把已经 Load 图形的 Pic 选入虚拟 DCSelectObject Hmemdc, pic.HandleEnd SubPrivate Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 单轴计算的图形载入方式End SubPrivate Sub Command3_Click()Call InstalMoveForm 0 - bm.bmWidth, 0, +1, xEnd SubPrivate Sub Command3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 单轴计算的图形载入方式End SubPrivate Sub Command4_Click()Call InstalMoveForm 0 - bm.bmHeight, 0, +1, yEnd SubPrivate Sub Command4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 单轴计算的图形载入方式End SubPrivate Sub Command5_Click()Call InstalDim fen As Integer, kuan As Singlefen = 40Picture1.ClssX = bm.bmWidth / fenFor kuan = 0 To sX + 1 For i = 0 To fen BitBlt Picture1.hdc, sX * i, 0, kuan, Picture1.Height, _ Hmemdc, sX * i, 0, vbSrcCopy Next idelay 0.1Next kuanDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = X轴的百叶窗End SubPrivate Sub Command6_Click()Call InstalDim fen As Integer, kuan As Singlefen = 20Picture1.ClssY = bm.bmHeight / fenFor kuan = 0 To sY + 1 For i = 0 To fen BitBlt Picture1.hdc, 0, sY * i, Picture1.Width, kuan, _ Hmemdc, 0, sY * i, vbSrcCopy Next idelay 0.15Next kuanDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = Y轴的百叶窗End SubPrivate Sub Command7_Click()Dim difX As Single, difY As Single, W As Single, H As Single, _ fen As IntegerCall InstalPicture1.Cls fen = 40 difX = Picture1.ScaleWidth / fen difY = Picture1.ScaleHeight / fenFor i = 1 To fensX = (Picture1.ScaleWidth - difX * i) / 2sY = (Picture1.ScaleHeight - difY * i) / 2StretchBlt Picture1.hdc, sX, sY, difX * i, difY * i, _ Hmemdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopydelay 0.01DoEventsNext iDeleteObject HmemdcDeleteObject OldDcEnd SubPrivate Sub Command7_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 由小到大的图形载入方式End SubPrivate Sub Command8_Click()Call InstalDim ystep As Singleystep = Picture1.ScaleHeight / Picture1.ScaleWidthxiex Picture1.ScaleWidth, 0, Picture1.ScaleHeight, 0, _ -1, ystep, 0, 0End SubSub xiex(startX As Single, endX As Single, _ startY As Single, endY As Single, Xstep As String, _ ystep As Single, picX As Single, picY As Single)Picture1.ClsDim XX As SingleXX = startY + ystepFor i = startX To endX Step Xstep XX = XX - ystepBitBlt Picture1.hdc, i, XX, Picture1.Width, Picture1.Height, _Hmemdc, picX, picY, vbSrcCopydelay 0.01Next iDeleteObject OldDcDeleteObject HmemdcEnd SubPrivate Sub Command8_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 斜向载入图形End SubPrivate Sub Command9_Click()Call Instalxiex 0 - Picture1.ScaleWidth, 0, 0 - Picture1.ScaleHeight, 0, _ +1, 0 - Picture1.ScaleHeight / Picture1.ScaleWidth, 0, 0End SubPrivate Sub Command9_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 斜向载入图形End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 图片演示。End SubPrivate Sub Form_Unload(Cancel As Integer)Unload MeEnd SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Form1.Caption = 演示图片的 Picture.End Sub二Public MnuItemNum As Long, Filename As StringPrivate Sub DynaMnu_Click(Index As Integer) Dim FileNo As Long FileNo = FreeFile Open DynaMnu(Index).Caption For Input As #FileNo TextEdit.Text = StrConv(InputB(LOF(FileNo), #FileNo), vbUnicode) Close #FileNoEnd SubPrivate Sub Form_Resize() TextEdit.Width = Form1.ScaleWidth TextEdit.Height = Form1.ScaleHeightEnd SubPrivate Sub mnuExit_Click() EndEnd SubPrivate Sub mnuFileClose_Click()Me.Enabled = FalseEnd SubPrivate Sub mnuFileOpen_Click() On Error Resume Next 设置错误处理 Dim FileNo As Long CommonDialog1.CancelError = True CommonDialog1.Filter = 文本文件|*.txt|所有文件|*.* CommonDialog1.InitDir = C:My Documents CommonDialog1.Flags = &H200000 允许使用长文件名 CommonDialog1.ShowOpen If Err.Number = 32755 Then Exit Sub 若按取消按钮，则退出过程 Filename = CommonDialog1.Filename 将要打开的文件名保存于变量中 FileNo = FreeFile Open Filename For Input As #FileNo 打开文件 下面在TextEdit文本框中显示文件的内容 TextEdit.Text = StrConv(InputB(LOF(FileNo), #FileNo), vbUnicode) Close #FileNo 关闭文件 下面将文件添加记录到动态菜单中 For n = 1 To MnuItemNum 检查是否已有同名项 If DynaMnu(n).Caption = Filename Then 若已有同名的，则不添加 Exit Sub End If Next MnuItemNum = MnuItemNum + 1 Load DynaMnu(MnuItemNum) DynaMnu(MnuItemNum).Caption = Filename DynaMnu(MnuItemNum).Visible = True DynaBar.Visible = TrueEnd SubPrivate Sub mnuFileSaveAs_Click()On Error Resume Next Dim FileNo As Long CommonDialog1.CancelError = True CommonDialog1.Filter = 文本文件|*.txt|所有文件|*.* CommonDialog1.InitDir = C:My Documents CommonDialog1.Flags = &H200000 CommonDialog1.ShowSave If Err.Number = 32755 Then Exit Sub Filename = CommonDialog1.Filename 获得要保存的文件名 FileNo = FreeFile Open Filename For Output As #FileNo 以写的方式打开文件 Print #FileNo, TextEdit.Text 将内容写入文件 Close #FileNo 关闭文件 下面将文件添加记录到动态菜单中 For n = 1 To MnuItemNum If DynaMnu(n).Caption = Filename Then Exit Sub Next MnuItemNum = MnuItemNum + 1 Load DynaMnu(MnuItemNum) DynaMnu(MnuItemNum).Caption = Filename DynaMnu(MnuItemNum).Visible = True DynaBar.Visible = True End SubPrivate Sub DynaMnu_Click(Index As Integer) Dim FileNo As Long FileNo = FreeFile Open DynaMnu(Index).Caption For Input As #FileNo TextEdit.Text = StrConv(InputB(LOF(FileNo), #FileNo), vbUnicode) Close #FileNoEnd SubPrivate Sub Form_Resize() TextEdit.Width = Form1.ScaleWidth TextEdit.Height = Form1.ScaleHeightEnd SubPrivate Sub mnuE