Новый выпуск!
Читайте!

Книги

		Переход на VB .NET. Стратегии, концепции, код (цена ~ 158 руб.) Эта книга была задумана как одна из первых книг о .NET, которая ознакомит читателя с основными идеями новой архитектуры и подготовит его к знакомству с более детальной литературой, например документацией Microsoft и ее толкованиями, которая неизбежно появится на рынке. Она поможет вам взглянуть на эту технологию с позиций ваших собственных рабочих планов и быстро освоить те концепции, которые покажутся необычными для большинства прогр...
		Автор(ы): Дан Эпплман, Издательство: Питер, 2002 г.
		Программирование на VB.NET. Учебный курс (цена ~ 119 руб.) Эта книга является вводным курсом по изучению языка программирования Visual Basic .NET. Даны основные принципы объектно-ориентированного программирования в контексте языка VB .NET, поскольку без хорошей подготовки в этой области невозможно в полной мере пользоваться всеми преимуществами VB .NET. Изложены азы всех аспектов языка, которыми должен владеть любой профессиональный разработчик VB .NET
		Автор(ы): Г. Корнелл, Дж. Моррисон, Издательство: Питер, 2002 г.
		VB.NET для разработчиков (цена ~ 125 руб.) Основная задача книги - быстро ознакомить разработчиков Visual Basic с изменениями в .NET Framework. Программисты, использующие Java, C++, Delphi или другие инструменты разработки приложений и интересующиеся Visual Basic или технологией .NET Framework, также найдут эту книгу полезной. Хотя книга посвящена Visual Basic.NET, ее основная цель - продемонстрировать взаимодействие Visual Basic и ...
		Автор(ы): Кит Франклин, Издательство: Вильямс, 2002 г.

Остальные книги о VB можно найти здесь.

наверх

---

Преобразование цветного рисунка в черно-белый

Вам понадобятся 2 PictureBox и CommandButton. Загрузите в первый PictureBox любую цветную картинку, запустите проект на выполнение, нажмите на кнопку.

Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Const CF_BITMAP = 2

Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal imageType As Long, ByVal newWidth As Long, ByVal newHeight As Long, ByVal lFlags As Long) As Long
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const LR_MONOCHROME = &H1

Private Sub Command1_Click()
Dim hNew As Long
hNew = CopyImage(Picture1.Picture, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG & LR_MONOCHROME)
OpenClipboard Me.hwnd
EmptyClipboard
SetClipboardData CF_BITMAP, hNew
CloseClipboard
Picture2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub

наверх

---

Тень от формы

Автор: Винокуров К.

Этот код показывает, как нарисовать тень от формы.

'КОД ФОРМЫ
Option Explicit
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub Form_Load()
     SetParent picShadow.hwnd, GetDesktopWindow
     SetProc hwnd
End Sub

'КОД МОДУЛЯ
Option Explicit
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal lngHandle As Long, ByVal nIndex As Long, ByVal dwNewLong 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private lngOldProc As Long
Public Sub SetProc(ByVal lngHandle As Long)
     lngOldProc = SetWindowLongA(lngHandle, -4, AddressOf WinProc)
