Option Explicit

'*******************************************************

Public Sub CreateObjectGenerically()

' Late binding, all bindings at run time.

' Does not use an object library reference.

Dim Wrd As Object

Dim doc As Object

Set Wrd = CreateObject("Word.application")

Wrd.Visible = True

Set doc = Wrd.Documents.Add

doc.Content = "To be or not to be"

doc.Save

End Sub

'*******************************************************

Public Sub CreateObjectSpecifically()

' Early binding, some bindings done at complile time,

' some at run time.

' Requires an object library reference

' Automation server not running

Dim Wrd As Word.Application

Set Wrd = CreateObject("Word.Application")

End Sub

'*******************************************************

Public Sub OpenWordMakeDocument()

'Very early binding, all bindings done at compile time.

' This is the preferred approach for programming Word from

' within another application since it is the most efficient.

' Requires an object library reference.

Dim Wrd As Word.Application, doc As Word.Document

Set Wrd = New Word.Application

Wrd.Visible = True

Set doc = Wrd.Documents.Add

doc.Content = "To be or not to be"

doc.Save

Wrd.Quit

End Sub

'*******************************************************

Private Sub ExampleListMacro()

Dim cbctl As CommandBarControl

' Find the list box control

Set cbctl = CommandBars("Toolbar Example"). _

FindControl(Tag:="ComposerList")

If Not cbctl Is Nothing Then

MsgBox "You selected " & cbctl.List(cbctl.ListIndex), , "Toolbar Example"

End If

End Sub

'*******************************************************

Public Sub JustInTime()

MsgBox "On Time", , "The OnTime Method"

End Sub

'*******************************************************

Public Sub DoingTime()

Application.OnTime Now + TimeValue("00:04:02"), "JustInTime"

End Sub

'*******************************************************

Public Sub GotoPrintPreview()

Application.PrintPreview = False

End Sub

'*******************************************************

Public Sub ShowTasks()

Dim t As Task

For Each t In Tasks

Debug.Print t.Name

End Sub

'*******************************************************

Public Sub ShowCommands()

Application.ListCommands (True)

'False will show only commands with customized key or menu assignments

End Sub

'*******************************************************

Public Sub ShowPrinter()

MsgBox Application.ActivePrinter

End Sub

'*******************************************************

Public Sub ListKeyBindings()

Dim kb As KeyBinding

Dim s As String

Dim tbl As Table

' Check active document for text

' and warn user

If ActiveDocument.Content <> vbCr Then

If MsgBox("Active doc has content. Proceed?", _

vbQuestion + vbYesNo) = vbNo Then Exit Sub

End If

' Print Heading

Selection.InsertAfter KeyBindings.Count & _

" key bindings in context: " & CustomizationContext _

& vbCr & vbCr

' Collapse selection to end of document

Selection.Collapse wdCollapseEnd

' Insert start of table bookmark

ActiveDocument.Bookmarks.Add "StartOfTable"

' Print table heading

Selection.InsertAfter "KeyString" & vbTab & _

"KeyCategory" & vbTab & "Command" & vbTab _

& "KeyCode" & vbTab & "KeyCode2" _

& vbTab & "CommandParameter" & vbCr

' Starty the For loop, printing key binding data

Selection.Collapse wdCollapseEnd

For Each kb In KeyBindings

s = kb.KeyString & vbTab & kb.KeyCategory _

& vbTab & kb.Command & vbTab & kb.KeyCode _

& vbTab & kb.KeyCode2 & vbTab _

& kb.CommandParameter & vbCr

Selection.InsertAfter s

Selection.Collapse wdCollapseEnd

' Collapse selection to end of document

Selection.Collapse wdCollapseEnd

' Insert end of table bookmark

ActiveDocument.Bookmarks.Add "EndOfTable"

' Select text between bookmarks

ActiveDocument.Bookmarks("StartOfTable").Select

With Selection

.ExtendMode = True

.GoTo wdGoToBookmark, , , "EndOfTable"

.ExtendMode = False

End With

Set tbl = _

Selection.ConvertToTable(Separator:=wdSeparateByTabs)

tbl.Columns.AutoFit

Selection.Collapse wdCollapseEnd

End Sub

