> НАЗАД <
VB Примеры
Модули:
-
Работа с реестром - (1,16 Кб)
-
Работа с *.ini файлами - (1,10 Кб)
-
...
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 |
Updated: 05.2003 |