zidingyi.frm

一个较为完整的校园铃声控制系统。可以任意设置时间次数。

      TabIndex        =   54
      Top             =   9000
      Width           =   615
   End
   Begin VB.Label lblQuit 
      Alignment       =   2  'Center
      BackColor       =   &H00000000&
      Caption         =   "退出"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   7200
      MouseIcon       =   "zidingyi.frx":2377D
      MousePointer    =   99  'Custom
      TabIndex        =   53
      Top             =   9000
      Width           =   615
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "欢迎使用本软件 Email:    553086159 @ qq.com               yasenjan.qq.   qzone.com"
      ForeColor       =   &H00C0FFFF&
      Height          =   1860
      Left            =   8880
      TabIndex        =   35
      Top             =   6720
      Width           =   1290
      WordWrap        =   -1  'True
   End
End
Attribute VB_Name = "frmziding"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _
    lpdwProcessId As Long) As Long
    
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, _
    ByVal lpWindowName As Long) As Long
    
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
    ByVal hWndNewParent As Long) As Long
Private Const GW_HWNDNEXT = 2
Private OldParent&
Private hWnd1&

'控制音量

Const MMSYSERR_NOERROR = 0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_PURGE = &H40
Const SND_FILENAME = &H20000
Dim MyVolume As clsVolume
'
'Play a wave file.
Private Declare Function PlaySound Lib "winmm.dll" _
    Alias "PlaySoundA" (ByVal lpszName As String, _
    ByVal hModule As Long, ByVal dwFlags As Long) As Long

Public Function TestCard() As Boolean
Dim Y As Long
Dim Find As String
Find = "Find Sound Blaster Card"
Y = waveOutGetNumDevs()
If Y > 0 Then
TestCard = True

Else
TestCard = False
MsgBox "对不起！没有声卡", Mb_OK, Find
End If
End Function
Public Function Listwaveformat(Aboutwave As Long) As String
Dim Waveformat As String
Select Case Aboutwave
    Case Wave_Format_1m08
        Waveformat = "11.025Khz,Mono,8bit,11Kb/Ps"
    Case Wave_Format_1m16
        Waveformat = "11.025Khz,Mono,16bit,22Kb/Ps"
    Case Wave_Format_1s08
        Waveformat = "11.025Khz,Stereo,8bit,22Kb/Ps"
    Case Wave_Format_1s16
        Waveformat = "11.025Khz,Stereo,16bit,43Kb/Ps"
    Case Wave_Format_2m08
        Waveformat = "22.05Khz,Mono,8bit,22Kb/Ps"
    Case Wave_Format_2m16
        Waveformat = "22.05Khz,Mono,16bit,43Kb/Ps"
    Case Wave_Format_2s08
        Waveformat = "22.05Khz,Stereo,8bit,43Kb/Ps"
    Case Wave_Format_2s16
        Waveformat = "22.05Khz,Stereo,16bit,86Kb/Ps"
    Case Wave_Format_4m08
        Waveformat = "44.1Khz,Mono,8bit,43Kb/Ps"
    Case Wave_Format_4m16
        Waveformat = "44.1Khz,Mono,16bit,86Kb/Ps"
    Case Wave_Format_4s08
        Waveformat = "44.1Khz,Stereo,8bit,86Kb/Ps"
    Case Wave_Format_4s16
        Waveformat = "44.1Khz,Stereo,16bit,172Kb/Ps"
End Select
Listwaveformat = Waveformat
End Function
Public Function Listwavesupport(Aboutwave As Long) As String
Dim Wavefun As String
Select Case Aboutwave
    Case Wavecaps_Pitch
        Wavefun = "Support Pitch"
    Case Wavecaps_Playbackrate
        Wavefun = "Support Playback"
    Case Wavecaps_Volume
        Wavefun = "Support Volume Control"
    Case Wavecaps_Lrvolume
        Wavefun = "Support Left-Right Channals"
    Case Wavecaps_Sync
        Wavefun = "Support Synchronization"
End Select
Listwavesupport = Wavefun

End Function






Private Sub CmdBrush_Click()
Dim m As MEMORYSTATUS
m.dwLength = Len(m)
GlobalMemoryStatus m
TxtPerCent = Str(m.dwMemoryLoad)
End Sub

