Отправлено: 02.06.06 02:08. Заголовок: Хитрости VB

Хитрости Visual Basic 6.0

 Отправлено: 02.06.06 02:09. Заголовок: Re:

Как же выключить компьютер в Windows XP® ?

Я долго искал способ выключить компьютер в Windows XP…
Например: функция ExitWindows() вообще сдохла, а ExitWindowsEx() делает только LOGOFF.
И однажды нашёл на одном форуме:


Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate, _
(Shutdown)}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery( _
"Select * from Win32_OperatingSystem")
For Each ObjOperatingSystem In colOperatingSystems
ObjOperatingSystem.Reboot ' Для перезагрузки
Next


и…

Dim strComputer As String

strComputer = "."

Set objWMIService = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery( _
"Select * from Win32_OperatingSystem")

For Each ObjOperatingSystem In colOperatingSystems

ObjOperatingSystem.ShutDown 'Для выключения

Next



Примечание:
Данный код работает и для VBScript…
P.S.
Пробуйте, у меня работает безотказно.

 Отправлено: 02.06.06 02:11. Заголовок: Re:

Замена системных цветов на свои собственные

На пустую форму положите этот код:


Option Explicit
Private Declare Function SetSysColors Lib "user32" _
(ByVal nChanges As Long, lpSysColor As _
Long, lpColorValues As Long) As Long

Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)


'Можно использовать следующие константы

Private Const COLOR_SCROLLBAR = 0 'The Scrollbar colour
Private Const COLOR_BACKGROUND = 1 'Colour of the background with no wallpaper
Private Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window
Private Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window
Private Const COLOR_MENU = 4 'Menu
Private Const COLOR_WINDOW = 5 'Windows background
Private Const COLOR_WINDOWFRAME = 6 'Window frame
Private Const COLOR_MENUTEXT = 7 'Window Text
Private Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)
Private Const COLOR_CAPTIONTEXT = 9 'Text in window caption
Private Const COLOR_ACTIVEBORDER = 10 'Border of active window
Private Const COLOR_INACTIVEBORDER = 11 'Border of inactive window
Private Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop
Private Const COLOR_HIGHLIGHT = 13 'Selected item background
Private Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item
Private Const COLOR_BTNFACE = 15 'Button
Private Const COLOR_BTNSHADOW = 16 '3D shading of button
Private Const COLOR_GRAYTEXT = 17 'Grey text, of zero if dithering is used.
Private Const COLOR_BTNTEXT = 18 'Button text
Private Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window
Private Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button

Dim OldColor As Long

Private Sub Form_Load()
'Эапоминаем текущий цвет
OldColor = GetSysColor(COLOR_ACTIVECAPTION)

SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 0, 0)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Восстанавливаем текущий цвет
SetSysColors 1, COLOR_ACTIVECAPTION, OldColor
End Sub

 Отправлено: 02.06.06 02:12. Заголовок: Re:

Как ловить нажатия на клавиши вне вашей программы

1. Положите на форму таймер, поставьте интервал в 50
2. Добавьте в модуль:


Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Public Const VK_TAB = &H9 ' Константа для TAB key.
' константы для других кнопок посмотрите в API вьювере
' Поместите в событие Timer:
If GetAsyncKeyState(VK_TAB) And KEY_SHIFT = True Then
msgboх "Кто то трогает ТАБ", vbinformation
End If

 Отправлено: 02.06.06 02:14. Заголовок: Re:

Проверка файла на "заблоченность"


