frmmain.frm

这是一个语音播放程序,对于编程人员很有帮助,使用vb开发的

VERSION 5.00
Begin VB.Form frmMain 
   BackColor       =   &H00000000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "ViaLan v0.1"
   ClientHeight    =   6195
   ClientLeft      =   225
   ClientTop       =   720
   ClientWidth     =   5970
   Icon            =   "FRMMAIN.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   413
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   398
   ShowInTaskbar   =   0   'False
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   600
      Left            =   5160
      Top             =   120
   End
   Begin VB.CheckBox Check1 
      BackColor       =   &H80000001&
      Caption         =   "私聊"
      Height          =   375
      Left            =   3075
      TabIndex        =   11
      Top             =   0
      Width           =   1050
   End
   Begin VB.OptionButton Option2 
      BackColor       =   &H80000001&
      Caption         =   "私人频道"
      Height          =   375
      Left            =   2025
      TabIndex        =   10
      Top             =   0
      Value           =   -1  'True
      Width           =   1050
   End
   Begin VB.OptionButton Option1 
      BackColor       =   &H80000001&
      Caption         =   "大厅频道"
      Height          =   375
      Left            =   975
      TabIndex        =   9
      Top             =   0
      Width           =   1050
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   0
      Top             =   0
   End
   Begin VB.CommandButton Command4 
      Caption         =   "停止语音"
      Enabled         =   0   'False
      Height          =   450
      Left            =   2250
      TabIndex        =   7
      Top             =   5700
      Width           =   1050
   End
   Begin VB.CommandButton Command3 
      Caption         =   "语音"
      Height          =   450
      Left            =   1200
      TabIndex        =   6
      Top             =   5700
      Width           =   1050
   End
   Begin VB.ListBox lstPlayers 
      Appearance      =   0  'Flat
      BackColor       =   &H00404040&
      ForeColor       =   &H00FFFFFF&
      Height          =   5295
      Left            =   3900
      TabIndex        =   3
      Top             =   360
      Width           =   1935
   End
   Begin VB.TextBox txtSend 
      Appearance      =   0  'Flat
      BackColor       =   &H00404040&
      ForeColor       =   &H00FFFFFF&
      Height          =   285
      Left            =   120
      TabIndex        =   2
      Top             =   5370
      Width           =   3750
   End
   Begin VB.Timer tmrMSG 
      Left            =   4920
      Top             =   3000
   End
   Begin VB.CommandButton cmdSend 
      BackColor       =   &H00E0E0E0&
      Caption         =   "发送"
      Height          =   450
      Left            =   150
      TabIndex        =   1
      Top             =   5700
      Width           =   1050
   End
   Begin VB.TextBox txtMsg 
      Appearance      =   0  'Flat
      BackColor       =   &H00404040&
      ForeColor       =   &H00FFFFFF&
      Height          =   4935
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Text            =   "FRMMAIN.frx":0442
      Top             =   360
      Width           =   3750
   End
   Begin VB.Image Image2 
      DragIcon        =   "FRMMAIN.frx":0448
      Height          =   720
      Left            =   4920
      Picture         =   "FRMMAIN.frx":1312
      Top             =   3000
      Width           =   720
   End
   Begin VB.Image Image1 
      DragIcon        =   "FRMMAIN.frx":21DC
      Height          =   480
      Left            =   4200
      Picture         =   "FRMMAIN.frx":24E6
      Top             =   5040
      Width           =   480
   End
   Begin VB.Label Label1 
      Height          =   450
      Left            =   3300
      TabIndex        =   8
      Top             =   5700
      Width           =   2535
   End
   Begin VB.Line Line1 
      X1              =   8
      X2              =   816
      Y1              =   0
      Y2              =   0
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      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       =   &H0000FF00&
      Height          =   255
      Left            =   4500
      TabIndex        =   5
      Top             =   120
      Width           =   1695
   End
   Begin VB.Label lblLobby 
      BackStyle       =   0  'Transparent
      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       =   &H0000FF00&
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   120
      Width           =   2055
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件"
      Begin VB.Menu mnuExit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu mnuCommands 
      Caption         =   "命令"
      Begin VB.Menu mnuCreateHost 
         Caption         =   "建立主机"
      End
      Begin VB.Menu mnuJoin 
         Caption         =   "加入"
      End
   End
   Begin VB.Menu mnuMessage 
      Caption         =   "消息"
      Begin VB.Menu mnusend 
         Caption         =   "发送"
         Shortcut        =   ^Z
      End
   End
   Begin VB.Menu mnuTray 
      Caption         =   "Popup"
      Visible         =   0   'False
      Begin VB.Menu mnuTrayRestore 
         Caption         =   "恢复[&R]"
      End
      Begin VB.Menu mnuTrayMove 
         Caption         =   "移动[&M]"
      End
      Begin VB.Menu mnuTraySize 
         Caption         =   "改变大小[&S]"
      End
      Begin VB.Menu mnuTrayMinimize 
         Caption         =   "最小化[&N]"
      End
      Begin VB.Menu mnuTrayMaximize 
         Caption         =   "最大化[&X]"
      End
      Begin VB.Menu mnuTraySep 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTrayClose 
         Caption         =   "关闭[&C]"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public LastState As Integer

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&


