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

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

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

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

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

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

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

With Application
     .EnableEvents = False
     .DisplayAlerts = False
     Dim iBook As Workbook '
     For Each iBook In .Workbooks
         iBook.Save
     Next
     .Quit
End With

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

Private Sub SetSystemDate()
    Date = Date + 1 '-1
    'Date = DateAdd("d", 1, Date) 'DateAdd("d", -1, Date)
End Sub

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

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

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

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