Функции API
Удаление из системного меню подменю Close и одновременное гашение 'крестика' на форме.
Private Declare
Function GetSystemMenu Lib
"user32" (ByVal hwnd As
Long, ByVal bRevert As
Long) As Long
Private Declare
Function RemoveMenu Lib "user32"
(ByVal hMenu As Long,
ByVal nPosition As Long,
_
ByVal wFlags As Long)
As Long
Const MF_BYPOSITION = &H400&
Public Sub RemoveCloseMenu(frm As Form)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(frm.hwnd, 0)
Call RemoveMenu(hSysMenu, 6, MF_BYPOSITION)
Call RemoveMenu(hSysMenu, 5, MF_BYPOSITION)
End Sub
Private Sub Form_Load()
RemoveCloseMenu
Me
End Sub
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
Открытие:
Call mciSEndString("Set CDAudio Door Open Wait", 0&, 0&,
0&)
Закрытие:
Call mciSEndString("Set CDAudio Door Closed Wait", 0&, 0&,
0&)
Операции "копировать", "вырезать", "вставить".
Копировать:
On Error
Resume Next
Clipboard.SetText ВАШ
ТЕКСТБОКС.SelText
Вырезать:
On Error Resume Next
Clipboard.SetText ВАШ
ТЕКСТБОКС.SelText
ВАШ
ТЕКСТБОКС.SelText = vbNullString
Вставить:
On Error Resume Next
ВАШ
ТЕКСТБОКС.SelText = Clipboard.GetText
Открытие стандартного диалогового окна выбора каталога.
Для работы примера на форме Form1 поставьте кнопку Сommand1 и текстбокс Text1.
В модуле:
Public Type BROWSEINFO
hOwner As
Long
pidlRoot As Long
pszDisplayName
As String
lpszTitle As
String
ulFlags As Long
lpfn As Long
lParam As
Long
iImage As Long
End Type
Public Declare Function
SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As
Long
Public Const BIF_RETURNONLYFSDIRS = &H1
В форме:
Private Sub
Command1_Click()
Dim myBrowseInfo As BROWSEINFO
Dim
execNumderDir As Boolean
Dim NumderDir As Long
Dim pos As
Integer
Dim myPath_512 As String
With myBrowseInfo
.hOwner = Me.hWnd
.pidlRoot =
0&
.lpszTitle = "Выберите директорию"
.ulFlags =
BIF_RETURNONLYFSDIRS
End With
NumderDir& =
SHBrowseForFolder(myBrowseInfo)
myPath_512$ = Space$(512)
execNumderDir =
SHGetPathFromIDList(ByVal NumderDir&, ByVal myPath_512$)
If execNumderDir Then
pos =
InStr(myPath_512$, Chr$(0))
myPath = Left(myPath_512$, pos - 1)
Else
myPath = ""
End If
Text1.Text =
myPath
End
Sub
Определение разрешения и количества цветов дисплея.
В модуле:
Declare Function
GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Declare Function
GetDesktopWindow Lib "user32" () As Long
Declare Function
GetDC Lib "user32" (ByVal
hwnd As Long) As
Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Const HORZRES =
8
Public Const VERTRES
= 10
Public Const
BITSPIXEL = 12
Public Sub GetVideoMode(ByRef Width As Long, ByRef Height As Long,
ByRef Depth As Long)
Dim hDC As Long
hDC =
GetDC(GetDesktopWindow())
Width = GetDeviceCaps(hDC, HORZRES)
Height =
GetDeviceCaps(hDC, VERTRES)
Depth = GetDeviceCaps(hDC,
BITSPIXEL)
ReleaseDC GetDesktopWindow(), hDC
End Sub
Использование:
Dim Width As Long, Height As Long,
Depth As
Long
GetVideoMode Width, Height, Depth
Примечание: В переменной Depth возвращается не количество цветов, а количество битов на один пиксель. Т.е. 16 цветам соответствует 4 бита на пиксель, 256 - 8 бит, 65536 - 16 бит и т.д.
Изменение текущего роазрешения экрана и кол-ва
цветов
В модуле:
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH =
&H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CCHDEVICENAME =
32
Public Const
CCHFORMNAME = 32
Type DEVMODE
dmDeviceName
As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As
Integer
dmSize As Integer
dmDriverExtra
As Integer
dmFields As
Long
dmOrientation As
Integer
dmPaperSize As
Integer
dmPaperLength As
Integer
dmPaperWidth As Integer
dmScale
As Integer
dmCopies As
Integer
dmDefaultSource As
Integer
dmPrintQuality As
Integer
dmColor As Integer
dmDuplex
As Integer
dmYResolution As
Integer
dmTTOption As Integer
dmCollate
As Integer
dmFormName As
String * CCHFORMNAME
dmUnusedPadding As
Integer
dmBitsPerPel As
Integer
dmPelsWidth As Long
dmPelsHeight
As Long
dmDisplayFlags As
Long
dmDisplayFrequency As Long
End Type
Declare Function ChangeDisplaySettings Lib "user32.dll" Alias
_
"ChangeDisplaySettingsA" (lpDevMode As DEVMODE, ByVal dwFalgs As Long) As Long
Public Sub SetVideoMode(Width As
Long, height As Long, Depth As Long)
Dim dm As DEVMODE
dm.dmPelsWidth = Width
dm.dmPelsHeight =
height
dm.dmBitsPerPel = Depth
dm.dmSize = Len(dm)
dm.dmFields =
DM_PELSWIDTH + DM_PELSHEIGHT + DM_BITSPERPEL
ChangeDisplaySettings dm,
0
End Sub
Использование:
SetVideoMode 1024, 768, 8
'Устанавливает видеорежим
1024x768 c 256 цветами.
Примечание: Указывается не количество цветов, а количество битов на один пиксель. Т.е. 16 цветам соответствует 4 бита на пиксель, 256 - 8 бит, 65536 - 16 бит и т.д.