'*******************************************************

Public Sub ShowKeyBindings()

Dim kb As KeyBinding

' Pring heading

Selection.InsertAfter KeyBindings.Count & _

" key bindings in context: " & CustomizationContext & vbCr

' Start the For loop, printing KeyString and Command

Selection.Collapse wdCollapseEnd

For Each kb In KeyBindings

Selection.InsertBefore kb.KeyString & vbTab & _

kb.Command & " (" & kb.CommandParameter & ")" & vbCr

Selection.Collapse wdCollapseEnd

End Sub

'*******************************************************

Public Sub ShowDialogBox()

Dialogs(wdDialogEditFind).Show

End Sub

'*******************************************************

Public Sub ShowBuiltInDocumentProperties()

Dim d As DocumentProperty

On Error Resume Next

For Each d In ActiveDocument.BuiltInDocumentProperties

Debug.Print d.Name & " - " & d.Value

End Sub

'*******************************************************

Public Sub PrintStatistics()

' Prints statistics on the active document

' to a table in a new document

Dim dial As Dialog, tbl As Table, sName As String, sProp As String

' Get this now, before the active document changes

Set dial = Dialogs(wdDialogDocumentStatistics)

' Create new document

Documents.Add

' Insert document heading

Selection.InsertAfter "Document Statistics. Created " & _

Now() & vbCr & vbCr

' Give it a nice style

Selection.Style = wdStyleHeading1

Selection.Collapse wdCollapseEnd

' Create a table with 2 columns

Set tbl = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=1, _

numcolumns:=2)

' Print the document statistics to the table

' adding rows as we go

tbl.Cell(1, 1).Select

Selection.Text = "File Name"

Selection.Font.Bold = True

Selection.Move wdCell

Selection.Text = dial.FileName

' DoNextRow adds a new row and

' fills it with the next piece of data

DoNextRow tbl, "Directory", dial.directory

DoNextRow tbl, "Template", dial.Template

DoNextRow tbl, "Title", dial.Title

DoNextRow tbl, "Created", dial.created

DoNextRow tbl, "LastSaved", dial.lastsaved

DoNextRow tbl, "LastSavedBy", dial.lastsavedby

DoNextRow tbl, "Revision", dial.Revision

DoNextRow tbl, "Time", dial.Time

DoNextRow tbl, "Printed", dial.printed

DoNextRow tbl, "Pages", dial.pages

DoNextRow tbl, "Words", dial.Words

DoNextRow tbl, "Characters", dial.Characters

DoNextRow tbl, "Paragraphs", dial.Paragraphs

DoNextRow tbl, "Lines", dial.lines

DoNextRow tbl, "FileSize", dial.filesize

tbl.Columns.AutoFit

End Sub

'*******************************************************

Private Sub DoNextRow(uTable As Table, _

sName As String, sProp As String)

uTable.Rows.Add

Selection.Move wdCell

Selection.Text = sName

Selection.Font.Bold = True

Selection.Move wdCell

Selection.Text = sProp

End Sub

'*******************************************************

Public Sub StartWordWithGetObject()

' Uses a currently running version of the

' Word server

Dim Wrd As Word.Application

On Error Resume Next

' Try to get reference to running Word

Set Wrd = GetObject(, "Word.Application")

If Err.Number = 429 Then

Set Wrd = CreateObject("Word.Application")

ElseIf Err.Number <> 0 Then

MsgBox "Error: " & Err.Description

Exit Sub

End If

End Sub

'*******************************************************

Public Sub UpdateDialogBoxMethod()

' Whenever it is necessary to rely on current information

' from a variable of type Dialog, it is important to first call

' the Update method

Dim dial As Dialog

Set dial = Dialogs(wdDialogFormatFont)

Selection.Font.Name = "Arial"

dial.Update

dial.Show

End Sub

'*******************************************************

Public Sub ExecuteDialogBoxMethod()

' If the user makes any changes in a dialog box while it

' is displayed, these changes will not be applied unless the

' Execute method is employed.

Dim dial As Dialog

Set dial = Dialogs(wdDialogFormatFont)

dial.Display

If dial.Font = "Tahoma" Then

If MsgBox("You have selected Tahoma. Are you sure?", _

vbYesNo) = vbYes Then