Private Sub Command1_Click()
Me.Data3.Recordset.AddNew

End Sub

Private Sub command2_Click()
Me.Data3.Refresh

Me.Data3.Recordset.MoveLast

MsgBox "设置成功"
End Sub

Private Sub Command21_Click()
Me.Combo1.Enabled = False
Me.Combo2.Enabled = False
Me.Combo3.Enabled = False


Data9.Refresh
Data9.Recordset.MoveLast
Data10.Refresh
Data10.Recordset.MoveLast
Data11.Refresh
Data11.Recordset.MoveLast
End Sub

Private Sub Command22_Click()
Me.Combo1.Enabled = True
Data9.Recordset.AddNew

End Sub

Private Sub Command23_Click()
Me.Combo2.Enabled = True
Data10.Recordset.AddNew
End Sub

Private Sub Command24_Click()
Me.Combo3.Enabled = True
Data11.Recordset.AddNew
End Sub

Private Sub Command4_Click()
Me.Data1.Recordset.AddNew


End Sub

Private Sub Command5_Click()
Me.Data1.Refresh

Me.Data1.Recordset.MoveLast

MsgBox "设置成功"
End Sub


Private Sub Command6_Click()
Me.Data2.Refresh

Me.Data2.Recordset.MoveLast

MsgBox "设置成功"
End Sub

Private Sub Command7_Click()
Me.Data2.Recordset.AddNew
End Sub

Private Sub Command8_Click()
Dim Existent As Boolean
Dim Consequencd As Long
Dim Returncaps As Waveoutcaps
Dim Mainver As Long
Dim Lesserver As Long
Dim pName As String * 32
Dim Aboutwave As Long
Dim Channel As String * 2
Dim I As Integer
Picture1.Cls
Existent = TestCard
   If Existent Then
    Consequence = waveOutGetDevCaps(0, Returncaps, Len(Returncaps))
   If Consequencd = 0 Then
    Mainver = Returncaps.vDriverVersion \ 256
    Lesserver = Returncaps.vDriverVersion Mod 256
pName = Left$(Returncaps.szPname, InStr(Returncaps.szPname, Chr$(0)) - 1)
    Channel = Str$(Returncaps.Wchannels)
    Picture1.Print "产品名称："; pName
    Picture1.Print "产品 Id："; Returncaps.wPid
    Picture1.Print "驱动程序 Id："; Returncaps.wMid
    Picture1.Print "驱动程序版本："; Mainver; "."; Lesserver
    Picture1.Print "输出声道："; Channel
    Picture1.Print "支持格式列表："
For I = 0 To 11
  If Returncaps.Dwformats And (2 ^ I) Then
     Picture1.Print Listwaveformat(2 ^ I)
  End If
Next I
Picture1.Print "扩展输出功能列表："
For I = 0 To 4
  If Returncaps.Dwsupport And (2 ^ I) Then
    Picture1.Print Listwavesupport(2 ^ I)
    End If
   Next I
 End If
Else
 End
End If
End Sub

Private Sub Form_Activate()
Call korsitix

Me.Combo1.Enabled = False
Me.Combo2.Enabled = False
Me.Combo3.Enabled = False

Call Command8_Click
End Sub

Private Sub Form_Load()
 
  
  Me.Data1.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data1.RecordSource = "guanji"
  
  Me.Data2.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data2.RecordSource = "zhuxiao"
  
  Me.Data3.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data3.RecordSource = "chongqi"
    
  Me.Data9.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data9.RecordSource = "buxiangling1"
  
  Me.Data10.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data10.RecordSource = "buxiangling2"
  
  Me.Data11.DatabaseName = App.Path + "\" & "\xiaoyuan.mdb"
  Me.Data11.RecordSource = "buxiangling3"
  
  
'内存测试
Dim m As MEMORYSTATUS
m.dwLength = Len(m)
GlobalMemoryStatus m
TxtLenght = Str(m.dwLength)
TxtPerCent = Str(m.dwMemoryLoad)
TxtTotal = Str(m.dwTotalPhys) / 1024 / 1024
TxtVoid = Str(m.dwTotalVirtual) / 1024 / 1024