End Sub
Private Function WinProc(ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
     If lngMsg = &H3 Then
         frmMain.picShadow.Move frmMain.Left, frmMain.Top
         DoEvents
         BitBlt frmMain.picShadow.hDC, 0, 0, frmMain.picShadow.Width, frmMain.picShadow.Height, GetDC(0), frmMain.picShadow.Left / Screen.TwipsPerPixelX + 30, frmMain.picShadow.Top / Screen.TwipsPerPixelY + 30, vbSrcCopy
         frmMain.picShadow.Line (0, 0)-(frmMain.picShadow.ScaleWidth, frmMain.picShadow.ScaleHeight), vbGrayText, BF
         frmMain.picShadow.Move frmMain.Left + (30 * Screen.TwipsPerPixelX), frmMain.Top + (30 * Screen.TwipsPerPixelY), frmMain.Width, frmMain.Height
     End If
     WinProc = CallWindowProcA(lngOldProc, lngHandle, lngMsg, lngFirstParam, lngLastParam)
End Function

наверх

---

Снять задачу

Автор: vmv

При работе, а чаще всего, при отладке програм связанных с открытием-закрытием приложений (например с XL) бывают ситуации, когда после активации приложения происходит сбой программы. Приложение остается в памяти и последующий старт программы загружает еще одно такое же приложение ... При старте программы необходимо проверить загружено ли приложение в память, и если - да, то предварительно снять задачу. Закрыть приложение (на примере с Excel) и снять задачу( как и любое другое ), оставшееся в памяти можно таким образом.

' помещаем в модуль

Public Const PROCESS_TERMINATE = &H1
Public Const WM_QUERYENDSESSION = &H11
Public Const WM_ENDSESSION = &H16
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public 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 Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Const WM_CLOSE = &H10
Dim strCaptions() As String ' Здесь будут лежать заголовки всех найденных окон
Dim lngHandle() As Long ' А здесь все хэндлы этих окон
Public Function CloseProg(strCaption As String) As Boolean
Dim iCount As Integer
Dim i As Integer
Dim Pos As Integer
Dim lngEnum As Long
ReDim strCaptions(0)

     ReDim lngHandle(0)' Обнуляем массив от возможных прошлых результатов
     lngEnum = EnumWindows(AddressOf Callback1_EnumWindows, 0)' то же чистим

     For i = 0 To UBound(strCaptions) ' перебираем эти массивы
         Pos = InStr(1, strCaptions(i), strCaption, vbTextCompare) ' ищем строку - название окна
         If Pos > 0 Then
         SendMessage lngHandle(i), WM_CLOSE, 0, 0
         SendMessage lngHandle(i), WM_ENDSESSION, 0, 0
         SendMessage lngHandle(i), WM_QUERYENDSESSION, 0, 0
         ' будут закрыты все окна с таким названием окна
         iCount = iCount + 1
         End If
     Next
End Function


Public Function Callback1_EnumWindows(ByVal hwnd As Long, ByVal lpData As Long) As Long
Dim cnt As Long
Dim rttitle As String * 256
     cnt = GetWindowText(hwnd, rttitle, 255) ' ищем следующее окно
     If cnt > 0 Then ' нашли, тогда добавляем элемент в массивы
         ReDim Preserve lngHandle(UBound(strCaptions) + 1)
         ReDim Preserve strCaptions(UBound(strCaptions) + 1)
         strCaptions(UBound(strCaptions)) = Left$(rttitle, cnt)
         lngHandle(UBound(lngHandle)) = hwnd
     End If
     Callback1_EnumWindows = 1 ' продолжаем перебирать
End Function
'-------

' в Private Sub Form_Load() помещаем
   CloseProg "Microsoft Excel - ****" ' где **** - имя приложения
   ' затем
   XL.Workbooks.Open App.Path & "\****.xls" ' открываем приложение

Примечание: имя приложения - "Microsoft Excel - ****" можно уточнить (при XL.Visible = True) через Ctrl-Alt-Del

наверх

---

Обеспечение корректной выгрузки формы

Форма позволяет поместить весь код для проверки выгрузки в одном месте – неважно, происходит ли это в результате выполнения метода Unload, щелчка по значку Х, выбора пункта Close из системного меню или даже нажатия Alt+F4. Событие, позволяющее перехватить любую попытку закрыть форму, называется QueryUnload.
Событие QueryUnload вызывается при любой попытке выгрузить форму – из программы или как-нибудь иначе. Это событие передает обработчику информацию о том, по какой причине закрывается форма. Если вам интересно знать, каким образом была инициирована выгрузка формы, вы можете проверить значение параметра UnloadMode.

Значение UnloadMode	Причина закрытия формы
vbFormControlMenu	Пользователь выбрал команду Close из системного меню окна формы
vbFormCode	В программе вызван метод Unload
vbAppWindows	Идет процесс завершения работы Windows
vbAppTaskManager	Менеджер задач закрывает приложение
vbFormMDIForm	Форма, вложенная в многодокументную (MDI) форму, закрывается, поскольку закрывается родительская форма

Если вы хотите каждый раз узнавать, по какой причине закрывается форма, можно поместить в обработчик события QueryUnload код, проверяющий все возможные значения параметра UnloadMode. Взгляните на следующий пример.

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Select Case UnloadMode Case vbFormControlMenu MsgBox "Выгрузка формы из системного меню или кнопкой Х." Case vbFormCode MsgBox "Выгрузка из кода." Case vbAppWindows MsgBox "Windows заканчивает свою работу." Case vbAppTaskManager MsgBox "Выгрузка из менеджера задач." Case vbFormMDIForm MsgBox "Выгружается MDI форма." End Select End Sub

наверх

---

Мои программы

BalloonMessage for MS Agent


Автора: Шатрыкин Иван и Павел Сурменок.

наверх

---

Вопрос/Ответ

Здесь Вы можете задать вопрос, или ответить на уже имеющиеся вопросы.

Вопросы:

---

Автор вопроса: Владимир

Ответ ожидается по этому адресу

   1.В связи с тем, что в TextBox нет свойства BackStyle=Transparent, как можно сделать вертикальный скроллинг текста в Label?

2. При частом обращении к базе данных посредством VB возникает предупреждение "Run-time error '7' Out of memory" и программа закрывается. Нужно снова её открыть и продолжить работу.Как избавиться от этого?

---

Автор вопроса: Денис

Ответ ожидается по этому адресу

   Подскажите если кто знает как отправить на принтер содержимое PictureBox?

---

Автор вопроса: Maxim

Ответ ожидается по этому адресу

   Где достать описание функций на русском яяыке!!!!!

---

Автор вопроса: SaRatovV

Ответ ожидается по этому адресу

   Подскажите пожалуйста, как пользоваться портами через вырьдовский WSOCK32.DLL.

---

Автор вопроса: ]...C...B...K...[C...R...a...S...H

Ответ ожидается по этому адресу

   SOS
Как можно проверить создался обьект Excel или нет
  
Dim ss As New Excel.Application
Dim xx As Application
Dim ZZ As Workbook
Set xx = ss.Application
Set ZZ = ss.Workbooks.Open(App.Path + "\Отчет.xls")

---

Автор вопроса: Илья

Ответ ожидается по этому адресу

   Известно, как картинку, которая находится в Picture1.Picture сохранить через диалоговое окно. А как сделать, чтобы в Листбоксе диалогового окна можно было бы выбирать несколько форматов сохранения (BMP,JPG,GIF)?

---

Ответы:

---

Вопрос:

   Подскажите, пожалуйста, как узнать все процессы в системе и отключить любой ия них.

Ответ:

Автор ответа: CRAZYDIMA

Данный пример демонстрирует вырубание процесса и их перечисление, но только в среде Вин 9х.
Если надо пример на ВБ - напиши - crazydima@mail.ru.

'\\ ToolHelp
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long

Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, lppe As PROCESSENTRY32) As Long

