KayPat
12-27-2012, 11:06 AM
Here is my complete code that inserts and removes a watermark and inserts a signature behind text from a drive. My only problem is that i need to be able to insert the signature to where my curser points, can anyone help with this part?
Sub InsertWatermark()
Dim oRg As Range
Dim oTempl As Template, tempTempl As Template
Dim oBBE As BuildingBlock, tempBBE As BuildingBlock
Dim idx As Long
Dim BBEname As String
BBEname = "DRAFT"
Templates.LoadBuildingBlocks
Set oRg = _
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
oRg.Collapse wdCollapseStart
For Each tempTempl In Templates
If InStr(LCase(tempTempl.Name), "building blocks.dotx") Then
Set oTempl = tempTempl
Exit For
End If
Next
If oTempl Is Nothing Then
MsgBox "Building Blocks.dotx not found"
Exit Sub
End If
For idx = 1 To oTempl.BuildingBlockEntries.Count
Set tempBBE = oTempl.BuildingBlockEntries(idx)
If InStr(LCase(tempBBE.Name), LCase(BBEname)) Then
Set oBBE = tempBBE
Exit For
End If
Next
If oBBE Is Nothing Then
MsgBox BBEname & " not found"
Exit Sub
End If
oBBE.Insert Where:=oRg, RichText:=True
End Sub
Sub RemoveWatermark()
Application.ScreenUpdating = False
Dim RngSel As Range, Scn As Section, HdFt As HeaderFooter, iView As Long
With ActiveDocument
Set RngSel = Selection.Range
iView = ActiveWindow.View.Type
For Each Scn In .Sections
For Each HdFt In Scn.Headers
HdFt.Range.Select
WordBasic.RemoveWatermark
Next
For Each HdFt In Scn.Footers
HdFt.Range.Select
WordBasic.RemoveWatermark
Next
Next
End With
RngSel.Select
ActiveWindow.View.Type = iView
Set RngSel = Nothing
Application.ScreenUpdating = True
End Sub
Sub Signature()
Application.ScreenUpdating = False
Dim Rng As Range, Shp As Shape, StrImg As String
StrImg = "C:\Signature.jpeg"
Set Rng = Selection.Range
Rng.Collapse
Set Shp = ActiveDocument.InlineShapes.AddPicture(FileName:=StrImg, _
SaveWithDocument:=True, Range:=Rng).ConvertToShape
With Shp
.LockAspectRatio = True
.Left = CentimetersToPoints(0)
.Top = CentimetersToPoints(20)
.Width = CentimetersToPoints(2.5)
.WrapFormat.Type = wdWrapBehind
End With
Set Rng = Nothing: Set Shp = Nothing
Application.ScreenUpdating = True
End Sub
Sub InsertWatermark()
Dim oRg As Range
Dim oTempl As Template, tempTempl As Template
Dim oBBE As BuildingBlock, tempBBE As BuildingBlock
Dim idx As Long
Dim BBEname As String
BBEname = "DRAFT"
Templates.LoadBuildingBlocks
Set oRg = _
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
oRg.Collapse wdCollapseStart
For Each tempTempl In Templates
If InStr(LCase(tempTempl.Name), "building blocks.dotx") Then
Set oTempl = tempTempl
Exit For
End If
Next
If oTempl Is Nothing Then
MsgBox "Building Blocks.dotx not found"
Exit Sub
End If
For idx = 1 To oTempl.BuildingBlockEntries.Count
Set tempBBE = oTempl.BuildingBlockEntries(idx)
If InStr(LCase(tempBBE.Name), LCase(BBEname)) Then
Set oBBE = tempBBE
Exit For
End If
Next
If oBBE Is Nothing Then
MsgBox BBEname & " not found"
Exit Sub
End If
oBBE.Insert Where:=oRg, RichText:=True
End Sub
Sub RemoveWatermark()
Application.ScreenUpdating = False
Dim RngSel As Range, Scn As Section, HdFt As HeaderFooter, iView As Long
With ActiveDocument
Set RngSel = Selection.Range
iView = ActiveWindow.View.Type
For Each Scn In .Sections
For Each HdFt In Scn.Headers
HdFt.Range.Select
WordBasic.RemoveWatermark
Next
For Each HdFt In Scn.Footers
HdFt.Range.Select
WordBasic.RemoveWatermark
Next
Next
End With
RngSel.Select
ActiveWindow.View.Type = iView
Set RngSel = Nothing
Application.ScreenUpdating = True
End Sub
Sub Signature()
Application.ScreenUpdating = False
Dim Rng As Range, Shp As Shape, StrImg As String
StrImg = "C:\Signature.jpeg"
Set Rng = Selection.Range
Rng.Collapse
Set Shp = ActiveDocument.InlineShapes.AddPicture(FileName:=StrImg, _
SaveWithDocument:=True, Range:=Rng).ConvertToShape
With Shp
.LockAspectRatio = True
.Left = CentimetersToPoints(0)
.Top = CentimetersToPoints(20)
.Width = CentimetersToPoints(2.5)
.WrapFormat.Type = wdWrapBehind
End With
Set Rng = Nothing: Set Shp = Nothing
Application.ScreenUpdating = True
End Sub