' пытается получить исключительный доступ к существующему файлу
' если неполучается или файл не существует - выдает FALSE
' использовать можно свободно
' ************************************************************************************
Public Const OPEN_EXISTING = 3
Public Const FILE_ATTRIBUTE_NORMAL = &H80&

Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Public Function IsFreeFile(ByVal sLongFileName As String) As Boolean
Dim hfile As Long
IsFreeFile = False
hfile = CreateFile(sLongFileName, 0, 0, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If hfile <> -1 Then
IsFreeFile = True
End If
CloseHandle hfile
End Function

 Отправлено: 02.06.06 02:15. Заголовок: Re:

Глюк в ExistDir

При разработке приложений в VB или VBA часто возникает потребность в функциях ExistFile и ExistDir, проверяющих существование файла или папки. В литературе встречаются такие примеры:


Public Function ExistFile(ByVal strFileName As String) As Boolean
ExistFile = False
On Error GoTo f1
ExistFile = (Dir(strFileName) <> "")
f1:
On Error GoTo 0
End Function

Public Function ExistDir(ByVal dirName As String) As Boolean
ExistDir = False
On Error GoTo f1
If Len(dirName) < 2 Then GoTo f1
If Right(dirName, 1) = "\" Then dirName = Left(dirName, Len(dirName) - 1)
ExistDir = (Dir(dirName, vbDirectory) <> "")
f1:
On Error GoTo 0
End Function


Однако, при попытке применить функцию ExistDir к сетевым путям, обнаруживается, что она работает неверно, возвращая, например, False для существующей папки \\MAIN\POST$.
Небольшая модификация этой фунции позволяет использовать ее как для обычных, так и сетевых путей:

Public Function ExistDir(ByVal dirName As String) As Boolean
ExistDir = False
On Error GoTo f1
If Len(dirName) < 2 Then GoTo f1
If Right(dirName, 1) = "\" Then dirName = Left(dirName, Len(dirName) - 1)
If Left(dirName, 2) = "\\" Then
ExistDir = (Dir(dirName + "\", vbDirectory) <> "")
Else
ExistDir = (Dir(dirName, vbDirectory) <> "")
End If
f1:
On Error GoTo 0
End Function


Возможно, это наблюдение окажется полезным разработчикам ПО.

 Отправлено: 02.06.06 02:16. Заголовок: Re:

Простой способ открыть файл, связанный с каким либо приложением Windows

Под Windos NT:


Shell "cmd /X /C start c:\mydoc\example.doc"


Под Windos 9x:

Shell "start c:\mydoc\example.doc"


При способе, предложенном Автором появляется минимизированое окно Command Prompt.
Не всем юзерам это нравиться. Как альтернативу можно использовать
API функцию ShellExecute. Для этого необходимо испльзовать декларацию:

' Декларация функции для запуска файла.
Public Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

' Декларация константы для максимизирования окна открываемого приложения.
' Для работы с другими константами смотрите MSDN.
Public Const SW_SHOWMAXIMIZED = 3

'После этого нижеследующий код будет открывать файл test.xls.

Call ShellExecute(0, "open", "test.xls","", "", SW_SHOWMAXIMIZED)

 Отправлено: 02.06.06 02:18. Заголовок: Re:

Как таскать форму не за заголовок, а за любое место

Не пугайтесь, никакого громоздкого кода на событе MouseMove,
с отслеживанием положения мыши. Все, как обычно просто:


Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
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
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
Call SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub


Увидел у Вас на странице пример кода для перемещения окна не за заголовок
и решил прислать свой вариант.
Используется объект Image с именем imgMove. Объект может любой.

Public BarX
Public BarY

Private Sub imgMove_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If Button = 1 Then BarY = Y: BarX = X
End Sub

Private Sub imgMove_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)

If Button = 1 Then
frmMain.Top = frmMain.Top + Y - BarY
frmMain.Left = frmMain.Left + X - BarX
end if

End Sub

 Отправлено: 02.06.06 02:19. Заголовок: Re:

Как поместить форму поверх других форм


'Поместите в модуль
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOPMOST = -1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1

Public Sub SetFormPosition(frmHandl As Long, TopPosition As Boolean)
If TopPosition Then
SetWindowPos frmHandl, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
Else
SetWindowPos frmHandl, HWND_NOTOPMOST, 0, 0, 0, 0, _
SWP_NOSIZE Or SWP_NOMOVE
End If
End Sub
'Поместите на форму в любой процедуре
call SetFormPosition(Me.hwnd, True)

 Отправлено: 02.06.06 02:24. Заголовок: Re:

Сделать программу невидимой в списке задач Windows 9х


Option Explicit
Private Declare Function RegisterServiceProcess Lib "kernel32.dll" _
(ByVal dwProcessId As Long, ByVal dwType As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long

Private Sub toVisible()
Call RegisterServiceProcess(GetCurrentProcessId, 0)
End Sub

Private Sub toInvisible()
Call RegisterServiceProcess(GetCurrentProcessId, 1)
End Sub

 Отправлено: 02.06.06 02:38. Заголовок: Re:

Вывод на экран постоянного показа позиции курсора в ToolTyp'е

В своей программке столкнулся с необходимостью вывода на экран постоянного
показа позиции курсора в ToolTyp'е.
Я думаю, что этот пример подойдет для твоего раздела хитростей:

1. Создаем форму Form1, размещаем на ней PictureBox с именем Picture1. Вводим код:


Option Explicit
Private clsPictureBox1 As Class1

Private Sub Form_Load()
Set clsPictureBox1 = New Class1
Set clsPictureBox1.Coordinat = Picture1
End Sub


2. Создаем модуль класса Class1 и размещаем в нем код:

Option Explicit

Private WithEvents pic As PictureBox

Public Property Set Coordinat(OutsidePictureBox As PictureBox)
Set pic = OutsidePictureBox
End Property

Private Sub pic_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
pic.ToolTipText = "X = " & X & "; Y = " & Y
End Sub