dial.Execute

End If

Else

dial.Execute

End If

End Sub

'*******************************************************

Public Sub ShowForm()

'Shortcut Alt+s

frmSelectAnItem.Show

End Sub

'*******************************************************

Public Sub GetIds()

' Getting the Names and IDs of Command Bar Controls

Dim fr As Integer, cbar As CommandBar, ctl As CommandBarControl

Dim i As Integer

Const maxid = 3000

fr = FreeFile

Open "c:\word\ids.txt" For Output As #fr

' Create temporary toolbar

Set cbar = CommandBars.Add("temporary", msoBarTop, False, True)

For i = 1 To maxid

On Error Resume Next ' skip if cannot add

cbar.Controls.Add ID:=i

On Error GoTo 0

For Each ctl In cbar.Controls

intPass = intPass + 1

Print #fr, ctl.Caption & " (" & ctl.ID & ")"

cbar.Delete

Close #fr

End Sub

'*******************************************************

Public Sub CreatePopup()

Dim cbpop As CommandBarControl

Dim cbctl As CommandBarControl

Dim cbsub As CommandBarControl

' Create a popup control on the main menubar

Set cbpop = CommandBars("Menu bar").Controls.Add(Type:=msoControlPopup)

cbpop.Caption = "&Custom"

cbpop.Visible = True

' Add a menu item

Set cbctl = cbpop.Controls.Add(Type:=msoControlButton)

cbctl.Visible = True

' Next is required for caption

cbctl.Style = msoButtonCaption

cbctl.Caption = "MenuItem&1"

' Action to perform

cbctl.OnAction = "ExampleMacro1"

' Add a menu item to the submenu

Set cbsub = cbpop.Controls.Add(Type:=msoControlPopup)

cbsub.Visible = True

cbsub.Caption = "&SubMenuItem1"

' Add a menu item to the submenu

Set cbctl = cbsub.Controls.Add(Type:=msoControlButton)

cbctl.Visible = True

' Next is required for caption

cbctl.Style = msoButtonCaption

cbctl.Caption = "SubMenuItem&2"

' Action to perform

cbctl.OnAction = "ExampleMacro2"

End Sub

'*******************************************************

Sub ExampleMacro()

MsgBox "Custom button pressed", , ""

End Sub

'*******************************************************

Public Sub ExampleMacro1()

MsgBox "Menu item 1 pressed", , ""

End Sub

'*******************************************************

Public Sub ExampleMacro2()

MsgBox "Menu item 2 pressed", , ""

End Sub

'*******************************************************

Public Sub CreateToolbar()

Dim cbar As CommandBar, cbctl As CommandBarControl

' Create a floating toolbar

Set cbar = CommandBars.Add(Name:="Toolbar Example", _

Position:=msoBarFloating)

cbar.Visible = True

' Add a custom button control to execut a macro

Set cbctl = cbar.Controls.Add(Type:=msoControlButton)

cbctl.Visible = True

cbctl.Style = msoButtonCaption

cbctl.Caption = "CustomButton"

' Run the following macro

cbctl.OnAction = "ExampleMacro"

' Add built-in Find... control

Set cbctl = cbar.Controls.Add(ID:=141)

' Icon for button

cbctl.FaceId = 141

cbctl.Visible = True

' Add built-in spell checking button

Set cbctl = cbar.Controls.Add(ID:=2)

cbctl.FaceId = 2

cbctl.Visible = True

' Add a list box

Set cbctl = cbar.Controls.Add(Type:=msoControlDropdown)

' Add a tag so macro can find it

cbctl.Tag = "ComposerList"

cbctl.Visible = True

cbctl.Caption = "ListCaption"

' Set list properties of the list box

With cbctl

.AddItem "Chopin", 1

.AddItem "Mozart", 2

.AddItem "Bach", 3

.DropDownLines = 0

.DropDownWidth = 75

' select nothing to start

.ListIndex = 0

End With

' Set macro to execute when an item

' is selected

cbctl.OnAction = "ExampleListMacro"

End Sub

'*******************************************************

Public Sub ZOrderExample()

Dim shSquare As Shape, shRect As Shape, rng As Range

Dim Msg As String