Private Declare Function Thread32First Lib "kernel32" (ByVal hSnapShot As Long, lppe As THREADENTRY32) As Long
Private Declare Function Thread32Next Lib "kernel32" (ByVal hSnapShot As Long, lppe As THREADENTRY32) As Long

Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'***************************************************
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


Public Const INFINITE = &HFFFF ' Infinite timeout
Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF

Private Const MAX_PATH = 260
Private Const MAX_MODULE_NAME32 = 255

Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_QUERY_INFORMATION = &H400

'CONST FOR PROCESS_FUNCTION
Private Const TH32CS_NAPHEAPLIST = &H1
Private Const TH32CS_SHAPPROCESS = &H2
Private Const TH32CS_SHAPTHREAD = &H4
Private Const TH32CS_SHAPMODULE = &H2
Private Const TH32CS_SHAPALL = (TH32CS_SHAPMODULE Or TH32CS_SHAPPROCESS Or TH32CS_SHAPTHREAD Or TH32CS_NAPHEAPLIST)
Private Const TH32CS_INHERIT = &H80000000
'CONST FOR THREAD_FUNCTION
Private Const MAXLONG = &H7FFFFFFF

Private Const IDLE_PRIORITY_CLASS = &H40
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const REALTIME_PRIORITY_CLASS = &H100
Private Const HIGH_PRIORITY_CLASS = &H80

