Запуск таблицы символов из Excel

Листинг 3.106. Вызов таблицы символов

Sub ShowSymbolTable()

On Error Resume Next

' Запуск Charmap.exe - таблицы символов

Shell "Charmap.exe", vbNormalFocus

If Err <> 0 Then

MsgBox "Невозможно запустить таблицу символов.", vbCritical

End If

End Sub

Листинг 3.107. Таблица символов

' Декларация API-функций:

' для открытия процесса

Declare Function OpenProcess Lib "kernel32" _

 (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _

 ByVal dwProcessId As Long) As Long

' для получения кода завершения процесса

Declare Function GetExitCodeProcess Lib "kernel32" _

 (ByVal hProcess As Long, lpExitCode As Long) As Long

' для закрытия процесса

Declare Function CloseHandle Lib "kernel32" _

 (hProcess) As Long

 

Sub ShowSymbolTable1()

Dim lProcessID As Long

Dim hProcess As Long

Dim lExitCode As Long

 

On Error Resume Next

' Запуск таблицы символов (Charman.exe). Функция возвращает _

идентификатор созданного процесса

lProcessID = Shell("Charmap.exe", 1)

If Err <> 0 Then

MsgBox "Нельзя запустить Charman.exe", vbCritical, "Ошибка"

Exit Sub

End If

' Открытие процесса по идентификатору (lProcessID). Функция _

возвращает дескриптор процесса (handle)

hProcess = OpenProcess(&H400, False, lProcessID)

' Ждем, пока процесс завершится, для этого периодически _

получаем код завершения процесса (пока Charman.exe исполняется, _

функция GetExitCodeProcess возвращает &H103)

Do

GetExitCodeProcess hProcess, lExitCode

DoEvents

Loop While lExitCode = &H103

' Закрытие процесса

CloseHandle (hProcess)

' Вывод на экран информационного сообщения

MsgBox "Charmap.exe завершает свою работу"

End Sub

 

Листинг 3.64. Формат «два знака после запятой»

Sub ChangeNumberFormat()

Selection.NumberFormat = "0.00"

End Sub

Листинг 3.65. Использование разделителя по разрядам

Sub ThreeNullSepatator()

Selection.NumberFormat = "#,##"

End Sub

Листинг 3.66. Изменение формата

Sub ChangeNumerFormatEx()

Selection.NumberFormat = "#,##0.00"

End Sub

Листинг 3.67. Помещение последнего символа над строкой

Sub LastCharUp()

' Изменение расположения последнего символа ячейки

With ActiveCell.Characters(Start:=Len(Selection), Length:=1).Font

.Superscript = True

End With

End Sub

Листинг 3.68. Нестандартная рамка

Sub ChangeSelGrid()

' Оформление границ выделения

' Левая граница

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Правая граница

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

    .ColorIndex = xlAutomatic

End With

' Верхняя граница

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Нижняя граница

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

 

' Изменение сетки внутри выделения

' Вертикальные линии сетки

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlHairline

.ColorIndex = xlAutomatic

End With

' Горизонтальные линии сетки

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlHairline

.ColorIndex = xlAutomatic

End With

End Sub

 

глава информация о пользователе, компьютере, принтере и т.д.

Получить имя пользователя

Логин юзера получить просто:

Dim UserName As String

UserName = CreateObject("WScript.Network").UserName

А как отслеживать - вариатнов много.

Я, например, просто не выполняю макрос, если логин не тот:

If ThisWorkbook.Sheets("Rules").Range("Admin").Find(CreateObject("WScript.Network").UserName, _

LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then Exit Sub

[ответить с цитированием]

Drony

14.12.2007, 10:55             

Спасибо, за ответ.

Я тоже нашел эту заветную строку

MsgBox "Имя пользователя: " & CreateObject("WScript.Network").UserNam

 

CreateObject("WScript.Network").UserName вместо Application.UserName

Вывод разрешения монитора

Листинг 3.73. Разрешение монитора

'Объявление API-функции

Declare Function GetSystemMetrics Lib "user32" _

 (ByVal nIndex As Long) As Long

' Константы, которые передаются в функцию для определения _

 горизонтального и вертикального размеров изображения

Const SM_CXSCREEN = 0

Const SM_CYSCREEN = 1

 

Sub GetMonitorResolution()

Dim lngHorzRes As Long

Dim lngVertRes As Long

 

' Получение ширины и высоты изображения на мониторе

lngHorzRes = GetSystemMetrics(SM_CXSCREEN)

lngVertRes = GetSystemMetrics(SM_CYSCREEN)

' Отображение сообщения

MsgBox "Текущее разрешение: " & lngHorzRes & "x" & lngVertRes

End Sub