Dim m_notify_dsb As Long
Dim m_notify_dscb As Long
Implements DirectXEvent

Private Sub cmdSend_Click()
    
    If Len(txtMsg.Text) > 1000000 Then
        txtMsg = ""
    End If
    
    If Check1.Value = 0 Then
        txtMsg.Text = txtMsg.Text & vbCrLf & PlayerName & ">" & txtSend.Text
        txtMsg.SelStart = Len(txtMsg.Text & vbCrLf & PlayerName & ">" & txtSend.Text)
        send_msg LOBBY_MSG, txtSend.Text
    ElseIf Check1.Value = 1 Then
        txtMsg.Text = txtMsg.Text & vbCrLf & "**Private**" & PlayerName & ">" & txtSend.Text
        txtMsg.SelStart = Len(txtMsg.Text & vbCrLf & PlayerName & ">" & txtSend.Text)
        send_msg PRIVATE_MSG, txtSend.Text
    End If
    
    
    txtSend.SetFocus
    txtSend.Text = ""
End Sub



Private Sub Form_Load()
    
    Show
    Timer2.Enabled = False
    If WindowState = vbMinimized Then
        LastState = vbNormal
    Else
        LastState = WindowState
    End If
    SetTrayIcon Image1.Picture
    AddToTray Me, mnuTray
    SetTrayTip "欢迎光临天一VB"
    TheData.hIcon = Image1.Picture
    txtMsg.Text = ""
    txtMsg.Locked = True
    txtMsg.TabStop = False
    txtSend.SetFocus
    
    current_Dsb = 0
    
    m_notify_dsb = 0
    m_notify_dscb = 0
 
    
    dsb_Ready = False
    Receive_Channel = PRIVATE_SOUND
    Public_Take = False
    Public_Free = False
    Public_Free_Counter = 0
    
 On Local Error GoTo errOut
   Set dsc = dx.DirectSoundCaptureCreate(vbNullString)
    On Error Resume Next
    Set ds = dx.DirectSoundCreate(vbNullString)
    If Err.Number = DSERR_ALLOCATED Then 'The card isn't supporting full duplex
        gfPlay = False
        MsgBox "This card does not support full duplex.  You may still record sound.", vbOKOnly Or vbInformation, "No full duplex"
    Else
        gfPlay = True
        ds.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
    End If
    On Local Error GoTo errOut
    
    InitCapture
    
    'Exit Sub
    Set dscb = Nothing
        Set dsc = dx.DirectSoundCaptureCreate(vbNullString)
        Call InitCapture
        
        dscb.GetCurrentPosition capCURS
        dsd.lBufferBytes = Buf_Size
        dsd.lFlags = DSBCAPS_CTRLVOLUME Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_STATIC Or DSBCAPS_CTRLPOSITIONNOTIFY Or DSBCAPS_GLOBALFOCUS