Private Type PROCESSENTRY32
         dwSize As Long
         cntUsage As Long
         th32ProcessID As Long
         th32DefaultHeapID As Long
         th32ModuleID As Long
         cntThread As Long
         th32ParentProcessID As Long
         pcPriClassBase As Long
         dwFlags As Long
         szExeFile As String * MAX_PATH
End Type

Private Type THREADENTRY32
         dwSize As Long
         cntUsage As Long
         th32ThreadID As Long
         th32OwnerProcessID As Long
         tpBasePri As Long
         tpDeltaPri As Long
         dwFlags As Long
End Type
'объявление UDT-структуры, относящейся к процессам
Public Type SnapShotInfoProcess
         hProcessID As Long
         hHandleProcess As Long
         sProcessName As String
         sPriority As Long
End Type
'объявление UDT-структуры, относящейся к потокам
Public Type SnapShotInfoThread
         hThreadID As Long
         hOwnerProcess As Long
End Type
Sub GetProcesses(sFQEXENames() As SnapShotInfoProcess)
'**************************************************
'** Функция возвращает список процессов **
'** Вход - пустой массив, пользовательского типа **
'** Выход - массив процессов **
'** Автор - Филюшин Дмитрий **
'**************************************************

Dim hSnapShot As Long
Dim lret As Long
Dim cProcesses As Long
Dim fso As New FileSystemObject
Dim sEXEName() As String
Dim procEntry As PROCESSENTRY32

Dim sfile As String
sfile = String(255, 0)
procEntry.dwSize = LenB(procEntry)
'вспомогательная функция-утилита
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SHAPALL, 0&)
'обязательное условие применение функции
If hSnapShot = -1 Then
         MsgBox "Error number - " & Hex(Err.Number) & vbCrLf & _
         "Error Description - " & Err.Description
         Exit Sub
End If
'переопределить массив
ReDim sFQEXENames(1 To 10)
sModuleName = String(255, 0)
cProcesses = 0
'начать проход по процессам
'получить первый процесс

lret = Process32First(hSnapShot, procEntry)
If lret > 0 Then
         cProcesses = cProcesses + 1
         sFQEXENames(cProcesses).hProcessID = procEntry.th32ProcessID
         sFQEXENames(cProcesses).hHandleProcess = GetHandle(procEntry.th32ProcessID)
         sFQEXENames(cProcesses).sProcessName = CN(Trim(procEntry.szExeFile))
         sFQEXENames(cProcesses).sPriority = GetPriorityClass(sFQEXENames(cProcesses).hHandleProcess)
End If
NextRun:
'в цикле получить следующие процессы
Do
         lret = Process32Next(hSnapShot, procEntry)
         If lret = 0 Then Exit Do
         cProcesses = cProcesses + 1
         If UBound(sFQEXENames) < cProcesses Then
                 ReDim Preserve sFQEXENames(1 To cProcesses + 2)
         End If
         sFQEXENames(cProcesses).hProcessID = procEntry.th32ProcessID
         sFQEXENames(cProcesses).hHandleProcess = GetHandle(procEntry.th32ProcessID)
         sFQEXENames(cProcesses).sProcessName = CN(Trim(procEntry.szExeFile))
         sFQEXENames(cProcesses).sPriority = GetPriorityClass(sFQEXENames(cProcesses).hHandleProcess)

NextDo:
Loop

CloseHandle hSnapShot

End Sub

Function GetHandle(procID As Long) As Long
'**************************************************
'** Функция возвращает Handle процесса **
'** Вход - ID процесса **
'** Выход - Handle процесса **
'** Автор - Филюшин Дмитрий **
'**************************************************
         GetHandle = OpenProcess(PROCESS_QUERY_INFORMATION, 0&, procID)
         Call CloseHandle(procID)
