Форум » SURreal SoftWorks » Хитрости VB » Ответить
Хитрости VB
Damien: Хитрости Visual Basic 6.0
Ответов - 12, стр:
1 2 All
Damien: Как же выключить компьютер в 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. Пробуйте, у меня работает безотказно.
Damien: Замена системных цветов на свои собственные На пустую форму положите этот код: 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
Damien: Как ловить нажатия на клавиши вне вашей программы 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
Damien: Проверка файла на "заблоченность" ' пытается получить исключительный доступ к существующему файлу ' если неполучается или файл не существует - выдает 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
Damien: Глюк в 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 Возможно, это наблюдение окажется полезным разработчикам ПО.
Damien: Простой способ открыть файл, связанный с каким либо приложением 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)
Damien: Как таскать форму не за заголовок, а за любое место Не пугайтесь, никакого громоздкого кода на событе 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
Damien: Как поместить форму поверх других форм 'Поместите в модуль 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)
Damien: Сделать программу невидимой в списке задач 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
Damien: Вывод на экран постоянного показа позиции курсора в 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
4eloveku_Wolk: круто
ALiRT: Гым..не плохие советики...надо бы продолжить....
полная версия страницы