VB Примеры

Программирование - VB
Печать
Рейтинг пользователей: / 28
ХудшийЛучший 
  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