End Function


Sub GetThreads(sFQEXENames() As SnapShotInfoThread)
'**************************************************
'** Функция возвращает потоки **
'** Вход - ID процесса **
'** Выход - массив потоков **
'** Автор - Филюшин Дмитрий **
'**************************************************

Dim hSnapShot As Long
Dim lret As Long
Dim cProcesses As Long
Dim fso As New FileSystemObject
Dim sModuleName As String
Dim sEXEName() As String
Dim uThreadEntry As THREADENTRY32
Dim hProc As Long
uThreadEntry.dwSize = LenB(uThreadEntry)
'вспомогательная функция-утилита
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SHAPTHREAD, 0&)
'обязательное условие применение функции
If hSnapShot = -1 Then
         MsgBox "Error number - " & Hex(Err.Number) & vbCrLf & _
         "Error Description - " & Err.Description
         Exit Sub
End If
'переопределить массив
ReDim sFQEXENames(1 To 10)
sModuleName = String(255, 0)
cProcesses = 0
'начать проход по процессам
'получить первый процесс

lret = Thread32First(hSnapShot, uThreadEntry)
If lret > 0 Then
         cProcesses = cProcesses + 1
         sFQEXENames(cProcesses).hThreadID = uThreadEntry.th32ThreadID
         sFQEXENames(cProcesses).hOwnerProcess = uThreadEntry.th32OwnerProcessID
End If
NextRun:
'в цикле получить следующие процессы
Do
         lret = Thread32Next(hSnapShot, uThreadEntry)
         If lret = 0 Then Exit Do
         cProcesses = cProcesses + 1
         If UBound(sFQEXENames) < cProcesses Then
                 ReDim Preserve sFQEXENames(1 To cProcesses + 2)
         End If
         'If LCase(fso.GetExtensionName(procEntry.szExeFile)) <> "exe" Then cProcesses = cProcesses - 1: GoTo NextDo
         sFQEXENames(cProcesses).hThreadID = uThreadEntry.th32ThreadID
         sFQEXENames(cProcesses).hOwnerProcess = uThreadEntry.th32OwnerProcessID
NextDo:
Loop
CloseHandle hSnapShot
End Sub
Function Priority(iPriorityConst As Long) As String
'**************************************************
'** Функция возвращает приоритет **
'** Вход - константа приоритета **
'** Выход - строковое выражение **
'** Автор - Филюшин Дмитрий **
'**************************************************

Select Case iPriorityConst
Case NORMAL_PRIORITY_CLASS
         Priority = "Normal priority process"
Case IDLE_PRIORITY_CLASS
         Priority = "Idle Process"
Case HIGH_PRIORITY_CLASS
         Priority = "High priority process"
Case REALTIME_PRIORITY_CLASS
         Priority = "Realtime priority process"
End Select
End Function
Function DestroyProcess(hProcess As Long) As Boolean
'**************************************************
'** Функция уничтожает процесс **
'** Вход - handle процесса **
'** Выход - в случае успешного завршения - True,**
'** в противном случае - False **
'** Автор - Филюшин Дмитрий **
'** Дата - 20.11.2002 **
'**************************************************
Dim lngRetVal As Long
Dim iRetVal As Long
iRetVal = GetExitCodeProcess(hProcess, lngRetVal)
iRetVal = TerminateProcess(hProcess, lngRetVal)
If iRetVal = 0 Then
     MsgBox "Неизвестная ошибка,невозможно завершить процесс!", vbExclamation
     DestroyProcess = False
     Exit Function
End If

End Function
'Запускает приложение и ждет его завершения
Public Function ShellWait(ByRef sPathName, ByVal iWindowStyle As VbAppWinStyle) As Boolean
Dim vProg As Variant, iProc As Long, iRet As Long
On Error GoTo errLabel
vProg = Shell(sPathName, iWindowStyle)
iProc = OpenProcess(PROCESS_ALL_ACCESS, False, vProg)
If iProc <> 0 Then
         iRet = WaitForSingleObject(iProc, INFINITE)
         CloseHandle iProc
         ShellWait = True
