|
|
Private Sub CreatePaletteColours()
With Application
.ScreenUpdating = False
.Workbooks.Add xlWBATWorksheet
.ActiveWorkbook.ResetColors
With .Range("A1:G8")
Dim iCell As Range
For Each iCell In .Cells
iColorIndex& = iColorIndex& + 1
iCell.Value = iColorIndex&
iCell.Interior.ColorIndex = iColorIndex&
Next
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 48
End With
.ColumnWidth = 3
.RowHeight = 19.5 '.Cells(1).Width
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
.ScreenUpdating = True
End With
End Sub
| 
Актуально только для MS Excel 97, 2000, XP
Для того, чтобы заблокировать все панели инструментов, включая собственные панели и контекстные меню, а также убрать заголовок окна книги, изменить заголовок окна приложения, убрать строку состояния, строку формул, сетку, заголовки столбцов, вертикальную и горизонтальную полосу прокрутки, а также ярлычки листов, достаточно выполнить макрос UserInterface() Для того, чтобы восстановить вид окна,
по умолчанию, достаточно выполнить макрос RestoreInterface()
Private Sub ChangeInterface(Value As Boolean)
With Application
.ScreenUpdating = False
.Caption = IIf(Value = True, Empty, "Наше окно")
.DisplayStatusBar = Value
.DisplayFormulaBar = Value
Dim iCommandBar As CommandBar
For Each iCommandBar In .CommandBars
iCommandBar.Enabled = Value
Next
With .ActiveWindow
.Caption = IIf(Value = True, .Parent.Name, "")
.DisplayHeadings = Value
.DisplayGridlines = Value
.DisplayHorizontalScrollBar = Value
.DisplayVerticalScrollBar = Value
.DisplayWorkbookTabs = Value
End With
.ScreenUpdating = True
End With
End Sub
Private Sub UserInterface()
ChangeInterface False
End Sub
Private Sub RestoreInterface()
ChangeInterface True
End Sub
| Если Вы пользовались более ранней версией, то, скорее всего, замечали, что там высота строки формулы менялась автоматически, в зависимости от количества(и ширины) символов активной ячейки. Однако, начиная с 2007 версии, всё изменилось и теперь подобного эффекта не наблюдается. И если Вас это не устраивает и хочется самостоятельно изменять высоту строки формул, то сделать это можно с помощью свойства FormulaBarHeight об'екта
Application
Application.FormulaBarHeight = 3
Комментарий : Обратите внимание на то, что высота - задаётся количеством строк.
| Для того, что отобразить диалоговое окно, с помощью которого можно выбрать необходимую папку и получить полный путь к этой папке, можно использовать об'ект FileDialog, который впервые появился в MS Office XP. Если же Вы работаете с другими версиями 97, 2000, то в этом случае можно воспользоваться следующим советом Private Sub GetSelectedFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 1 Then
iPath = .SelectedItems(1) '.InitialFileName
MsgBox "Выбрана папка : " & iPath, vbExclamation, ""
Else
MsgBox "Выберите нужную папку", vbCritical, ""
End If
End With
End Sub
| Private Sub GetSelectedFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
'.AllowMultiSelect = False
If .Show = True Then
iPath = .SelectedItems(1) '.InitialFileName
MsgBox "Выбрана папка : " & iPath, vbExclamation, ""
Else
MsgBox "Выберите нужную папку", vbCritical, ""
End If
End With
End Sub
| Если с помощью функции MsgBox, создаются сообщения, которые содержат две или три кнопки и Вам необходимо, чтобы основной была вторая или третья, то используйте константы vbDefaultBitton2 и vbDefaultBitton3 Private Sub Example_MsgBox2()
If MsgBox("Есть ли жизнь на Марсе ?", _
vbYesNo + vbDefaultButton2) = vbNo Then
MsgBox "Выбрали 'Нет'"
Else
MsgBox "Выбрали 'Да'"
End If
End Sub
| Private Sub Example_MsgBox3()
Select Case MsgBox("Ваш выбор ?", _
vbAbortRetryIgnore + vbDefaultButton3)
Case vbIgnore: MsgBox "Выбрали 'Пропустить'"
Case vbAbort: MsgBox "Выбрали 'Прервать'"
Case vbRetry: MsgBox "Выбрали 'Повтор'"
End Select
End Sub
Комментарий : Если же необходимо, чтобы фокус находился
на первой кнопке, то несмотря на наличии константы vbDefaultBitton1,
её применение вовсе не обязательно.
|
Актуально для MS Excel 97-2003
Если Вы являетесь обладателем указанных выше версий, то для вывода информации на экран, кроме функции MsgBox, Вы можете также использовать возможности, которые предоставляет помошник, например : Private Sub Assistant_NewBalloon()
With Assistant.NewBalloon
.Icon = msoIconTip
.Heading = "Заголовок подсказки"
.Text = "Текст подсказки"
.Show
End With
End Sub
| Private Sub Assistant_NewBalloon2()
With Assistant.NewBalloon
'.Icon = msoIconAlertQuery
'.BalloonType = msoBalloonTypeButtons
.Button = msoButtonSetYesNoCancel
.Heading = "Выберите нужное действие"
.Text = "Продолжить ?"
Select Case .Show
Case -3: MsgBox "Кнопка Да"
Case -4: MsgBox "Кнопка Нет"
Case -2: MsgBox "Кнопка Отмена"
End Select
End With
End Sub
Обратите внимание на то, что в отличии от функции MsgBox,
помошник(ассистент) позволяет нам несколько расширить взаимодействие с
пользователем, например, "создать" и использовать "флажки" или "надписи"
(нумерация которых, обязательно начинается с 1,
а количество ограничено 5)
| Private Sub Assistant_NewBalloon3()
Dim iCount%, iArrCity As Variant, iCheck As BalloonCheckbox
iArrCity = Array("Новосибирск", "Москва", "Ленинград", "Тверь", "Иркутск")
With Assistant.NewBalloon
.Heading = "Выберите нужные города"
For iCount = 0 To 4 'UBound(iArrCity)
.CheckBoxes(iCount + 1).Text = iArrCity(iCount)
Next
.Show
For Each iCheck In .CheckBoxes
If iCheck.Checked = True Then
MsgBox "Вы выбрали = " & iCheck.Text
End If
Next
End With
End Sub
И наконец, помошник(ассистент) позволяет выводить немодальные
сообщения, пример создания и использование которых, также прилагается
(MsgBox, разумеется, применяются исключительно в демонстрационных целях)
| Private Sub Auto_Open() 'XL2000-2003
With Assistant
.On = True: '.Visible = True
With .NewBalloon
.BalloonType = msoBalloonTypeButtons
.Icon = msoIconAlertInfo
.Button = msoButtonSetNone
.Mode = msoModeModeless
.Callback = "PrintingUsingAssistant"
.Heading = "Вывести на печать ..."
.Labels(1).Text = "Выделенный диапазон"
.Labels(2).Text = "Выделенные листы"
.Labels(3).Text = "Всю книгу"
.Show
End With
.Animation = msoAnimationPrinting
End With
End Sub
Private Sub PrintingUsingAssistant(bln As Balloon, lbtn As Long, lPriv As Long)
bln.Close: Assistant.Visible = False
Select Case lbtn
Case 1: MsgBox "Выделенный диапазон"
Case 2: MsgBox "Выделенные листы"
Case 3: MsgBox "Всю книгу"
End Select
End Sub
| ThisWorkbook.FollowHyperlink Address:="http://www.msoffice.nm.ru"
Примечание : Необходимо обязательно указать протокол, в
данном примере это http:// в противном случае возникнет ошибка,
кроме того, данную инструкцию желательно выполнять,
если Вы подключены к сети.
| ThisWorkbook.FollowHyperlink Address:="mailto:excel_vs_calc@mail.com" ThisWorkbook.FollowHyperlink _ Address:="mailto:excel_vs_calc@mail.com?subject=Excel"
| Application.Dialogs(xlDialogSendMail).Show Application.Dialogs(xlDialogSendMail).Show _ Arg1:="excel_vs_calc@mail.com", Arg2:="Calc"
Примечание : Второй вариант позволяет отправить активную рабочую книгу
в виде вложения (attachment) и он может быть применён в MS Excel 95
| Для того, чтобы создать своё собственное сообщение о ошибке (без создания нестандартных диалоговых окон имитирующих стандартное окно) достаточно использовать метод Raise об'екта Err.
Err.Raise Number:=13, Description:="Не нужно вводить текст в столбец с датами"
Если же Вы хотите изменить, например, текст в стандартном сообщении, то это можно
осуществить также с помощью вышеупомянутого метода, например :
| Private Sub ErrorRaise()
On Error GoTo ErrHandler
iDivisor# = Application.InputBox(Title:="", Default:=0, _
Prompt:="Введите любое число, отличное от нуля", Type:=1)
iResult# = 100 / iDivisor#: Exit Sub
ErrHandler:
Select Case Err.Number
Case 11: Err.Raise Number:=Err.Number, _
Description:="Ну сколько можно повторять ... " & _
"что в таких случаях, перед делением, нужно проверять делитель на 0"
Case Else: Err.Raise Number:=Err.Number, _
Description:="Чудны дела твои ..."
End Select
End Sub
| Для того, чтобы в активном окне программно зафиксировать области, причём без выделения ячеек, можно использовать функцию ФИКСИРОВАТЬ.ПОДОКНА (макроязык Excel4.0)
Например, если мы хотим зафиксировать верхние три строки окна, то это может выглядить так : ExecuteExcel4Macro "FREEZE.PANES(TRUE,,3)"
Важно : Имейте ввиду, что верхние три строки вовсе не
обязательно будут строками "1:3" Например, если после прокрутки,
на экране строки начинаются с 50-й, то макрос зафиксирует строки
"50:53" и если Вас это не устраивает, то перед фиксацией можно
осуществить прокрутку к первой строке, например так :
| ExecuteExcel4Macro "VSCROLL(0)" ExecuteExcel4Macro "FREEZE.PANES(TRUE,,3)"
Примечание : Вместо макрофунции | ВПРОКРУТКА
допускается применение свойства .ScrollRow об'екта
Window, т.е.
ActiveWindow.ScrollRow = 1
| Для того, чтобы запретить пользователю изменять размеры активного окна, достаточно выполнить следующий код : ActiveWindow.EnableResize = False
Комментарий : Подобный запрет действует только для пользователя,
программно же изменить размеры активного окна, можно.
| Для того, чтобы свернуть/развернуть окно приложения, достаточно использовать свойство WindowState об'екта
Application.
Application.WindowState = xlMinimized 'Здесь должен быть код Вашей программы. Application.WindowState = xlMaximized
| Для того, чтобы на время выполнение макроса скрыть приложение, достаточно использовать свойство Visible об'екта
Application.
Application.Visible = False 'Здесь должен быть код Вашей программы. Application.Visible = True
| Application.Quit
Комментарий :
| Workbook_BeforeSave, Workbook_BeforeClose, которые могут отменить
сохранение и закрытие книги.
Стало быть, если Вы хотите избежать всех вышеперечисленных "неприятностей", то имеет смысл недопустить вызов и выполнение этих событий [FAQ157], а также отключить вывод стандартных сообщений [FAQ16] With Application
.EnableEvents = False
.DisplayAlerts = False
Dim iBook As Workbook '
For Each iBook In .Workbooks
iBook.Save
Next
.Quit
End With
Если же Вам необходимо закрыть Excel, причём без сохранения изменений, то :
| With Application
.EnableEvents = False
.DisplayAlerts = False
.Quit
End With
| If Application.UserControl = True Then MsgBox "Вы запустили программу вручную", , "" Else MsgBox "Программно : CreateObject/GetObject", , "" End If
| Dim XLApp As Excel.Application 'Object
Set XLApp = CreateObject("Excel.Application")
If XLApp.UserControl = True Then
MsgBox "Скорее всего, вручную ...", , ""
Else
MsgBox "Программно, т.е. CreateObject/GetObject", , "": XLApp.Quit
End If
Примечание : Под программным, конечно же, подразумевается получение
доступа к об'екту только с помощью функций CreateObject/GetObject
| iDecimalSeparator = Application.International(xlDecimalSeparator)
Актуально для MS Excel XP
| В этой версии появилась возможность использовать разделитель целой и дробной части, отличный от системного, и в таких случаях свойство International будет возвращать не системный разделитель, а тот, что используется в MS Excel. iDateSeparator = Application.International(xlDateSeparator)
| iTimeSeparator = Application.International(xlTimeSeparator)
| Date = #9/8/04# ' "08.09.04" |
Пример того, как можно перевести "часы" на день вперед/назад. Один день,
конечно же, используется только в качестве примера.
| Private Sub SetSystemDate()
Date = Date + 1 '-1
'Date = DateAdd("d", 1, Date) 'DateAdd("d", -1, Date)
End Sub
| Time = #7:00:00 AM# ' "07:00:00"
| Time = #7:00:00 PM# ' "19:00:00"
Пример того, как можно перевести "часы" на три часа вперед/назад.
| Private Sub SetSystemTime()
Time = Time + (1 / 24 * 3) '- (1 / 24 * 3)
'Time = DateAdd("h", 3, Now) 'DateAdd("h", -3, Now)
'и т.д.
CreateObject("Shell.Application").SetTime 'просто демонстрация
End Sub
|
Актуально для MS Excel 97, 2000, XP
Private Sub GetFonts()
With Application.CommandBars("Formatting")
If Not .FindControl(Id:=1728) Is Nothing Then
With .FindControl(Id:=1728)
ReDim iFonts$(1 To .ListCount)
For iCount% = 1 To .ListCount
iFonts$(iCount%) = .List(iCount%)
Next
End With
Else
MsgBox "Вы удалили контрол, который содержит список всех шрифтов"
End If
End With
End Sub
|
Актуально для MS Excel 97, 2000, XP
Для того, чтобы сохранить все .jpg или .gif файлы, которые могут находиться в указанной(нужной) папке, в формате .bmp, можно создать пользовательскую форму, разместить на ней элемент управления Рисунок - Image1 и скрыть этот элемент управления установив значение Visible = False. Затем, по мере необходимости, использовать свойство Picture, вкупе с функцией
LoadPicture и инструкцией SavePicture (см. пример)
Private Sub ConvertJPGtoBMP_Click()
With Application.FileSearch
.NewSearch
.SearchSubFolders = False 'True
.LookIn = ThisWorkbook.Path 'Укажите свою папку
.FileName = "*.jpg" '"*.jpeg" игнорируются 'XL97 - ".jpg"
.Execute
For iCount& = 1 To .FoundFiles.Count
iFileName$ = .FoundFiles(iCount&)
Me.Image1.Picture = LoadPicture(FileName:=iFileName$) ':DoEvents
'SetAttr iFileName$, vbNormal: Kill iFileName$
'Если необходимо удалить исходные файлы
Mid(iFileName$, Len(iFileName$) - 2, 3) = "bmp"
SavePicture Picture:=Me.Image1.Picture, FileName:=iFileName$
Next
End With
End Sub
Комментарий : Если работы с диалоговым окном не предполагается, то просто
используйте инструкцию | SavePicture и функцию LoadPicture
(см. ниже)
Private Sub ConvertJPGtoBMP()
iPath$ = ThisWorkbook.Path & "\" 'Укажите свою папку
iFileName$ = Dir(iPath$ & "*.jpg") '"*.jpeg" игнорируются
Do While iFileName$ <> ""
SavePicture LoadPicture(iPath$ & iFileName$), _
iPath$ & Left(iFileName$, Len(iFileName$) - 3) & "bmp"
iFileName$ = Dir
Loop
End Sub
| Вариант I. iFileName = "C:\Windows\Media\LogOff.wav" iMacroFunction = "SOUND.PLAY(,""" & iFileName & """)" ExecuteExcel4Macro iMacroFunction
Если же необходимо программно определить был или нет воспроизведён звук, то
для этого можно воспользовать функцией IsSoundPlay, вызов которой приведён ниже.
| Private Sub Test()
iFileName$ = "C:\Windows\Media\LogOff.wav"
If IsSoundPlay(iFileName$) = True Then
MsgBox "Мы только что воспроизвели звук", , ""
Else
MsgBox "К сожалению, ничего не вышло", , ""
End If
End Sub
Private Function IsSoundPlay(iFileName$) As Boolean
iMacroFunction$ = "SOUND.PLAY(,""" & iFileName$ & """)"
IsSoundPlay = Not IsError(ExecuteExcel4Macro(iMacroFunction$))
End Function
Вариант II.
Если на компьютере установлен Проигрыватель Windows Media Player, то,
в отличии от предыдущего варианта, Вы сможете прослушивать не только файлы .wav,
но и более популярный формат у "меломанов", а именно .mp3
|
CreateObject("MediaPlayer.MediaPlayer.1").Open "C:\Windows\Media\Tada.wav" 'Tada.wma
Допустим также и такой способ воспроизведения :
| With CreateObject("MediaPlayer.MediaPlayer.1")
.AutoStart = True
.FileName = "C:\Windows\Media\Music.mp3"
.Play
End With
Обратите внимание на то, что Вы можете использовать и другие возможности
этого проигрывателя, к примеру, узнать причину отсутствия звука :
| With CreateObject("MediaPlayer.MediaPlayer.1")
.AutoStart = True
.Open "C:\Windows\Media\Music.mp3"
If .HasError = True Then MsgBox .ErrorDescription, , ""
End With
Вариант III. Продолжение следует ...
|
iComputerName = Environ("ComputerName")
Важно : Подобная возможность определения имени компьютера впервые
появилась только в Windows 2000 и если Вы являетесь обладателем
более ранней версии, то используйте другие способы :
FAQ303,
FAQ333,
FAQ506
|
iUserName = Environ("UserName")
Важно : Подобная возможность определения имени компьютера впервые
появилась только в Windows 2000 и если Вы являетесь обладателем
более ранней версии, то используйте другие способы :
FAQ334,
FAQ335,
FAQ506
| Для того, чтобы получить значение переменной среды, можно воспользоваться функцией Environ(), например
FAQ145,
FAQ504,
FAQ502, FAQ503
Для получения же списка всех доступных переменных среды Вашей операционной системы, можно воспользоваться нижеопубликованным макросом : Private Sub CreateListEnvironVariables()
Workbooks.Add xlWBATWorksheet '[2]
Application.ScreenUpdating = False '[1]
iCount% = 2: iVariable$ = Environ(1)
Do Until iVariable$ = ""
iPosition% = InStr(iVariable$, "=")
Cells(iCount%, 1) = Mid(iVariable$, 1, iPosition% - 1)
Cells(iCount%, 2) = Mid(iVariable$, iPosition% + 1)
iVariable$ = Environ(iCount%)
iCount% = iCount% + 1
Loop
With Cells(1).Resize(, 2) 'Range("A1:B1")
.Value = Array("Имя", "Значение")
.Font.Bold = True
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = False
End Sub
| Для того, чтобы создать новый или изменить уже существующий раздел и запись в реестре Windows, можно использовать инструкцию SaveSetting.
SaveSetting AppName:="UserForm1", Section:="TextBox1", _ Key:="Value", Setting:="Введите номер заказа" 'Or SaveSetting "UserForm1", "TextBox1", "Tag", "123" SaveSetting "UserForm1", "Label1", "Caption", "Номер заказа:"
Комментарий : Данная инструкция позволяет работать только с одним
разделом реестра, а именно :
| HKEY_USERS\...\VB and VBA Program Settings\... 'Win98/WinMe HKEY_CURRENT_USER\...\VB and VBA Program Settings\... 'Win2000/WinXP Для того, чтобы получить значение нужной записи из раздела в реестре Windows, можно воспользоваться функцией GetSetting.
iSetting = GetSetting(AppName:="UserForm1", Section:="TextBox1", Key:="Value") 'Or
'iSetting = GetSetting("UserForm1", "TextBox1", "Value")
Примечание : Если искомое значение определено не будет, например, в случае
отсутствия указанного приложения, раздела, записи, то данная функция возвращает
значение необязательного именованного аргумента Default. Поскольку, в данном примере,
этот аргумент не используется, функция возвращает пустую строку, однако, это довольно
легко изменить.
|
iSetting = GetSetting(AppName:="UserForm1", _
Section:="TextBox2", Key:="Value", Default:="Текст, по умолчанию") 'Or
'iSetting = GetSetting("UserForm1", "TextBox2", "Value", "Текст, по умолчанию")
Комментарий : Данная функция позволяет работать только с одним
разделом реестра, а именно :
| HKEY_USERS\...\VB and VBA Program Settings\... 'Win98/WinMe HKEY_CURRENT_USER\...\VB and VBA Program Settings\... 'Win2000/WinXP Для того, чтобы получить список всех значений и записей указанного раздела, достаточно воспользоваться функцией GetAllSettings. Обратите внимание
на то, что эта функция возвращает двумерный массив (тип Variant), первый столбец
которого, содержит имена всех записей указанного раздела, а второй столбец содержит
значения всех записей. Однако, если Вы попытаетесь получить список записей и их
значений, для несуществующей ветки или раздела, то тогда функция GetAllSettings
возвратит значение Empty (Пусто)
iAllSettings = GetAllSettings(AppName:="UserForm1", Section:="TextBox1") 'Or
'iAllSettings = GetAllSettings("UserForm1", "TextBox1")
If Not IsEmpty(iAllSettings) Then
For iCount = 0 To UBound(iAllSettings)
MsgBox _
"Имя записи : " & iAllSettings(iCount, 0) & vbCrLf & _
"Значение : " & iAllSettings(iCount, 1)
Next
End If
Комментарий : Данная функция также позволяет работать только с одним
разделом реестра :
| HKEY_USERS\...\VB and VBA Program Settings\... 'Win98/WinMe HKEY_CURRENT_USER\...\VB and VBA Program Settings\... 'Win2000/WinXP Для того, чтобы удалить ненужную запись или раздел в реестре Windows, можно воспользоваться инструкцией DeleteSetting.
DeleteSetting AppName:="UserForm1", Section:="TextBox1", Key:="Value" 'DeleteSetting "UserForm1", "TextBox1", "Value" DeleteSetting AppName:="UserForm1", Section:="TextBox1" 'DeleteSetting "UserForm1", "TextBox1"
Комментарий : И эта инструкция, конечно же, позволяет удалять
ненужные записи только в одном разделе реестра :
| HKEY_USERS\...\VB and VBA Program Settings\... 'Win98/WinMe HKEY_CURRENT_USER\...\VB and VBA Program Settings\... 'Win2000/WinXP
|
Воспроизведение любых опубликованных здесь материалов возможно только с
письменного разрешения автора :