> НАЗАД <



 VB Примеры


 

Примеры:

  1. Простой пример - как записать звук с микрофона

  2. Как можно через библиотеку winmm.dll померить время

  3. Как управлять кареткой СD-ROM-а

  4. Как определить начилие аудиокарты

  5. Как вычислить факториал числа

  6. Как спрятать "Таскбар"

  7. Как узнать размеры Таскбара

  8. Как минимизировть все открытые окна или восстановить их обратно

  9. Приложение не выгружается из памяти

  10. Как отловить нажатие TAB

  11. ...

 

Модули:

 


 

1. Простой пример - как записать звук с микрофона  


Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As
String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub cmdPlay_Click()
Dim L As Long, Res As String, cb As Long
On Error Resume Next
Res = Space$(128)
L = mciSendString("open new type waveaudio alias sound", Res, 128, cb)
L = mciSendString("set sound time format ms format tag pcm channels 1
samplespersec 22050 bytespersec 44100 alignment 2
bitspersample 16", Res, 128, cb)

L = mciSendString("record sound", Res, 128, cb)
End Sub

Private Sub cmdStop_Click()
Dim L As Long, Res As String, cb As Long
On Error Resume Next
Res = Space$(128)
L = mciSendString("stop sound", Res, 128, cb)
L = mciSendString("close sound", Res, 128, cb)
End Sub

Наверх



2. Как можно через библиотеку winmm.dll померить время :


Private lngStart As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Sub StartTimer()
lngStart = timeGetTime
End Sub
Public Function StopTimer() As Long
StopTimer = (timeGetTime - lngStart)
End Function

Private Sub Command1_Click()
Print Time
StartTimer
Do While StopTimer < 1000
DoEvents
Loop
Print Time
Debug.Print StopTimer
End Sub

Точность такого измерения - во много раз выше точности обычного таймера . Впрочем это не таймер . Но на его основе можно наворотить.... 

Наверх



3. Как управлять кареткой СD-ROM-а.


Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long

'выезжает
Private Sub Command1_Click()
Call mciSendString("Set CDAudio Door Open Wait", 0&, 0&, 0&)
End Sub
'заезжает
Private Sub Command2_Click()
Call mciSendString("Set CDAudio Door Closed Wait", 0&, 0&, 0&)
End Sub

Наверх



4. Как определить начилие аудиокарты


Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

Private Sub Check_Click()
Dim rtn As Integer 'declare the needed variables
rtn = waveOutGetNumDevs() 'check for a sound card
If rtn = 1 Then 'Когда больше, чем 1- карта работает :-)
MsgBox "Your system supports a sound card."
Else 'А иначе карты нету :-(
MsgBox "Your system cannot play Sound Files."
End If
End Sub

 

Наверх


 

5. Как вычислить факториал числа:

n! = 1 * 2 * 3 * .... * n - реализация програмно:

 

Function Factorial(N as long ) as long 

If n > 1 Then 'Проверяем не дошли ли мы до конца нашей рекурсии 

    Factorial = n * Factorial(n - 1) 

Else 'Последний элемент рекурси 

    Factorial = n 

End If 

End function

Наверх


 

6. Как спрятать "Таскбар" (эта та самая полосочка внизу экрана, куда минимизируются окна)

 

Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
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

'и никаких Public деклараций внутри формы! Если функции 

'обьявлены в модуле, то там можно делать их Public 

 

Private Const WM_SHOWWINDOW = &H18 

Dim hWndTaskbar As Long 

Dim bShow As Boolean 

 

Private Sub Form_Click() 

    Dim r As Long 

    Dim i As Integer 

    i = 0 

    bShow = Not bShow 

    r = SendMessage(hWndTaskbar, WM_SHOWWINDOW, bShow, i) 

End Sub 

 

Private Sub Form_Load() 

    bShow = True 

    hWndTaskbar = FindWindow("shell_trayWnd", "") 

End Sub

 

Наверх


 

7. Как узнать размеры Таскбара:

 

Dim mLeft As Single 

Dim mTop As Single 

Dim mWidth As Single 

Dim mHeight As Single 

 

Private Declare Function FindWindow Lib "user32" Alias _

        "FindWindowA" (ByVal lpClassName As String,_

    ByVal lpWindowName As String) As Long 

Private Declare Function GetWindowRect Lib "user32" _

    (ByVal hwnd As Long, lprect As RECT) As Long 

 

Public Sub GetTascbarInfo() 

    Dim precTaskbar As RECT 

    Dim plngResult As Long 

    Dim phWndTaskbar As Long 

 

    phWndTaskbar = FindWindow("shell_trayWnd", "") 

    plngResult = GetWindowRect(phWndTaskbar, precTaskbar) 

    mLeft = precTaskbar.L * Screen.TwipsPerPixelX 

    mTop = precTaskbar.T * Screen.TwipsPerPixelY 

    mWidth = (precTaskbar.R - precTaskbar.L) * Screen.TwipsPerPixelX

    mHeight = (precTaskbar.B - precTaskbar.T) * Screen.TwipsPerPixelY

    Print mLeft, mTop, mHeight 

End Sub 

 

Private Sub Form_DblClick()

     GetTascbarInfo 

End Sub

 

Наверх


 

8. Как минимизировть все открытые окна, или восстановить их обратно:
 

Private Const WM_COMMAND = &H111
Private Const MIN_ALL = 419
Private Const MIN_ALL_UNDO = 416

Private Declare Function FindWindow Lib "user32" Alias _

    "FindWindowA" (ByVal lpClassName As String, _

    ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias _

    "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _

    ByVal wParam As Long, ByVal lParam As Long) As Long

Private Sub Command1_Click()
    Dim lRetVal As Long
    lRetVal = FindWindow("Shell_TrayWnd", vbNullString)
    lRetVal = PostMessage(lRetVal, WM_COMMAND, MIN_ALL, 0&)
End Sub

Private Sub Command2_Click()
    Dim lRetVal As Long
    lRetVal = FindWindow("Shell_TrayWnd", vbNullString)
    lRetVal = PostMessage(lRetVal, WM_COMMAND, MIN_ALL_UNDO, 0&)
End Sub

 

Наверх


 

9. Очень часто задаваемый вопрос: приложение не выгружается из памяти. Такой же частый ответ - что-то из обьектов не выгружено. Если вы используете DAO для доступа к базе данных, то вам не повредит такой код:

 

Private Sub Form_Unload(Cancel As Integer)

    On Error Resume Next

    Dim ws As Workspace
    Dim db As Database
    Dim rs As Recordset

    For Each ws In Workspaces
        For Each db In ws.Databases
            For Each rs In db.Recordsets
                rs.Close
                Set rs = Nothing
            Next
            db.Close
            Set db = Nothing
        Next
        ws.Close
        Set ws = Nothing
    Next
    '
End Sub

Наверх


10. Как отловить нажатие TAB?

Private Declare Function GetKeyState% Lib "User32" (ByVal nVirtKey%)

Private Sub Text1_LostFocus()
  If GetKeyState(vbKeyTab) < 0 Then
    Text1.SetFocus
    MsgBox "Tab Нажали!"
  End If
End Sub
Наверх




 

 

Продолжение следует ...

 > НАЗАД <

 



 


DDA Software HOME page

ddasoft@narod.ru

Updated: 05.2003

 

Сайт управляется системой uCoz