Picture1.Cls

'控制音量
Set MyVolume = New clsVolume

MyVolume.meOpenMixer

If MyVolume.prMixerErr = MMSYSERR_NOERROR Then
    With vsVolume
        .Max = MyVolume.prSpeakerMinVolume
        .Min = MyVolume.prSpeakerMaxVolume \ 2
        .SmallChange = 1000
        .LargeChange = 1000
    End With
    With vsMic
        .Max = MyVolume.prMicMinVolume
        .Min = MyVolume.prMicMaxVolume \ 2
        .SmallChange = 1000
        .LargeChange = 1000
        .Enabled = True
    End With
End If
Call Command8_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set MyVolume = Nothing
Set frmVolume = Nothing
End Sub

Private Sub korsitix()
  Me.Data1.Recordset.MoveLast
  
  Me.Data9.Recordset.MoveLast
  Me.Data10.Recordset.MoveLast
  Me.Data11.Recordset.MoveLast
End Sub
Private Sub Command3_Click()
Me.Visible = False
End Sub

Private Sub Label1_Click()
'Shell ("http://user.qzone.qq.com/553086159/infocenter")
End Sub

Private Sub Label10_Click()
Dim l          As Long
Dim lFlags     As Long
Dim sSoundName As String
'
'Open a wavefile and initialize the form.
'
On Error GoTo lblPlayError
With CommonDialog1
    .FileName = "*.wav"
    .DefaultExt = "wav"
    .Filter = "*.wav"
    .FilterIndex = 1
    .Flags = cdlOFNPathMustExist Or cdlOFNFileMustExist
    .DialogTitle = "Select a Wave File"
    .CancelError = True
    .ShowOpen
    sSoundName = .FileName
End With

lFlags = SND_ASYNC Or SND_NODEFAULT Or SND_FILENAME
l = PlaySound(sSoundName, 0, lFlags)

lblPlayError:
End Sub

Private Sub vsMic_Change()
Dim lVol As Long

lVol = CLng(vsMic.Value) * 2
MyVolume.prMicVolume = lVol
'Call fSetVolumeControl(hmixer, micCtrl, lVol)
End Sub
Private Sub vsMic_Scroll()
Dim lVol As Long

lVol = CLng(vsMic.Value) * 2
MyVolume.prMicVolume = lVol
'Call fSetVolumeControl(hmixer, micCtrl, lVol)
End Sub
Private Sub vsVolume_Change()
Dim lVol As Long

lVol = CLng(vsVolume.Value) * 2
MyVolume.prSpeakerVolume = lVol
'Call fSetVolumeControl(hmixer, volCtrl, lVol)
End Sub
Private Sub vsVolume_Scroll()
Dim lVol As Long

lVol = CLng(vsVolume.Value) * 2
MyVolume.prSpeakerVolume = lVol
'Call fSetVolumeControl(hmixer, volCtrl, lVol)
End Sub



Private Sub Timer1_Timer()
Me.Label4.Caption = Hour(Now)
Me.Label5.Caption = Minute(Now)
Me.Label6.Caption = Second(Now)
If Me.Combo4.Text = Me.Label4.Caption Then
If Me.Combo5.Text = Me.Label5.Caption Then
If Me.Combo6.Text = Me.Label6.Caption Then
Shell ("c:\windows\system32\shutdown.exe /s /t 0")
End If
End If
End If

If Me.Combo7.Text = Me.Label4.Caption Then
If Me.Combo8.Text = Me.Label5.Caption Then
If Me.Combo9.Text = Me.Label6.Caption Then
 t& = ExitWindowsEx(0, 0)
End If
End If
End If

If Me.Combo12.Text = Me.Label4.Caption Then
If Me.Combo11.Text = Me.Label5.Caption Then
If Me.Combo10.Text = Me.Label6.Caption Then
 Dim str1 As String
 Dim RetVal As Variant
  
   On Error Resume Next
   
 
 
   Dim X As Integer
     X = ExitWindowsEx(EWX_FORCE Or EWX_SHUTDOWN, 0)
  '重启计算机选项
   
     'AdjustToken 'NT下关机需先调用的安全机制涵数子过程
     X = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
  

End If
End If
End If

End Sub