form1.frm

VB遥控播放器红外遥控解码 #include <regX52.h> #define c(x) (x*110592/120000) sbit Ir_Pin=P3^2 sb

         Height          =   480
         Left            =   435
         TabIndex        =   2
         Top             =   345
         Width           =   1590
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private iniPath As String
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lplFileName As String) As Long
Dim sBarcodeTemp As String
Dim sInTemp As String
Dim k1
Dim k2
Dim k3
Dim k4
Dim k5
Dim k6
Dim k7
Dim k8
Dim k9
Dim k10
Dim k11
Dim k12
Dim k13
Dim hi
Dim ss

Function GetFromINI(AppName As String, KeyName As String, Filename As String) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   GetFromINI = Left(RetStr, GetPrivateProfileString(AppName, ByVal KeyName, "", RetStr, Len(RetStr), Filename))
End Function
Private Function Fun_FloppyDrive(sDrive As String) As Boolean
  On Error Resume Next
  Fun_FloppyDrive = Dir(sDrive) <> ""
  End Function


Private Sub cmdClear_Click()
    lstBarcodes.Clear
    txtBarcode.Text = ""
End Sub



Private Sub Command1_Click()
Form2.Show vbModal
End Sub



Private Sub Command3_Click()
End
End Sub



Private Sub Dir1_Change()
File1.Path = Dir1
End Sub

Private Sub Dir1_Click()
File1.Path = Dir1
End Sub

Private Sub Drive1_Change()
 On Error Resume Next
Dir1.Path = Drive1.Drive
  
   If Err <> 0 Then
       MsgBox "请选择有效磁盘！", vbOKOnly, "错误提示"
    End If

