Создание ярлыка на рабочем столе

Этот скрипт позволяет создать ярлык для объекта файловой системы. Он может быть использован как отдельный файл с расширением '.vbs'.

Set WshShell  = Wscript.CreateObject("Wscript.Shell")' Создание объекта ярлыка
' Объявление места ярлыка
Set oShellLink  = WshShell.CreateShortcut("well.lnk")
oShellLink.TargetPath  = "D:\"' Определение объекта (ссылки)
oShellLink.IconLocation  = "D:\Public\Images\Icons\JavaCup.ico"' Определение иконки
oShellLink.Save' Создание ярлыка

Создание ярлыка на рабочем столе (процедура VB)

Аналог предыдущего позволяет создать ярлык для объекта файловой системы. Он может быть использован как фрагмент VB-кода.

Public Sub Test_02()
  Dim WshShell As Object ' Объект Wscript.Shell
  Dim oShellLink As Object ' Ярлык
  Set WshShell  = CreateObject("Wscript.Shell") ' Создание объекта ярлыка
  ' Объявление места ярлыка
  Set oShellLink  = WshShell.CreateShortcut(ThisWorkbook.Path & "\well.lnk") 
  With oShellLink
    .TargetPath  = ThisWorkbook.FullName ' Определение объекта (ссылки)
    .IconLocation  = "D:\Public\Images\Icons\JavaCup.ico" ' Определение иконки
    .Save ' Создание ярлыка
  End With
End Sub

Использование объекта Dictionary

Объект Dictionary - родственник объекта Collection и по сути является именованным массивом.

Sub Test_01()
' Использование объекта словаря
Dim S As Object ' Словарь
Dim V As Variant ' Ключ словаря
Dim I As Integer ' Счетчик
Dim MSG As String ' Сообщение

Set S  = CreateObject("Scripting.Dictionary") ' Создаем словарь
' Заполняем случайными значениями
With S
  For I  = 1 To 5
    .Add "Str #" & I, CInt(Rnd * 1000)
  Next I
End With
' Кол-во элементов словаря
Debug.Print "В словаре " & S.Count & " пар" 
' Вывод пары ключ-значение
For Each V In S
  Debug.Print , V, S(V)
Next V

V  = "Str #2"
' Наличие элемента в словаре
MSG  = IIf(S.Exists(V), "Элемент найден " & S(V), "Элемент не найден")
Debug.Print V, MSG

' Удаление элемента словаря
If S.Exists(V) Then S.Remove CStr(V) 
' Кол-во элементов словаря
Debug.Print "В словаре (после попытки удаления)" & S.Count & " пар"

' Очистка словаря
S.RemoveAll
' Кол-во элементов словаря
Debug.Print "В словаре (после очистки)" & S.Count & " пар" 

Debug.Print "Tes_01"
End Sub

Получение значений переменных окружения

Получение значений переменных окружения проще всего осуществить используя функцию Environ. При этом желательно вызывать параметры по имени.

  • ALLUSERSPROFILE - Общий профиль
  • APPDATA - Application Data
  • CommonProgramFiles - Common Files
  • COMPUTERNAME - Имя компьютера
  • NWUSERNAME - Сетевое имя пользователя
  • ProgramFiles - Program Files
  • SystemDrive - Системный диск
  • SystemRoot - Каталог Windows
  • USERPROFILE - Профиль пользователя
  • WinDir - Каталог Windows
Public Sub EnvironVariable()
' Параметр окружения
Dim Result As Variant ' Результат
Dim Name As String ' Имя параметра

Name  = "USERPROFILE"' Профиль пользователя
Result  = Environ(Name)
Debug.Print Name & ":", Result
End Sub

Переключение раскладки

Очень часто приходится заполнять формы, поля которых содержат данные на разных языках. Следующая функция выполняет это переключение 

' Должны быть описаны библиотеки
Public Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long)
Public Declare Function ActivateKeyboardLayout& Lib "user32" (ByVal HKL As Long, _
  ByVal flags As Long)

Public Function SetLanguage(Optional Layout As Long = 3) As Long
' Устанавливаетт язык по параметру Layout
' 0 - возвращает текущий язык
' 1, 67699721 - русский
' 2, 68748313 - английский
' 3 - переключает

Dim C As Long ' Текущая раскладка

C = GetKeyboardLayout(0)
SetLanguage = C
Select Case Layout
  Case 1, 67699721: ActivateKeyboardLayout 68748313, 1 ' На русский
  Case 2, 68748313: ActivateKeyboardLayout 67699721, 1 ' На английский
  Case 3:
    If C = 68748313 Then
      ActivateKeyboardLayout 67699721, 1
    Else
      ActivateKeyboardLayout 68748313, 1
    End If
End Select
End Function

Экспорт диаграмм в gif-файлы

Иногда приходится результаты работы в Excel предоставлять в HTML формате, однако, как быть с графическими объектами, например с диаграммами. Фрагмент кода, представленный ниже решает эту задачу. 

 
Public Sub ExportGraph()
Dim SRC As Worksheet ' Таблица источник
Dim Ch As Chart ' Очередная диаграмма
Dim i As Integer ' Счетчик
Dim FN As String ' Имя файла (полное)

Set SRC = ThisWorkbook.Sheets("График")
Debug.Print "Найдено объектов: " & SRC.ChartObjects.Count

For i = 1 To SRC.ChartObjects.Count
  Set Ch = SRC.ChartObjects(i).Chart
  FN = ThisWorkbook.Path & "\" & Format$(i, "000") & ".gif"
  Application.StatusBar = FN
  Debug.Print "Объект: " & i & " - " & Ch.Name,
  Debug.Print ChartToGif(Ch, FN)
  Application.StatusBar = False
Next i
End Sub

Function ChartToGif(oChart As Chart, sFilePath As String, _
  Optional bOverwrite As Boolean = True) As Boolean
If bOverwrite Then
On Error Resume Next
' Удаляем существующий файл
    VBA.Kill sFilePath
End If
' Экспортируем график
On Error GoTo ErrFailed
oChart.Export sFilePath
ChartToGif = True
Exit Function

ErrFailed:
'Ошибка
Debug.Print "Ошибка в ChartToGif: " & Err.Description
ChartToGif = False
End Function
Hosted by uCoz