Set rng = Selection.Range

Set shSquare = ActiveDocument.Shapes.AddShape _

(msoShapeRectangle, 0, 0, 72, 72, rng)

Set shRect = ActiveDocument.Shapes.AddShape _

(msoShapeRectangle, 0, 0, 144, 36, rng)

' Shade each shape

shSquare.Fill.ForeColor.RGB = RGB(196, 196, 196)

shRect.Fill.ForeColor.RGB = RGB(216, 216, 216)

shSquare.ZOrder msoSendBehindText

shRect.ZOrder msoSendBehindText

shSquare.ZOrder msoSendToBack

MsgBox ""

shSquare.ZOrder msoBringInFrontOfText

End Sub

'*******************************************************

Public Sub CreatingInLineShapes()

Dim para As Paragraph

For Each para In ActiveDocument.Paragraphs

If para.Style = "Heading 2" Then

ActiveDocument.InlineShapes.AddPicture _

"c:\word\atten.bmp", , , para.Range

End If

End Sub

'*******************************************************

Public Sub DeleteInLineShapes()

Dim shp As InlineShape

For Each shp In ThisDocument.InlineShapes

shp.Delete

End Sub

'*******************************************************

Public Sub DisplayAutoShapes()

Dim sh As Shape, rng As Range, i As Integer

Set rng = Selection.Range

Set sh = ActiveDocument.Shapes.AddShape(1, 50, 50, 72, 72, rng)

For i = 1 To 137

sh.AutoShapeType = i

sh.Visible = True

sh.TextFrame.TextRange = sh.AutoShapeType

sh.TextFrame.TextRange.Borders.OutsideLineStyle = _

i Mod 24 + 1 ' There are 24 border styles.

sh.Fill.ForeColor.RGB = RGB(230, 230, 230)

Delay 0.5

Next i

End Sub

'*******************************************************

Private Sub Delay(rTime As Single)

' Delay rTime seconds (min=.01, max=300)

Dim OldTime As Variant

' Safety net

If rTime < 0.01 Or rTime = 1 Then OldTime = Timer

DoEvents ' Yield to the operating system

Loop Until Timer - OldTime >= rTime

End Sub

'*******************************************************

Public Sub DrawSine2()

' Dampened sine wave of small start

Const pi As Double = 3.1416

Dim i As Integer, x As Single, y As Single

Dim rng As Range ' For starting point

Dim n As Single ' Cycle length in inches

Dim k As Integer ' k stars

Dim ScaleY As Single ' Vertical scaling

Dim sSize As Single ' Star size

Dim sDamp1 As Single ' Dampening factor

Dim sDamp2 As Single ' Dampening factor

Dim cCycles As Integer ' Number of cycles

Dim sh As Shape

cCycles = 3: sDamp1 = 1: sDamp2 = 0.2: n = 2: k = 20

ScaleY = 0.5: sSize = InchesToPoints(0.1)

' Start at insertion point

Set rng = Selection.Range

' Looop for first curve with phase shift

For i = 1 To cCycles * k

x = n * i / k

y = ScaleY * Sin((2 * pi * i) / k + n) * _

(sDamp1 / (x + sDamp2))

y = InchesToPoints(y)

x = InchesToPoints(x)

Set sh = ActiveDocument.Shapes.AddShape _

(msoShape5pointStar, x, y, sSize, sSize, rng)

sh.Fill.ForeColor.RGB = RGB(192, 192, 192) ' 25% gray

sh.Fill.Visible = msoTrue

End Sub

'*******************************************************

Public Sub DrawName()

' Random placement of large stars with name

Const pi As Double = 3.1416

Dim i As Integer, x As Single, y As Single, z As Single

Dim rng As Range ' For starting point

Dim n As Single ' Cycle length in inches

Dim k As Integer ' k stars

Dim sSize As Single ' Star size

Dim sh As Shape

Dim sName As String ' Name to display

sName = InputBox("Text to Display", "The Stars Will Shine")

n = 5

k = Len(sName)

sSize = InchesToPoints(0.5)

' Start at insertion point

Set rng = Selection.Range

Randomize Timer

z = 0#

' Loop for first curve with phase shift

For i = 1 To k

If Mid(sName, i, 1) <> " " Then

x = n * i / k

x = InchesToPoints(x)

' Get random 0 or 1. Go up or down accordingly.

If Int(2 * Rnd) = 0 Then

z = z + 0.2

Else

z = z - 0.2

End If

y = InchesToPoints(z)

Set sh = ActiveDocument.Shapes.AddShape _

(msoShape5pointStar, x, y, sSize, sSize, rng)

' Add shading

sh.Fill.ForeColor.RGB = RGB(230, 230, 230)

sh.Fill.Visible = msoTrue

' Add text

sh.TextFrame.TextRange.Text = Mid(sName, i, 1)

sh.TextFrame.TextRange.Font.Size = 10

sh.TextFrame.TextRange.Font.Name = "Arial"

sh.TextFrame.TextRange.Font.Bold = True

End If

End Sub

'*******************************************************

Public Sub DrawRose()

' Draw rose of small stars

Const pi As Double = 3.1416

Dim t As Single, i As Integer, x As Single, y As Single

Dim rng As Range ' For starting point

Dim n As Single ' Number of stars per cycle

Dim k As Integer ' Number of cycles

Dim sSize As Single ' Star size

Dim r As Integer ' Half the number of petals

Dim sh As Shape

Dim Pass As Integer, xPlus As Integer

For Pass = 1 To 2

If Pass = 1 Then

' for a 3-petal rose

r = 3: k = 1: xPlus = 2: n = 100 ' Number of stars

Else

' for a 4-petal rose

r = 2: k = 2: xPlus = 4: n = 150 'Number of stars

End If

sSize = InchesToPoints(0.03)

' Start curve at insertion point

Set rng = Selection.Range

For i = 1 To n

t = k * pi * i / n

x = Sin(r * t) * Sin(t) + xPlus

y = Sin(r * t) * Cos(t) + 1

x = InchesToPoints(x)

y = InchesToPoints(y)

Set sh = ActiveDocument.Shapes.AddShape _

(msoShape5pointStar, x, y, sSize, sSize, rng)

End Sub

'*******************************************************

Public Sub DrawSpiral()

' Draw a spiral of small stars

Const pi As Double = 3.1416

Dim t As Single, i As Integer, z As Single, x As Single, y As Single

Dim rng As Range ' For starting point

Dim n As Single ' Number of stars per cycle

Dim k As Integer ' Length of spiral

Dim sSize As Single ' Star size

Dim sh As Shape

n = 80: k = 8: sSize = InchesToPoints(0.03)

' Start curve at insertion point

Set rng = Selection.Range

For i = 5 To n

t = k * pi * i / n

x = 2 * (1 / t) * Sin(t) + 2

y = 2 * (1 / t) * Cos(t)

x = InchesToPoints(x)

y = InchesToPoints(y)

Set sh = ActiveDocument.Shapes.AddShape _

(msoShape5pointStar, x, y, sSize, sSize, rng)

z = 256 * i / n

sh.Line.ForeColor.RGB = RGB(z, z, z) ' vary line color

sh.Line.Visible = msoTrue

End Sub

'*******************************************************

Public Sub aaDrawHypocycloid()

' Draw a hypocycloid of small stars

Const pi As Double = 3.1416

Dim t As Single, i As Integer, x As Single, y As Single

Dim rng As Range ' For starting point

Dim n As Single, k As Integer

Dim sSize As Single ' Star size

Dim r As Integer, r0 As Integer, R1 As Integer

Dim sh As Shape, sc As Single

r = 1

r0 = 3 * r

R1 = 8 * r

n = 400: k = 4: sc = 0.1: sSize = InchesToPoints(0.03)

' Start curve at insertion point

Set rng = Selection.Range

For i = 1 To n

t = k * pi * i / n

x = (R1 - r) * Cos(t) + r0 * Cos(t * (R1 - r) / r) + 4

y = (R1 - r) * Sin(t) + r0 * Sin(t * (R1 - r) / r)

x = sc * x

y = sc * y

x = InchesToPoints(x)

y = InchesToPoints(y)

Set sh = ActiveDocument.Shapes.AddShape _

(msoShape5pointStar, x, y, sSize, sSize, rng)

End Sub