Else
         ShellWait = False
End If

Exit Function
errLabel:
If Err.Number = 53 Then ' file not found
         MsgBox "Файл " & sPathName & " не найден! Операция прервана, проверьте правильность указанного путь и повторите операцию.", vbCritical + vbOKOnly + vbDefaultButton1
         ShellWait = False
End If
End Function

---

Вопрос:

   В МОДУЛЕ ПИШУ:

Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public AsciiZnak(255) As Integer

Function KeyDruk() As String
      
    For i = 1 To 255 ' Prisvoenie
       If Not AsciiZnak(i) = GetKeyState(i) Then
          KeyDruk = Chr(i)
       End If
       AsciiZnak(i) = GetKeyState(i)
    Next i
            
End Function

В ПРОГРАММЕ ПИШУ:

Private Sub Timer1_Timer()
Dim a As String
a = KeyDruk()
Text1.Text = Text1.Text + a
End Sub


ВОПРОС:
Почему при выполнении таймера он выдаёт один символ два раза? По идеи в модуле я написал всю проверку насчёт косяка.
Менять интервал времени таймера не помогает, а если сделать уж очень большой интервал, то вообще функция не успевает следить за нажатием кнопок.
Что делать?

Ответ:

Автор ответа: AndroiD

Так, че-то я не понял, зачем надо было такую структуру программы делать..? Кейлоггер, что ли? Юзай не GetKeyState, а GetAsynkKeyState. Если я чего-то не так понял или нужен исходник кейлоггера - пиши на e-mail. (а вообще-то я уже вроде кому-то давал исходник кейлоггера в предыдущем выпуске)

---

Вопрос:

   Подскажите, как перевернуть содержимое ячейки в Excele на 180 градусов ("вверх ногами").
Требуется для формы Госкомстата.
Может быть воспользоваться перевернутым шрифтом, тогда подскажите, где его взять?

Ответ:

Автор ответа: Владимир Кирко

Выделяешь нужную для разворота ячейку с текстом (или без оного), далее Сервис->Макрос->начать запись->(щелчок правой кнопкой мыша по ячейке)-> Формат ячеек->ориентация текста:90 градусов->OK и остановить запись макроса.
Далее Alt-F11 и в редакторе VB в модулях имеем нечто вроде:

     With Selection
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlBottom
         .WrapText = False
         .Orientation = 90
         .AddIndent = False
         .IndentLevel = 0
         .ShrinkToFit = False
         .ReadingOrder = xlContext
         .MergeCells = False
     End With

(сделать в десять раз быстрее, чем написать).
Единственная содержательная строчка здесь для нас это Selection.Orientation = 90. Можно её использовать непосредственно для написания макроса (т.е. что-нибудь вставляем в выделенную ячейку и тут же Selection.Orientation = 90 её). А можно залезть в help и узнаать массу интересных вещей о том, что оказывается .Orientation может быть у Range-объекта, TextFrame-объекта, ... Там же есть ещё какие-то примеры.

---

Ответ:

Автор ответа: Иван

текст "вверх ногами"?
Думаю, что такое можно сделать только с помощью WordArd.
Пример (для off2000):

ActiveSheet.Shapes.AddTextEffect _
    (msoTextEffect1, "Перевёрнутая надпись", "Arial", _
     36#, msoFalse, msoFalse, 96#, 138.75).Select
Selection.ShapeRange.Rotation = 180# '!!!!!!!!!!!!!!!!Вот оно
Selection.ShapeRange.Height = 41.25 'это уже по вкусу и обстоятельствам
Selection.ShapeRange.Width = 240.75 '

Шрифт, размер, позицию - уже совсем нетрудно.

---

---

Можете заполнить эту форму, либо отослать вопрос СЮДА

Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.

Текст сообщения:

Ваше имя
E-mail для ответа

наверх