11. Узнаем свой IP адрес - Visual Basic
Private Sub Form_Load() MsgBox "IP Host Name: " & GetIPHostName() MsgBox "IP Address: " & GetIPAddress() End Sub 'Добавьте модуль в проект Public Const MAX_WSADescription = 256 Public Const MAX_WSASYSStatus = 128 Public Const ERROR_SUCCESS As Long = 0 Public Const WS_VERSION_REQD As Long = &H101 Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF& Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF& Public Const MIN_SOCKETS_REQD As Long = 1 Public Const SOCKET_ERROR As Long = -1 Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Public Type WSADATA wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim HOST As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim sIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If sHostName = Trim$(sHostName) lpHost = gethostbyname(sHostName) If lpHost = 0 Then GetIPAddress = "" MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name." SocketsCleanup Exit Function End If CopyMemory HOST, lpHost, Len(HOST) CopyMemory dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen For i = 1 To HOST.hLen sIPAddr = sIPAddr & tmpIPAddr(i) & "." Next GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) SocketsCleanup End Function Public Function GetIPHostName() As String Dim sHostName As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPHostName = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1) SocketsCleanup End Function Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Sub SocketsCleanup() If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup." End If End Sub Public Function SocketsInitialize() As Boolean Dim WSAD As WSADATA Dim sLoByte As String Dim sHiByte As String If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then MsgBox "The 32-bit Windows Socket is not responding." SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then sHiByte = CStr(HiByte(WSAD.wVersion)) sLoByte = CStr(LoByte(WSAD.wVersion)) MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets." SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function Наверх 12. Определение имени или IP-адреса удаленного компьютера - Visual Basic
'Вначале вы должны инициализировать winsock WinsockInit 'Определение имени машины, зная ее IP-адрес MsgBox HostByAddress("10.244.6.165") 'Определение IP-адреса машины, зная ее имя MsgBox HostByName("STUART") 'В конце работы вы должны использовать функцию WSACleanUp WSACleanUp 'КОД МОДУЛЯ Option Explicit Public Const SOCKET_ERROR = -1 Public Const AF_INET = 2 Public Const PF_INET = AF_INET Public Const MAXGETHOSTSTRUCT = 1024 Public Const SOCK_STREAM = 1 Public Const MSG_PEEK = 2 Private Type SockAddr sin_family As Integer sin_port As Integer sin_addr As String * 4 sin_zero As String * 8 End Type Private Type T_WSA wVersion As Integer wHighVersion As Integer szDescription(0 To 255) As Byte szSystemStatus(0 To 128) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As Long End Type Dim WSAData As T_WSA Type Inet_Address Byte4 As String * 1 Byte3 As String * 1 Byte2 As String * 1 Byte1 As String * 1 End Type Public IPStruct As Inet_Address Public Type T_Host h_name As Long h_aliases As Long h_addrtype As Integer h_length As Integer h_addr_list As Long End Type Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&) Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long Declare Function inet_addr Lib "wsock32.dll" (ByVal addr As String) As Long Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" ByVal HostName As String) As Long Declare Function GetHostName Lib "wsock32.dll" Alias "gethostname" (ByVal HostName As String, HostLen As Long) As Long Declare Function WSAStartup Lib "wsock32.dll" (ByVal a As Long, b As T_WSA) As Long Declare Function WSACleanUp Lib "wsock32.dll" Alias "WSACleanup" () As Integer Function HostByName(sHost As String) As String Dim s As String Dim p As Long Dim Host As T_Host Dim ListAddress As Long Dim ListAddr As Long Dim Address As Long s = String(64, 0) p = GetHostByName(sHost) If p = SOCKET_ERROR Then Exit Function Else If p <> 0 Then CopyMemory Host.h_name, ByVal p, Len(Host) ListAddress = Host.h_addr_list CopyMemory ListAddr, ByVal ListAddress, 4 CopyMemory Address, ByVal ListAddr, 4 HostByName = InetAddrLongToString(Address) Else HostByName = "No DNS Entry" End If End If End Function Private Function InetAddrLongToString(Address As Long) As String CopyMemory IPStruct, Address, 4 InetAddrLongToString = CStr(Asc(IPStruct.Byte4)) + "." + CStr(Asc(IPStruct.Byte3)) + "." + CStr(Asc(IPStruct.Byte2)) + "." + CStr(Asc(IPStruct.Byte1)) End Function Function HostByAddress(ByVal sAddress As String) As String Dim lAddress As Long Dim p As Long Dim HostName As String Dim Host As T_Host lAddress = inet_addr(sAddress) p = gethostbyaddr(lAddress, 4, PF_INET) If p <> 0 Then CopyMemory Host, ByVal p, Len(Host) HostName = String(256, 0) CopyMemory ByVal HostName, ByVal Host.h_name, 256 If HostName = "" Then HostByAddress = "Unable to Resolve Address" HostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1) Else HostByAddress = "No DNS Entry" End If End Function Public Sub WinsockInit() WSAStartup &H101, WSAData End Sub Наверх 13. Как заполнить ComboBox всеми шрифтами, которые установленны в системе? - Visual Basic
Private Sub Form_Load() Dim I As Integer For I = 0 To Screen.FontCount - 1 Combo1.AddItem Screen.Fonts(I) Next End Sub Наверх 14. Как заполнить ComboBox буквами доступных дисков? в VB
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long Private Sub Form_Load() FillCombo Combo1, True FillCombo Combo2, False End Sub Private Sub FillCombo(cbo As ComboBox, ByVal bUsed As Boolean) Dim DriveNum As Long cbo.Clear For DriveNum = 0 To 25 If CBool(GetLogicalDrives And (2 ^ DriveNum)) = bUsed Then cbo.AddItem Chr$(Asc("A") + DriveNum) & ":" End If Next DriveNum End Sub Наверх 15. Изменение высоты ниспадающей части элемента ComboBox в VB
Function SetComboHeight(YourCombo As ComboBox, lDropDownHeight As Long) Dim oldscalemode As Integer If TypeOf YourCombo.Parent Is Frame Then Exit Function oldscalemode = YourCombo.Parent.ScaleMode YourCombo.Parent.ScaleMode = vbPixels MoveWindow YourCombo.hwnd, YourCombo.Left, YourCombo.Top, YourCombo.Width, lDropDownHeight, 1 YourCombo.Parent.ScaleMode = oldscalemode End Function Private Sub Form_Load() 'Замените значение '100' ниже на нужную вам высоту элемента ComboBox SetComboHeight Combo1, 100 End Sub Наверх 16. Cкриншот экрана, формы или контрола - Visual Basic
Не забудьте проверить, чтобы папка "C:\1\" существовала. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private 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 Public Sub Capture(control_hWnd As Long, fNAME As String, Optional OnlyToClipBoard As Boolean = False) On Error GoTo ErrorCapture Dim sp As RECT, x As Long If fNAME <> "" Then x = GetWindowRect(control_hWnd, sp) ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom If OnlyToClipBoard = False Then SavePicture Clipboard.GetData, fNAME End If End If Exit Sub ErrorCapture: MsgBox Err & ":Error in Caputre(). Error Message:" & Err.Description, vbCritical, "Warning" Exit Sub End Sub Private Sub ScrnCap(Lt, Top, Rt, Bot) On Error GoTo ErrorScrnCap Dim rWIDTH As Long, rHEIGHT As Long Dim SourceDC As Long, DestDC As Long, bHANDLE As Long, Wnd As Long Dim dHANDLE As Long, dm As DEVMODE rWIDTH = Rt - Lt rHEIGHT = Bot - Top SourceDC = CreateDC("DISPLAY", 0&, 0&, dm) DestDC = CreateCompatibleDC(SourceDC) bHANDLE = CreateCompatibleBitmap(SourceDC, rWIDTH, rHEIGHT) SelectObject DestDC, bHANDLE BitBlt DestDC, 0, 0, rWIDTH, rHEIGHT, SourceDC, Lt, Top, &HCC0020 Wnd = 0 OpenClipboard Wnd EmptyClipboard SetClipboardData 2, bHANDLE CloseClipboard DeleteDC DestDC ReleaseDC dHANDLE, SourceDC Exit Sub ErrorScrnCap: MsgBox Err & ":Error in ScrnCap(). Error Message:" & Err.Description, vbCritical, "Warning" Exit Sub End Sub Public Sub CaptureDesktop() On Error GoTo ErrorCaptureDesktop Dim dhWND As Long, sp As RECT, x As Long dhWND = GetDesktopWindow If dhWND <> 0 Then x = GetWindowRect(dhWND, sp) ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom End If Exit Sub ErrorCaptureDesktop: MsgBox Err & ":Error in CaptureDesktop. Error Message: " & Err.Description, vbCritical, "Warning" Exit Sub End Sub Private Sub Form_Load() Command1.Caption = "Экран" Command2.Caption = "Форма" Command3.Caption = "Кнопка" Command4.Caption = "Текстовое окно" End Sub Private Sub Command1_Click() On Error Resume Next Call CaptureDesktop SavePicture Clipboard.GetData, "C:\1\desktop.bmp" MsgBox "Картинка экрана сохранена в C:\1\desktop.bmp" End Sub Private Sub Command2_Click() On Error Resume Next Call Capture(Me.hwnd, "C:\1\form.bmp") MsgBox "Картинка формы сохранена в C:\1\form.bmp" End Sub Private Sub Command3_Click() On Error Resume Next Call Capture(Me.Command1.hwnd, "C:\1\button.bmp") MsgBox "Картинка кнопки сохранена в C:\1\button.bmp" End Sub Private Sub Command4_Click() On Error Resume Next Call Capture(Me.Dir1.hwnd, "C:\1\drv.bmp") MsgBox "Картинка DriveListBox сохранена в C:\1\drv.bmp" End Sub Наверх 17. Выделить кусок картинки в VB
Dim X1 As Integer, X2 As Integer, Y1 As Integer, Y2 As Integer Dim SelectBox As Boolean Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Picture1.DrawMode = 6 'Draw style to dots Picture1.DrawStyle = 2 'Check if a Select Box is already drawn If X2 > 0 Then Picture1.Line (X1, Y1)-(X2, Y2), , B 'Reset all the values to the current point X1 = X Y1 = Y X2 = X Y2 = Y End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'Проверить, нажата ли левая кнопка мыши If Button = 1 Then Picture1.Line (X1, Y1)-(X2, Y2), , B X2 = X Y2 = Y Picture1.Line (X1, Y1)-(X, Y), , B End If End Sub Наверх 18. Изменение фона рабочего стола Windows из VB
'с именем Cdlg и одну кнопку Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long Const SPI_SETDESKWALLPAPER = 20 Const SPIF_UPDATEINIFILE = &H1 Private Sub Command1_Click() Cdlg.DialogTitle = "Choose a bitmap" Cdlg.Filter = "Windows Bitmaps (*.BMP)|*.bmp|All Files (*.*)|*.*" Cdlg.ShowOpen SystemParametersInfo SPI_SETDESKWALLPAPER, 0, Cdlg.FileName, SPIF_UPDATEINIFILE End Sub Private Sub Form_Load() Command1.Caption = "Изменить Фон" End Sub Наверх 19. Скопировать содержимое PictureBox в буфер обмена - Visual Basic
Запустите проект, нажмите на кнопку. Затем откройте приложение Paint и нажмите сочетание клавиш Ctrl + V. Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long Private Const SRCCOPY = &HCC0020 Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function CountClipboardFormats Lib "user32" () As Long Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Public Enum EPredefinedClipboardFormatConstants [_First] = 1 CF_TEXT = 1 CF_BITMAP = 2 CF_METAFILEPICT = 3 CF_SYLK = 4 CF_DIF = 5 CF_TIFF = 6 CF_OEMTEXT = 7 CF_DIB = 8 CF_PALETTE = 9 CF_PENDATA = 10 CF_RIFF = 11 CF_WAVE = 12 CF_UNICODETEXT = 13 CF_ENHMETAFILE = 14 CF_HDROP = 15 CF_LOCALE = 16 CF_MAX = 17 [_Last] = 17 End Enum Public Function CopyEntirePictureToClipboard(ByRef objFrom As Object) As Boolean Dim lhDC As Long Dim lhBmp As Long Dim lhBmpOld As Long lhDC = CreateCompatibleDC(objFrom.hdc) If (lhDC <> 0) Then lhBmp = CreateCompatibleBitmap(objFrom.hdc, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY) If (lhBmp <> 0) Then lhBmpOld = SelectObject(lhDC, lhBmp) BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hdc, 0, 0, SRCCOPY SelectObject lhDC, lhBmpOld EmptyClipboard OpenClipboard 0 SetClipboardData CF_BITMAP, lhBmp CloseClipboard End If DeleteObject lhDC CopyEntirePictureToClipboard = True Else CopyEntirePictureToClipboard = False End If End Function Private Sub Command1_Click() Call CopyEntirePictureToClipboard End Sub Наверх 20. Преобразование и форматирования данных (функции) - Visual Basic
Функция | Действия
----------------------------------------------------------
Cbool | преобразует выражение в тип Boolean
---------------------------------------------------------
Cbyte | преобразует выражение в тип Byte
---------------------------------------------------------
Ccur | преобразует выражение в тип Currency
---------------------------------------------------------
CVdate | преобразует выражение в тип Date
---------------------------------------------------------
CDbl | преобразует выражение в тип Double
---------------------------------------------------------
Cint | преобразует выражение в тип Integer
---------------------------------------------------------
Clng | преобразует выражение в тип Long
---------------------------------------------------------
CSng | преобразует выражение в тип Single
---------------------------------------------------------
Cstr | преобразует выражение в тип String
---------------------------------------------------------
Cvar | преобразует выражение в тип Variant
---------------------------------------------------------
CVErr | Error
---------------------------------------------------------
CDec | преобразует выражение в тип данных Decimal
---------------------------------------------------------
Chr | Возвращает значение типа String,
| содержащее символ, соответствующий
| указанному коду символа.
---------------------------------------------------------
Hex | Возвращает значение типа String,
| задающее шестнадцатеричное
| представление указанного числа.
---------------------------------------------------------
Oct | Возвращает значение типа Variant (String),
| содержащее восьмеричное представление
| указанного числа.
----------------------------------------------------------
Str | позволяет перевести числовое значение в
| строковое. Делает почти то же самое,
| что и CStr(), но при этом вставляет
| пробел впереди для положительных чисел.
----------------------------------------------------------
Val | Ф-ия Val используется для преобразования
| строк, содержащих числа, в число.
----------------------------------------------------------
Format | форматирует выражение
----------------------------------------------------------
FormatPercent | форматирует выражение в процентном формате
----------------------------------------------------------
FormatCurrency | форматирует выражение в денежном формате
----------------------------------------------------------
FormatDateTime | форматирует дату или время
----------------------------------------------------------
FormatNumber | форматирует числовые выражения
----------------------------------------------------------
Примеры
Преобразовать из String в Integer и записать в переменную Integer
Dim str As String
Dim x As Integer
str = "1"
x = CInt(str)
Преобразовать из ASCII кода в символ
MsgBox Chr(65) 'Возвращает A
Пример использования функции CVdate
Dim A, retval
A="Июль 1,1990" 'выбираем дату
MsgBox = CVDate(A) 'преобразует результат в значение типа Date
Пример использования функции Hex
MsgBox Hex(2007) 'Возвращает 7D7
Пример использования функции Oct
MsgBox Oct(8) 'возвращает 10
Пример использования функции FormatPercent
MsgBox FormatPercent(5) 'возвращает 500,00%
Пример использования функции FormatNumber
MsgBox FormatNumber(200) 'возвращает 200,00
Пример использования функции FormatCurrency
MsgBox FormatCurrency(200) 'возвращает 200,00 р.
Наверх 21. Программно переключить клавиатуру с русского на английский и обратно - Visual Basic
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long Private Sub Command1_Click() ActivateKeyboardLayout 0, 0 End Sub Наверх 22. Работа с системным треем - Visual Basic
22.2 Как скрыть системный трей вместе с часами - Visual Basic 22.3 Добавление иконки в SystemTray средствами Visual Basic 22.4 Расширить/уменьшить системный трей - Visual Basic 22.1 Как скрыть показать часы в трее? - Visual Basic ==================================================== 'Кинье на форму 2 кнопки 'Вот код: Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Dim hnd As Long Private Sub Command1_Click() ShowWindow hnd, 0 End Sub Private Sub Command2_Click() ShowWindow hnd, 1 End Sub Private Sub Form_Load() hnd = FindWindow("Shell_TrayWnd", vbNullString) hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString) hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString) Command1.Caption = "Скрыть часы" Command2.Caption = "Показать часы" End Sub 22.2 Как скрыть системный трей вместе с часами - Visual Basic ==================================================== Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Dim hnd As Long Private Sub Command1_Click() ShowWindow hnd, 0 End Sub Private Sub Command2_Click() ShowWindow hnd, 1 End Sub Private Sub Form_Load() hnd = FindWindow("Shell_TrayWnd", vbNullString) hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString) Command1.Caption = "Скрыть" Command2.Caption = "Показать" End Sub 22.3 Добавление иконки в SystemTray средствами Visual Basic ==================================================== Автор: Кирилл Головин Эта статья является самодостаточной, то есть в ней дана исчерпывающая информация по созданию иконки в SystemTray с помощью VB. Однако при этом она является компиляцией общедоступных источников, то есть заслуга автора состоит лишь в сборе этой информации в одном месте и пояснениях. Основы создания иконки изложены в FAQ Льва Серебрякова. Используется пример на VB от Alexander Shherbakov. Описания функций и констант из книги Daniel Applemana и API.TXT. Вопросы связанные с редактором ресурсов не рассматриваются. Единственная функция для работы с иконкой Shell_NotifyIcon. Ее описание на VB выглядит так: Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _ (ByVal dwMessage As dwMess, lpData As NOTIFYICONDATA) As Long Возвращает ноль в случае ошибки Тип dwMess описывается так: Public Enum dwMess NIM_ADD = &H0 ' Добавление иконки NIM_DELETE = &H2 ' Удаление иконки NIM_MODIFY = &H1 ' Изменение параметров иконки End Enum Переменная dwMessage должна иметь одно из этих значений. Тип NOTIFYICONDATA имеет следующую структуру: Type NOTIFYICONDATA cbSize As Long ' Размер переменной типа NOTIFYICONDATA hwnd As Long ' Указатель окна создающего иконку uID As Long ' Указатель на иконку в пределах приложения uFlags As uF ' Маска для следующих параметров uCallbackMessage As CallMess ' Возвращаемое событие hIcon As Long ' Указатель на изображение для иконки szTip As String * 64 ' Всплывающий над иконкой текст End Type Где тип uF имеет вид: Public Enum uF NIF_MESSAGE = &H1 ' Значение имеет uCallbackMessage NIF_ICON = &H2 ' Значение имеет hIcon NIF_TIP = &H4 ' Значение имеет szTip End Enum Эти константы можно применять в любых сочетаниях, для определения какой из параметров имеет значение. Тип CallMess: Public Enum CallMess WM_MOUSEMOVE = &H200 WM_LBUTTONDOWN = &H201 WM_LBUTTONUP = &H202 WM_LBUTTONDBLCLK = &H203 WM_RBUTTONDOWN = &H204 WM_RBUTTONUP = &H205 WM_RBUTTONDBLCLK = &H206 WM_MBUTTONDOWN = &H207 WM_MBUTTONUP = &H208 WM_MBUTTONDBLCLK = &H209 WM_SETFOCUS = &H7 WM_KEYDOWN = &H100 WM_KEYFIRST = &H100 WM_KEYLAST = &H108 WM_KEYUP = &H101 End Enum Эти константы обозначают, какое событие возвращается вызывающей форме. Буквально, все, что будет происходить с иконкой, будет вызывать у формы одно из перечисленных событий. Ясно, что самое частое событие самой иконки это MouseMove, но для формы оно будет выглядеть как событие заданное переменной uCallbackMessage. Как же узнать, что в действительности произошло с иконкой? Это можно узнать через переменные X и Y событий MouseMove, MouseDown и MouseUp вызывающей формы. При этом Y, если событие произошло с иконкой, а не формой, всегда будет равно нулю, а X несет информацию о событии с иконкой. О параметре X следует сказать отдельно. Действительно, он передает информацию о событиях с иконкой, однако эти значения зависят от масштабного коэффициента системного шрифта, но не напрямую, а через параметр свойства TwipsPerPixelX объекта Screen. То есть для одной и той же системы, при разных величинах системного шрифта, значения будут разными. Начальными значениями событий являются следующие: MouseMove – 512 LeftButtonDown – 513 LeftButtonUp - 514 LeftButtonDblClick - 515 RightButtonDown - 516 RightButtonUp – 517 RightButtonDblClick - 518 Для того чтобы узнать действующие в данной системе значения их следует умножить на Screen.TwipsPerPixelX Как же узнать, что событие произошло с иконкой, а не с формой? Просто, по значению Y, равному нулю. Но есть и другой способ, если используется двухкнопочная мышь то параметр Button в событиях MouseDown и MouseUp формы, будет принимать значения 1 и 2, и при uCallbackMessage равно WM_MBUTTONDOWN=&H207 или WM_MBUTTONUP = &H208 Button равен 4, если событие с иконкой. Само собой разумеется, что возвращаемые X значения следуют одно за другим, как и события (Down->Up->DbClick),поэтому невозможно на одну кнопку мыши назначить два события, к примеру, Click и DbClick. События не связанные с мышью не несут практически ни какой информации, и обычно не используются, следует так же отметить, что количество констант uCallbackMessage намного больше и здесь приведена лишь небольшая часть Из описанного видно, что с иконкой можно совершить одно из следующих действий: добавить, модифицировать и удалить, при этом, модифицируя можно заменить возвращаемое событие, картинку (указатель при этом останется тем же) и всплывающую надпись (ToolTips). Следующий момент, который нужно осветить это получение hIcon (указателя на картинку). Предполагается, что иконка будет находится в исполняемом файле или в DLL с ресурсами, но ни в коем случае не валяется в виде ICO файла. Если иконка запакована в DLL, то нам понадобятся две функции: Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal _ lpLibFileName As String) As Long Возвращающая hInstance библиотеки с именем lpLibFileName. Достаточно указать только имя файла с расширением, без пути. Возвращает ноль в случае ошибки Declare Function LoadIconA Lib "user32" (ByVal hInstance As Long, ByVal _ lpIconName As String) As Long Возвращающая hIcon для иконки указанной параметром lpIconName в библиотеке. Этот параметр может быть String или Long, в зависимости от данного вами наименования в Res файле, соответственно надо изменить декларацию. Можно передать и число как строку, для этого перед числом ставится знак #, а все это берется в кавычки. Следует заметить, что использование срокового параметра не желательно из за значительно большего размера занимаемой памяти и соответственно, большего времени на передачу параметра. Функция возвращает ноль в случае ошибки Понадобится так же функция: Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Выгружающая библиотеку из памяти. Параметр hLibModule это hInstanse, возвращаемое LoadLibrary. Возвращает ноль в случае ошибки. Обязательно надо не забыть выгрузить из памяти библиотеку, для освобождения памяти. Выгрузку можно произвести сразу же после добавления иконки в SystemTray. Обязательно надо не забыть выгрузить из памяти библиотеку, для освобождения памяти. Выгрузку можно произвести сразу же после добавления иконки в SystemTray. Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _ (ByVal lpModuleName As String) As Long Возвращающей hInstanse нашего приложения. В качестве lpModuleName передается имя EXE файла с расширением. Следует быть внимательным, так как имя процесса в TaskMenager не всегда соответствует имени процесса для Windows. Я использую для определения имени DLLView, можно воспользоваться, встроенным в VB System Information. Функция возвращает действительное значение только при работе скомпилированного приложения, а в режиме отладки возвращает ноль, ведь реального процесса при отладке не существует. Свойство hInstanse объекта App всегда возвращает действительное значение, однако при отладке из за отсутствия процесса LoadIcon возвращает 0, и создается "пустая" иконка, тем не менее годная для отладки (реагирующая на все события). Полученное hInstanse передаем LoadIconA, в качестве lpIconName указываем номер или имя иконки в Res файле, как и в случае с DLL. Выгружать в этом случае ничего не надо. Создание иконки можно проиллюстрировать следующим примером. Считается, что иконка с номером 101 находится в файле Project1.exe. Понятно, что пока мы его не скомпилировали, ее там нет (да и самого файла нет). Форма приложения называется Form1. Dim NID As NOTIFYICONDATA Sub AddIcon() Dim IDLib As Long ' Указатель на библиотеку Dim IDIcon As Long ' Указатель на иконку Const IDMyIcon = 101 ' Идентификатор иконки внутри приложения Dim AddResult As Long ' Результат добавления иконки IDLib = GetModuleHandle("Project1.exe") ' Получаем hInstanse IDIcon = LoadIcon(IDLib, "#101") ' Получаем hIcon ' Заполняем структуру NID типа NOTIFYICONDATA NID.cbSize = Len(NID) ' Размер структуры NID.hwnd = Form1.hWnd ' Указатель на форму NID.uID = IDMyIcon ' Идентификатор иконки NID.uFlags = NIF_MESSAGE + NIF_ICON + NIF_TIP 'Указываем, что действующими являются поля 'uCallBackMessage, hIcon и szTip. NID.uCallbackMessage = WM_LBUTTONDOWN ' Указываем, что событием возвращаемым в форму 'является MouseDown с параметром Button = 2 NID.hIcon = IDIcon ' Указатель на иконку в файле NID.szTip = Left$("MyIcon", 63) & Chr(0) ' Передаем всплывающую фразу "MyIcon", при этом обрезаем 'ее до 63 символов и добавляем 64-й символ с кодом ноль AddResult = Shell_NotifyIcon(NIM_ADD, NID) ' Вызываем функцию, через параметр dwMessage указываем, 'что следует добавить иконку, и передаем заполненный NID End Sub Удаление созданной иконки можно сделать так: Sub DeleteIcon() Dim DeletResult As Long DeleteResult = Shell_NotifyIcon(NIM_DELETE, NID) ' Вызываем функцию, через dwMessage указываем, 'что следует удалить иконку, при этом, раз переменная NID описана на уровне модуля, не следует 'заполнять ее заново End Sub Размер структуры достаточно указывать один раз, так как за время жизни переменной он измениться не может, и в данном виде составляет 88 байт. Даже при изменении всплывающей строки ее длина (строки) не будет больше 64 байт. Для модификации иконки надо вызвать Shell_NotifyIcon с параметром dwMessage равным NIM_MODIFY и NID с внесенными изменениями, при этом параметр uFlags будет указывать, какие из параметров изменены. В форме Form1 для обработки, к примеру, DbClick левой кнопкой мыши по иконке можно применить следующий код: Private Sub Form_MouseDown(Button As Integer, Shift As Integer _ X As Single, Y As Single) ' Событие MouseDown происходит не потому, 'что пользователь нажал на кнопку мыши над иконкой, а из-за того, 'что параметр uCallbackMessage имеет значение WM_LBUTTONDOWN If Y = 0 Then ' Y = 0 если событие с иконкой Select Case X Case 515*Screen.TwipsPerPixelX ' Значение X при LeftDblClick ' Код, выполняемый в случае LeftDblClick End Select End If End Sub 22.4 Расширить/уменьшить системный трей - Visual Basic ==================================================== источник: bbs.vbstreets.ru/viewtopic.php?p=71927#71927 Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long Private Declare Function OpenThread Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwThreadId As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Private Const PROCESS_CREATE_THREAD = &H2& Private Const PROCESS_VM_OPERATION = &H8& Private Const PROCESS_VM_WRITE = &H20& Private Const SYNCHRONIZE = &H100000 Private Const MEM_RESERVE = &H2000& Private Const MEM_COMMIT = &H1000& Private Const MEM_DECOMMIT = &H4000& Private Const MEM_RELEASE = &H8000& Private Const PAGE_EXECUTE_READWRITE = &H40& Private Sub Form_Load() Dim hWnd As Long, PID As Long, hProcess As Long Dim pStub As Long, TID As Long, hThread As Long hWnd = GetDlgItem(GetDlgItem(FindWindow("Shell_TrayWnd", vbNullString), &H12F&), &H12F&) GetWindowThreadProcessId hWnd, PID hProcess = OpenProcess(PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, 0, PID) pStub = VirtualAllocEx(hProcess, 0, 100, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE) WriteProcessMemory hProcess, pStub + 4, &HB8EC8B55, 4, 0 'push ebp; mov ebp,esp; mov eax, WriteProcessMemory hProcess, pStub + 8, GetProcAddress(GetModuleHandle("user32"), "SetWindowLongW"), 4, 0 WriteProcessMemory hProcess, pStub + 12, &H68, 1, 0 'push WriteProcessMemory hProcess, pStub + 13, pStub + 35, 4, 0 WriteProcessMemory hProcess, pStub + 17, &H68FC6A, 3, 0 'push GWL_WNDPROC; push WriteProcessMemory hProcess, pStub + 20, hWnd, 4, 0 WriteProcessMemory hProcess, pStub + 24, &HA3D0FF, 3, 0 'call eax; mov [imm32],eax WriteProcessMemory hProcess, pStub + 27, pStub, 4, 0 WriteProcessMemory hProcess, pStub + 31, &H4C2C9, 4, 0 'leave; ret 4 WriteProcessMemory hProcess, pStub + 35, &H81EC8B55, 4, 0 'push ebp; mov ebp,esp; cmp WriteProcessMemory hProcess, pStub + 39, &H4640C7D, 4, 0 'dword ptr [ebp+0Ch],464h WriteProcessMemory hProcess, pStub + 43, &H9750000, 4, 0 'jnz $+0Bh WriteProcessMemory hProcess, pStub + 47, &HB8, 1, 0 'mov eax, WriteProcessMemory hProcess, pStub + 48, &H100060, 4, 0 WriteProcessMemory hProcess, pStub + 52, &H10C2C9, 4, 0 'leave; ret 10h WriteProcessMemory hProcess, pStub + 56, &HFF1475FF, 4, 0 'push dword ptr [ebp+14h]; push WriteProcessMemory hProcess, pStub + 60, &H75FF1075, 4, 0 'dword ptr [ebp+10h]; push dword ptr WriteProcessMemory hProcess, pStub + 64, &H875FF0C, 4, 0 '[ebp+0Ch]; push dword ptr [ebp+8] WriteProcessMemory hProcess, pStub + 68, &HA1, 1, 0 'mov eax,[imm32] WriteProcessMemory hProcess, pStub + 69, pStub, 4, 0 WriteProcessMemory hProcess, pStub + 73, &HE7EBD0FF, 4, 0 'call eax; jmp $-17h CreateRemoteThread hProcess, ByVal 0&, 0, pStub + 4, 0, 0, TID hThread = OpenThread(SYNCHRONIZE, 0, TID) WaitForSingleObject hThread, -1 CloseHandle hThread VirtualFreeEx hProcess, pStub, 100, MEM_DECOMMIT Or MEM_RESERVE CloseHandle hProcess End Sub '------ 'Для того чтобы регулировать размер нужно изменить вот эту строчку: 'WriteProcessMemory hProcess, pStub + 48, &H100060, 4, 0 'попробуйте вместо &H100060 написать &H100010 и запустить программу Наверх 23. Как извлечь иконку из файла? - Visual Basic
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long Private Sub Command1_Click() Dim hIcon As Long Dim i As Long Dim n As Long AutoRedraw = True ' Получаем число иконок в файле n = ExtractIcon(App.hInstance, "c:\windows\system\shell32.dll", -1) ' Рисуем каждую иконку на форме For i = 0 To n - 1 hIcon = ExtractIcon(App.hInstance, "c:\windows\system\shell32.dll", i) DrawIcon hdc, i * 32, 0, hIcon Next ' Освобождаем ресурсы DestroyIcon hIcon Refresh End Sub Наверх 24. Как сменить курсор на "песочные часы" и обратно? - Visual Basic
Восстановление обычного курсора: Me.MousePointer=0 Наверх 25. Как узнать количество свободной оперативной памяти?
Private Type TMemoryStatus dwLength As Long dwMemoryLoad As Long dwTotalPhys As Long dwAvailPhys As Long dwTotalPageFile As Long dwAvailPageFile As Long dwTotalVirtual As Long dwAvailVirtual As Long End Type Dim ms As TMemoryStatus Private Sub Form_Load ms.dwLength = Len(ms) Call GlobalMemoryStatus(ms) MsgBox "Всего:" & ms.dwTotalPhys & vbCr & "Свободно:" & ms.dwAvailPhys & vbCr & "Загружено:" & ms.dwMemoryLoad End Sub Наверх 26. Как узнать сколько процессоров в компьютере? - Visual Basic
Private Type TSystemInfo dwOemID As Long dwPageSize As Long lpMinimumApplicationAddress As Long lpMaximumApplicationAddress As Long dwActiveProcessorMask As Long dwNumberOfProcessors As Long dwProcessorType As Long dwAllocationGranularity As Long dwReserved As Long End Type Public Function NumberOfProcessors() As Long Dim Info As TSystemInfo Call GetSystemInfo(Info) NumberOfProcessors = Info.dwNumberOfProcessors End Function Private Sub Form_Load() Me.Caption = NumberOfProcessors End Sub Наверх 27. Как узнать сколько работает ваш компьютер? - Visual Basic
Private Sub Form_Load() Dim a_hour, a_minute, a_second a = Format(GetTickCount() / 1000, "0") 'всего секунд a_hour = Int(a / 3600) a = a - a_hour * 3600 a_minute = Int(a / 60) a_second = a - a_minute * 60 MsgBox "Ваш компьютер работает в эту загрузку " & Str(a_hour) & " часов " & Str(a_minute) & " минут" & Str(a_second) & " секунд" End Sub Наверх 28. Как управлять консолью под vb6? - Visual Basic
Subj : Console help!!! A*>> Hе знаю как сделать программу в консольном режиме, так, чтобы A*>> вывод на AS> Так консоль или не консоль? ;) Будет тебе палка, будет тебе и свисток. Кто-то постил совершенно недавно. module1.bas: Option Explicit Public ProcessHandle As Long Public ProcessID As Long Private Declare Function AllocConsole Lib "kernel32" () As Long Private Declare Function FreeConsole Lib "kernel32" () As Long Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, dwMode As Long) As Long Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long Private Declare Function WriteConsole Lib "kernel32" Alias WriteConsoleA" (ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long ''''C O N S T A N T S''''''''''''''''''''''''''''''''''''' 'I/O handlers for the console window. These are much like the 'hWnd handlers to form windows. Private Const STD_INPUT_HANDLE = -10& Private Const STD_OUTPUT_HANDLE = -11& Private Const STD_ERROR_HANDLE = -12& 'Color values for SetConsoleTextAttribute. Private Const FOREGROUND_BLUE = &H1 Private Const FOREGROUND_GREEN = &H2 Private Const FOREGROUND_RED = &H4 Private Const FOREGROUND_INTENSITY = &H8 Private Const BACKGROUND_BLUE = &H10 Private Const BACKGROUND_GREEN = &H20 Private Const BACKGROUND_RED = &H40 Private Const BACKGROUND_INTENSITY = &H80 'For SetConsoleMode (input) Private Const ENABLE_LINE_INPUT = &H2 Private Const ENABLE_ECHO_INPUT = &H4 Private Const ENABLE_MOUSE_INPUT = &H10 Private Const ENABLE_PROCESSED_INPUT = &H1 Private Const ENABLE_WINDOW_INPUT = &H8 'For SetConsoleMode (output) Private Const ENABLE_PROCESSED_OUTPUT = &H1 Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2 Private hConsoleIn As Long ' The console's input handle Private hConsoleOut As Long ' The console's output handle Private hConsoleErr As Long ' The console's error handle Private Sub Main() Dim szUserInput As String AllocConsole 'ProcessID = Shell("command.com", 1) ' Create a console instance SetConsoleTitle "VB Console Example" 'Set the title on the console window 'Get the console's handle hConsoleIn = GetStdHandle(STD_INPUT_HANDLE) hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE) hConsoleErr = GetStdHandle(STD_ERROR_HANDLE) 'Print the prompt to the user. Use the vbCrLf to get to a new line. SetConsoleTextAttribute hConsoleOut, FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Or BACKGROUND_BLUE ConsolePrint "VB Console Example" & vbCrLf SetConsoleTextAttribute hConsoleOut, FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE ConsolePrint "Enter your name--> " 'Get the user's name Call SetConsoleMode(hConsoleOut, ENABLE_PROCESSED_OUTPUT) szUserInput = ConsoleRead() If Not szUserInput = vbNullString Then ConsolePrint "Hello, " & szUserInput & "!" & vbCrLf Else ConsolePrint "Hello, whoever you are!" & vbCrLf End If 'End the program ConsolePrint "Press enter to exit" Call ConsoleRead FreeConsole ' Destroy the console End Sub ' Summary: Prints the output of a string'' Args: String ConsolePrint ' The string to be printed to the console's ouput buffer.'' Returns: None' '----------------------------------------------------- Private Sub ConsolePrint(szOut As String) WriteConsole hConsoleOut, szOut, Len(szOut), vbNull, vbNull End Sub 'F+F++++++++++++++++++++++++++++++++++++++++++++++++++++' 'Function: ConsoleRead ' Summary: Gets a line of input from the user.'' Args: None' ' Returns: String ConsoleRead' The line of input from the user. '---------------------------------------------------F-F Private Function ConsoleRead() As String Dim sUserInput As String * 256 Call ReadConsole(hConsoleIn, sUserInput, Len(sUserInput), vbNull, vbNull) 'Trim off the NULL charactors and the CRLF. ConsoleRead = Left$(sUserInput, InStr(sUserInput, Chr$(0)) - 3) End Function Наверх 29. Пишем трейнер на Visual Basic
Windows API - функции: Любое Windows-приложение использует так называемые стандартные API-функции. Вначале поговорим о тех функциях, которые понадобятся при написании простейшего трейнера. О том, куда это все писать и как, будет рассказано позже. FindWindow (ClassName, "заголовок окна") - с помощью этой функции программа ищет окно по его заголовку. В скобках указывается класс окна и, через запятую, в кавычках его заголовок. В Visual Basic любую функцию надо "декларировать", т.е. как бы описать машине, что это функция из себя представляет. Выглядит это так: Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long. Я не буду подробно пояснять смысл этих слов, так как в этой строке менять вам все равно ничего не придется, какую бы игру вы ни взяли. GetWindowThreadProcessId (WindowHandle, ProcessId) - перехватывает управление из FindWindow и возвращает идентификатор процесса (ProcessId), который нужен для управления этим процессом. Это описывается так: Declare Function GetWIndowProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long OpenProcess (DesiredAccess, Inherit, ProcessId) - эта функция возвратит управление игре. Потом это можно использовать для записи и чтения данных. DesiretAccess определяет права доступа к данным игры. Здесь мы укажем полный доступ: PROCESS_ALL_ACCESS. Inherit всегда должен иметь значение False. ProcessId устанавливается такой же как в функции, описанной в пункте 2. Описывается все это так: Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long CloseHandle (ProcessHandle) - закрывает все открытые программой процессы. Описывается так: DeclareFunction CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long WriteProcessMemory (ProcessHandle, Address, Value, SizeofValue, BytesWritten) - записывает значение в адрес игры. Декларируется так: Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long ReadProcessMemory (ProcessHandle, Address, Value, SizeofValue, BytesWritten) - читает значение из адреса игры. Описывается: Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Это пока что все функции Windows, которые понадобятся. Вы можете использовать еще и другие, если знаете их и если это вам понадобится для расширения возможностей. Прочитать подробней про них можно в хелпах и в соответствующей литературе. Если вы ничего не поняли из сказанного выше, а под рукой не нащупывается книги по Visual Basic, то пока что продолжайте читать дальше - по ходу разберетесь. Простейший трейнер Шаг первый - поиск адреса: Вначале ищем адрес. Для примера возьмем игру SimCity 3000 Holiday Theme Edition. Вы можете искать адрес любой удобной для вас программой, но здесь я объясню, как искать, на примере Magic Trainer Creator (МТС). Запустим игру, затем MTC. В поле Process ID выбираем запускаемый файл игры (Sc3.exe). Выбираем режим поиска Normal, в поле Value to search вводим текущую сумму денег. Нажимаем Start. По завершении поиска (нужный адрес, скорее всего, не будет найден с первого раза) возвращаемся в игру и меняем количество денег (строим новое недорогое здание, чтобы потратить немного). Затем в MTC ставим в поле Value to search новое количество денег и нажимаем Continue. Проделываем все это несколько раз, пока не найдем один адрес. У меня этот адрес был 235B218, но у вас может быть и другой. Адрес надо будет указывать в программе сразу после знаков &H без пробелов - это указывает программе, что мы используем шестнадцатеричные значения. Выглядеть будет так: &H235B218. Теперь на всякий случай проверим, правильно ли найден адрес. Щелкаем по нему, чтобы добавить в нижнее поле, затем щелкаем по нему там. В поле Monitor нажимаем кнопку в левом верхнем углу и в появившемся окне меняем первые 2 бита на FF FF. Нажимаем кнопку в нижнем правом углу окна для возврата в основное окно MTC. В поле Monitor нажимаем среднюю нижнюю кнопку. Возвращаемся в игру и смотрим, изменилось ли количество денег. Если да, тогда выписываем найденный адрес на бумагу - он нам пригодится при создании трейнера. Конечно, здесь можно ограничиться этим и создать трейнер в MTC. Но мы-то собрались писать трейнер сами. Выходим из MTC и игры и продолжаем читать статью дальше. Шаг второй - написание трейнера: Запускайте Visual Basic. Начните новый проект и выберите Standard EXE. В окне Properties в поле Caption можете оставить свое название для заголовка окна вместо принятого по молчанию Form1. Добавьте1 Textbox, 1 Button и Timer. Выделите только что добавленное текстовое поле (Textbox) и сотрите в окне Properties в поле Text название text1 - текстовое поле нужно для записи желаемого значения. Выделите добавленный таймер (Timer) и в окне Properties в поле Interval поставьте 500 - это частота обновления значения в игре (заморозка). Выделите добавленную кнопку (Button), и в окне Properties в поле Caption сможете поставить свое наименование кнопки (она нужна для записи в игру набранного нами в текстовом поле трейнера значения). Выберите в меню Project опцию Add Module, чтобы добавить новый модуль в программу. В окне Project перейдите в этот модуль и наберите указанные ниже строчки. Каждая новая строка начинается со слова Declare и должна быть набрана в одну строку (здесь некоторые строчки могут быть напечатаны с переносом): Declare Function FindWindow Lib “user32” Alias “FindWindowA” (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function GetWindowThreadProcessId Lib “user32” (ByVal hwnd As Long, lpdwProcessId As Long) As Long Declare Function OpenProcess Lib “kernel32” (ByVal dwDesiredAcess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Declare Function WriteProcessMemory Lib “kernel32” (ByVal hProcess As Long, ByVal lpBaseAdress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Declare Function ReadProcessMemory Lib “kernel32” (ByVal hProcess As Long, ByVal lpBaseAddess As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWriten As Long) As Long Declare Function CloseHandle Lib “kernel32” (ByVal hObject As Long) As Long Теперь перейдите в Form1, щелкнув по ней в окне Project. Вы увидите исходный экран с образом вашего будущего трейнера. Щелкните в любом месте этого окна правой кнопкой мыши и выберите пункт View Code. Напоминаю, что адрес, который я использовал здесь и в котором хранится инфа о деньгах, был у меня 235B218, но у вас может быть и другой. А заголовок окна игры в моей версии был Sim City 3000. У вас заголовок может несколько отличаться, и узнать вы его можете, переключившись из игры по Alt+Tab - заголовок написан на кнопке свернутого окна. Теперь наберите весь написанный ниже текст программы (после знака ' следуют комментарии, которые можно и не писать): Private Sub Command1_Click() ' Объявляем некоторые необходимые моменты для кнопки. Dim hwnd As Long ' удерживает управление, переданное функцией Find Window. Dim pid As Long' используется для хранения идентификатора процесса. Dim pHandle As Long' держит управление процессом. ' Ищем окно игры и, если игра не запущена, выдаем сообщение об ошибке. hwnd = FindWindow(vbNullString, "Sim City 3000") If (hwnd = 0) Then MsgBox "Window not found!" Exit Sub End If ' Теперь можно определить идентификатор процесса. GetWindowThreadProcessId hwnd, pid ' Используем этот идентификатор для получения управления процессом. pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid) If (pHandle = 0) Then MsgBox "Couldn't get a process handle!" Exit Sub End If ' Теперь можно записать новое значение в память по нужному адресу. WriteProcessMemory pHandle, &H235B218, "Beans", 5, 0& ' Прекращаем управлять процессом. CloseHandle hProcess End Sub Private Sub ReadTimer_Timer() ' Объявляем некоторые необходимые моменты для таймера. Dim hwnd As Long' удерживает управление, переданное функцией FindWindow. Dim pid As Long ' удерживает идентификатор процесса. Dim pHandle As Long ' удерживает управление процессом. Dim str As String * 20 ' параметр текстовой строки. ' Вначале ищем окно игры. hwnd = FindWindow(vbNullString, "Sim City 3000") If (hwnd = 0) Then Exit Sub ' Теперь можно определить идентификатор процесса. GetWindowThreadProcessId hwnd, pid ' Используем идентификатор для управления процессом. pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid) If (pHandle = 0) Then Exit Sub ' Теперь можно прочитать из памяти... ReadProcessMemory pHandle, &H235B218, str, 20, 0& ' ... и показать строку в текстовом поле трейнера. txtDisplay = str ' Прекращаем управлять процессом. CloseHandle hProcess End Sub Вот вроде и все. Теперь нажмите в меню File->Make Project1.exe, чтобы создать запускаемый файл вашего трейнера. Не забудьте предварительно сохранить проект и вообще почаще сохраняйтесь в процессе написания программы, чтобы вернуться, если что, к первоначальному рабочему ее варианту. Вот теперь уже можно испытать трейнер в работе. Не забудьте, что вначале нужно запускать игру, а затем уже трейнер. Прочие игры ломаются аналогичным образом. Автор: Ivanov Ivanovich Наверх 30. Зашифрованные пароли - Visual Basic
Function EncryptPassword(Number As Byte, DecryptedPassword As String) Dim Password As String, Counter As Byte Dim Temp As Integer Counter = 1 Do Until Counter = _ Len(DecryptedPassword) + 1 Temp = Asc(Mid(DecryptedPassword, _ Counter, 1)) If Counter Mod 2 = 0 Then 'see if even Temp = Temp - Number Else Temp = Temp + Number End If Temp = Temp Xor (10 - Number) Password = Password & Chr$(Temp) Counter = Counter + 1 Loop EncryptPassword = Password End Function Function DecryptPassword(Number As Byte, EncryptedPassword As String) Dim Password As String, Counter As Byte Dim Temp As Integer Counter = 1 Do Until Counter = _ Len(EncryptedPassword) + 1 Temp = Asc(Mid(EncryptedPassword, _ Counter, 1)) Xor (10 - Number) If Counter Mod 2 = 0 Then 'see if even Temp = Temp + Number Else Temp = Temp - Number End If Password = Password & Chr$(Temp) Counter = Counter + 1 Loop DecryptPassword = Password End Function Наверх 31. Как завершить указанный процесс - Visual Basic
Shell "Cmd /x/c taskkill /f /im ICQlite.exe", vbvhite Наверх 32. Управление событиями в комбоксе - Visual Basic
' В VB3 надо поменять тип флага на integer Dim bNoise as Boolean ' True означает, что происходит «шум», на который не следует реагировать А этот код введите в секции события Form_Load: bNoise = False Этот код введите в событии KeyDown комбобокса: Private Sub cbTest_KeyDown(KeyCode As _ Integer, Shift As Integer) ' если юзер использует стрелки для езды по списку комбобокса ' игнорировать события Click If KeyCode = vbKeyDown Or KeyCode _ = vbKeyUp Then bNoise = True End Sub Этот код вводится в событии Click комбобокса: Private Sub cbTest_Click() If bNoise Then ' Ignore Noise events ' (up or down arrow) bNoise = False Else ' Увести фокус с контрола SendKeys "{TAB}", True End If End Sub Теперь Вам остается написать код, содержащий реакцию на выбор юзера, и занести его в секцию события LostFocus комбика. Наверх 33. Как содержимое формы или Picture выкинуть на принтер? - Visual Basic
h=Screen.ScaleY(Picture1.Picture.Height, vbHiMetric, vbTwips) Printer.PaintPicture Picture1.Picture, 0, 0, w, h, 0, 0, w, h, vbSrcCopy Наверх 34. Ошибки при замене десятичного разделителя - Visual Basic
Функция Val в качестве десятичного разделителя воспринимает только точку (.) : fV = Val("1.2") ' fV = 1.2 fV = Val("1,2") ' fV = 1 т.е. числа после запятой не воспринимаются Функции конвертации с учетом типа данных (CSng, CDbl) зависят от локальных установок компьютера. Hа компьютере с локализованной (русской) версией Win'95 : fV = CSng("1.2") ' Run-time error 13 - Type mismatch fV = CSng("1,2") ' fV = 1.2 Функция Format воспринимает только точку (.), если число передается непосредственно в функцию: sV = Format(1.2, "#0.00") ' sV = "1.20" sV = Format(1, 2, "#0.00") ' Run-time error 13 - Type mismatch Однако, если число в функцию Format передается с помощью переменной, допустима цепочка команд : fV = CSng("1,2") sV = Format(fV, "#0.00") ' sV = "1.20" а компьютере с американской версией Win'98 в качестве десятичного разделителя используется точка, использование запятой приводит к сообщению об ошибке или неправильному результату. Чтобы избежать ошибок, сначала надо выяснить какой символ используется на данном компьютере в качестве десятичного разделителя. Это можно сделать, например, так: Sub PVar_Define() ' Определить глобальные переменные, общие для проекта On Error GoTo ErrH ' ........ определение различных глобальных переменных ......... spDS = "." ' Разделитель целой и дробной части. По умолчанию "." If CSng("1,2") = 1.2 Then spDS = "," ErrH: End Sub При чтении данных из файла можно использовать функцию типа следующей: ' Замена точек, используемых в качестве десятичных разделителей, ' на запятые (если надо) Public Function PointToComma(sStr As String) As String Dim nP As Integer If spDS = "," Then ' В качестве десятичного разделителя установлена запятая nP = InStr(sStr, ".") ' Заменим вероятные точки на запятые While nP > 0 Mid(sStr, nP, 1) = "," nP = InStr(sStr, ".") Wend End If PointToComma = sStr End Function При записи данных в файл соответственно используется обратное преобразование. Что касается ввода данных в TextBox, то можно разрешить только ввод корректного на данной машине десятичного разделителя, не давая вводить неправильный. Наверх 35. Как определить длину файла (все версии Visual Basic)
Наверх 36. Управление длиной элемента списка ComboBox - Visual Basic
Private Sub Combo1_KeyPress(KeyAscii As Integer) ' ' Если пользователь попытается нажать одиннадцатую клавишу и ' если эта клавиша не Backspace, то отменить данное событие ' Const MAXLENGTH = 10 If Len(Combo1.Text) >= MAXLENGTH And KeyAscii <> vbKeyBack Then KeyAscii = 0 End If End Sub Константа MaxLength может иметь любое значение. Кроме того, вместо Backspace вы можете использовать любые другие клавиши. Для этого просто введите их значения KeyAscii, как показано в примере с клавишей Backspace. Наверх 37. Увеличение и уменьшение даты с помощью клавиш [+] и [-] - Visual BasicВ некоторых программах работа с датой реализована довольно интересным образом. Нажатие клавиши [+] увеличивает дату на один день, клавиши [-] — уменьшает на один день, клавиша [PgDn] прибавляет один месяц, а клавиша [PgDn] убавляет на один месяц. Попробуем реализовать это с помощью VB. Вначале поместите на форму элемент управления TextBox (txtDate). Установите его свойство Text равным "", а свойство Locked — True. После этого введите следующий код в событие KeyDown: Private Sub txtDate_KeyDown(KeyCode As Integer, Shift As Integer) ' ' KeyCode — специальный код клавиши (а не ASCII-код!) ' 107 = "+" KeyPad (цифровая клавиатура) ' 109 = "-" KeyPad ' 187 = "+" (в действительности это клавиша "=") ' 189 = "-" ' 33 = PageUp ' 34 = PageDown ' Dim strYear As String Dim strMonth As String Dim strDay As String ' If txtDate.Text = "" Then txtDate.Text = Format(Now, "d/m/yyyy") Exit Sub End If ' strYear = Format(txtDate.Text, "yyyy") strMonth = Format(txtDate.Text, "mm") strDay = Format(txtDate.Text, "dd") ' Select Case KeyCode Case 107, 187 ' добавляет один день txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) + 1, "d/m/yyyy") Case 109, 189 ' убавляет на один день txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) - 1, "d/m/yyyy") Case 33 ' увеличивает на один месяц txtDate.Text = Format(DateSerial(strYear, strMonth + 1, strDay), "d/m/yyyy") Case 34 ' уменьшает на один месяц txtDate.Text = Format(DateSerial(strYear, strMonth - 1, strDay), "d/m/yyyy") End Select ' End Sub Этот способ коррекции даты очень полезен, так как гарантирует правильный формат даты в окне. Именно для того, чтобы избежать возможных ошибок при вводе, мы, установив свойство Locked равным True, заблокировали возможность редактировать в текстовом окне дату в явном виде. Наверх 38. Как перетащить элементы из одного списка в другой - Visual Basic
Private Sub Form_Load() ' Установите свойство Visible ' для текстового поля как False txtItem.Visible = False ' Добавьте элементы к списку 1 (lstDraggedItems) lstDraggedItems.AddItem "Яблоко" lstDraggedItems.AddItem "Апельсин" lstDraggedItems.AddItem "Грейпфрут" lstDraggedItems.AddItem "Банан" lstDraggedItems.AddItem "Лимон" End Sub В событии MouseDown списка lstDraggedItems напишите следующее: Private Sub lstDraggedItems_MouseDown _ (Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' txtItem.Text = lstDraggedItems.Text txtItem.Top = Y + lstDraggedItems.Top txtItem.Left = X + lstDraggedItems.Left txtItem.Drag End Sub А в событии DragDrop списка lstDroppedItems введите такой код: Private Sub lstDroppedItems_DragDrop _ (Source As Control, X As Single, Y As Single) ' If lstDraggedItems.ItemData _ (lstDraggedItems.ListIndex) = 9 Then Exit Sub ' Убедимся, что данный элемент ' не будет перемещен снова lstDraggedItems.ItemData _ (lstDraggedItems.ListIndex) = 9 lstDroppedItems.AddItem txtItem.Text End Sub Теперь запустите этот тест на выполнение и попробуйте перетащить элементы из списка lstDraggedItems и поместить их в список LstDroppedItems. Обратите внимание, что вы не можете перемещать элементы второго списка в первый. Кроме того, перетаскиваемые элементы сохраняются в первом списке. Надеемся, вы сумеете легко устранить данные ограничения. Наверх 39. Создание нового контекстного меню - Visual Basic
Private Const WM_RBUTTONDOWN = &H204 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 Sub OpenContextMenu(FormName As Form, MenuName As Menu) ' ' Говорит системе, что пользователь щелкнул ' правой кнопкой мыши на форме Call SendMessage(FormName.hwnd, _ WM_RBUTTONDOWN, 0, 0&) ' Показывает контекстное меню FormName.PopupMenu MenuName End Sub После этого с помощью редактора Visual Basic Menu Editor и приведенной здесь таблицы создайте простое меню. Caption_____Name_____Visible Контекстное меню mnuContext__No Первый элемент mnuContext1 Второй элемент mnuContext2 Обратите внимание, что два последних элемента смещены на один уровень (...) и что у первого элемента ("Контекстное меню") свойство Visible установлено как NO. Теперь добавьте текстовое поле к форме и введите следующий код в событие MouseDown для этого элемента управления: Private Sub Text1_MouseDown(Button As Integer, _ Shift As Integer, X As Single, Y As Single) ' If Button = vbRightButton Then Call OpenContextMenu(Me, Me.mnuContext) End If End Sub Наверх 40. Для тех, кто занимается геометрическими расчетами - Visual Basic
Возможно, вам пригодятся две процедуры, которые приведены в модуле XY_TESTC.BAS (см. ниже). Они сохранились у нас еще со времен Basic/DOS, поэтому их текст и имеет такой вид (например, все ключевые слова записаны заглавными буквами). Процедура CircleTestXY определяет местоположение точки относительно фигуры-многоугольника (внутри или снаружи), CircleSquare вычисляет площадь многоугольника. Следует обратить внимание на то, что одна из вершин многоугольника задана в массиве дважды - в качестве начальной и конечной точки. Кстати. Раньше названия языков программирования и их ключевых слов было принято писать большими буквами. Однако в начале 90-х годов Международная Организация по Стандартам (ISO - International Standard Organization) приняла решение об изменении этого правила, С тех пор они пишутся так: первая буква - заглавная, остальные - прописные. DECLARE SUB CircleTestXY (xyd!(), Np%, x0!, y0!, kz%) DECLARE SUB CircleSquare (xyd!(), Np%, Square!) DEFINT I-N '************************************************** ' Модуль XY_TESTC.BAS ' ' Процедуры: ' CircleTestXY - определение местоположения точки ' относительно фигуры-многоугольника ' CircleSquare - вычисление площади многоугольника ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''""""""""""""""""""""""""""""""""" ' тестовый пример использования функций Np = 6: DIM xyd(Np, 2) ' массив для пятиугольника xyp(1, 1) = 10: xyp(2, 1) = 20 xyp(1, 2) = 0: xyp(2, 2) = 10 xyp(1, 3) = -10: xyp(2, 3) = 20 xyp(1, 4) = -10: xyp(2, 4) = -20 xyp(1, 5) = 10: xyp(2, 5) = -20 xyp(1, Np) = xyp(1, 1): xyp(2, Np) = xyp(2, 1) ' вычисление площади многоугольника CALL CircleSquare(xyp(), Np, Square) ' проверка - где находится заданная точка? x0 = 0: y0 = 0 ' координаты тестируемой точки CALL CircleTestXY(xyp(), Np, x0, y0, kz) PRINT "kz, Square = "; kz; Square END SUB CircleSquare (xyd(), Np, Square) ' Вычисление площади многоугольника '———————————————————————————————— ' ВХОД: ' xyd() - массив координат углов многоугольника ' x = xyd(1,i), y = xyd(2,i) ; i = 1 to Np ' (Np-1) - количество узлов ' координаты 1-й точки = координатам N-й ' ' ВЫХОД: Square - площадь многоугольника '''''''''''''''''''''''''''''''''''''''''''''''"""""""""""""""""""""""""""""""""" CONST pi = 3.141593 Square = 0 FOR k = 1 TO Np ' Np + 1 x2 = xyd(1, k): y2 = xyd(2, k) v2 = SQR(x2 * x2 + y2 * y2) ay2 = ABS(y2): ax2 = ABS(x2) IF ax2 * 10000 > ay2 THEN alfa2 = ATN(ay2 / ax2) ELSE alfa2 = pi * .5 END IF IF x2 < 0 THEN alfa2 = pi - alfa2 IF y2 < 0 THEN alfa2 = -alfa2 IF k > 1 THEN ' проверка перехода Square = Square + .5 * SIN(alfa2 - alfa1) * v1 * v2 END IF x1 = x2: y1 = y2: v1 = v2: alfa1 = alfa2 NEXT END SUB SUB CircleTestXY (xyd(), Np, x0, y0, kz) ' ' Проверка местонахождения точки на плоскости ' относительно многоугольника - внутри или снаружи '————————————————————————- ' ВХОД: ' xyd() - массив координат углов многоугольника ' x = xyd(1,i), y = xyd(2,i) ; i = 1 to Np ' (Np-1) - количество узлов ' координаты 1-й точки = координатам N-й точки ' x0,y0 - координаты тестируемой точки ' ' ВЫХОД: положение тестируемой точки ' kz = 0 - вне ' = -100 - на границе ' = -4 - внутри (обход по часовой стрелке) ' = 4 - внутри (против часовой стрелки) '''''''''''''''''''''''''' kz = 0 FOR k = 1 TO Np ' Np + 1 ' IF l > Np THEN k = 1 ELSE k = l x2 = xyd(1, k) - x0: y2 = xyd(2, k) - y0 ' ' проверка четверти плоскости kv2 = 0 IF x2 >= 0 AND y2 > 0 THEN kv2 = 1 IF x2 < 0 AND y2 >= 0 THEN kv2 = 2 IF x2 <= 0 AND y2 < 0 THEN kv2 = 3 IF x2 > 0 AND y2 <= 0 THEN kv2 = 4 IF kv2 = 0 THEN kz = -100: EXIT FOR ' IF k > 1 THEN ' проверка перехода IF kv2 <> kv1 THEN ' переход в другую четверть kv = kv2 - kv1 IF kv = 3 THEN kv = -1 IF kv = -3 THEN kv = 1 IF kv = 2 OR kv = -2 THEN ' переход через две четверти IF x1 = x2 THEN kz = -100: EXIT FOR yb = (y2 * x1 - y1 * x2) / (x1 - x2) IF yb = 0 THEN kz = -100: EXIT FOR kv = kv * SGN(yb) IF kv1 = 2 OR kv1 = 4 THEN kv = -kv END IF kz = kz + kv END IF END IF x1 = x2: y1 = y2: kv1 = kv2 NEXT END SUB Наверх 41. Копирование областей памяти в DOS - Visual BasicДополнительные функции DLL-библиотек могут серьезно расширить возможности VB-программиста. При этом следует иметь в виду, что для написания таких процедур зачастую совсем не обязательно быть большим знатоком языка, на котором они будут писаться. Например, функция копирования областей памяти пригодится и тем, кто еще работает в Basic/DOS. В силу специфики использования библиотек в этих версиях Basic (мы вновь сожалеем, что в VB/Win-проектах Microsoft не позволяет подключать к исполняемому модулю объектные библиотеки) такие внешние функции лучше всего было писать на Ассемблере. Посмотрите, какой простой код имеет функция StringCopy, написанная для варианта MASM 6.0 и фактически являющаяся точным аналогом функции CopyMemory для режима DOS (только число байтов задается целочисленной переменной): .MODEL Medium,Basic .CODE StringCopy PROC USES DS DI SI DF, SourceAddr:DWord, DestAddr:DWord, Len:Word ; прием входных параметров: MOV CX,Len ; количество байт LES DI,DestAddr ; полный адрес Приемника (Куда) LDS SI,SourAddr ; полный адрес Источника (Откуда) ; пересылка данных: CLD ; очистка флага DF REP MOVSB ; пересылка CX-байт ; выход из процедуры: RET ; возврат управления StringCopyByv ENDP END Ее описание можно сделать двумя способами: 1. Адреса задаются с помощью двух 16-разрядных переменных — сегмент и смещение: описание: DECLARE SUB StringCopy(BYVAL SourceSeg%, BYVAL SourceOff%,_ BYVAL DistSeg%, BYVAL DistOff%, BYVAL LenByte%) обращение: CALL StringCopyByv(SourceSeg%, SourceOff%, _ DistSeg%, DistOff%, LenByte%) 2. Полные адреса задаются с помощью 32-разрядных переменных: описание: DECLARE SUB StringCopy(BYVAL SourceAdr&, BYVAL DistAdr&, _ BYVAL LenByte%) обращение: CALL StringCopyByv(SourceAddr&, DistAddr&, LenByte%) Наверх 42. Сортировка содержимого ListView
Public Sub SortListView(ByVal lvw As MSComctlLib.ListView, ByVal colHdr As MSComctlLib.ColumnHeader) ' установка режима сортировки для указанной колонки lvw.SortKey = colHdr.Index - 1 lvw.Sorted = True ' изменение сортировки меняется между ' "по возрастанию" и "по уменьшению" lvw.SortOrder = 1 Xor lvw.SortOrder End Sub Чтобы обеспечить выполнение данной операции при щелчке мышью на заголовках, используйте событие ColumnClick для конкретного элемента управления: Private Sub lvwMyListView_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader) SortListView lvwMyListView, ColumnHeader End Sub Наверх 43. Быстрый поиск в массивах, листбоксах и комбобоксах
'Вход: 'Массив для поиска Dim rasArray() As String 'Строка для поиска Dim vsName As String 'Выход: 'Индекс в массиве строки, если найдено Dim rlIndex As Long 'Локальные переменные: 'Индекс в массиве Dim lnIdx As Long 'Нижний предел интервала поиска Dim lnMin As Long 'Верхний предел интервала поиска Dim lnMax As Long 'Если строка не найдена, то в индексе возвращаем ошибку rlIndex = LBound(rasArray) - 1 lnMax = UBound(rasArray) lnMin = LBound(rasArray) 'ищем vsName в rasArray() Do While lnMin <= lnMax lnIdx = (lnMax + lnMin) \ 2 If vsName = rasArray(lnIdx) Then rlIndex = lnIdx Exit Do ElseIf vsName < rasArray(lnIdx) Then lnMax = lnIdx - 1 Else lnMin = lnIdx + 1 End If Loop Так же этот код можно легко переделать как для combo-box, так и для list-box: 'Вход: 'Combo для поиска ' (change into As ListBox for listbox controls ' or use As Controls to use with both types ' of controls) Dim rcboCombo As ComboBox 'Строка для поиска Dim vsName As String 'Выход: 'Если строка найдена, то это индекс в combo Dim rlIndex As Long 'Локальные переменные 'Индекс в массиве Dim lnIdx As Long 'Нижний предел интервала поиска Dim lnMin As Long 'Верхний предел интервала поиска Dim lnMax As Long 'Если строка не найдена, то в индексе возвращаем ошибку rlIndex = -1 lnMin = 0 lnMax = rcboCombo.ListCount - 1 lnIdx = lnMax \ 2 'ищем имя в combo Do While rlIndex = -1 And lnMin <= lnMax If vsName = rcboCombo.List(lnIdx) Then rlIndex = lnIdx ElseIf vsName < rcboCombo.List(lnIdx) Then lnMax = lnIdx - 1 lnIdx = (lnMax + lnMin) \ 2 Else lnMin = lnIdx + 1 lnIdx = (lnMax + lnMin) \ 2 End If Loop Наверх 44. Сделать картинку светлей или темней - Visual Basic
Private Sub LightOrDark(ByVal fraction As Single) Dim r As Integer, g As Integer, b As Integer Dim X As Integer, Y As Integer, clr As Long MyPic.ScaleMode = vbPixels For Y = 0 To MyPic.ScaleHeight For X = 0 To MyPic.ScaleWidth ' Получить цвет clr = MyPic.Point(X, Y) r = clr Mod 256 g = (clr \ 256) Mod 256 b = clr \ 256 \ 256 ' Уменьшить/увеличить яркость r = r * fraction g = g * fraction b = b * fraction ' Иногда бывает < 0 If r < 0 Then r = 0 If g < 0 Then g = 0 If b < 0 Then b = 0 ' Hарисовать пиксель MyPic.PSet (X, Y), RGB(r, g, b) Next X DoEvents Next Y End Sub Private Sub Form_Click() Call LightOrDark(0.9) End Sub Вызов - LightOrDark 1.5 - если аргумент > 1 - засветление,< 1 - затемнение. Hа форме не забудь поместить пикчербокс MyPic скакой нибудь картинкой. Hо это ооочень долго, если много пикчуров (For Each.....Next), а еще и форма :((. Может, сам метод где нибудь пригодится? Так, изобласти предположений, попробуй накрывать свою форму прозрачной формойс черными точками или тонкими линиями - затемнение и белыми (м.б.желтыми?) - засветление. Наверх 45. Как загрузить текст из файла в ListBox? - Visual Basic
Private Sub Form_Load() Dim strText As String Dim FileNum As Integer Dim FName As String FileNum = FreeFile Open App.Path & "\Text.txt" For Input As #FileNum Do While Not EOF(FileNum) Line Input #FileNum, strText List1.AddItem strText Loop Close #FileNum End Sub Наверх 46. Формы в виде текста! - Visual Basic
Private Declare Function SelectClipPath Lib "gdi32" _ (ByVal hdc As Long, ByVal iMode As Long) As Long Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SetWindowRgn Lib "user32" _ (ByVal hWnd As Long, ByVal hRgn As Long, _ ByVal bRedraw As Boolean) As Long Private Const RGN_COPY = 5 Private Sub Form_Load() Const TXT = " Прикольной программы" & vbCrLf & "Прикольный пример" Dim hRgn As Long Font.Name = "Times New Roman" Font.Bold = True Font.Size = 50 Width = TextWidth(TXT) Height = TextHeight(TXT) BeginPath hdc CurrentX = 0 CurrentY = 0 Print TXT ' Здесь вместо текста можно рисовать фигуры EndPath hdc hRgn = PathToRegion(hdc) SetWindowRgn hWnd, hRgn, False ' Hачинаем фантазировать с формой. Можно так Picture = LoadPicture("c:\windows\Кофейня.bmp") ' А можно так ' dclr = 256 / (TextHeight(TXT) / 30) ' clr = 0 ' For i = 120 To 120 + TextHeight(TXT) Step 30 ' Line (0, i)-Step(5000, 0), RGB(0, 0, clr) ' clr = clr + dclr ' Next i ' Можно дать форме градиентную заливку и т.д. ' Двигаем к центру, а можно в таймере крутить Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2 End Sub P.S. Не забудь изменит свойство BorderStyle на 0 - None. Удачи! Наверх 47. Как выполнять код пока кнопка нажата - Visual Basic
Откройте или создайте стандартный проект Visual Basic. Поместите на форму объекты Label, Command Button и Timer. Щелкните правой кнопкой мыши на форме, выберите View Code и введите введите следующий код: Private Sub Command1_MouseDown(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Timer1.Enabled = True End Sub Private Sub Command1_MouseUp(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Timer1.Enabled = False End Sub Private Sub Form_Load() Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() Label1.Caption = Now End Sub Нажмите F5 для запуска проекта. Теперь нажмите и удерживайте кнопку, которую вы поместили на форму. В течении этого времени событие Timer() должно обновлять label и отображать там текущее время. После того, как вы отпустите кнопку таймер должен остановить выполнение кода. Наверх 48. Как работать с ресурсами, файлы ресурсов (*.RES) - Visual Basic
ФАЙЛ РЕСУРСОВ ЧТО это? Файл-ресурсов - это некий мульти-файл, в который могут входить данные абсолютно любого типа, будь то строковые данные или целые файлы. В проекте может находится только один файл ресурсов, но с любым количеством и типами данных в нем. Как создать файл-ресурс? 1. Откройте меню Add-Ins (Модули) и выберите опцию Add-In Manager (Менеджер модулей) 2. В открывшейся форме найдите VB6 Resource Editor, выделите его и внизу справа поставьте галочку на Loaded/Unloaded (Загруженный/Выгруженный),а так же на Load on Startup (Загружать при запуске) если вы хотите чтобы при запуске VB, Редактор ресурсов запускался автоматически, затем нажмите Ок. Если вы не нашли VB6 Resource Editor в Менеджере модулей, то смотри раздел "Секреты и полезные советы по файлу-ресурсу" 3. Выберите меню Tools (Инструменты) и в самом низу Resource Editor 4. Нажмите на иконку с дискетой (Save), чтобы сохранить файл ресурсов на диске, после зтого, файл-ресурс появится в составе вашего проекта. Как работать с файлом ресурсов? Как добавить данные в файл-ресурсов? Для добавления в файл-ресурс строковых значений, курсоров, иконок, картинок (только BMP) служат соответствующие иконки на панели инструментов VB Resource Editor: Edit String Tables, Add Cursor, Add Icon, Add Bitmap Если вы хотите добавить в файл ресурсов данные другого типа (файл) то используйте кнопку Add Custom Resource, на той же пнели инструментов. Как взять данные из файла ресурсов? 'Загрузка текстовых данных. Объект = LoadResString(index) 'Index - идентификационный номер строки 'Объект - TextBox, Label, текстовая переменная и все остальное, куда можно загргрузить текст. 'Загрузка графических данных Объект = LoadResPicture(index,format) 'Index - идентификационный номер строки с картинкой 'Format - тип загружаемых данных: 'VbResBitmap - картинки 'VbResCursor - курсоры 'VbResIcon - иконки 'Объект - PictureBox, Image и все остальное, куда можно загрузить графику Объект = LoadResData(index, format) 'Загружает данные и возвращает байтовый массив 'ВНИМАНИЕ!!! Используйте эту функцию ОЧЕНЬ ОСТОРОЖНО!!! 'Так как могут возникнуть проблемы с форматом данных 'Index - идентификационный номер строки с данными 'Format - тип возвращаемых данных в виде байтов '(может быть и строкой с названием типа пользовательских данных, 'например: LoadResData(101, "CUSTOM")): '1 - Курсор '2 - Графика '3 - Иконка '4 - Меню '5 - Окно диалога '6 - Текст '7 - Каталог со шрифтами '8 - Шрифт '9 - Таблица '10 - Пользовательские ресурсы '12 - Группа курсоров '14 - Группа иконок Секреты и полезные советы по файлу-ресурсу Как достать файл из файла-ресурса и сохранить его на диск? Для начала его туда нужно поместить) Вообще-то для загрузки данных произвольного типа служит функция LoadResData(index,format), но она возращает массив байтов, которые не есть исходный файл Вот функция, которая устраняет данную проблему: Dim i1 as Variant 'index = идентификационный номер строки, в файле-ресурсе i1 = LoadResData(index, "CUSTOM") Open "полный путь к файлу" For Binary As #1 For x = 0 To UBound(i1) Put #1, , CByte(i1(x)) Next x Close #1 Какие есть особенности при работе с файлом-ресурсов? # Если вы не нашли VB6 Resource Editor в Менеджере модулей, то нужно переустановить VB6.0, выбрав выборочную (CUSTOM) установку и поставив в меню выбора устанавливаемых компонентов галочку Select All (выбрать все) # После создания файла ресурсов картинки, тексты и т.д., которые были вставлены в файл - не нужны; # Не присваивайте идентификационный номер 1, т.к. VB резервирует этот номер для себя; # При компиляции файл ресурсов сохраняется в иполняемый файл (exe), поэтому, если вы скомпилировали программу, то вам не нужно таскать файл ресурсов оттдельно от самой программы, это может быть полезно при создании инсталляторов; Наверх 49. Как узнать полный к программе, зная её h, именно hWnd
Private Const MAX_PATH As Long = 260 Private Type PROCESSENTRY32 dwSize As Long cntUsage As Long th32ProcessID As Long th32DefaultHeapID As Long th32ModuleID As Long cntThreads As Long th32ParentProcessID As Long pcPriClassBase As Long dwflags As Long szexeFile As String * MAX_PATH End Type Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlgas As Long, ByVal lProcessID As Long) As Long Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long) Public Function GetExeFromHandle(hwnd As Long) As String Dim threadID As Long, processID As Long, hSnapshot As Long Dim uProcess As PROCESSENTRY32, rProcessFound As Long Dim i As Integer, szExename As String ' Get ID for window thread threadID = GetWindowThreadProcessId(hwnd, processID) ' Check if valid If threadID = 0 Or processID = 0 Then Exit Function ' Create snapshot of current processes hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&) ' Check if snapshot is valid If hSnapshot = -1 Then Exit Function 'Initialize uProcess with correct size uProcess.dwSize = Len(uProcess) 'Start looping through processes rProcessFound = ProcessFirst(hSnapshot, uProcess) Do While rProcessFound If uProcess.th32ProcessID = processID Then 'Found it, now get name of exefile i = InStr(1, uProcess.szexeFile, Chr(0)) If i > 0 Then szExename = Left$(uProcess.szexeFile, i - 1) Exit Do Else 'Wrong ID, so continue looping rProcessFound = ProcessNext(hSnapshot, uProcess) End If Loop Call CloseHandle(hSnapshot) GetExeFromHandle = szExename End Function Private Sub Form_Load() Me.Caption = GetExeFromHandle(Me.hWnd) End Sub Наверх 50. Форма сверху всех - Visual Basic
Эта подпрограмма хороша для создания "плавающих" поддонов значка, и т.д. Между прочим, если Вы любите Visual Basic, и Вы не имеете verions 2.0 все же, Вы должны получить это. Это верно удивительно! Модуль: 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 Global Const HWND_TOPMOST = -1 Global Const HWND_NOTOPMOST = -2 Global Const SWP_NOACTIVATE = &H10 Global Const SWP_SHOWWINDOW = &H40 Наверху всех: SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Цифры в функции: X, Y, ширина, высота Не наверху: SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Еще один вариант: ==================== ' Declaration of a Windows routine. ' This statement should be placed in the module. Declare Function SetWindowPos Lib "user32" Alias_ "SetWindowPos" (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 ' Set some constant values (from WIN32API.TXT). Const conHwndTopmost = -1 Const conHwndNoTopmost = -2 Const conSwpNoActivate = &H10 Const conSwpShowWindow = &H40 Private Sub mnuTopmost_Click () ' Add or remove the check mark from the menu. mnuTopmost.Checked = Not mnuTopmost.Checked If mnuTopmost.Checked Then ' Turn on the TopMost attribute. SetWindowPos hWnd, conHwndTopmost, 0, 0, 0, 0,_ conSwpNoActivate Or conSwpShowWindow Else ' Turn off the TopMost attribute. SetWindowPos hWnd, conHwndNoTopmost, 0, 0, 0,_ 0, conSwpNoActivate Or conSwpShowWindow End If End Sub Наверх 51. Как перетаскивать окно не за заголовок - Visual Basic
Private Const WM_NCLBUTTONDOWN = &HA1 Private Const LP_HT_CAPTION = 2 Private Declare Function ReleaseCapture Lib "user32" () 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 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim rc As Long rc = ReleaseCapture rc = SendMessage(hWnd, WM_NCLBUTTONDOWN, LP_HT_CAPTION, ByVal 0&) End Sub И ВСЁ!!! Наверх 52. Как ловить нажатия на клавиши вне вашей программы - Visual Basic
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 Наверх 53. Форматирование и копирование дискет через функции API - VB
Private Declare Function SHFormatDrive _ Lib "shell32" (ByVal hwnd As Long, _ ByVal Drive As Long, _ ByVal fmtID As Long, _ ByVal options As Long) As Long Private Declare Function GetDriveType _ Lib "kernel32" _ Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long Добавьте две command buttons в форму, назовите их cmdDiskCopy и cmdFormatDrive, и засуньте в их события Click следующие фрагменты кода: Private Sub cmdDiskCopy_Click() ' DiskCopyRunDll требует два параметра - From и To Dim DriveLetter$, DriveNumber&, _ DriveType& Dim RetVal&, RetFromMsg& DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - _ 65) DriveType = GetDriveType_ (DriveLetter) If DriveType = 2 Then 'Floppies, _ etc RetVal = Shell_ ("rundll32.exe " & _ "diskcopy.dll," _ & "DiskCopyRunDll " & _ DriveNumber & "," & _ DriveNumber, 1) Else ' Just in case RetFromMsg = MsgBox_ ("Only floppies can be " & _ "copied", 64, _ "DiskCopy Example") End If End Sub Private Sub cmdFormatDrive_Click() Dim DriveLetter$, DriveNumber&, _ DriveType& Dim RetVal&, RetFromMsg% DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - _ 65) ' Заменить букву на цифру: A=0 DriveType = GetDriveType_ (DriveLetter) If DriveType = 2 Then _ ' т.е. флоп RetVal = SHFormatDrive(Me.hwnd, _ DriveNumber, 0&, 0&) Else RetFromMsg = MsgBox_ ("This drive is NOT a " & _ "removeable drive! " & _ "Format this drive?", _ 276, "SHFormatDrive Example") If RetFromMsg = 6 Then ' Раскомментируйте и увидите... 'RetVal = SHFormatDrive_ (Me.hwnd, _ ' DriveNumber, 0&, 0&) End If End If End Sub Добавьте контрол DriveListBox под именем Drive1: Private Sub Drive1_Change() Dim DriveLetter$, DriveNumber&, _ DriveType& DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - _ 65) DriveType = GetDriveType_ (DriveLetter) If DriveType <> 2 Then _ 'Floppies, etc cmdDiskCopy.Enabled = False Else cmdDiskCopy.Enabled = True End If End Sub Будьте осторожны: так недолго и винт запороть. Наверх 54. Ярылык для загрузки последнего рабочего проекта в Visual Basic
Option Explicit Declare Function GetPrivateProfile String Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Public Sub Main() Dim temp As String, rVal$, tmp As Long rVal$ = String$(256, 0) tmp = GetPrivateProfileString ("Visual Basic", "vb32location", "", rVal$, ByVal Len(rVal$) - 1, "c:\windows\vb.ini") temp = Left$(rVal$, tmp) rVal$ = String$(256, 0) tmp = GetPrivateProfileString ("Visual Basic", "RecentFile1", "", rVal$, ByVal Len(rVal$) - 1, "c:\windows\vb.ini") temp = temp & " """ & Left$(rVal$, tmp) & """" Shell temp, 1 End End Sub Наверх 55. Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic
допустим я сделал блокнот, и мне нужно чтобы когда я открывал например TXT файл с помощью 2ой кнопки мыши, Открыть с помощью... и после того как я указал в окне выбора программ, свою программу чтобы когда я нажал на кнопку ОК, не просто тупо октрылася моя программа, а чтобы в текстовом поле этой программы появился путь к этому файл. Ответ Используй функцию Command Пример Кинь на форму 1 TextBox и в загрузку формы, помести код: Text1.text = Command теперь скомпилируй программу и открой какойнибудь файл указав на свою программу) при загрузке программы в переменную Command записывается путь того файла который ты открыл через свою прогу Наверх 56. Создание временных файлов
Function FileAux(Ext As String) As String Dim i As Long, X As String If InStr(Ext, ".") = 0 Then Ext = "." + Ext End If ' Ищем уже имеющиеся файлы на винте i = 0 Do X = "Aux" + Format$(i, "0000") + Ext If FileExists(X) Then i = i + 1 Else Exit Do End If Loop FileAux = X End Function 'Эта функция обращается к функции FileExists: Function FileExist(filename As String) As Boolean FileExist = Dir$(filename) <> "" End Function А вот пример использования: Sub Test() Dim File1 As String, File2 As String, File3 As String Dim DB1 As database, DB2 As DataBase Dim FileNum As Integer File1 = FileAux("MDB") Set DB1 = CreateDataBase(File1) File2 = FileAux("MDB") Set DB2 = CreateDataBase(File2) File3 = FileAux("TXT") FileNum = FreeFile Open File3 For OutPut As FileNum ' Ваш код ' ... Close FileNum End Sub Наверх 57. Быстрый поиск в базе данных - Visual Basic
Public Function MyDLookUp(Column As _ String, TableName As String, _ Condition As String) As Variant Dim Rec As Recordset On Error GoTo MyDlookUp_Err ' gCurBase - глобальная переменая, указывающая на текущкю БД Set Rec = gCurBase.OpenRecordset_ ("Select * From " & TableName) Rec.FindFirst Condition If Not Rec.NoMatch Then ' возвращает искомое поле, если найдено MyDLookUp = Rec(Column) Exit Function End If ' возврат, если не найдено, или произошла другая ошибка MyDlookUp_Err: MyDLookUp = -1 End Function Наверх 58. Заперетить юзеру закрывать форму - Visual Basic
' если у Вас VB3, раскомментируйте следующую строку ' Const vbFormControlMenu = 0 Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If UnloadMode = vbFormControl Menu Then Cancel = True End If End Sub Наверх 59. Как просто отформатировать и округлить число - Visual Basic
n = 12.345 Format(n, "0.00\0") ' возвращает "12.350" Format(n, "0.\0\0") ' возвращает "12.00" Format(0.55, "#.0\0") ' возвращает ".60" Наверх 60. Перевод денежных сумм из цифp в 'прописью' - Visual Basic
Function Сумма_прописью(s@) As String Static triad(4) As Integer, numb1(0 To 19) As String, numb2(0 To 9) As String, numb3(0 To 9) As String If s@ = 0 Then Сумма_прописью = "" Exit Function End If ss@ = s@ triad(1) = ss@ - Int(ss@ / 1000) * 1000 ss@ = Int(ss@ / 1000) triad(2) = ss@ - Int(ss@ / 1000) * 1000 ss@ = Int(ss@ / 1000) triad(3) = ss@ - Int(ss@ / 1000) * 1000 ss@ = Int(ss@ / 1000) triad(4) = ss@ - Int(ss@ / 1000) * 1000 ss@ = Int(ss@ / 1000) numb1(0) = "" numb1(1) = "один " numb1(2) = "два " numb1(3) = "три " numb1(4) = "четыре " numb1(5) = "пять " numb1(6) = "шесть " numb1(7) = "семь " numb1(8) = "восемь " numb1(9) = "девять " numb1(10) = "десять " numb1(11) = "одиннадцать " numb1(12) = "двенадцать " numb1(13) = "тринадцать " numb1(14) = "четырнадцать " numb1(15) = "пятнадцать " numb1(16) = "шестнадцать " numb1(17) = "семнадцать " numb1(18) = "восемнадцать " numb1(19) = "девятнадцать " numb2(0) = "" numb2(1) = "" numb2(2) = "двадцать " numb2(3) = "тридцать " numb2(4) = "сорок " numb2(5) = "пятьдесят " numb2(6) = "шестьдесят " numb2(7) = "семьдесят " numb2(8) = "восемьдесят " numb2(9) = "девяносто " numb3(0) = "" numb3(1) = "сто " numb3(2) = "двести " numb3(3) = "триста " numb3(4) = "четыреста " numb3(5) = "пятьсот " numb3(6) = "шестьсот " numb3(7) = "семьсот " numb3(8) = "восемьсот " numb3(9) = "девятьсот " txt$ = "" If ss@ <> 0 Then n% = MsgBox("Сумма выходит за границы формата", 16, "Сумма прописью") Сумма_прописью = "" Exit Function End If For i% = 4 To 1 Step -1 n% = 0 If triad(i%) > 0 Then n% = Int(triad(i%) / 100) txt$ = txt$ & numb3(n%) n% = Int((triad(i%) - n% * 100) / 10) txt$ = txt$ & numb2(n%) If n% < 2 Then n% = triad(i%) - (Int(triad(i%) / 10) - n%) * 10 Else n% = triad(i%) - Int(triad(i%) / 10) * 10 End If Select Case n% Case 1 If i% = 2 Then txt$ = txt$ & "одна " Else txt$ = txt$ & "один " Case 2 If i% = 2 Then txt$ = txt$ & "две " Else txt$ = txt$ & "два" Case Else txt$ = txt$ & numb1(n%) End Select Select Case i% Case 2 If n% = 0 Or n% > 4 Then txt$ = txt$ + "тысяч " Else If n% = 1 Then txt$ = txt$ + "тысяча " Else txt$ = txt$ + "тысячи " End If Case 3 If n% = 0 Or n% > 4 Then txt$ = txt$ + "миллионов " Else If n% = 1 Then txt$ = txt$ + "миллион " Else txt$ = txt$ + "миллиона " End If Case 4 If n% = 0 Or n% > 4 Then txt$ = txt$ + "миллиардов " Else If n% = 1 Then txt$ = txt$ + "миллиард " Else txt$ = txt$ + "миллиарда " End If End Select End If Next i% If n% = 0 Or n% > 4 Then txt$ = txt$ + "рублей" Else If n% = 1 Then txt$ = txt$ + "рубль" Else txt$ = txt$ + "рубля" End If txt$ = UCase$(Left$(txt$, 1)) & Mid$(txt$, 2) Сумма_прописью = txt$ End Function Наверх 61. Как запретить запуск второй копии программы - Visual Basic
If App.PrevInstance Then End Наверх 62. Открыть/закрыть дверцу CD/DVD-ROM
62.2 Открытие и закрытие нескольких CD-ROM ’ов - Visual Basic 62.3 Информация о CD-ROM - Visual Basic 62.1 Открыть/закрыть дверцу CD/DVD-ROM =================================================== ' Открыть дверцу CD-ROM mciSendString "Set CDAudio Door Open Wait", 0&, 0&, 0& ' Закрыть дверцу CD-ROM mciSendString "Set CDAudio Door Closed Wait", 0&, 0&, 0& 62.2 Открытие и закрытие нескольких CD-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 OpenCloseDoor(strDriveLetter As String, Optional blnDoOpen As Boolean = True) Dim AliasName$, strOpenClose$ strOpenClose = IIf(blnDoOpen, "Open", "Closed") AliasName = "Laufwerk" & strDriveLetter mciSendString "Open " & strDriveLetter & ": Alias " & AliasName & " Type CDAudio", 0, 0, 0 mciSendString "Set " & AliasName & " Door " & strOpenClose, 0, 0, 0 End Sub Private Sub Command1_Click() OpenCloseDoor "d:\" 'Открываем End Sub Private Sub Command2_Click() OpenCloseDoor "d:\", False 'Закрываем End Sub 'Источник: http://bit.pirit.info/ 62.3 Информация о CD-ROM - Visual Basic =================================================== Dim WMI, str, ColCD, CD set WMI=getobject("Winmgmts:") str=str & "CD-ПРИВОДЫ:" & VBCRLF Set ColCD=WMI.execquery("select * from Win32_CDROMDrive") str=str & "Количество: " & ColCD.count & vbcrlf For Each CD In ColCD str=str & "Диск (" & CD.MediaType & ") " & CD.Drive & vbcrlf str=str & CD.caption & vbcrlf Next Источник: http://www.cyberforum.ru/ Наверх 63. Работа с Word - Создание, открытие, форматирование, закрытие и сохранение
Источник: www.vbstreets.ru Использование Word в приложениях на Visual Basic 6 открывает широчайшие возможности для создания профессионально оформленных документов (например отчетов). Это часто необходимо при работе в фирме или на предприятии для обеспечения документооборота. Основным преимуществом использования Wordа в этом случае является то, что практически на всех компьютерах, используемых в фирмах и на предприятиях установлены Windows и пакет Microsoft Office. Поэтому подготовленные документы Word не требуют каких-либо дополнительных усилий для их просмотра, печати и редактирования. Единственное что нужно помнить, это то что работа через автоматизацию OLE (связывание и внедрение объектов) на деле оказывается довольно медленной технологией, хотя и очень полезной. Чтобы использовать объекты Word в Visual Basic , необходимо инсталлировать сам Word. После этого вы получаете в своё распоряжение библиотеку Microsoft Word Object Library, которую нужно подключить к текущему проекту через диалоговое окно "Разработать">>"Ссылки" (References) и указать Microsoft Word 9.0 Object Library (для Word 2000). Два самых важных объекта Word это Word.Application и Word.Document. Они обеспечивают доступ к экземпляру приложения и документам Word. Поэтому в раздел Generals "Общее" формы введите следующий код для объявления объектных переменных приложения Word и документа Word. Dim WordApp As Word.Application ' экземпляр приложения Dim DocWord As Word.Document' экземпляр документа Чтобы создать новый экземпляр Word, введите такой код кнопки; Private Sub Комманда1_Click() 'создаём новый экземпляр Word-a Set WordApp = New Word.Application 'определяем видимость Word-a по True - видимый, 'по False - не видимый (работает только ядро) WordApp.Visible = True 'создаём новый документ в Word-e Set DocWord = WordApp.Documents.Add '// если нужно открыть имеющийся документ, то пишем такой код 'Set DocWord = WordApp.Documents.Open("C:\DDD.doc") 'активируем его DocWord.Activate End Sub Для форматирования печатной области документа используйте данный код: (вообще-то Word использует для всех размеров своих элементов пункты, поэтому для использования других единиц измерения, необходимо использовать встроенные функции форматирования.) Например: CentimetersToPoints(Х.ХХ) - переводит сантиметры в пункты. MillimetersToPoints(X.XX) - переводит миллиметры в пункты Private Sub Комманда2_Click() 'отступ слева "2,0 сантиметра" DocWord.Application.Selection.PageSetup.LeftMargin = CentimetersToPoints(2) 'отступ справа "1,5 сантиметра" DocWord.Application.Selection.PageSetup.RightMargin = CentimetersToPoints(1.5) 'отступ сверху "3,5 сантиметра" DocWord.Application.Selection.PageSetup.TopMargin = CentimetersToPoints(3.5) 'отступ снизу "4,45 сантиметра" DocWord.Application.Selection.PageSetup.BottomMargin = CentimetersToPoints(4.45) End Sub Небольшое отступление. Для того чтобы в своём приложении не писать постоянно одно и тоже имя объекта, можно использовать оператор With. Например код находящейся выше можно переписать так: With DocWord.Application.Selection.PageSetup .LeftMargin = CentimetersToPoints(2) .RightMargin = CentimetersToPoints(1.5) .TopMargin = CentimetersToPoints(3.5) .BottomMargin = CentimetersToPoints(4.45) End With Если вам необходимо создать документ Word с нестандартным размером листа, то используйте данный код: With DocWord.Application.Selection.PageSetup .PageWidth = CentimetersToPoints(20) 'ширина листа (20 см) .PageHeight = CentimetersToPoints(25) 'высота листа (25 см) End With Данный код меняет ориентацию страницы (практически меняет местами значения ширины и высоты листа): DocWord.Application.Selection.PageSetup.Orientation = wdOrientLandscape wdOrientLandscape - альбомная ориентация ( число 1) wdOrientPortrait - книжная ориентация ( число 0) Для сохранения документа под новым именем и в определенное место используйте данный код код: 'сохраняем документ как DocWord.SaveAs "c:\DDD.doc" После такого сохранения вы можете про ходу работы с документом сохранять его. 'сохраняем документ DocWord.Save Или проверить, были ли сохранены внесенные изменения свойством Saved и если изменения не были сохранены - сохранить их; If DocWord.Saved=False Then DocWord.Save Завершив работу с документом, вы можете закрыть сам документ методом Close и сам Word методом Quit. 'закрываем документ (без запроса на сохранение) DocWord.Close True 'закрываем Word (без запроса на сохранение) WordApp.Quit True 'уничтожаем обьект - документ Set DocWord = Nothing 'уничтожаем обьект - Word Set WordApp = Nothing Если в методах Close и Quit не использовать необязательный параметр True то Word запросит согласие пользователя (если документ не был перед этим сохранён) на закрытие документа. Если вам необходимо оставить Word открытым, просто не используйте методы Close и Quit. Если вам необходимо поставить пароль на документ, то используйте код: DocWord.Protect wdAllowOnlyComments, , "123456789" Наверх 64. Работа с Word - Добавление текста в документ Word - VB
В этом примере описываются основные приёмы последовательного добавления текста в документ Word. Для правильного использования данных приёмов нужно представлять принцип построения документа Word. Основным принципом структуры текста в Word-е можно назвать то, что текст делится на параграфы. Сам текст не привязан к какому-либо конкретному месту листа, как это происходит в SCADa системах. В Word-е можно в конкретное место листа (по каким-либо координатам ) вставить графические элементы (линии, прямоугольники, рисунки и т.д.), а текст не является жесткой структурой. Весь текст в документе вводится последовательно и так или иначе связан между собой. Вы можете, например, изменить размер части текста и при этом тот текст который находится ниже изменит своё положение на листе. Весь текст в документе разбит на параграфы, когда вы при работе в Word и нажимаете Ввод нового текста Перед этим вы должны создать или открыть документ Word, как это было описано в первой статье. Я лично предпочитаю создавать новый документ, ведь при этом вы можете, не зависимо от установок на конкретном компьютере, делать документ, параметры которого целиком задаёте вы. При добавлении текста он выделяется и если вам необходимо вводить последующий текст с новыми параметрами, вы должны снять выделение с предыдущего текста. Добавляем текст к концу предыдущего. 'печатаем какой то текст (при этом он выделен) DocWord.Application.Selection.InsertAfter "Первая строка текста (синий, 12 пт," DocWord.Application.Selection.InsertAfter " Tahoma, полужирный)" 'делаем выделенный текст полужирным "Font.Bold=True" DocWord.Application.Selection.Font.Bold = True 'делаем выделенный текст синим DocWord.Application.Selection.Font.Color = wdColorBlue 'делаем выделенный текст размером 12 пунктов DocWord.Application.Selection.Font.Size = 12 'делаем текст шрифтом "Tahoma" DocWord.Application.Selection.Font.Name = "Tahoma" 'снимаем выделение с текста DocWord.Application.Selection.EndOf Данная строка кода добавляет параграф ниже существующего 'начинаем с новой строки, то есть новый параграф (при этом параметры 'текста как в предыдущей строке) DocWord.Application.Selection.InsertParagraphAfter Печатаем новый параграф. With DocWord.Application.Selection 'печатаем какой то текст (при этом он выделен) 'и используем Tab для отступа .InsertAfter vbTab & "Вторая строка текста с отступом (обычный" .InsertAfter ", черный, 14 пт, Arial)" 'текст напечатался с параметрами текста в 'предыдущем параграфе, поэтому 'вводим новые параметры 'делаем выделенный текст простым "Font.Bold= False" .Font.Bold = False 'делаем выделенный текст черным .Font.Color = wdColorBlack 'делаем выделенный текст размером 14 пунктов .Font.Size = 14 'делаем текст шрифтом "Arial" .Font.Name = "Arial" 'снимаем выделение с текста .EndOf 'начинаем с новой строки, то есть новый параграф '(при этом параметры текста как в предыдущей строке) .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter End With Печатаем текст различными стилями With DocWord.Application.Selection 'печатаем текст (при этом он выделен) 'и используем Tab для отступа .InsertAfter vbTab & "Простой текст, " 'делаем выделенный текст простым "Font.Bold= False" .Font.Bold = False 'делаем выделенный текст черным .Font.Color = wdColorBlack 'делаем выделенный текст размером 14 пунктов .Font.Size = 14 'делаем текст шрифтом "Arial" .Font.Name = "Arial" 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "полужирный текст, " 'делаем выделенный текст полужирным "Font.Bold=True" .Font.Bold = True 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "текст курсив, " 'делаем текст обычным (выше был полужирный) .Font.Bold = False 'делаем текст курсивом .Font.Italic = True 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "полужирный курсив, " 'делаем текст полужирным .Font.Bold = True 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "подчеркнутый текст, " 'делаем текст простым (отключаем Bold, Italic) .Font.Bold = False .Font.Italic = False 'делаем текст с подчеркиванием (выбирая разные константы 'делаем перечеркнутый,двойное подчеркивание и т.д.) .Font.Underline = wdUnderlineSingle 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "окончание стилей." 'делаем текст простым (отключаем подчеркивание) .Font.Underline = wdUnderlineNone 'снимаем выделение с текста .EndOf End With Наверх 65. Работа с Word - Добавление текста в документ Word (Продолжение)l
Источник: www.vbstreets.ru Вместо инструкции .Application вы можете использовать .ActiveWindow. Печатаем надстрочный и подстрочный текст With DocWord.ActiveWindow.Selection 'делаем текст простым "Font.Bold= False" .Font.Bold = False 'делаем выделенный текст черным .Font.Color = wdColorBlack 'делаем выделенный текст размером 14 пунктов .Font.Size = 14 'делаем текст шрифтом "Arial" .Font.Name = "Arial" 'начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "Обычный текст" 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "подстрочный текст" 'делаем его подстрочным "нижний индекс" .Font.Subscript = True 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "обычный текст" 'делаем его обычным .Font.Subscript = False 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "надстрочный текст" 'делаем его надстрочным "верхний индекс" .Font.Superscript = True 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "обычный текст" 'делаем его обычным .Font.Superscript = False 'снимаем выделение с текста .EndOf End With Выравнивание текста: With DocWord.ActiveWindow.Selection 'делаем текст простым "Font.Bold= False" '.Font.Bold = False 'делаем выделенный текст черным '.Font.Color = wdColorBlack 'делаем выделенный текст размером 14 пунктов '.Font.Size = 14 'делаем текст шрифтом "Arial" '.Font.Name = "Arial" 'начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "Обычный текст с выравниванием по центру." 'форматируем текст 'по центру "wdAlignParagraphCenter"=1 .ParagraphFormat.Alignment = 1 'начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "Обычный текст с выравниванием по правому краю." 'форматируем текст 'по правому краю "wdAlignParagraphRight"=2 .ParagraphFormat.Alignment = 2 'начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "Обычный текст с выравниванием по ширине. " .InsertAfter "Обычный текст с выравниванием по ширине." 'форматируем текст 'по ширине "wdAlignParagraphJustify"=3 .ParagraphFormat.Alignment = 3 начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf 'печатаем текст .InsertAfter "Обычный текст с выравниванием по левому краю." 'форматируем текст ' по левому краю "wdAlignParagraphLeft"=0 .ParagraphFormat.Alignment = 0 начинаем с новой строки, то есть новый параграф .InsertParagraphAfter 'делаем строку промежуток .InsertParagraphAfter 'снимаем выделение с текста .EndOf End With Междустрочный интервал With DocWord.ActiveWindow.Selection 'начинаем с новой строки .InsertParagraphAfter .InsertParagraphAfter 'печатаем какой то текст .InsertAfter "полуторный интервал полуторный интервал полуторный интервал." 'снимаем выделение с текста .EndOf 'начинаем с новой строки .InsertParagraphAfter .InsertParagraphAfter 'полуторный интервал (в параграфе выше) .ParagraphFormat.Space15 'печатаем какой то текст .InsertAfter "обычный интервал обычный интервал обычный интервал " 'снимаем выделение с текста .EndOf 'начинаем с новой строки .InsertParagraphAfter .InsertParagraphAfter 'обычный интервал (в параграфе выше) .ParagraphFormat.Space1 'печатаем какой то текст .InsertAfter "двойной интервал двойной интервал двойной интервал." 'снимаем выделение с текста DocWord.ActiveWindow.Selection.EndOf 'двойной интервал (в параграфе выше) DocWord.Application.Selection.ParagraphFormat.Space2 'снимаем выделение с текста .EndOf End With Наверх 66. Работа с Word - Работа с таблицами в Word (часть 1)
При создании документов в Word рано или поздно возникает необходимость в каких-либо методах форматирования данных, вводимых в документ. Можно конечно использовать Tab-ы в параграфах или всё время новые строки, но это не решение всех проблем. Хорошим решением этой проблемы являются таблицы. Работа с таблицами в Word очень напоминает работу с книгой в Exsel, методы практически одни и те же. Перейдём к практике. Основным элементом для работы с таблицами является коллекция Tables. Также как и все объекты Word, данную коллекцию нужно сначала объявить, а потом инициализировать. В данной статье не рассматриваются вопросы доступа к существующим таблицам, мы создаём новые и работаем с ними. Рассмотрим это на примере. 'объявляем объектную переменную в разделе ' Generals формы Dim TableWord As Word.Table Инициализируем коллекцию Tables и создаём новую таблицу. При этом нужно сразу определиться, какая таблица вам необходима, сколько в ней должно быть строк и столбцов, а также где она будет находиться. Если использовать первый код, то новая таблица перекроет весь текст который был в документе ("удалит" его). Если вы уже добавили текст в документ, то используйте второй код. Он вставит таблицу туда, где находится в данный момент "мигающий" курсор. Код №1 'создаём таблицу 10 строк, 2 столбца 'во всю ширину области печати текста Set TableWord = DocWord.Tables.Add(DocWord.Range(), 10, 2) Код №2 'создаём таблицу 10 строк, 2 столбца 'во всю ширину области печати текста Set TableWord = DocWord.Tables.Add(DocWord.Application.Selection.Range, 10, 2) После этого мы можем добавлять текст в ячейки таблицы используя метод Cell. 'печатаем текст в ячейке с адресом '(номер_строки, номер_столбца) TableWord.Cell(1, 1).Range.Text = "Первая ячейка" TableWord.Cell(2, 1).Range.Text = "Вторая ячейка" Небольшое отступление. Вы можете данную инструкцию использовать и для получения текста из ячейки: Dim strText As String 'получаем текст из ячейки strText= TableWord.Cell(1, 1).Range.Text Следующий этап программирования - задаём высоту строк в данной таблице. Имеется возможность задавать высоту строк для конкретной строки или для всех сразу. Изменение высоты всех строк используйте сразу после создании таблицы, иначе, если вы по ходу программы для конкретных строк задали разные высоты, все ваши труды пропадут. При этом и учитывайте то, что если текст больше вместимости ячейки, а вы не задали опцию "не изменять размер ячейки", текст раздвинет её высоту (и ширину) до необходимых для себя размеров и естественно увеличит высоту всей строки. 'делаем все строки высотой 24 пт 'если нужно в других единицах измерения, то 'используем функции перевода: например (CentimetersToPoints(Х.ХХ)) TableWord.Rows.Height = 24 'делаем определённую строку (5-тую) высотой 2 см TableWord.Rows(5).Height = CentimetersToPoints(2) Продолжаем форматирование таблицы - изменяем ширину столбцов. Внимательно следите за общей шириной таблицы, чтобы её ширина не превысила ширину области печати. Иначе ваша таблица "уползёт" за границы листа. Также как высота строк, ширина столбцов может задаваться для конкретных столбцов по отдельности или всех столбцов сразу, со всеми вытекающими последствиями. 'делаем все столбцы шириной 5 см TableWord.Columns.Width = CentimetersToPoints(5) 'делаем 1-вый столбец шириной 3 см TableWord.Columns(1).Width = CentimetersToPoints(3) По ходу выполнения программы вы можете изменять местоположение таблицы. При этом текст будет "обтекать" таблицу (по умолчанию). Помните, что позиция таблицы задается от левой и верхней границ места вставки. 'изменяем положение таблицы по вертикали TableWord.Rows.VerticalPosition = CentimetersToPoints(5) ''изменяем положение таблицы по горизонтали TableWord.Rows.HorizontalPosition = CentimetersToPoints(1.5) Для того чтобы эффективно работать с таблицей, нужно знать количество строк и столбцов, а также ячеек в таблице (особенно это касается тех таблиц, которые уже есть в документе, если вы работаете не с новым экземпляром Word-а, а с уже существующим). Для этого OLE automation предоставляет свойство Count (количество). Это свойство позволяет узнать количество строк, столбцов, ячеек в таблице, а также количество самих таблиц в документе (а также количество слов, параграфов "абзацев" и т.д). Для получения количества строк в данной таблице воспользуемся коллекцией Rows. 'получаем количество строк в таблице TableWord.Cell(2, 2).Range.Text = "Строк - " & TableWord.Rows.Count Для получения количества столбцов в данной таблице воспользуемся коллекцией Columns. 'получаем количество столбцов в таблице TableWord.Cell(3, 2).Range.Text = "Столбцов - " & TableWord.Columns.Count А для получения количества ячеек в данной таблице воспользуемся коллекцией Cells. 'получаем количество ячеек в таблице TableWord.Cell(3, 2).Range.Text = "Ячеек - " & TableWord.Range.Cells.Count Коллекции Columns, Rows и Cells позволяют получить доступ к своим элементам через индекс. Например TableWord.Range.Cells(1).Text получит текст из первой ячейки. Однако помните, что обращение к несуществующему индексу вызовет ошибку времени исполнения. Поэтому перед обращением к коллекции через индекс проверьте, не выходит ли он за допустимый диапазон свойством .Count и не забудьте добавить в начало код обработчика ошибок. После этого вы можете использовать циклы для обработки каждого элемента коллекции. Для получения количества таблиц в документе воспользуемся коллекцией Tables. 'получаем количество таблиц в документе TableWord.Cell(4, 2).Range.Text = "Таблиц - " & DocWord.Tables.Count После этого вы можете получить доступ к любой таблице в данном документе, то есть ко всем её элементам также как мы это делали выше (с небольшим изменением конечно). 'печатаем текст в ячейке с адресом '(номер_строки, номер_столбца) DocWord.Tables(1).Cell(5, 2).Range.Text = "Привет" Наверх 67. Работа с Word - Работа с таблицами в Word (часть 2)
При работе с таблицами часто возникает необходимость изменить вид ячеек, объединить их между собой. Это позволяет визуально распределить вводимую информацию в таблице, а также улучшить внешний вид в целом (естественно при продуманном применении данной возможности). Однако нужно помнить и о "подводных камнях" при использовании данного кода в программировании. Основное что нужно помнить, это то что при объединении ячеек одна ячейка как бы "поглащает" другую ячейку (или ячейки). При этом не только изменится общее количество ячеек (уменьшится), но и "поглащенные" ячейки как бы перестанут существовать. Поэтому при обращении к "поглащенной" ячейке произойдёт ошибка. Например: при объединении ячейки 1,2 с ячейкой 1,1 останется ячейка 1,1 , а ячейка 1,2 перестанет существовать. При объединении ячеек 1,1; 2,1; 3,1 в итоге останется только ячейка 1,1. 'объеденяем ячейку 1,1 с ячейкой 1,2 TableWord.Cell(1, 1).Merge TableWord.Cell(2, 1) 'объеденяем ячейку 4,2 с ячейкой 4,1 TableWord.Cell(4, 2).Merge TableWord.Cell(4, 1) По умолчанию (при создании таблицы) толщина линий, разделяющая ячейки, строки и столбцы одинакова, и зависит от настроек Word-a. Для изменения толщины линий вы можете воспользоваться данным кодом: 'делаем верхнюю линию (границу) ячейки толщиной 6 пт TableWord.Cell(5, 1).Borders(wdBorderTop).LineWidth = wdLineWidth600pt 'делаем слева линию (границу) ячейки толщиной 3 пт TableWord.Cell(6, 1).Borders(wdBorderLeft).LineWidth = wdLineWidth300pt 'делаем нижнюю линию (границу) ячейки толщиной 2,25 пт TableWord.Cell(7, 1).Borders(wdBorderBottom).LineWidth = wdLineWidth225pt 'делаем справа линию (границу) ячейки толщиной 3 пт TableWord.Cell(8, 1).Borders(wdBorderRight).LineWidth = wdLineWidth300pt В ходе работы с таблицей вам может понадобиться разукрасить линии разным цветом для придания более красочного вида таблице. Для этого вы можете воспользоваться разными программными кодами. В первом примере кода мы используем встроенные константы для определения цвета линии. Синтаксис можно вольно перевести так: <объект_ТАБЛИЦА>.<ЯЧЕЙКА>(номер_строки, номер_столбца).<ГРАНИЦЫ>(верхняя_граница).<ЦВЕТ> = <константа_ЦВЕТ_СИНИЙ> После знака равно вы можете подставить любую встроенную цветовую константу VB. 'делаем цвет верхней линии (границы) ячейки синим TableWord.Cell(9, 1).Borders(wdBorderTop).Color = wdColorBlue Если среди встроенных цветовых констант вам не удалось найти нужного вам цвета, то вы всегда можете воспользоваться функцией RGB и задать необходимый вам цвет в цифровом коде. 'делаем цвет верхней линии (границы) ячейки произвольным TableWord.Cell(10, 1).Borders(wdBorderTop).Color = RGB(100, 200, 50) Кроме толщины и цвета линий вы можете оформить таблицу разными стилями линий. В Word встроено множество стилей оформления линий. Рассмотрим большинство из них (вы всегда можете поэкспериментировать с другими константами). 'изменим стиль линий используя разные константы TableWord.Cell(6, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashDotDot TableWord.Cell(7, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashDotStroked TableWord.Cell(8, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashLargeGap TableWord.Cell(9, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashSmallGap TableWord.Cell(10, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDot TableWord.Cell(11, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDouble TableWord.Cell(12, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDoubleWavy TableWord.Cell(13, 2).Borders(wdBorderTop).LineStyle = wdLineStyleEmboss3D TableWord.Cell(14, 2).Borders(wdBorderTop).LineStyle = wdLineStyleEngrave3D 'Невидимая при печати линия TableWord.Cell(15, 2).Borders(wdBorderTop).LineStyle = wdLineStyleNone TableWord.Cell(16, 2).Borders(wdBorderTop).LineStyle = wdLineStyleSingleWavy TableWord.Cell(17, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinLargeGap TableWord.Cell(18, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinMedGap TableWord.Cell(19, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinSmallGap TableWord.Cell(20, 2).Borders(wdBorderTop).LineStyle = wdLineStyleTriple После того как вы измените стиль линии, вы можете изменять цвет и толщину, как это было показано в коде выше. При работе с таблицами, уже после её создания вам может не хватить строк, столбцов или ячеек для ввода информации. Тогда вам будет необходимо динамически добавить нужное количество элементов в таблицу. В принципе это не сложно, за исключением некоторых оговорок. Напрямую объект Tables не поддерживает динамическое добавление элементов. Но от лома нет приёма, если нет другого лома. Поэтому добавлять элементы к таблице мы будем через другие объекты. Смысл этого приёма состоит в том, что объекты Word.Application и его "дочерний объект " Word.Document позволяют производить такие действия над своими потомками, которые сами эти объекты не поддерживают. Мы должны для начала выбрать необходимый нам для работы элемент "дочернего" объекта, а уже после этого произвести необходимые действия через объект - "родитель". Но необходимо помнить и о "подводных камнях" данного приёма. Конкретно для таблиц это значит, что как я уже упоминал выше, при объединении строк происходит "поглощение" ячеек. Из этого следует, что если вы попытаетесь выбрать столбец или строку которые содержат "поглощённые" ячейки, то вызовете ошибку. Если вы выберете ячейку ("нормальную"), то вы избежите предыдущую ошибку, но так как добавляемые столбцы и строки наследуют свойства строки и столбца родителя вы получите результат, который вам не понравиться. Ведь столбец потомок наследует объединенную строку и её формат, при этом ячейка "вылезет" за границы таблицы. Из этого следует, что желательно добавлять такие строки и столбцы, родители которых не имеют объединенных ячеек, строк и столбцов. Перейдём к коду. 'Выделяем (выбираем) 1-ю строку 'TableWord.Rows(1).Select 'Выделяем (выбираем) 1-й столбец 'TableWord.Columns(1).Select 'Выделяем (выбираем) ячейку TableWord.Cell(20, 2).Select 'добавляем столбец справа от выбранного DocWord.Application.Selection.InsertColumnsRight 'или WordApp.Selection.InsertColumnsRight 'добавляем столбец слева от выбранного DocWord.Application.Selection.InsertColumns 'или WordApp.Selection.InsertColumns 'Выделяем (выбираем) ячейку TableWord.Cell(20, 2).Select 'добавляем строку выше (как параметр можно указать сколько строк вставить) DocWord.Application.Selection.InsertRowsAbove 2 'добавляем строку ниже (как параметр можно указать сколько строк вставить) DocWord.Application.Selection.InsertRowsBelow 2 'Выделяем (выбираем) ячейку TableWord.Cell(24, 2).Select 'вставим ячейку (c применением параметров) ' 3 - вставить целый столбец ' 2 - вставить целую строку ' 1 - вставить со смещением вниз ' 0 - вставить со смещением вправо DocWord.Application.Selection.InsertCells (3) Наверх 68. Как запретить запуск второй копии программы
В предыдущей статье были рассмотрены способы динамического добавления строк и столбцов. Но вам может понадобиться и обратная операция, удаление. Поэтому рассмотрим данный код: 'Удаляем 3-й столбец TableWord.Columns(3).Delete 'Удаляем 20-ю строку TableWord.Rows(20).Delete 'Удаляем ячейку TableWord.Cell(19, 1).Delete Для оформления внешнего вида таблицы в Word-e часто используется заливка ячеек цветом. Мы тоже не обойдём вниманием эту возможность и добавим код в программу. 'произведём заливку ячейки с помощью константы TableWord.Cell(8, 1).Shading.BackgroundPatternColor = wdColorGold 'произведём заливку ячейки с помощью функции RGB TableWord.Cell(8, 2).Shading.BackgroundPatternColor = RGB(100, 200, 50) 'произведём заливку столбца TableWord.Columns(3).Shading.BackgroundPatternColor = wdColorOrange 'произведём заливку строки TableWord.Rows(10).Shading.BackgroundPatternColor = wdColorTan 'произведём заливку всей таблицы 'TableWord.Shading.BackgroundPatternColor = wdColorBlue Основным действием в ходе работы с таблицами является добавление текста в ячейки. Для простого добавления текста хватает и кода TableWord.Cell(4, 2).Range.Text = "", но здесь есть некоторые нюансы. Например при использовании данного кода вы всегда будете обновлять содержимое ячейки, то есть уничтожать предыдущий текст. И самое неприятное это то что при изменении свойств текста вы изменяете свойства всего текста в ячейке. Рассмотрим на примере: 'печатаем текст в ячейку (в две строки) TableWord.Cell(10, 1).Range.Text = "Назаров" & vbCrLf & "GGG" 'меняем цвет текста в ячейке TableWord.Cell(10, 1).Range.Font.Color = wdColorBlue 'делаем текст размером 14 пт. TableWord.Cell(10, 1).Range.Font.Size = 14 'переключаем на полужирный текст TableWord.Cell(10, 1).Range.Font.Bold = wdToggle Для того чтобы обойти эти ограничения мы воспользуемся способом, описанным в предыдущей статье. 'выбираем ячейку TableWord.Cell(10, 2).Select Если после этого кода мы не вставим команду "снять выделение", то текст, который был в ячейке, уничтожится и вместо него напечатается новый. Для того чтобы этого избежать, введите код: 'снимаем выделение 'DocWord.Application.Selection.EndOf После этого вы можете добавлять и изменять текст. Для изменения свойств текста вводите код для изменения свойств, перед тем как добавите текст. Свойства можно изменять почти так же, как описано в предыдущих статьях за исключением операторов TypeText и TypeParagraph. 'добавляем в её текст DocWord.Application.Selection.TypeText "Первый текст" 'начинаем новую строку DocWord.Application.Selection.TypeParagraph 'делаем её шрифт синим DocWord.Application.Selection.Font.Color = wdColorBlue 'добавляем текст DocWord.Application.Selection.TypeText "Вторая строка текста." 'начинаем новую строку DocWord.Application.Selection.TypeParagraph 'делаем текст размером 14 пт. DocWord.Application.Selection.Font.Size = 14 'меняем цвет текста DocWord.Application.Selection.Font.Color = wdColorOrange 'переключаем на полужирный текст DocWord.Application.Selection.Font.Bold = wdToggle 'добавляем текст DocWord.Application.Selection.TypeText "Третья строка текста." Одним из способов оформления таблиц является "авто формат", то есть готовые стили оформления встроенные в Word. Их в 2000 целых 43 штуки. Вы можете поэкспериментировать с ними, введя следующий код и нажимая кнопку для переключения стилей. Предупреждение - изменение стиля производите в начале работы с таблицей, иначе все ваши изменения в оформлении ячеек пропадут! 'изменяем счетчик и сбрасываем его при достижении 43 Shet = Shet + 1 If Shet = 43 Then Shet = 0 'форматировать таблицу выбраным стилем TableWord.AutoFormat Shet Интересной возможностью Word-a является возможность добавлять (почти) сколько угодно вложенных таблиц. Работать с ними можно также, как это было описано выше. 'выбираем ячейку TableWord.Cell(15, 2).Select 'снимаем выделение (для нормальной работы следующего кода) DocWord.Application.Selection.EndOf 'добавляем вложенную таблицу Set TableWord2 = DocWord.Tables.Add(DocWord.Application.Selection.Range, 5, 3) 'печатаем текст в ячейку TableWord2.Cell(2, 2).Range.Text = "2,2" Наверх 69. Сортировка методом ШеллаSub ShellSort(vArray As Variant) Dim TempVal As Variant Dim i As Long, GapSize As Long, CurPos As Long Dim FirstRow As Long, LastRow As Long, NumRows As Long FirstRow = LBound(vArray) LastRow = UBound(vArray) NumRows = LastRow - FirstRow + 1 Do GapSize = GapSize * 3 + 1 Loop Until GapSize > NumRows Do GapSize = GapSize \ 3 For i = (GapSize + FirstRow) To LastRow CurPos = i TempVal = vArray(i) Do While CompareResult(vArray(CurPos - GapSize), TempVal) vArray(CurPos) = vArray(CurPos - GapSize) CurPos = CurPos - GapSize If (CurPos - GapSize) < FirstRow Then Exit Do Loop vArray(CurPos) = TempVal Next Loop Until GapSize = 1 End Sub Private Function CompareResult(Value1 As Variant, Value2 As Variant) CompareResult = (Value1 > Value2) End Function Наверх 70. Работа с Word - Работа с графическими объектами в Word (часть 1)
Кроме инструментов для работы с таблицами и текстом Word располагает обширным набором функций и методов для работы с графическими объектами. Для этого у Word-a есть встроенный графический редактор, набор инструментов которого вы можете использовать для красочного оформления документов. Вы можете использовать линии, прямоугольники, стрелки, автофигуры и т.д. При этом имеется коллекция ThreeD, для придания практически всем этим графическим элементам, "примитивам", объёма. Для создания графического объекта вы можете использовать два метода: 1) явным объявлением объектной переменной типа Shape, например Dim Line1 As Word.Shape, и последующей её инициализацией. 2) неявной инициализацией объекта Shape. Оба метода имеют свои преимущества и недостатки, например при 2-м методе не нужно объявлять объектную переменную для каждого графического примитива, но в дальнейшем сложнее получать доступ к свойствам и методам этого конкретного объекта. Это происходит потому, что к заранее объявленному и в последствии инициализированному графическому объекту вы обращаетесь напрямую, а при неявной инициализации вам необходимо знать индекс или имя конкретного графического объекта, что довольно сложно, особенно если не Вы создали часть объектов. Из этого следует, что проще (на мой взгляд) при создании новых графических примитивов сначала инициализировать заранее объявленный объект, получить и запомнить его имя или ввести уникальное, а затем уничтожить ссылку на этот объект (если вы хотите переициализировать переменную) и в дальнейшем использовать для доступа к объекту его уникальное имя. Если вы не собираетесь использовать слишком много графических объектов, то ещё проще, просто объявить нужное количество объектных переменных и в последствии спокойно обращаться к ним. Следует помнить о том, что новый графический объект создается на текущем листе и принадлежит этому листу, поэтому сначала перейдите на нужный вам лист и только потом инициализируйте примитив. Его координаты задаются от левого верхнего угла листа, а не от этой же части "печатной области", и если вы зададите координаты за пределами листа, то объект создастся, но не будет виден, хотя вы можете впоследствии и передвинуть его в видимую область. Естественно, что координаты задаются в твипах и если вы хотите использовать другие единицы, то должны будете использовать встроенные функции, например CentimetersToPoints(Х,хх). Также нужно (в дальнейшем) пре необходимости изменять координаты графического объекта, помнить о том, что после создания примитива он автоматически привязывается к ближайшей от своей верхней границы текстовой строке и его свойство .Top и .Left будет отсчитываться от начала этой строки. Это сделано для того, чтобы при перемещении "привязанной" строки перемещались и связанные с ней графические объекты. При этом они (объекты) могут перейти при недостатке места на текущем листе на соседний лист, чего вы не сможете сделать, просто изменяя координаты графического объекта. Остановимся на общем принципе построения графических объектов для понимания принципа работы с ними. Любой Г.О. это (в принципе) квадрат в котором находиться изображение какого ни будь примитива, поэтому у него есть только ширина и высота. Если вы зададите равными ширину и высоту для "овала", то получите круг и т.д. Если вы объедините несколько примитивов (сгруппируете их), то получите новый квадрат с изображением группы примитивов. Так как ширина и высота не могут быть отрицательными, чтобы изменить, например, координаты концов линии вам потребуется зеркально отобразить изображение линии по вертикали или горизонтали, а уже после этого шириной, высотой, отступом сверху и слева привести её к нужному вам виду и расположению. Сразу понять, что получится от применения того или иного кода, сложно, поэтому я вам предлагаю поэкспериментировать и для этого запустить на выполнение программу пример. Работа с линией Для начала создадим линию двумя способами: 1) 'инициализируем (создадим) линию 'с координатами (начало_Линии_слева(Х),начало_Линии_сверху(У), 'конец_Линии_слева(Х),конец_Линии_сверху(У) Set Line1 = DocWord.Shapes.AddLine(0, 0, CentimetersToPoints(3), CentimetersToPoints(2)) 'изменим цвет линии Line1.Line.ForeColor.RGB = RGB(0, 0, 255) 'изменим толщину линии Line1.Line.Weight = 2.25 2) 'инициализируем (создадим) линию неявным объявлением 'и присвоим ей уникальное имя для дольнейшего доступа DocWord.Shapes.AddLine(100, 0, 100, 100).Name = "DDD1" 'изменим цвет линии DocWord.Shapes("DDD1").Line.ForeColor.RGB = RGB(255, 0, 0) 'или DocWord.Shapes.Range("GGG1").Line.ForeColor.RGB = RGB(1, 255, 0) 'изменим толщину линии DocWord.Shapes("DDD1").Line.Weight = 4 заносим данные в талицу: 'добавляем данные в таблицу TableWord.Cell(2, 1).Range.Text = "Line1" 'получаем имя объекта "линия" TableWord.Cell(2, 2).Range.Text = Line1.Name 'получяем отступ сверху TableWord.Cell(2, 3).Range.Text = Line1.Top 'получяем отступ слева TableWord.Cell(2, 4).Range.Text = Line1.Left 'получаем ширину несушего квадрата TableWord.Cell(2, 5).Range.Text = Line1.Width 'получаем высоту несушего квадрата TableWord.Cell(2, 6).Range.Text = Line1.Height 'если нужно в сантиметрах 'Round(Line1.Height / 28.35, 2) & " см" 'меняем имя линии 'Line1.Name = "GGG1" С помощью этого кода изменим положение линии. 'Смещаем линию (отступ сверху) Line1.Top = Line1.Top + 10 'Смещаем линию (отступ слева) Line1.Left = Line1.Left + 10 А с помощью этого кода изменим размеры несущего квадрата, то есть его высоту и ширину. 'изменим ширину несушего квадрата Line1.Width = Line1.Width + 10 'изменяем высоту несушего квадрата Line1.Height = Line1.Height + 10 Зеркально отразим изображение примитива (линии) по вертикали и горизонтали, то есть перевернём картинку. 'Зеркально отразим по вертикали Line1.Flip 1 'msoFlipVertical 'Зеркально отразим по горизонтали Line1.Flip 0 'msoFlipHorizontal Для придания объемного вида графическим примитивам вы можете использовать данный код: 'показать объём Line1.ThreeD.Visible = &HFFFFFFFF 'msoTrue 'скрыть объём Line1.ThreeD.Visible = 0 'msoFalse 'переключить видимость объёма Line1.ThreeD.Visible = &HFFFFFFFD 'msoTriStateToggle 'изменим стиль изображения объёма Line1.ThreeD.SetThreeDFormat 1 Наверх 71. Работа с Word - Работа с графическими объектами в Word (часть 2)
Эту статью я хочу начать с того, что все методы и код который я описал в предыдущей статье, применимы практически для всех графических объектов в Word. А также и все ограничения, которые я отразил ранее, поэтому я не буду подробно останавливаться на них. И так продолжим: Рассмотрим создание объекта "ОВАЛ" и используем уже известные нам свойства (небольшую часть, остальные добавьте сами из прошлой статьи). 'Добавляем объект овал (константа=9,отступ_слева,отступ_справа,ширина,высота) Set Oval1 = DocWord.Shapes.AddShape(9, 200, 200, 100, 100) 'цвет линии Oval1.Line.ForeColor.RGB = RGB(0, 0, 255) 'толщина линии Oval1.Line.Weight = 2.25 'добавляем цвет заливки Oval1.Fill.ForeColor.RGB = RGB(255, 255, 95) В объекты с границами (имеющими замкнутый контур) вы можете добавлять текст. 'добавляем простой текст выбрав объект по имени DocWord.Shapes(Oval1.Name).TextFrame.TextRange.Select DocWord.Application.Selection.TypeText ".Name" DocWord.Application.Selection.TypeParagraph DocWord.Application.Selection.TypeText Oval1.Name DocWord.Application.Selection.EndOf ' 'изменим стиль изображения объёма 'Oval1.ThreeD.SetThreeDFormat 1 Следующий часто употребляемый графический объект - это ПРЯМОУГОЛЬНИК. Его часто используют для создания рамок на листах в рефератах. Вы при необходимости можете написать программу, которая будет оформлять документ, заключая все листы в рамки. А теперь перейдём к коду. 'Добавляем объект квадрат (квадрат=1, отступ_слева, отступ_справа, ширина, высота) Set Kyb1 = DocWord.Shapes.AddShape(1, 350, 200, 100, 80) В этой секции кода мы рассмотрим общий для многих графических объектов способ изменения порядка отображения графического элемента в документе, а также способ поворота на произвольный угол. 'изменим порядок отображения Kyb1.ZOrder 5 'используйте данные значения констант '0 - на передний план '1 - на задний план '2 - переместить вперёд '3 - переместить назад '4 - поместить перед текстом '5 - поместить за текстом 'повернуть на произвольный угол (можно на отрицательный) Kyb1.IncrementRotation 45 Следующий объект - это НАДПИСЬ. При его создании вы можете с помощью констант определить как в нем будет располагаться текст; горизонтально, вертикально, перевернуто и т.д. 'Добавляем объект надпись (текст_горизонтальный=1,отступ_слева,отступ_справа,ширина,высота) Set Textbox1 = DocWord.Shapes.AddTextbox(1, 270, 200, 100, 100) 'цвет линии (белый) Textbox1.Line.ForeColor.RGB = RGB(255, 255, 255) 'толщина линии Textbox1.Line.Weight = 2.25 'добавляем цвет заливки Textbox1.Fill.ForeColor.RGB = RGB(255, 255, 95) Для оформления документа вы можете использовать объект WordArt. Его основные графические свойства задаются при создании. 'Добавляем объект WordArt (стиль,текст,шрифт,его размер,полужырный(да,нет), 'курсив(да,нет),отступ_слева,отступ_справа,ширина,высота) Set TextEffect1 = DocWord.Shapes.AddTextEffect(3, "Просто текст", "Arial", 20, 1, 0, 100, 350) 'добавляем цвет заливки TextEffect1.Fill.ForeColor.RGB = RGB(255, 255, 95) 'цвет линии TextEffect1.Line.ForeColor.RGB = RGB(255, 0, 255) Следующие объекты прекрасно подходят для создания линейных графиков в вашем документе. Это объекты СПЛАЙН (кривая) и ПОЛИЛИНИЯ. Объявляются они одинаково, единственное отличие это применение разных констант при добавлении точек. 'создадим кривые ( СПЛАИН и ПОЛИЛИНИЯ) 'инициализируем и вводим координаты первой точки With WordApp.ActiveDocument.Shapes.BuildFreeform(0, 80, 160) 'добавляем следующие точки (в стиле сплаин "сглаживание") .AddNodes 1, 0, 100, 170 .AddNodes 1, 0, 120, 150 .AddNodes 1, 0, 140, 170 .AddNodes 1, 0, 160, 150 .AddNodes 1, 0, 180, 170 'добавляем следующие точки (в стиле полилинии) .AddNodes 1, 1, 250, 170 .AddNodes 1, 1, 280, 150 .AddNodes 1, 1, 310, 170 .AddNodes 1, 1, 340, 150 .AddNodes 1, 1, 370, 170 'заканчиваем создание и выбираем созданный объект .ConvertToShape.Select End With 'переименовываем. ВНИМАНИЕ если нажмете на кнопку ещё раз, 'то вызовете ошибку, так как объект с таким именем уже есть DocWord.ActiveWindow.Selection.ShapeRange.Name = "XXX1" 'меняем цвет линии DocWord.Shapes.Range("XXX1").Line.ForeColor.RGB = RGB(1, 255, 0) 'и т.д. Вам может понадобиться сгруппировать несколько объектов в один. Для этого вы можете использовать следующий код. ВНИМАНИЕ: для избежание ошибки сначала создайте все объекты. 'выбираем несколько объектов DocWord.Application.ActiveDocument.Shapes.Range(Array(Oval1.Name, Kyb1.Name, Textbox1.Name, "XXX1")).Select 'WordApp.ActiveDocument.Shapes.Range(Array()).Select 'группируем все объекты (выбранные) DocWord.ActiveWindow.Selection.ShapeRange.Group.Select 'переименовываем созданный объект если нажмете на кнопку ещё раз, 'то вызовете ошибку так как объект с таким именем уже есть DocWord.ActiveWindow.Selection.ShapeRange.Name = "DDD1" 'и т.д. 'разгруппируем группу 'DocWord.Shapes.Range("DDD1").Ungroup.Select И последний код - вставка рисунка. 'вставим рисунок DocWord.Application.ActiveDocument.Shapes.AddPicture(App.Path & "\Образец.jpg").Select Наверх 61. Как запретить запуск второй копии программы
If App.PrevInstance Then End Наверх 72. Использование Visual Basic 6.0 для управления внешними устройствами и приём внешней информации (температура, давление, напряжение, ток и т.п.) через LPT порт
Введение Любое внешнее устройство подключается к компьютеру через порты. Например, LTP, COM, USB. Наиболее просто – программирование LTP порта. Общий принцип компьютерной системы контроля выглядит так: Компьютерная программа посылает определенные сигналы через LTP порт на коммутатор, на основании полученных сигналов коммутатор подключает к аналого-цифровому преобразователю датчики. Данные с АЦП поступают в коммутатор, LTP и обрабатываются нашей волшебной программой написанной на VB 6.0. Это – развитая промышленная система контроля и управления, которую я, Божьей помощью рассчитываю создать. Если вы хотите научиться включать свет в своём туалете с помощью PC, узнавать температуру воды в вашей ванне, то надо начинать с системы попроще. ШАГ 1: Изучение работы LTP порта Для тех, кто не знает, что есть LTP, скажу – это то «отверстие» куда ты подключаешь принтер старой модели. Широкий разъём. LTP порт имеет следующую структуру: Он состоит из отсеков (адресов) H378, H37a. Есть еще другие, но для создания компьютерного управления чайником на кухне тебе знать о них необязательно. Адреса H378, H37a могут выдавать и принимать сигналы, работают двунаправлено. Как правило, H37a служит для управления коммутирующим устройством, а H378 для отправки и приёма сигналов. Под понятием сигнал надо понимать присутствие или отсутствие напряжения (5В) на порте. Например, если вы хотите включать/выключать всего 12 (8+4) лампочек или чайников (или светомузыки), то вы можете отказаться от коммутатора и АЦП. Просто программой необходимо подать, например, напряжение 5В адреса H378, ножки 2. Эта ножка, например, связана с реле, которое включает более мощное реле (можно и полупроводниковое) и энергия подаётся на вашу лампочку. Вот и весь принцип. Главное программой указать компьютеру, на какую ножку, какого адреса подать или убрать напряжение. Можно сделать устройство, которое определит, например, горит ли у вас свет на кухне. Для этого необходимо сделать простенькое устройство, которое подаёт напряжение на LTP (5В). После программа читает порт и делает вывод, какое реле подаёт сигнал (1, 2, 3…) и делает вывод что работает (TRUE) или что не работает (FALSE). В зависимости от полученного результата, например, объект Shape меняет цвет. Важно, чтобы коммутирующие устройства имели качественную гальваническую развязку с компьютером, иначе спалите PC. ШАГ 2: Научимся считать в системах…BIN, HEX, DEC BIN – цифровая форма записи числа (10111011 – байт), или бинарная система исчисления (слыхал о цифровой технике…?). HEX – долго объяснять, если есть желание возьми и изучи булеву алгебру. Просто позже поймешь, как использовать HEX. Абстрактно – на этих числах работает электроника компьютера и команды управления, часто задаются в этой системе исчисления. DEC – привычные нам числа, один, три целых шесть десятых. Любое число, которое вы видите в учебнике по математике за 7 класс. Нам надо уметь пользоваться этой системой исчисления, для того чтобы составлять команды для LTP порта, какую ножку ему «зажечь или потушить». Научимся сначала «зажигать». Например, ты хочешь чтобы третья ножка адреса H378 загорелась. В бинарной системе это выглядит так: 00000100. Согласен? Третья справа имеет на выходе единицу (5В). Запускаем калькулятор, меню «ВИД», пункт «ИНЖЕНЕРНЫЙ» или качаем понятную, специальную программу-конвертер изображенную снизу. Если ты всё-таки хочешь использовать калькулятор Билла Гейтса, то укажи опцию BIN и введи число: 100 – это 00000100 за минусом передних нулей. После этого просто переключи опцию на HEX и ты получишь число 4. После от FF отними 4 и получишь FB. Это и есть число, которое надо послать в адрес H378, порта LTP чтобы на третьей ножке компьютер вывел напряжение 5 вольт. Если ты хочешь зажечь 1,2,5,7 ножку то операция формирования команды выглядит так: BIN – 01010011 HEX – (FF-53) = AC А привычное нам число – 83 Помни, что команда формируется не программой, а программистом (в простых системах). Да забыл сказать, у нас адрес H378 имеет восемь выходов (битов), поэтому опция на калькуляторе 8-бит. Пока не изучишь системы исчисления, не поймешь как получаются HEX. А пока, просто умей определять команду. ШАГ 3: Понятие дискретного сигнала Дискретный сигнал это – бит. Например, ты хочешь знать включена ли лампочка в ванне. Эта лампочка зажигается от реле, контакт которого соединен с третьей ножкой порта. В данном случае вас интересует, есть ли на 3-й ножке 5 вольт. Это и есть дискретный сигнал (один бит). Аналогично, если вы подаёте единицу на 4-ю ножку чтобы включить четвертую лампочку, можно расценивать это как дискретный сигнал (один бит). ШАГ 4: Обработка дискретного сигнала Мы уже представляем принцип формирования команды на LTP порт. Как принять и понять, есть ли на определенной ножке напряжение (единица или включена ли ваша лампочка). Принцип следующий: Читаем порт, и получаем число, например DATA Оценка результатов ШАГ 5. Написание программы Для того, чтобы VB мог работать с LTP портом, необходимо скачать специальный драйвер. Установите этот драйвер у себя на компьютере (Setup прилагается). Напишем программу, которая будет «зажигать» ножки LTP порта, или тушить их, а также определять на какую ножку приходит единица (5Вольт) с внешнего устройства и использовать результат для нашей программы. Запустите VB 6.0 и создайте проект. Создайте форму по примеру: На кнопках в скобках указан номер ножки на порте, а до скобки номер ножки на нашем рисунке, в CHECK указан номер ножки на порте. Например при нажатии кнопки 2(3) на 3-й разъём порта подаётся 5 вольт. В случае адреса H37а рассмотрен другой вариант реализации запуск/остановка ножек. Там происходит автоматическое формирование команды, которая в последствии записывается в порт. При нажатии кнопки ПРОЧИТАТЬ АДРЕС H378, производится считывание с порта и в зависимости от того, на какой ножке есть единица, та линия и окрашивается в красный цвет. Если Вы хотите что-либо считывать с порта, то Вам необходимо переключить режим работы порта компьютера в режим EPP (Enhanced Parallel Port – режим двунаправленной передачи данных). Это делается в BIOS. Во время загрузки компьютера когда появится надпись Press DEL to enter setup, нажмите DEL, чтобы попасть в меню BIOS. Затем выберите раздел INTEGRATED PERIPHERALS и там выберите строку PARALLEL PORT MODE: измените режим работы Вашего порта на EPP или SPP/EPP. Сохраните сделанные изменения. Теперь декларируем в модуле: Public Declare Function DlPortReadPortUchar Lib "dlportio.dll" _ (ByVal Port As Long) As Byte Public Declare Function DlPortReadPortUshort Lib "dlportio.dll" _ (ByVal Port As Long) As Integer Public Declare Function DlPortReadPortUlong Lib "dlportio.dll" _ (ByVal Port As Long) As Long Public Declare Sub DlPortReadPortBufferUchar Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Public Declare Sub DlPortReadPortBufferUshort Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Public Declare Sub DlPortReadPortBufferUlong Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Public Declare Sub DlPortWritePortUchar Lib "dlportio.dll" _ (ByVal Port As Long, ByVal Value As Byte) Public Declare Sub DlPortWritePortUshort Lib "dlportio.dll" _ (ByVal Port As Long, ByVal Value As Integer) Public Declare Sub DlPortWritePortUlong Lib "dlportio.dll" _ (ByVal Port As Long, ByVal Value As Long) Public Declare Sub DlPortWritePortBufferUchar Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Public Declare Sub DlPortWritePortBufferUshort Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Public Declare Sub DlPortWritePortBufferUlong Lib "dlportio.dll" _ (ByVal Port As Long, Buffer As Any, ByVal Count As Long) Представте, что к адресу Н378 подключена схема: В кнопку прочитать адрес H378: Dim data as Integer data = DlPortReadPortUchar(&H378)) '(читаем порт, 'полученное значение присваиваем переменной) 'а теперь, проверяем наличие сигнала на каждой ножке 'и в зависимости от этого выполняем действие If (data And &H1) > 0 Then Line1.BorderColor = &HFF& Else Line1.BorderColor = &H0& If (data And &H2) > 0 Then Line2.BorderColor = &HFF& Else Line2.BorderColor = &H0& If (data And &H4) > 0 Then Line3.BorderColor = &HFF& Else Line3.BorderColor = &H0& If (data And &H8) > 0 Then Line4.BorderColor = &HFF& Else Line4.BorderColor = &H0& If (data And &H10) > 0 Then Line5.BorderColor = &HFF& Else Line5.BorderColor = &H0& If (data And &H20) > 0 Then Line6.BorderColor = &HFF& Else Line6.BorderColor = &H0& If (data And &H40) > 0 Then Line7.BorderColor = &HFF& Else Line7.BorderColor = &H0& If (data And &H80) > 0 Then Line8.BorderColor = &HFF& Else Line8.BorderColor = &H0& Для работы с Check, необходимо объявить глобальную переменную: Public nojka As Integer Код выглядит следующим образом: Private Sub Check10_Click() If Check10.Value = 1 Then nojka = nojka + &H10 Else nojka = nojka - &H10 DlPortWritePortUlong &H37A, nojka End Sub Private Sub Check11_Click() If Check11.Value = 1 Then nojka = nojka + &H2 Else nojka = nojka - &H2 DlPortWritePortUlong &H37A, nojka End Sub Private Sub Check12_Click() If Check12.Value = 1 Then nojka = nojka + &H4 Else nojka = nojka - &H4 DlPortWritePortUlong &H37A, nojka End Sub Private Sub Check13_Click() If Check13.Value = 1 Then nojka = nojka + &H8 Else nojka = nojka - &H8 DlPortWritePortUlong &H37A, nojka End Sub Вы видите, что в адрес H37a записывается команда nojka, которая формируется математически в зависимости от состояния Check-ов. Если к LTP порту вы подключите лампочки (с резистором), то вы увидите, как они загораются или тухнут (чертеж для адреса &H378). Вот и всё, портом управлять вы умеете, собирайте схему и работайте… ШАГ 6: Очень важные мелочи… Для персонального обучения управлению LTP вам необязательно собирать внешние устройства (лампочки, реле и т.п.). Можно самостоятельно записывать данные в порт ('DlPortWritePortUlong Val(&H378), "&H" & "bf"), где "&H" & "bf" сформированная команда. Причем данные останутся записанными в порте и вы можете прочитать их: Private Sub Command2_Click() Dim Value As Long Value = DlPortReadPortUchar((&H378) TextValue = "&H" + Hex(Value) Text1.Text = Value End Sub Или обработать данные по принципу кнопки «прочитать адрес H378». Учтите, что в случае, когда вы самостоятельно записываете команду в порт и потом читаете порт, данные после чтения удаляются. А в случае, когда данные подаются на порт внешним устройством, читать можно хоть сто раз, данные с порта не исчезнут, так как подаются внешним, независимым от компьютера устройством. Знайте, что при использовании неэкранированного кабеля для приёма/передачи данных, в нём могут возникать наводки (так мы как-то регистрировали частоту 33кГц) – это нарушит работу сложной системы коммутатор-АЦП (я с этим сталкивался…). Это устраняется внесением сглаживающего блокирования в схему. Но это другая история… ШАГ 7: Приём сигналов с АЦП, коммутаторов и т.п. Расписывать подробно не буду, так как в домашних условиях вряд ли кто будет собирать АЦП или коммутатор. Скажу обобщенно. АЦП бывает 4, 6, 8, 16 и т.п. разрядный + тип. В зависимости от этого ( и от датчиков и всей системы подачи/отправки данных) необходимо определить коэффициент пересчёта. Пересчёт данных с порта выглядит обобщенно так: Результат = ((«Верхняя граница измерения» - «Нижняя граница измерения»)/»Разрядность АЦП»)*«data» + «Нижний предел измерения» Разрядность АЦП – 256 (если выдаёт восемь бит), 64 (если 4 бит) и т.д. АЦП – аналого-цифровой преобразователь. Это устройство можно собрать самостоятельно. Устройство достаточно сложное, ориентировочный срок изготовления 25-40 дней. Например, вы хотите передать на компьютер силу тока и отобразить её где-нибудь. Ток в измеряемой цепи колеблется от 0 до 100А. В этом случае мы поступаем как я нарисовал на схеме: Схема упрощена, так как в ней отсутствует коммутирование к АЦП нескольких датчиков Это может казаться сложно, но это очень просто, просто нужно знать, что за система, с какими параметрами она передаёт данные. Скажу одно, эту систему можно (обычно это так и делается!) простым паяльником. Если есть вопросы, то я с удовольствием всегда вас проконсультирую по электронной почте о приёме «аналогового сигнала». ШАГ 8: Область применения На этом принципе можно собрать светомузыку для дискотек, управление и контроль за работой любого оборудования, принимать и отображать на компьютере данные по току, давлению, температуре, потреблению газа, воды, воздуха и т.п. И всё это можно сделать на VB 6.0 используя его возможности. Главное, отправить и принять/обработать данные с порта и как вы видели, это так же просто, как и работа с элементом Label. Изложены основные принципы, проверенные на практике! Нужна схема коммутатора? Жду, пиши… Наверх 73. Как написать игру на Visual Basic
Наверх | Скачать статью + исходник 74. Как расшарить программно ресурс (несколько способов)
1. Способ Помести это в загрузку формы: Shell "net share " & "c" & "=C:\" 2 Способ. Через АПИ: Кинь на форму 1 кнопку, и 5 текстовых полей Вот код: Option Explicit Private Const NERR_SUCCESS As Long = 0& 'типы шар Private Const STYPE_ALL As Long = -1 'note: my const Private Const STYPE_DISKTREE As Long = 0 Private Const STYPE_PRINTQ As Long = 1 Private Const STYPE_DEVICE As Long = 2 Private Const STYPE_IPC As Long = 3 Private Const STYPE_SPECIAL As Long = &H80000000 'разрешения Private Const ACCESS_READ As Long = &H1 Private Const ACCESS_WRITE As Long = &H2 Private Const ACCESS_CREATE As Long = &H4 Private Const ACCESS_EXEC As Long = &H8 Private Const ACCESS_DELETE As Long = &H10 Private Const ACCESS_ATRIB As Long = &H20 Private Const ACCESS_PERM As Long = &H40 Private Const ACCESS_ALL As Long = ACCESS_READ Or ACCESS_WRITE Or ACCESS_CREATE Or ACCESS_EXEC Or ACCESS_DELETE Or ACCESS_ATRIB Or ACCESS_PERM Private Type SHARE_INFO_2 shi2_netname As Long shi2_type As Long shi2_remark As Long shi2_permissions As Long shi2_max_uses As Long shi2_current_uses As Long shi2_path As Long shi2_passwd As Long End Type Private Declare Function NetShareAdd Lib "netapi32" (ByVal servername As Long, ByVal level As Long, buf As Any, parmerr As Long) As Long Private Sub Form_Load() Text1.Text = "\\" & Environ$("COMPUTERNAME") Text2.Text = "c:\program files\adobe" Text3.Text = "vbnetdemo" Text4.Text = "VBnet demo test share" Text5.Text = "" End Sub Private Sub Command1_Click() Dim success As Long success = ShareAdd(Text1.Text, Text2.Text, Text3.Text, Text4.Text, Text5.Text) Select Case success Case 0: MsgBox "share created successfully!" Case 2118: MsgBox "share name already exists" Case Else: MsgBox "create error " & success End Select End Sub Private Function ShareAdd(sServer As String, sSharePath As String, sShareName As String, sShareRemark As String, sSharePw As String) As Long Dim dwServer As Long Dim dwNetname As Long Dim dwPath As Long Dim dwRemark As Long Dim dwPw As Long Dim parmerr As Long Dim si2 As SHARE_INFO_2 'получаем указатели на сервер, ресурс и путь dwServer = StrPtr(sServer) dwNetname = StrPtr(sShareName) dwPath = StrPtr(sSharePath) 'Если описание или пароль указаны, 'то также получаем указатели на них If Len(sShareRemark) > 0 Then dwRemark = StrPtr(sShareRemark) End If If Len(sSharePw) > 0 Then dwPw = StrPtr(sSharePw) End If 'подготавливаем структуру SHARE_INFO_2 With si2 .shi2_netname = dwNetname .shi2_path = dwPath .shi2_remark = dwRemark .shi2_type = STYPE_DISKTREE .shi2_permissions = ACCESS_ALL .shi2_max_uses = -1 .shi2_passwd = dwPw End With 'расшариваем ресурс ShareAdd = NetShareAdd(dwServer, 2, si2, parmerr) End Function 3. Способ Еще можно через реесстр: Вот исходник: http://vbrus.narod.ru/MyProgs/Share.zip Наверх 75. Как узнать сколько памяти жрет указанный процесс?
Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long Public Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) Public Const PROCESS_QUERY_INFORMATION = 1024 Public Const PROCESS_VM_READ = 16 Public Const MAX_PATH = 260 Public Const STANDARD_RIGHTS_REQUIRED = &HF0000 Public Const SYNCHRONIZE = &H100000 Public Const PROCESS_ALL_ACCESS = &H1F0FFF Public Const TH32CS_SNAPPROCESS = &H2& Public Const hNull = 0 Public Const WIN95_System_Found = 1 Public Const WINNT_System_Found = 2 Public Const Default_Log_Size = 10000000 Public Const Default_Log_Days = 0 Public Const SPECIFIC_RIGHTS_ALL = &HFFFF Public Const STANDARD_RIGHTS_ALL = &H1F0000 Type MEMORYSTATUS dwLength As Long dwMemoryLoad As Long dwTotalPhys As Long dwAvailPhys As Long dwTotalPageFile As Long dwAvailPageFile As Long dwTotalVirtual As Long dwAvailVirtual As Long End Type Type PROCESS_MEMORY_COUNTERS cb As Long PageFaultCount As Long PeakWorkingSetSize As Long WorkingSetSize As Long QuotaPeakPagedPoolUsage As Long QuotaPagedPoolUsage As Long QuotaPeakNonPagedPoolUsage As Long QuotaNonPagedPoolUsage As Long PagefileUsage As Long PeakPagefileUsage As Long End Type Public Type PROCESSENTRY32 dwSize As Long cntUsage As Long th32ProcessID As Long th32DefaultHeapID As Long th32ModuleID As Long cntThreads As Long th32ParentProcessID As Long pcPriClassBase As Long dwFlags As Long szExeFile As String * 260 End Type Public Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Public Function GetProcesses(ByVal EXEName As String) Dim booResult As Boolean Dim lngLength As Long Dim lngProcessID As Long Dim strProcessName As String Dim lngSnapHwnd As Long Dim udtProcEntry As PROCESSENTRY32 Dim lngCBSize As Long Dim lngCBSizeReturned As Long Dim lngNumElements As Long Dim lngProcessIDs() As Long Dim lngCBSize2 As Long Dim lngModules(1 To 200) As Long Dim lngReturn As Long Dim strModuleName As String Dim lngSize As Long Dim lngHwndProcess As Long Dim lngLoop As Long Dim b As Long Dim c As Long Dim e As Long Dim d As Long Dim pmc As PROCESS_MEMORY_COUNTERS Dim lret As Long Dim strProcName2 As String Dim strProcName As String On Error GoTo Error_handler booResult = False EXEName = UCase$(Trim$(EXEName)) lngLength = Len(EXEName) Select Case getVersion() Case WIN95_System_Found Case WINNT_System_Found lngCBSize = 8 lngCBSizeReturned = 96 Do While lngCBSize <= lngCBSizeReturned DoEvents lngCBSize = lngCBSize * 2 ReDim lngProcessIDs(lngCBSize / 4) As Long lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned) Loop lngNumElements = lngCBSizeReturned / 4 'Loop thru each process For lngLoop = 1 To lngNumElements DoEvents 'Get a handle to the Process and Open lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop)) If lngHwndProcess <> 0 Then 'Get an array of the module handles for the specified process lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2) 'If the Module Array is retrieved, Get the ModuleFileName If lngReturn <> 0 Then 'Buffer with spaces first to allocate memory for byte array strModuleName = Space(MAX_PATH) 'Must be set prior to calling API lngSize = 500 'Get Process Name lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize) 'Remove trailing spaces strProcessName = Left(strModuleName, lngReturn) 'Check for Matching Upper case result strProcessName = UCase$(Trim$(strProcessName)) strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1) If strProcName2 = EXEName Then 'Get the Site of the Memory Structure pmc.cb = LenB(pmc) lret = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb) MsgBox EXEName & "::" & CStr(pmc.WorkingSetSize / 1024) End If End If End If 'Close the handle to this process lngReturn = CloseHandle(lngHwndProcess) DoEvents Next End Select IsProcessRunning_Exit: 'Exit early to avoid error handler Exit Function Error_handler: Err.Raise Err, Err.Source, "ProcessInfo", Error Resume Next End Function Private Function getVersion() As Long Dim osinfo As OSVERSIONINFO Dim retvalue As Integer osinfo.dwOSVersionInfoSize = 148 osinfo.szCSDVersion = Space$(128) retvalue = GetVersionExA(osinfo) getVersion = osinfo.dwPlatformId End Function Private Function StrZToStr(s As String) As String StrZToStr = Left$(s, Len(s) - 1) End Function Public Function GetElement(ByVal strList As String, ByVal strDelimiter As String, ByVal lngNumColumns As Long, ByVal lngRow As Long, ByVal lngColumn As Long) As String Dim lngCounter As Long ' Append delimiter text to the end of the list as a terminator. strList = strList & strDelimiter ' Calculate the offset for the item required based on the number of columns the list ' 'strList' has i.e. 'lngNumColumns' and from which row the element is to be ' selected i.e. 'lngRow'. lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn) ' Search for the 'lngColumn' item from the list 'strList'. For lngCounter = 0 To lngColumn - 1 ' Remove each item from the list. strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList)) ' If list becomes empty before 'lngColumn' is found then just ' return an empty string. If Len(strList) = 0 Then GetElement = "" Exit Function End If Next lngCounter ' Return the sought list element. GetElement = Left$(strList, InStr(strList, strDelimiter) - 1) End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Function GetNumElements (ByVal strList As String, ' ByVal strDelimiter As String) ' As Integer ' ' strList = The element list. ' strDelimiter = The delimiter by which the elements in ' 'strList' are seperated. ' ' The function returns an integer which is the count of the ' number of elements in 'strList'. ' ' Author: Roger Taylor ' ' Date:26/12/1998 ' ' Additional Information: ' ' Revision History: ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer Dim intElementCount As Integer If Len(strList) = 0 Then GetNumElements = 0 Exit Function End If strList = strList & strDelimiter While InStr(strList, strDelimiter) > 0 intElementCount = intElementCount + 1 strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList)) Wend GetNumElements = intElementCount End Function 'Теперь на форме создай кнопку, вот к ней код: GetProcesses "explorer.exe" Наверх 76. Сделать картинку светлей или темней
Автор: Max V. Irgiznov www.vbrussian.com Данная статья расскажет вам о том, как можно создавать свои плагины для популярного мультимедиа плеера Winamp. Вступление В 2002 году я работал в одной компании системным администратором, и по долгу службы 80% времени мне приходилось находится в окружении серверов FreeBSD. У меня был еще в распоряжении был сервер с Windows на котором крутилась музыка чтобы не скучать, и было не удобно менять треки в плейлисте да и вообще работать с винампом (по некоторым причинам я не мог пользоваться такими вещами как Terminal Service, переключатели мониторов, и.т.п.), и я задался целью сделать управляющую программу для Винампа. Языком программирования был выбран VB, т.к. на этом языке я решения такой задачки не встречал и это мой любимый язык, также нужна была быстрота разработки. Для программирования под API Winamp`а нам потребуется: Winamp SDK http://www.winamp.com/nsdn/winamp2x/dev/sdk/ Visual Basic 5.0/6.0 желательно с установленным SP5 Col_Rjl GenWrapper - Обвертка позволяющая использовать ActiveX DLL в Винампе http://www.winamp.com/nsdn/vault/GenWrapper.exe, http://www.winamp.com/nsdn/vault/WinAMP_VB.jhtml Немного API для работы с сообщениями Windows Правда есть небольшое ограничение, этим набором можно создавать только основные (gen_*) плагины. Данный текст рассчитан на программистов уже имеющих опыт работы в VB с сетевыми приложениями и WinAPI. Часть 1. Пишем простую управляющую программу. Для начала напишем простую программу (не плагин) для управления винампом. Например программу которая будет принимать команду на определенном TCP порту и транслировать ее Винампу. Запускаем VB и создаем новый проект Standard EXE и добавляем в проект Microsoft Winsock Control 6.0, несколько API функций и констант, больше нам ничего не потребуется. Вот декларации функций, которые нам понадобятся: 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 функция посылает сообщение окну в указанным хендлом; Private Declare Sub Sleep Lib "kernel32" ( _ ByVal dwMilliseconds As Long _ ) функция позволяющая процессу <уснуть> (система не выделяет процессу процессорного времени) на указанное число миллисекунд; Размещаем эти функции в секции General, также нам потребуются следующие управляющие сообщения винампа (полный их список есть в SDK к нему) и системы: 'system Private Const WM_USER = &H400 Private Const WM_COMMAND = &H111 'winamp Private Const WM_Raise_Volume = 40058 'increase 1% Private Const WM_Lower_Volume = 40059 'decrease 1% Private Const WM_Close_Winamp = 40001 Private Const WM_Previous = 40044 Private Const WM_Next = 40048 Private Const WM_Play = 40045 Private Const WM_Pause_Unpause = 40046 Private Const WM_Stop = 40047 Private Const WM_Toggle_Shuffle = 40023 Private Const WA_SETVOLUME = 122 Также добавляем пару переменных уровня формы: Dim Response As String Dim Connections As Long первая переменная потребуется для принятия строки от клиента, вторая для счета числа подключений. Внешними они сделаны по той причине, что они могут вам потребоваться в других методах, если нет, то переменную Response можно убрать в метод DataArrival. Закончив с секцией General переходим к форме и основному коду. Размещаем на форме Winsock и задаем ему имя wnsServer и устанавливаем его свойство Index = 0, в событие Form_Load пишем следующий код: wnsServer(0).Protocol = sckTCPProtocol wnsServer(0).LocalPort = 806 wnsServer(0).Listen Тут указываем что будем использовать только протокол TCP и указываем что для приема данных используем порт с номером 806. Начинаем писать обработчики событий винсока, первое - опишем процесс подключения клиента: Private Sub wnsServer_ConnectionRequest(index As Integer, ByVal requestID As Long) If index = 0 Then Connections = Connections + 1 Load wnsServer(Connections) 'Load New control wnsServer(Connections).LocalPort = 0 wnsServer(Connections).Accept requested end if DoEvents End Sub вот, мы приняли (принимает запросы только сокет с индексом 0) входящие соединение и выделили для его обслуживания отдельный сокет. При этом основной сокет может принять следующего клиента. LocalPort = 0 применено для того чтобы клиенту порт выделился динамически из числа свободных. Ну и наконец ядро программы собственно обработка команд поступаемых в сокет: Private Sub wnsServer_DataArrival(index As Integer, ByVal bytesTotal As Long) Dim hWnd As Long hWnd = FindWindow("Winamp v1.x", vbNullString) 'если к нам подконектились и если у нас присутствует 'винамп, ждем команду для отправки If bytesTotal <> 0 Then wnsServer(index).GetData Response 'получаем данные 'если нет винампа то можно только выходить If hWnd = 0 Then Exit Sub End If 'обработка поступившей команды 'Next Track If InStr(1, Response, "next", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Next, vbNull Exit Sub End If 'Previous Track If InStr(1, Response, "previous", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Previous, vbNull Exit Sub End If 'Play If InStr(1, Response, "play", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Play, vbNull Exit Sub End If 'Stop If InStr(1, Response, "stop", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Stop, vbNull Exit Sub End If 'Shuffle If InStr(1, Response, "shuffle", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Toggle_Shuffle, vbNull Exit Sub End If 'Pause/UnPause If InStr(1, Response, "pause", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Pause_Unpause, vbNull Exit Sub End If 'Close If InStr(1, Response, "close", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Close_Winamp, vbNull Exit Sub End If 'Volume inc If InStr(1, Response, "+", vbTextCompare) <> 0 Then If Response = "+" Then Response = "+1" Volume hWnd, CInt(Mid$(Response, InStr(1, Response, "+") + 1, 3)), 1 Exit Sub End If 'Volume dec If InStr(1, Response, "-", vbTextCompare) <> 0 Or InStr(1, Response, "0", vbTextCompare) <> 0 Then If Mid$(Response, InStr(1, Response, "-") + 1, 3) < "A" Then If Response = "-" Then Response = "-1" Volume hWnd, CInt(Mid$(Response, InStr(1, Response, "-") + 1, 3)), -1 End If End If End If 'bytes End Sub Метод проверяет загружен ли Винамп и если да то переходит к обработке пришедших данных. Рассмотрим чуть подробнее один из блоков проверок приведенного кода: If InStr(1, Response, "next", vbTextCompare) <> 0 Then SendMessage hWnd, WM_COMMAND, WM_Next, vbNull CloseSocket Index Exit Sub End If собственно говоря это простейший вариант проверки поступивший команды и отправка сообщения Винампу. Параметры функции SendMessage: hWnd это хендл на окно винампа определенный в начале метода, WM_COMMAND - системное сообщение показывающие что в последующем параметре функции идет команда, WM_Next - собственно сама команда для окна винампа и последний параметр это дополнительные данные для Винампа или например параметры команды посылаемой окну. После отработки команды закроем сокет (для обеспечения сбалансированной нагрузки) и выйдем из метода. Данный код является простейшей проверкой поступивших данных в сокет, в идеале нужно проверять соответствие команды определенному формату. Ну и последние несколько вспомогательных методов: Посылка команды увеличения или уменьшения (зависимости от параметра incdec) громкости. Private Sub Volume(hWnd As Long, percent As Integer, incdec As Long) Dim i As Long For i = 0 To percent - 1 Select Case incdec Case -1 SendMessage hWnd, WM_COMMAND, WM_Lower_Volume, vbNull Case 1 SendMessage hWnd, WM_COMMAND, WM_Raise_Volume, vbNull End Select Next i End Sub Событие происходит когда клиенту переданы все данные, как только оно возникает, выдерживаем <контрольный> интервал и закрываем сокет. Private Sub wnsServer_SendComplete(index As Integer) Sleep 1000 CloseSocket index End Sub 'Само закрытие сокета и выгрузка его из памяти. Private Sub CloseSocket(index As Integer) wnsServer(index).Close Unload wnsServer(Connections) Connections = Connections - 1 DoEvents End Sub Ну вот, теперь если все сделано без ошибок проект успешно откомпилируется и запустится сервер на ожидающий подключение на 806 порту, транслирующий команды Винампу. Для проверки его работы можно воспользоваться программкой TRCClient из каталога src, любители языка Perl могут воспользоваться управляющим скриптом от моего плагина VbTRC для Винампа. Надеюсь это не стало для вас затруднением и на этом закончим первую часть нашей статьи. Часть 2. От простой программы к настоящему плагину. Ну вот мы освоились с простейшим управлением Винампом через TCP сокет, настало время создать настоящий плагин. Используем наши предыдущие исходники над которыми мы работали как шаблон. Распаковываем скаченный GenWrapper.exe, оттуда нам понадобятся файлы GenWrapper.dll и GenWrapper.tlb, а также из каталога Template класс Plugin.cls. Создаем проект ActiveX DLL с именем tcpctrl удаляем из него Class1.cls и добавляем распакованный Plugin.cls. После добавления открываем пункт меню Project->References и добавляем ссылку на GenWrapper.tlb, не забыв также добавить компонент Microsoft Winsock Control. Ядро плагина мы создали, теперь мы можем использовать сокеты так как делали это в нашей первой программе, для любителей WinAPI скажу сразу что в данном случае лучше пользоваться сокетами напрямую через АПИ в этом случае можно будет отказаться от использования формы-контейнера. Итак приступим к работе. Создадим модуль main.bas, он нам понадобится для того чтобы корректно загрузить форму на которой будут располагаться наши элементы управления. Напрямую форму инициализировать нельзя, т.к. Винамп не поддерживает отображение форм на этапе своей загрузки и инициализации(даже когда она скрыта). В модуль поместим декларации АПИ функций из первой программы, а также добавим одну глобальную переменную Global This As Plugin (Где Plugin это имя нашего класса, его необходимо будет запомнить) для создания указателя на класс плагина. Также в модуль добавляем следующий метод для загрузки нашей скрытой формы(ее параметры описываются ниже): Public Sub ld() Load frmHidden End Sub Открываем класс Plugin и следуем в метод IRjlWinAmpGenPlugin_Configure он вызывается при нажатии кнопочки Configure в диалоге настроек плагинов Винампа, т.к. в простейшем случае у нас параметров плагина нет, то просто выведем описание плагина: MsgBox App.FileDescription. Следующий метод Info() вызывается при нажатии кнопочки "About" в диалоге настроек плагинов Винампа, тут может быть все что вам угодно я например вывожу такой MsgBox: MsgBox "Plugin Description: " & vbCrLf & m_Wrapper.Description & vbCrLf & _ "WinAmp Window Handle: 0x" & Hex(m_Wrapper.HWndParent) _ , vbInformation, "tcpctrl Information" Метод заслуживающий отдельного внимания: IRjlWinAmpGenPlugin_Initialize он вызывается при загрузке винампа и инициализации его списка плагинов, в нем мы поменяем строчку - описание для списка найденных плагинов, например на такую: m_Wrapper.Description = "tcpctrl Plugin v." & App.Major & "." & App.Minor & "." & App.Revision & " (gen_tcpctrl.dll)". Как я уже и говорил напрямую Load frmHidden тут сделать нельзя из-за особенностей работы винампа, поэтому придется сделать косвенный вызов установив при этом ссылку на наш класс: If Not This Is Nothing Then Err.Raise vbObjectError + 1, , "Already have a plugin instance" Exit Sub End If Set This = Me main.ld все, форма загружена и инициализирована. В методе IRjlWinAmpGenPlugin_Quit все просто, выгружаем нашу форму Unload frmHidden. Вот и все, с классом мы закончили, приступим к созданию формы-контейнера для контролов. Добавляем форму в проект, даем ей имя frmHidden и устанавливаем ее свойство Visible равное False. Помещаем на нее Winsock с именем аналогичным как в первой программе, также помещаем сюда те же константы и переменные. Событие Load формы будет выглядеть так: Private Sub Form_Load() On Error Resume Next Me.Visible = False wnsServer(0).Protocol = sckTCPProtocol wnsServer(0).LocalPort = 806 wnsServer(0).Listen End Sub Код для события Unload: Private Sub Form_Unload(Cancel As Integer) Dim i As Long If Connections > 0 Then For i = Connections To 1 wnsServer(i).Close Unload wnsServer(Connections) Next i End If DoEvents End Sub Код в данных местах практически идентичен коду в первом приложении, поступим также и с остальными методами, т.е можно просто скопировать следующие методы и функции: wnsServer_ConnectionRequest, wnsServer_DataArrival, Volume, wnsServer_SendComplete, СloseSocket. Компилируем, надеюсь все прошло замечательно? Нет, тогда исправляем ошибки. Теперь самое интересное, т.к. Винамп не понимает ActiveX DLL, то мы воспользовались обверткой , которая требует чтобы ее DLL переименовали следующим образом, например наша DLL называется tcpctrl.dll, а класс плагина называется Plugin, то GenWrapper.dll переименовываем так: gen_tcpctrl.Plugin.dll. И наконец обе библиотеки копируем в каталог Plugins Винампа. Все поздравляю вы получили простейший рабочий плагин, а также необходимые знания и шаблоны для вашей дальнейшей деятельности. Желаю удачи и творческих успехов. P.S В своем плагине vbTRC я реализовал дополнительные функции управления Винампом такие как: работа с пультом ДУ от ТВ-Тюнера AverMedia(основные клавиши управления плюс любимые треки и предпрослушка треков), добавил также веб-интерфейс для управления и конфигурирования, простейшие списки доступа, автостарт после загрузки, запись NP и Uptime в файл для вставки в другие программы и другие разные улучшения и нововведения. Базовое ядро я использовал то же, что и приведено в данной статье плюс мои дополнения. Наверх 77. Проигрыватель файлов AVI и WAV
И присвой ему имя MMControlCDPlayer. Затем, элемент управленияMicrosoft Common Dialog Control 6.0, присвойте ему имя cdPlayer И кнопку "открыть". Назови эту кнопку cbFindFile Код: Private Sub Form_Load() MMControlCDPlayer.Notify=False MMControlCDPlayer.Wait=True MMControlCDPlayer.Shareable=False MMControl.CDPlayer.DeviceType="WaveAudio" MMControlCDPlayer.DeviceType="AVIVideo" End Sub Private Sub cbFindFile_Click() cdPlayer.ShowOpen MMControlCDPlayer.FileName=cdPlayer.FileName MMControlCDPlayer.Command="Open" MMControlCDPlayer.hWndDisplay=PicView.hWnd FormPlayer.picView.SetFocus End Sub Private Sub Form_Unload(Cancel As Integer) MMControlCDPlayer.Command="Close" End Sub После компиляции нажми открыть, выбери файл и нажми кнопку проиграть. Команды управления элемента MMControl: Open - открывает файл (устройство) для работы Close - закрывает файл (устройство) для работы Prev - Переходит в начало предыдущего трека. Если первый трек, или файл, то переход осуществляется в начало этого трека, файла. Next - Переходит в нач. след. трека. Step - Переходит на кадр назад по треку Back - Переходит назад Pause - Приостанавливает проигрывание Play - Проигрывает Record - Записывает (Внимание любителям подслушивать!) Stop - Останавливает Eject - Извлекает носитель (диск) Save - Сохраняет Seek - Находит позицию Наверх 78. Как защитить свою программу от взломщиков - VB
Я решил написать статью о том, как защитить свои программы от взлома. Оговорюсь сразу, практически невозможно создать такую защиту, которая могла бы противостоять опытному взломщику. Но можно попытаться создать такую защиту, которая окажется не по зубам около 90% взломщиков. Все мои идеи по защите основаны на личных наблюдениях, и они могут не быть достоверными, но могут быть полезными против большинства новичков и продвинутых взломщиков. Сейчас я расскажу, какие инструменты использует средний взломщик: Во-первых, самый незаменимый инструмент это дебагер, то есть программа, которая позволяет трассировать код чужой программы в живую. Список этих программ варьируется от простого debug'а до продвинутого Soft-Ice'а. Во-вторых, программа дизассемблер, которая превращает байты программы в команды ассемблера, тем самым позволяет просмотреть, где и как действует защита. Причем хороший дизассемблер показывает еще и где, какие строки используются в программе. Далее идут всевозможные утилиты, для мониторинга реестра, файлов, определители компилятора и упаковщика, распаковщики, дамперы памяти, генераторы кряков и т.д. Ну и конечно самое главное это мозги взломщика, ведь во многом результат взлома зависит от его сообразительности или идиотизма. Короче наша задача, обмануть все эти средства, и самое главное запутать взломщика. И вот как мы это сделаем, я буду идти по приведенному списку и буду объяснять, как защитится от этих средств и от взломщика. Начнем с дебагеров. Вообще-то, многие взломщики недолюбливают VB, потому что он работает благодаря своим библиотекам, и естественно взломщику потребуется очень много времени, чтобы разобраться, где код программы, а где вызовы библиотечных функций (проверено на опыте). Но это случается, только тогда когда программа была скомпилирована в P-код, то есть в псевдокод. Значит первое кольцо защиты, должно быть компилирование в псевдокод. Если вы думаете, что на этом все закончилось, то глубоко ошибаетесь. На свете есть дебагер именуемый P-Code Loader, и он позволяет фильтровать вызовы библиотек и показывать непосредственно код программы. Конечно, не у всех он есть, но если есть, то не стоит слишком надеяться на то, что взломщик откажется от взлома. Поэтому P-код не должен быть главной ставкой программиста. Конечно, с псевдокодом придется таскать кучу библиотек но, как говориться здоровье дороже. Иногда программы используют различные приемы против дебагеров, основанные на их свойстве выполнять команды до их фактического выполнения. То есть теоретически можно создать команду, которая отправит дебагер в тартарары, в то время как процессор проигнорирует эту команду из-за системы прогнозирования переходов. Я не умею это делать, поэтому упоминаю это только потому, что однажды встретился с этим приемом. Копаясь с АПИ справочнике, я обнаружил замечательную функцию IsDebuggerPresent, которая возвращает True, если в системе стоит системный дебагер типа SofIce'а. Функция работает, начиная с NT и Win98: Declare Function IsDebuggerPresent Lib "kernel32" () As Long Далее, дизассемблеры. В инструментарии взломщика дисассемблер занимает почетно место. Редко взломщик изучает программу без дизассемблера. Дизассемблер дает не только информацию о коде программы, но и показывает имена используемых функций и строковые выражения, использующиеся в программе, а также предоставляет удобную навигацию по вызовам функций и прыжкам. Дизассемблер можно обмануть несколькими путями. С начала, что значит обмануть? Обмануть значить не дать дизассемблеру показать истинный код программы. Этого достигнуть можно следующим способом, программу можно упаковать каким-нибудь упаковщиком типа Aspack, UPX и т.п. В этом случае дизассемблер сможет показать разве что код упаковщика и более ничего. Но ведь существуют и распаковщики, поэтому всегда есть вероятность того, что у взломщика найдется подходящий распаковщик, и он получит готовенький код вашей программы. Что бы предотвратить это, нет никаких способов. Разве что пользоваться несколькими упаковщиками или использовать нестандартный, мало кому известный упаковщик. Это серьезно затруднит взломщиков, но особенно настырных это не сможет остановить (ведь теоретически можно найти то место где упаковщик передает программе управление и провести кое-какие манипуляции с кодом). Кроме того, есть ещё один способ усложнить взломщику жизнь. Для этого я расскажу, как производится обычный взлом с помощью дизассемблера. Берется жертва, дизассемблируется. Первое на что смотрит взломщик, это какие строки использует программа. Допустим, программа при вводе неверного серийного номера показывает что-то типа "Сорри, но ваш серийник не подходит нам". Взломщик первым делом ищет эту строчку, и если находит, то у него уже появляется точка старта взлома, так как он сможет в большинстве случаев найти, то место где вызывается это сообщение, и соответственно найти место проверки серийника. Значит, наша задача убрать эту возможность для взломщика, то есть убрать все важные сообщения из программы. Это можно сделать, если вынести все сообщения во внешний файл и читать их оттуда во время рантайма. В этом случае дизассемблер покажет разве что имя вызываемого файла. Особенно хорошо загрузить сообщения в начале программы, чтобы взломщик не смог связать их с каким-нибудь важным местом в программе. Ну и я думаю понятно, что самая глупая ошибка это писать прямо в программе правильный пароль. Это сводит на нет всю защиту. Есть ещё один способ повысить безопасность программы, правда я не знаю, как это сделать на VB, но смысл состоит в следующем: Надеюсь всем известно о компьютерных регистрах. Также вам известно, что на ассемблере можно вызвать процедуру по адресу находящемуся в регистре. Так вот, дизассемблер не может сказать какое значение будет в регистре в тот или иной момент, поэтому можно вызвать окно с сообщением через регистр, и тогда ни один дизассемблер не сможет сказать, откуда вызвана та или иная функция. Иногда я замечал, что некоторые программы подвешивали дизассемблер при попытке чтения файла. Я не знаю, как это делают, но подозреваю, это происходит из-за несущественно испорченной структуры файла. Как обмануть мониторы реестра и файлов я не знаю, но могу посоветовать спрятать иголку в стогу сена (опять же встречались случаи падения мониторов при запуске некоторых программ). То есть запрятать чтение данных пользователя в кучу ненужных вызовов. Также желательно не давать очевидных имен типа "Code" или "User Name". Вообще чтение данных, является слабым местом любой защиты, так как большинство программистов полагают раз прочтенные данные правильные, то значит, все в порядке и бросают все свои силы на защиту процедуры подсчитывания пароля, забывая о том важном месте, где программа устанавливает, куплена она или нет. Поэтому настоятельно советую не забывать ни об одном месте, где программа делает решающий выбор. Кстати подавляющее число программ использует одну и туже функцию для этой цели. Это оказалось фатальным для этих программ. Нельзя, повторяю ни в коем случае нельзя пользоваться одной и той же функцией. Её легко вычислить и тогда она теряет свой смысл. Помните самая хорошая защита, это защита которую нельзя обнаружить. Желательно пользоваться разными функциями, причем желательно рабочими (чтобы их корректировка привела к не работоспособности программы). Также лучше пользоваться разными переменными, чтобы нельзя было отследить адрес в памяти. Далее сверяйте переменные, и если они не равны, то лучше программе аварийно выйти, чем дать взломщику продолжить работу. Поставьте таймер, который проверяет каждые 10 минут право пользователя на работу. Причем если вы используете чистые проверки (без мусора), то взломщик может заметить это, и использовать это. Поэтому проверяйте пользователя в месте с мусором, чтобы ваша проверка не бросалась в глаза. Кстати тот же таймер (или другой с меньшим интервалом) подскажет вам, трассируют ли вашу программу или нет. Дело в том, что во время трассирования программы, время в Windows останавливается (системный таймер блокируется), то есть вы засекаете время, и если через 20 секунд оно не сдвинулось, то это означает, что либо материнская плата полетела, либо вашу программу взламывают. Кстати есть смысл хранить данные зашифрованными в реестре или файле, чтобы взломщик не сразу вычислил, где вы храните их. И конечно очень глупо записать где-нибудь строчку типа Registered=0, я думаю, что даже младенец поймет, что надо сделать. Но это можно использовать это как прикрытие, то есть если Registered=1, то можно показать сообщение типа <Попался грязный хакер!!!> и форматнуть ему комп (шутка). Но, в самом деле, идея не плохая. Вообще все чем я вам пудрю мозги, рассчитано на то, чтобы запутать взломщика. Но это были цветочки, теперь ягодки. Как вам известно, проверка пароля самая важная в защите, так как именно ей приходится выдерживать удары тяжелой артиллерии и поэтому у нее должна быть защита, как у банковского сейфа. Для начала я объясню, как взломщик начинает взлом. У него обычно есть два выбора начать с начала или с конца. Это значит, что он может начать исследовать программу с самого ввода пароля или начать с того момента, когда программа показывает сообщение о неверном пароле. У обоих методов есть свои плюсы и минусы. Если идти с начала, то можно узнать, где хранится введенное имя и пароль, и что с ним делают. Но с другой стороны приходится фильтровать кучу мусора, чтобы найти что-то стоящее. Если идти с конца, то есть шанс посмотреть код вышестоящий вызова сообщения или если это отдельная процедура выйти к месту проверки. Но и здесь есть свои трудности, иногда программа не использует стандартные функции показа сообщений, поэтому её нельзя поймать, или после показа сообщения программа не возвращается туда, откуда оно вызывалось, и поэтому тоже не узнаешь, что там случилось. Наша задача сделать так чтобы взломщик не понял где вообще проверка и не смог её подсмотреть. Так как в большинстве случаев взломщики идут первым путем, то и мы пойдем их путем. Я не вижу способа прочитать имя и пароль без вызова hmemcpy, эта стандартная функция Windows которая вызывается всюду без нашего разрешения, так что здесь у взломщика есть преимущество. Но кто сказал, что нам обязательно проверять пароль, тут же не отходя от кассы. Мы можем сказать <так и так учтем вашу просьбу, подождите ответа> и спокойно записать данные где-нибудь, и тут же использовать вышеописанный таймер и если нас просматривали, то выходим без лишних сообщений. Если нет то, где-нибудь через 20 кликов мышки, проверить тихо мирно чего нам подсунули. Желательно закодировать и имя и пароль по какому-нибудь крепкому алгоритму и сверить результаты. Причем сверять надо по букве, чередуя с мусором, а то программа типа Smartcheck запишет <сверялись такие и такие символы> и если их не спрятать, то можно догадаться, где это творится. Кстати если результат не верный то не надо ругаться, можно спокойно продолжать работу, так как взломщик может подловить на этом сообщении программу. И как я уже говорил, используйте разные функции всюду. Кстати, я недавно прочитал книжку по хакингу, крэкингу, и фрикингу. Так вот там автор утверждал, что надежность защиты определяется надежностью её самого слабого звена. Это утверждение применимо и в нашем деле. Насколько я понимаю самая слабая точка в защите, это то место где программа решает как её вести себя дальше, то есть купили её или нет. Это является очень критической точкой, так как большинство начинающих и ленивых взломщиков, часто трассируют огромные куски кода ради вышеописанного места в программе. Значит надо внимательно следить за этим, и лучше завести несколько дублей переменной и сверять их. Иногда программы используют CRC, то есть число уникальное для каждой программы которое определяет её целостность. Его можно хранить где-нибудь и подсчитывать заново каждый раз, и если числа не совпадают, то или на компе вирус или взломщик копался в коде программы. Если копался то лучше выйти. И ещё лучше выйти без сообщений. Я советую вообще воздержаться от каких либо сообщений по поводу защиты. А все потому что нельзя давать взломщику хоть малейший шанс подловить программу на чём либо. Функций для показа сообщений не так уж и много и они довольно известны, а вот функция, которая используется для выхода программы, не очень известна, и есть шанс, что взломщик не поймет что делать. Я перечитал то что написал и понял что так и не объяснил что, значит, подловить программу. Сейчас объясню. Программы бывают большими, и защита бывает тоже не маленькая. Поэтому чтобы не ворочать зря горы, взломщики используют точки останова. То есть в VB допустим, чтобы показать сообщение msgbox используется функция rtcMsgBox, взломщик может сказать дебагеру (если знает эту функцию), останови программу, если она вызовет rtcMsgBox. И когда ваша программа возмутится из-за неверного пароля, взломщик сможет начать свое исследование гораздо ближе к важному месту защиты, чем надо. Поэтому я считаю, что лучше всего вообще не давать взломщику лишнего шанса, проникнуть в программу. Часто взломщики не просто банально меняют нужный код, а исследуют алгоритм создания пароля и пишут генераторы серийных номеров. Поэтому необходимо хорошо защитить этот алгоритм. Желательно использовать какой-нибудь криптостойкий алгоритм типа RSA или MD5. В Интернете можно найти методы работы с ними. Также, чтобы затруднить взломщика желательно разбить генерирование пароля на несколько этапов, разбить по функциям (желательно рабочим, чтобы чаще вызывались не только из-за пароля), и в промежутках между вызовами этих функций проверять на исследование вашу программу. И ещё помните что когда ваша программа под дебагером, она не может выполнять параллельно несколько вещей, то есть если она проверит на наличие дебагера, взломщик может это заметить и выключить. Поэтому не давайте никому этого шанса, относитесь к каждому пользователю как к потенциальному взломщику. Ну вот и все, что я хотел рассказать Я написал эту статью по нескольким причинам: Мне захотелось поделиться с людьми своими знаниями. Мне нечего было делать. Мне надоело смотреть, как все кому не лень издеваются над слабыми защитами программистов, которые используют схемы защит 20-летней давности, и я решил по мере своих сил исправить положение. Я заметил, что когда объясняешь кому-нибудь, что-то, то начинаешь сам лучше понимать. Все приведенные методы используйте, как хотите. Ну и конечно тому, кому лень защищать свое детище, или он отмахивается тем, что программу все равно сломают, не стоило даже и читать эту статью. Я буду рад любым комментариям, замечаниям и любым отзывам. Вы можете прислать их мне на noobsaibott@hotmail.com. Наверх 79. Как запустить Screen saver? - VBОчередной совет на тему: как запустить Screen saver. Всё очень просто. Объявите функцию SendMessage и две константы: WM_SYSCOMMAND и SC_SCREENSAVE. Вот собственно и всё. Осталось только в нужный момент вызвать эту функцию и заставка запустится! Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const WM_SYSCOMMAND = &H112& Private Const SC_SCREENSAVE = &HF140& Sub Start() Dim Ret As Long Ret = SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&) End Sub Наверх 80. Использование специальной клавиши клавиатуры - VB
с помощью API функции эмулирует нажатие на эту клавишу и дополнительную клавишу, вызывая определенную процедуру в системе. В событии Form_Load() показан один пример: эмулирование нажатие клавиши ПУСК. В качестве параметра функции Launch вы можете использовать любую константу из StartMenuItems. Private Declare Sub keybd_event Lib "User32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Const VK_LWIN = &H5B, KEYEVENTF_KEYUP = &H2, VK_APPS = &H5D Public Enum StartMenuItems strtExplorer 'запустить ПРОВОДНИК strtFind 'окно "ПОИСК ФАЙЛОВ" strtMinimize 'минимизировать все окна strtRun 'вызвать окно "ЗАПУСК ПРОГРАММ" (ПУСК | ВЫПОЛНИТЬ...) strtStartMenu 'эмулировать нажатие клавиши ПУСК strtHelp 'вызвать справочную систему End Enum Public Sub Launch(func As StartMenuItems) Dim VK_ACTION As Long Select Case func Case strtExplorer: VK_ACTION = &H45 Case strtFind: VK_ACTION = &H46 Case strtMinimize: VK_ACTION = &H4D Case strtRun: VK_ACTION = &H52 Case strtStartMenu: VK_ACTION = &H5B Case strtHelp: VK_ACTION = &H70 End Select Call keybd_event(VK_LWIN, 0, 0, 0) Call keybd_event(VK_ACTION, 0, 0, 0) Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0) End Sub Private Sub Form_Load() Call Launch(strtStartMenu) End Sub Наверх | ||