Программирование на Visual Basic

Данный пример показывает, как можно хранить в базе данных информацию по музыке, а в случае ее необходимости проиграть. Проигрыватель сделан ввиде элипса, используя этот метод можно создать его любой формы.

Private Sub Form_Load()
Dim hRgn As Long    'Область окна
Dim x0 As Long, y0 As Long, ww As Long, hh As Long
Dim scrX As Long 'Коэффициент перевода в пикселы
Dim scrY As Long 'Коэффициент перевода в пикселы
Dim frmhwnd As Long, frmhdc As Long
    
    ' Очистить сообщения
    DoEvents
    
    ' Определяем размеры окна и область отсечения
    frmhwnd = apiFindWindowEx(Me.hWnd, apiFindWindowEx(Me.hWnd, 0, "OFormSub", ""), "OFormSub", "")
    If frmhwnd = 0 Then Exit Sub
    
    ' Определяем контекст устройства
    frmhdc = apiGetDC(frmhwnd)
    
    'Определяем размеры области отсечения
    'Число твипов в пикселах
    scrX = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSX)
    scrY = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSY)
    With Me.Controls("myPicture")
        x0 = .Left / scrX '+ 1 'Позиция в пикселах
        y0 = .Top / scrY '+ 1 'Позиция в пикселах
        ww = .Width / scrX - 1 'Ширина таймера
        hh = .Height / scrY - 1 'Высота таймера
    End With
    Call apiReleaseDC(frmhwnd, frmhdc)
    hRgn = apiCreateEllipticRgn(x0, y0, ww, hh) 'Область отсечения
    
    'Отрезаем лишнее от окна
    If hRgn  0 Then
       Call apiSetWindowRgn(Me.hWnd, hRgn, True)
    End If
    
End Sub

' leadersoft.ru - v01 от 02.03.2001
Private Sub Form_Open(Cancel As Integer)
    ' При открытии запускаем проигрыватель
    nFileName = Application.CurrentProject.Path  "\Flaming Star.mp3"
    If Dir(nFileName, vbNormal)  "" Then
        Me.butExit.SetFocus
        Me.butSelect.Enabled = False
        MP3Play Me.hWnd, nFileName
    End If
End Sub

' Определяем режим движения окна
' leadersoft.ru - v01 от 02.03.2001
Private Sub myPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    apiReleaseCapture 'Эмуляция захвата окна
    Call apiSendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MOVE_MOUSE, 0)
End Sub

'Это просто остановка программы
Private Sub butVBA_Click()
    Stop
End Sub

'
' Сайт: http://www.vbforums.com/archive/index.php/t-272432.html
'
Public Function MP3Play(wndHandle As Long, sFileName As String)
Dim cmdToDo As String * 255
Dim dwReturn As Long
Dim ret As String * 128
Dim tmp As String * 255
Dim lenShort As Long
Dim ShortPathAndFie As String, glo_HWND As Long

    If Dir(sFileName) = "" Then
        mmOpen = "Error with input file"
        Exit Function
    End If
    lenShort = GetShortPathName(sFileName, tmp, 255)
    ShortPathAndFie = Left$(tmp, lenShort)
    glo_HWND = wndHandle
    cmdToDo = "open "  ShortPathAndFie  " type MPEGVideo Alias MP3Play"
    dwReturn = mciSendString(cmdToDo, 0, 0, 0)
    If dwReturn  0 Then 'not success
        mciGetErrorString dwReturn, ret, 128
        mmOpen = ret
        MsgBox ret, vbCritical
        Exit Function
    End If
    mmOpen = "Success"
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Pause()
    mciSendString "pause MP3Play", 0, 0, 0
End Function

Public Function MP3UnPause()
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Stop() As String
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "close MP3Play", 0, 0, 0
End Function


Private Sub butExit_Click()
    DoCmd.Close acForm, Me.Form.Name
End Sub

Private Sub butSelect_Click()
    Me.butExit.SetFocus
    butSelect.Enabled = False
'    butExit.Enabled = False
    Open_file
End Sub

Private Sub butPause_Click()
    Me.butExit.SetFocus
    If butPause.Caption = "Пауза" Then
        butPause.Caption = "Играть "
        MP3Pause
    Else
        butPause.Caption = "Пауза"
        MP3UnPause
    End If
End Sub

Private Sub butStop_Click()
    Me.butExit.SetFocus
    butPause.Enabled = False
    butStop.Enabled = False
    butStart.Enabled = False
    butSelect.Enabled = True
    butPause.Caption = "Пауза"
    MP3Stop
End Sub

Private Sub butStart_Click()
    Me.butExit.SetFocus
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "play MP3Play from 0", 0, 0, 0
    butPause.Caption = "Пауза"
End Sub

' Срабатывает, когда заканчивается музыка
Private Sub Form_Timer()
    If IsPlaying = False And butSelect.Enabled = False And butPause.Caption = "Пауза" Then
        butStop_Click
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    MP3Stop
End Sub

Private Sub Open_file()
Dim cderr As Long
    OFN.lStructSize = 76
    OFN.hwndOwner = Me.hWnd
    OFN.lpstrFilter = "mp3 (*.mp3)" + Chr(0) + "*.mp3" + Chr(0) + Chr(0)
    OFN.lpstrCustomFilter = String(256, Chr(0))
    OFN.nMaxCustFilter = 256
    OFN.lpstrFile = "" + String(512, Chr(0))
    OFN.nMaxFile = 512
    OFN.lpstrFileTitle = String(256, Chr(0))
    OFN.nMaxFileTitle = 256
    OFN.flags = OFN_FILEMUSTEXIST + OFN_HIDEREADONLY
    '************
    DoEvents
    '************
    If GetOpenFileName(OFN) Then
        OFN.lpstrFile = Mid(OFN.lpstrFile, 1, InStr(OFN.lpstrFile, Chr(0)) - 1)
        nFileName = OFN.lpstrFile
        OFN.lpstrFileTitle = Mid(OFN.lpstrFileTitle, 1, InStr(OFN.lpstrFileTitle, Chr(0)) - 1)
        InitialDir = Left(OFN.lpstrFile, Len(OFN.lpstrFile) - Len(OFN.lpstrFileTitle))
    Else
        cderr = CommDlgExtendedError
        GoTo ex
    End If
    MP3Play hWnd, nFileName
    butPause.Enabled = True
    butStop.Enabled = True
    butStart.Enabled = True
    butExit.Enabled = True
    Exit Sub
ex:
    butSelect.Enabled = True
    butExit.Enabled = True
End Sub

' Проверка игры
Public Function IsPlaying() As Boolean
    Static s As String * 30
    mciSendString "status MP3Play mode", s, Len(s), 0
    IsPlaying = (Mid$(s, 1, 7) = "playing")
End Function