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

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\06 Массивы\la_array.mdb
 Язык интерфейса: Русский

   

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 As String * 30
    mciSendString "status MP3Play mode", s, Len(s), 0
    IsPlaying = (Mid$(s, 1, 7) = "playing")
End Function

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access