End Sub
Private Sub File1_Click()
On Error Resume Next
wmz = FileLen(File1.Path + "\" + File1.Filename)
rrr = Right(File1.Filename, 4)
rrr = LCase(rrr)
rr = Right$(File1.Filename, 3)
rr = LCase(rr)
If wmz < 1024 Then
filesize = Str(wmz) + "字节"
ElseIf wmz >= 1024 And wmz <= 1048576 Then
filesize = Str(Round((wmz / 1024), 2)) + "KB"
ElseIf wmz > 1048576 Then
filesize = Str(Round((wmz / 1048576), 2)) + "MB"
End If
'filesize = Str(Int((FileLen(File1.Path + "\" + File1.FileName)) / 1024)) + "KB"
wmp1.URL = File1.Path + "\" + File1
Label1.Caption = "当前文件：" + File1.Path + "\" + File1 + vbCrLf + vbCrLf + "文件大小：" + filesize + vbCrLf + vbCrLf
wmp1.Controls.play
Timer1.Enabled = True
Text3.Text = wmp1.settings.volume
End Sub




Private Sub Form_Load()
On Error Resume Next

iniPath = App.Path & "\hifans.ini"
k1 = GetFromINI("IRCODE", "KEYCODE1", iniPath)
k2 = GetFromINI("IRCODE", "KEYCODE2", iniPath)
k3 = GetFromINI("IRCODE", "KEYCODE3", iniPath)
k4 = GetFromINI("IRCODE", "KEYCODE4", iniPath)
k5 = GetFromINI("IRCODE", "KEYCODE5", iniPath)
k6 = GetFromINI("IRCODE", "KEYCODE6", iniPath)
k7 = GetFromINI("IRCODE", "KEYCODE7", iniPath)
k8 = GetFromINI("IRCODE", "KEYCODE8", iniPath)
k9 = GetFromINI("IRCODE", "KEYCODE9", iniPath)
k10 = GetFromINI("IRCODE", "KEYCODE10", iniPath)
k11 = GetFromINI("IRCODE", "KEYCODE11", iniPath)
k12 = GetFromINI("IRCODE", "KEYCODE12", iniPath)
k13 = GetFromINI("IRCODE", "KEYCODE13", iniPath)


'Form2.Show
  '端口循环计数器
    Dim iComPort As Integer

    '错误陷阱
    On Error GoTo CommErrorHandle
    
    '尝试列表存在端口
    For iComPort = 1 To 4
        ComPort.CommPort = iComPort '指定端口号
        If ComPort.PortOpen = True Then ComPort.PortOpen = False '如打开先关闭
        ComPort.PortOpen = True  '尝试打开
        ComPort.PortOpen = False '确认成功关闭
    Next
    
    '端口配置
    ComPort.InputLen = 1    '1 个字符产生接收事件
    ComPort.RThreshold = 1  '1 个字符产生接收事件
    
    '跳出错误
    Exit Sub
   
    
CommErrorHandle:

    '68   = 设备无效
    '8002 = 端口号无效
    '8012 = 端口无法打开
    If Err = 68 Or Err = 8002 Or Err = 8012 Then
        '端口无效时则禁止单击连接按钮
        optComPort(iComPort - 1).Enabled = False
    End If
    
    '继续错误
    Resume Next

End Sub

Private Sub Form_Unload(Cancel As Integer)
'On Error Resume Next
'wmp1.Controls.stop
wmp1.Close
'Set wmp1 = Nothing
End
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    '断开连接并退出
    If ComPort.PortOpen = True Then ComPort.PortOpen = False
    wmp1.Close

End
End Sub

Private Sub cmdConnect_Click()

    '查找指定端口
    Dim i As Integer
    For i = 1 To 4
        If optComPort(i - 1).Value = True Then
            ComPort.CommPort = i
            Exit For '跳出循环
        End If
    Next
    
    If ComPort.PortOpen = True Then ComPort.PortOpen = False  '如果端口打开则先关闭
    ComPort.PortOpen = True  '然后打开
    
    '状态信息
    lblStatus = "已连接..."
    
    cmdConnect.Enabled = False
    cmdDisconnect.Enabled = True
    
End Sub

Private Sub cmdDisconnect_Click()

    '断开连接
    If ComPort.PortOpen = True Then ComPort.PortOpen = False
    
    lblStatus = "已断开..."
    
    cmdDisconnect.Enabled = False
    cmdConnect.Enabled = True
    
End Sub

Private Sub cmdExit_Click()

    '先断开端口再退出程序
    If ComPort.PortOpen = True Then ComPort.PortOpen = False
        Unload Me
    End

End Sub

'串口时间
Private Sub ComPort_OnComm()
    '如果已经接收数据，则继续
   On Error Resume Next
    If ComPort.CommEvent <> comEvReceive Then Exit Sub
     
    '读取数据
    sInTemp = ComPort.Input

    
    sBarcodeTemp = sBarcodeTemp & sInTemp
    
    'Text1.Text = sBarcodeTemp

    If Right$(sBarcodeTemp, 2) = vbNewLine Then
    
        'If chkWedge Then SendKeys sBarcodeTemp
     sBarcodeTemp = Left$(sBarcodeTemp, Len(sBarcodeTemp) - 2)
        
        
        '把条码放到文本框
       txtBarcode = sBarcodeTemp
       Form2.Text7 = sBarcodeTemp
        'Mo.Value = txtBarcode
       If txtBarcode = k6 Then
        If File1.ListIndex < File1.ListCount - 1 Then
        File1.ListIndex = File1.ListIndex + 1
        Call File1_Click
End If
End If
          If txtBarcode = k5 Then
          If File1.ListIndex > 0 Then
        File1.ListIndex = File1.ListIndex - 1
        Call File1_Click
 End If
 End If
If txtBarcode = k7 Then
 wmp1.settings.volume = wmp1.settings.volume + 3
 Text3.Text = wmp1.settings.volume
       End If
If txtBarcode = k2 Then
   If Drive1.ListIndex < Drive1.ListCount Then
   Drive1.ListIndex = Drive1.ListIndex + 1
   Call Drive1_Change
   End If
   End If
   
 If txtBarcode = k1 Then

   If Drive1.ListIndex > 0 Then
   Drive1.ListIndex = Drive1.ListIndex - 1
   Call Drive1_Change
   End If
   End If
   
    If txtBarcode = k4 Then

   If Dir1.ListIndex < Dir1.ListCount - 1 Then
   Dir1.ListIndex = Dir1.ListIndex + 1
   End If
   End If
   If txtBarcode = k3 Then

   If Dir1.ListIndex > -1 Then
   Dir1.ListIndex = Dir1.ListIndex - 1
   End If
   End If
   
    If txtBarcode = k9 Then

   
 Dir1.Path = Dir1.List(Dir1.ListIndex)
 End If
If txtBarcode = k10 Then

 On Error Resume Next
 Dir1.Path = "c:\"
 Dir1.Path = Drive1
 End If
   If txtBarcode = k8 Then


        wmp1.settings.volume = wmp1.settings.volume - 3
        Text3.Text = wmp1.settings.volume
        End If
        
        If txtBarcode = k13 Then
          If wmp1.fullScreen = True Then

        wmp1.fullScreen = False
        Else
        wmp1.fullScreen = True
        End If
        
        End If
        
          
      If txtBarcode = k12 Then

If wmp1.settings.mute = True Then
        wmp1.settings.mute = False
        Else
       wmp1.settings.mute = True
       End If
       End If
      If txtBarcode = k11 Then

If wmp1.playState = wmppsPlaying Then
wmp1.Controls.Pause
Else
If wmp1.playState = wmppsPaused Then
wmp1.Controls.play
End If
   End If
   End If
        '放到列表框
       'lstBarcodes.AddItem sBarcodeTemp, 0
        
        
       sBarcodeTemp = ""
        
        
        '状态
        lblStatus = "连接控制器成功！"

    End If
       
End Sub

Private Sub Timer1_Timer()

Text2 = wmp1.currentMedia.durationString
Text1 = wmp1.Controls.currentPositionString

End Sub
Private Sub wmp1_PlayStateChange(ByVal NewState As Long)
If NewState = 1 Then '1为停止(一曲播完)
 If File1.ListIndex < File1.ListCount - 1 Then
        File1.ListIndex = File1.ListIndex + 1
    
        Call File1_Click
     Pause (1)
End If
If File1.ListIndex = File1.ListCount - 1 Then
File1.ListIndex = 0
Call File1_Click
Pause (1)
End If
'wmp1.Controls.play
End If

End Sub
Public Sub Pause(interval)
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub