| Following is a word macro ex Word V2.x that creates watermarks. Only
tricky thing is if you have applied a watermark and then wish to delete
it you need to look under options, enable field code display, view the
header and explicitly delete the field contents.
Owen.
Sub MAIN
If SelInfo(27) Then
MsgBox "Command not available in a macro window"
Goto bye
End If
fViewFieldCodes = ViewFieldCodes()
fViewOutline = ViewOutline()
fViewPage = ViewPage()
ViewNormal
REM the following lists would be used with popup box
Dim mptextfont$(2)
mptextfont$(0) = "Courier"
mptextfont$(1) = "Helvetica"
mptextfont$(2) = "Times-Roman"
maxsize = 127
minsize = 4
Begin Dialog UserDialog 493, 270
Text 18, 4, 40, 13, "&Text:"
TextBox 18, 18, 289, 18, .usertext
Text 18, 43, 40, 13, "&Font:"
ComboBox 18, 60, 147, 61, mptextfont$(), .userfont
Text 178, 43, 100, 13, "&Size: (points)"
TextBox 178, 60, 129, 18, .usersize
Text 178, 88, 71, 13, "Rotatio&n:"
TextBox 178, 103, 129, 18, .userrotate
GroupBox 338, 74, 132, 49, "Page"
OptionGroup .userpage
OptionButton 349, 87, 48, 16, "&All"
OptionButton 349, 105, 105, 16, "First &Page"
GroupBox 18, 128, 148, 100, "Format:"
CheckBox 30, 142, 83, 16, "All &Cap", .usercap
CheckBox 30, 164, 63, 16, "Bol&d", .userbold
CheckBox 30, 186, 67, 16, "&Italic", .useritalic
CheckBox 30, 208, 91, 16, "S&hading", .usershade
GroupBox 178, 128, 293, 100, "Position:"
GroupBox 193, 146, 119, 71, "Vertical"
OptionGroup .userver
OptionButton 203, 158, 59, 16, "T&op"
OptionButton 203, 177, 79, 16, "&Middle"
OptionButton 203, 195, 81, 16, "&Bottom"
GroupBox 338, 146, 117, 70, "Horizontal"
OptionGroup .userhor
OptionButton 348, 159, 59, 16, "&Left"
OptionButton 348, 178, 79, 16, "C&enter"
OptionButton 348, 195, 69, 16, "&Right"
OKButton 338, 11, 130, 21
CancelButton 338, 39, 130, 21
Text 18, 244, 401, 13, "A PostScript printer must be used to print
the results."
End Dialog
REM message for size too big
msg$ = "Font size need to be between" + Str$(minsize) + " and " +
Str$(maxsize) + " . Do you want to make any changes?"
msg1$ = "Degree of rotation needs to be between 0 and 90 "
Dim dlg As UserDialog
REM set default
dlg.userfont = "Times-Roman"
dlg.usershade = 1
dlg.usercap = 1
dlg.userbold = 1
dlg.usersize = "90"
dlg.userrotate = "45"
dlg.userver = 1
dlg.userhor = 1
prompt: On Error Goto bye
Dialog dlg
On Error Goto 0
REM get cur values & checking parameters
usize = Int(Val(dlg.usersize))
urotate = Int(Val(dlg.userrotate))
ufont$ = dlg.userfont
If dlg.usercap Then
utext$ = UCase$(dlg.usertext)
Else
utext$ = dlg.usertext
End If
ubold = dlg.userbold
uitalic = dlg.useritalic
ushade = dlg.usershade
uver = dlg.userver
uhor = dlg.userhor
upage = dlg.userpage
fgotoprompt = 0
fgotobye = 0
If usize < minsize Or usize > maxsize Then
Select Case MsgBox(msg$, 3)
Case - 1 REM yes, go back and change value
fgotoprompt = 1
Case 0 REM no, continue
Case 1 REM cancel
fgotobye = 1
End Select
End If
If fgotoprompt <> 1 And fgotobye <> 1 Then
If urotate < 0 Or urotate > 90 Then
Select Case MsgBox(msg1$, 1)
Case - 1REM yes, go back and change value
fgotoprompt = 1
Case 0REM cancel
fgotobye = 1
End Select
End If
End If
If fgotoprompt Then Goto prompt
If fgotobye Then Goto bye
REM get page margins
Redim dlg As FilePageSetup
GetCurValues dlg
utop = Val(dlg.TopMargin)
uleft = Val(dlg.LeftMargin)
uright = Val(dlg.RightMargin)
uwidth = Val(dlg.PageWidth)
uheight = Val(dlg.PageHeight)
ubottom = Val(dlg.BottomMargin)
REM setup printing
REM set the height of char
uhyp = usize - 10
If ushade Then
shade$ = ".96 "
Else
shade$ = ".96"
End If
text$ = "Print \p page " + Chr$(34)
REM setting font-format
If ufont$ = "Times-Roman" Then
If ubold Then
If uitalic Then
text1$ = "/Times-BoldItalic"
Else
text1$ = "/Times-Bold"
End If
ElseIf uitalic Then
text1$ = "/Times-Italic"
Else
text1$ = "/Times-Roman"
End If
ElseIf ufont$ = "Helvetica" Then
If ubold Then
If uitalic Then
text1$ = "/Helvetica-BoldOblique"
Else
text1$ = "/Helvetica-Bold"
End If
ElseIf uitalic Then
text1$ = "/Helvetica-Oblique"
Else
text1$ = "/Helvetica"
End If
ElseIf ufont$ = "Courier" Then
If ubold Then
If uitalic Then
text1$ = "/Courier-BoldOblique"
Else
text1$ = "/Courier-Bold"
End If
ElseIf uitalic Then
text1$ = "/Courier-Oblique"
Else
text1$ = "/Courier"
End If
End If
REM setting left and right margin and print routine
text2$ = " findfont " + Str$(usize) + " scalefont setfont " + Chr$(13)
text3$ = "/LM " + Str$(0) + " def" + Chr$(13)
text4$ = "/RM " + Str$(uwidth * 72) + " def" + Chr$(13)
text5$ = "/dlength {(" + utext$ + ") stringwidth } def" + Chr$(13)
text6$ = "/psize {RM LM sub} def" + Chr$(13)
text7$ = "/printDraft {0 0 moveto (" + utext$ + ") show } def " +
Chr$(13)
text8$ = "/halflen { dlength pop 2 div} def" + Chr$(13)
text17$ = "/adjmt {90 " + Str$(urotate) + " sub sin 80 mul 2 div} def"
+ Chr$(13)
REM positioning: horizontal
Select Case uhor
Case 0
REM left align
text9$ = "/ucos {" + Str$(urotate) + " cos} def" + Chr$(13)
text9$ = text9$ + "/uadj{halflen ucos mul}def" + Chr$(13)
text9$ = text9$ + "/ucos1 {90 " + Str$(urotate) + " sub cos
} def" + Chr$(13)
text9$ = text9$ + "/uadj1 {uhyp ucos1 mul}def" + Chr$(13)
text9$ = text9$ + "uadj1 uadj add" + Chr$(13)
text9$ = text9$ + Str$(uleft * 72) + " add" + Chr$(13)
If urotate = 90 Then text9$ = text9$ + "8 sub" + Chr$(13)
Case 1
REM center
text9$ = "psize 2 div" + Chr$(13)
Case 2
REM right align
text9$ = "/ucos {" + Str$(urotate) + " cos } def" +
Chr$(13)
text9$ = text9$ + "/uadj {halflen ucos mul} def" + Chr$(13)
text9$ = text9$ + "RM uadj sub" + Chr$(13)
text9$ = text9$ + Str$(uright * 72) + " sub" + Chr$(13)
End Select
REM positioning : vertical
Select Case uver
Case 0
REM top
text10$ = "/uvcos { " + Str$(urotate) + " cos} def" +
Chr$(13)
text10$ = text10$ + "/uvadj { uhyp uvcos mul} def" +
Chr$(13)
text10$ = text10$ + "/uvsin1 { " + Str$(urotate) + " sin }
def " + Chr$(13)
text10$ = text10$ + "/uvopp { halflen uvsin1 mul} def" +
Chr$(13)
text10$ = text10$ + Str$((uheight - utop) * 72) + " uvadj
uvopp add sub"
If ushade Then text10$ = text10$ + " 6 sub "
text10$ = text10$ + " translate" + Chr$(13)
Case 1
REM middle
text10$ = Str$(uheight * 72) + " 2 div translate" +
Chr$(13)
Case 2
REM bottom
text10$ = "/uvsin { " + Str$(urotate) + " sin}def" +
Chr$(13)
text10$ = text10$ + "/uvopp { halflen uvsin mul} def" +
Chr$(13)
text10$ = text10$ + Str$(ubottom * 72) + " 8 uvopp add add"
text10$ = text10$ + " translate" + Chr$(13)
End Select
text11$ = Str$(urotate) + " rotate" + Chr$(13)
text12$ = "0 halflen sub" + Chr$(13)
text18$ = "adjmt add" + Chr$(13)
text13$ = "0 translate" + Chr$(13)
text14$ = ".96 -.02 .85 %start incr.end" + Chr$(13)
text15$ = "{setgray printDraft -1 .5 translate} for" + Chr$(13)
text16$ = shade$ + "setgray printDraft " + Chr$(34)
Redim dlg As NormalViewHeaderArea
GetCurValues dlg
ffirst = dlg.FirstPage
fodd = dlg.OddAndEvenPages
If fodd = 0 Then
If ffirst = 0 Then
fheader = 0
Else
fheader = 1
End If
Else
If ffirst = 0 Then
fheader = 2
Else
fheader = 3
End If
End If
fheaderagain = 0
If upage Then
REM watermark only on first page
Select Case fheader
Case 0 REM same header for all pages
NormalViewHeaderArea .Type = 0, .FirstPage = 0,
.OddAndEvenPages = 0
EditSelectAll
EditCopy
ClosePane
NormalViewHeaderArea .Type = 2, .FirstPage = 1,
.OddAndEvenPages = 0
EditPaste
StartOfDocument
Case 1 REM different first page header
NormalViewHeaderArea .Type = 2, .FirstPage = 1,
.OddAndEvenPages = 0
Case 2 REM different odd and even page header
NormalViewHeaderArea .Type = 2, .FirstPage = 0,
.OddAndEvenPages = 1
Case 3 REM different first, odd and even page header
NormalViewHeaderArea .Type = 0, .FirstPage = 1,
.OddAndEvenPages = 1
End Select
Else
REM on all pages
Select Case fheader
Case 0 REM same header for all pages
NormalViewHeaderArea .Type = 0, .FirstPage = 0,
.OddAndEvenPages = 0
Case 1 REM different first page header
ctype = 0
cfirstpage = 1
coddandevenpages = 0
NormalViewHeaderArea .Type = ctype, .FirstPage =
cfirstpage, \
.OddAndEvenPages = coddandevenpages
fheaderagain = 1
Case 2 REM different odd and even page header
ctype = 0
cfirstpage = 0
coddandevenpages = 1
NormalViewHeaderArea .Type = ctype, .FirstPage =
cfirstpage, \
.OddAndEvenPages = coddandevenpages
fheaderagain = 1
Case 3 REM different first, odd and even page header
ctype = 0
cfirstpage = 1
coddandevenpages = 1
NormalViewHeaderArea .Type = ctype, .FirstPage =
cfirstpage, \
.OddAndEvenPages = coddandevenpages
fheaderagain = 2
End Select
End If REM all or first page
While fdone = 0
StartOfDocument
InsertFieldChars
REM insert definition
WW2_Insert text$ + text1$ + text2$ + text3$ + text4$ + text5$ +
text6$ + text7$ + text8$
REM only for vertical center alignment
If uver = 1 Then WW2_Insert text17$
REM insert horizontal alignment
WW2_Insert text9$
REM insert vertical alignment
WW2_Insert text10$
REM instruction for rotation and translate
WW2_Insert text11$ + text12$
REM only for vertical center alignment
If uver = 1 Then WW2_Insert text18$
WW2_Insert text13$
If ushade Then WW2_Insert text14$ + text15$
WW2_Insert text16$
If fheaderagain Then
fheaderagain = fheaderagain - 1
ctype = ctype + 2
NormalViewHeaderArea .Type = ctype, .FirstPage =
cfirstpage, \
.OddAndEvenPages = coddandevenpages
Else
fdone = 1
End If
Wend
ClosePane
If fViewOutline Then ViewOutline
If fViewPage Then ViewPage
ViewFieldCodes fViewFieldCodes
bye:
End Sub
|
| The advantage of this Macro is that it will work on any printer, the one
offered in .-1 seems to require a Postscript printer.
This macro tested on Word 2.0, 6.0, 95 and 7.0
To remove the watermark just run it and enter a new blank watermark.
Sub MAIN
REM Define Dialog Box for Watermark text color
Dim DropListBox1$(16)
DropListBox1$(0) = "Windows Default"
DropListBox1$(1) = "Black"
DropListBox1$(2) = "Blue"
DropListBox1$(3) = "Cyan"
DropListBox1$(4) = "Green"
DropListBox1$(5) = "Magenta"
DropListBox1$(6) = "Red"
DropListBox1$(7) = "Yellow"
DropListBox1$(8) = "White"
DropListBox1$(9) = "Dark Blue"
DropListBox1$(10) = "Dark Cyan"
DropListBox1$(11) = "Dark Green"
DropListBox1$(12) = "Dark Magenta"
DropListBox1$(13) = "Dark Red"
DropListBox1$(14) = "Dark Yellow"
DropListBox1$(15) = "Dark Grey"
DropListBox1$(16) = "Light Grey"
Begin Dialog UserDialog 470, 198, "Watermark"
Text 104, 72, 121, 13, "Watermark Text", .Text1
TextBox 238, 68, 167, 18, .TextBox1
Text 126, 91, 281, 13, "(Delete this text to Erase Watermark)", .Text2
Text 97, 34, 136, 13, "Watermark Colour", .Text3
DropListBox 239, 32, 182, 108, DropListBox1$(), .DropListBox1
OKButton 100, 134, 88, 21
CancelButton 303, 130, 88, 21
End Dialog
REM Define Data Record for data to and from Dialog Box
Dim UserData As UserDialog
REM Define Data Records for finding page setup values
Dim PageData As FilePageSetup
Dim GeneralData As ToolsOptionsGeneral REM Used for changing units
REM If we are in a Macro then tell user and exit
If SelInfo(27) = - 1 Then
MsgBox "Can't add watermarks to a Macro window", "Error"
Goto ErrorExit
End If
REM Set default color to be current watermark color
OldWaterMarkColor$ = GetDocumentVar$("WaterMarkColor")
If OldWaterMarkColor$ = "" Then
REM Set default color to be Dark Grey
UserData.DropListBox1 = 15
Else
UserData.DropListBox1 = Val(OldWaterMarkColor$)
End If
REM Set default WaterMark to be current watermark
OldWaterMarkText$ = GetDocumentVar$("WaterMarkText")
If OldWaterMarkText$ = "" Then
REM Set default Watermark text to be DRAFT
UserData.TextBox1 = "DRAFT"
Else
UserData.TextBox1 = OldWaterMarkText$
End If
REM Note if we are in Print Preview mode so we can return there
InPreview = FilePrintPreview()
REM Mark the current insertion point so we can return here
EditBookmark .Name = "Temp", .SortBy = 0, .Add
numBookmarks = CountBookmarks()
REM display the dialog box and get the user input
ButtonChoice = Dialog(UserData)
REM ButtonChoice = -1 when OK button selected
REM The corresponding End If is just before the End Sub right at the end
If ButtonChoice = - 1 Then
REM Remember if we were in a header and switch to header view
If ViewHeader() = 0 Then
HeaderNum = 0 REM Note that we have switched to Header view
ViewHeader REM Switch to Header view
Else
HeaderNum = 1 REM Remember that we were already in header
End If
REM Go to the First Header
On Error Goto First_Header
REM Keep stepping back through errors till we get an error
While Err = 0
ShowPrevHeaderFooter
If HeaderNum > 0 Then
REM We will use HeaderNum to get back to correct header
HeaderNum = HeaderNum + 1
End If
Wend
First_Header: REM Get here when ShowPrevHeaderFooter gets an error
REM Re-Enable standard error handling
Err = 0
On Error Goto 0
REM Delete any previous WaterMarks
REM Add line breaks and tabs for comparing to existing headers
OldWaterMarkPara$ = DiagonalText$(OldWaterMarkText$)
REM Step through headers till ShowNextHeaderFooter gets an error
REM Checking for the old watermark in each header
While Err = 0
WaterMarkNum = FindTextBox(OldWaterMarkPara$)
If WaterMarkNum <> 0 Then REM Found an old WaterMark
DrawSelect(WaterMarkNum)
EditClear REM Delete the old WaterMark
End If
REM If ShowNextHeaderFooter gets an error then we are done
On Error Goto Remove_Done
ShowNextHeaderFooter
On Error Goto 0
Wend REM Go back and check this header for old WaterMark
Remove_Done: REM Finished removing old WaterMarks
REM Re-Enable standard error handling
Err = 0
On Error Goto 0
WaterMarkLen = Len(UserData.TextBox1)
If WaterMarkLen = 0 Then
REM Clear Document Variables so we know there's no WaterMark
SetDocumentVar "WaterMarkText", ""
SetDocumentVar "WaterMarkColor", ""
Goto Exitnow
End If
REM Note that there is a watermark in this document
SetDocumentVar "WaterMarkText", UserData.TextBox1
SetDocumentVar "WaterMarkColor", Str$(UserData.DropListBox1)
REM Add line breaks and tabs for inserting into headers
WaterMarkPara$ = DiagonalText$(UserData.TextBox1)
REM Step through the headers again, adding watermarks on the way
While Err = 0
REM Find out if this header ALREADY has the watermark
REM (from link to previous...)
WaterMarkNum = FindTextBox(WaterMarkPara$)
If WaterMarkNum = 0 Then REM No WaterMark in this header yet
REM Note current units and set units to Points
REM So we can calculate font size from page size/margins
GetCurValues GeneralData
OldUnits = GeneralData.Units
ToolsOptionsGeneral .Units = 2 REM Units=2 is Points
REM Get page size information in Points
GetCurValues PageData
PageWidth = Val(PageData.PageWidth)
PageWidth = PageWidth - Val(PageData.LeftMargin)
PageWidth = PageWidth - Val(PageData.RightMargin)
PageHeight = Val(PageData.PageHeight)
PageHeight = PageHeight - Val(PageData.HeaderDistance)
PageHeight = PageHeight - Val(PageData.FooterDistance)
REM If the header was previously empty then get rid
REM of the automatically created header separator
If GetBookmark$("\Doc") = "" Then
FormatBordersAndShading .ApplyTo = 0, .Shadow = 0, .TopBorder = 0, .LeftBorder = 0, .BottomBorder = 0, .RightBorder = 0, .HorizBorder = 0, .VertBorder = 0, .TopColor = 0, .LeftColor = 0, .BottomColor = 0, .RightColor = 0, .HorizColor = 0, .VertColor = 0, .FromText = "1 pt", .Shading = 0, .Foreground = 0, .Background = 0, .Tab = "0", .FineShading = - 1
End If
REM Create a graphics text box behind the text plane
DrawTextbox
DrawSendBehindText
REM Set Top and Left of text box at top of page and left margin
FormatDrawingObject .HorizontalFrom = 0, .VerticalFrom = 1
FormatDrawingObject .VerticalPos = Val(PageData.HeaderDistance), .HorizontalPos = 0
REM Set text box size to fit exactly between margins
FormatDrawingObject .Width = PageWidth, .Height = PageHeight
REM Clear borders fill and line (make text box invisible)
FormatDrawingObject .FillColor = "0" REM No Fill color
FormatDrawingObject .FillPattern = "0" REM No Pattern
FormatDrawingObject .LineType = 0 REM No line
REM Move text insert point into the new text box
DrawSetInsertToTextbox
REM Set Font Size to fit text between top and bottom
FontSize(PageHeight * 0.85) / WaterMarkLen
FormatFont .Color = UserData.DropListBox1
If WaterMarkLen > 1 Then
REM Set tab stops to spread WaterMark across page
TabSize = PageWidth / WaterMarkLen
For TabCount = 1 To WaterMarkLen - 1
TabPos$ = Str$(TabSize * TabCount)
TabPos$ = TabPos$ + "pt"
FormatTabs .Position = TabPos$
Next TabCount
Else
REM Only one character. So center it between margins
CenterPara
End If
REM Set Units back to original value
ToolsOptionsGeneral .Units = OldUnits
REM Now we finally get to put the text on the page
Insert WaterMarkPara$
REM Move the text insert point out of the text box again
DrawSetInsertToAnchor
End If REM WaterMarkNum = 0
REM If ShowPrevHeaderFooter generates an error we've finished
On Error Goto Exitnow
ShowPrevHeaderFooter
On Error Goto 0
Wend REM Err=0 from ShowPrev..., stepping back through headers
Exitnow: REM Finished removing and adding headers
REM Re-Enable standard error handling
Err = 0
On Error Goto 0
REM Check to see if we were originally in a header
If HeaderNum = 0 Then
ViewHeader REM Toggle header display off again
Else
If HeaderNum > 1 Then
REM Return to the originally selected header
If UserData.TextBox1 = "" Then
REM Go back to the First Header
On Error Goto First_Header_Again
While Err = 0
ShowPrevHeaderFooter
Wend
First_Header_Again:
End If
For Count = 1 To HeaderNum - 1
ShowNextHeaderFooter
Next Count
End If
End If
REM Return to the original editing position
REM Bookmarks in headers seem to generate errors
On Error Resume Next
If ExistingBookmark("Temp") Then
EditGoTo .Destination = "Temp"
EditBookmark .Name = "Temp", .SortBy = 0, .Delete
End If
On Error Goto 0
REM If we were originally in Print Preview then go back there
If InPreview = - 1 Then
FilePrintPreview
End If
End If REM ButtonChoice = - 1
ErrorExit:
End Sub
Function DiagonalText$(Text$)
REM Insert <NEWLINE><TAB> between each pair of characters in Text$
Tmp$ = ""
For Count = 1 To Len(Text$)
If Count > 1 Then
Tmp$ = Tmp$ + Chr$(11) REM NewLine
For SpaceCount = 1 To Count - 1
Tmp$ = Tmp$ + Chr$(9) REM TAB
Next SpaceCount
End If
Tmp$ = Tmp$ + Mid$(Text$, Count, 1)
Next Count
DiagonalText$ = Tmp$
End Function
Function FindTextBox(Text$)
REM Locate any text box whose first paragraph is text$, return
REM the drawing object id of the text box, or 0 if not found.
Temp = 0
DrawSetRange("\Doc") REM Select entire object
If DrawCount() > 0 Then REM Any drawing objects?
For Count = 1 To DrawCount() REM For each drawing object
If DrawGetType(Count) = 3 Then REM It's a text box?
DrawSetInsertToTextbox
If GetBookmark$("\Para") = Text$ Then
Temp = Count
End If
On Error Resume Next
DrawSetInsertToAnchor
On Error Goto 0
End If REM DrawGetType = 3
Next Count
End If REM DrawCount > 0
FindTextBox = Temp
End Function
|