Solved: Paste Special Problem

[xCav8r]

With a few users, the code below doesn't work like I want it to. It's grabbing a textbox from one of two files. The textboxes in the originating templates are aligned absolutely to the page .25" to the right and 10.25" from the top. For all but a few users, the textbox gets inserted onto the desired page as positioned in the template, but sometimes the values here change.

Public Sub InsertFooter(Optional strParams As String)
On Error GoTo InsertFooter_Error:

Dim strUserOptionsPath As String
Dim strFooterFileName As String

strPathToWorkgroupTemplatesFolder = MyAdjustedFilePath _
(strcPathToWorkgroupTemplatesFolder)

strUserOptionsPath = Application.Options.DefaultFilePath(wdUserOptionsPath) & "\"

strFooterFileName = CommandBars.ActionControl.Parameter

If strFooterFileName <> "footer.dot" Or strFooterFileName <> "footerwithpath.dot" Then
strFooterFileName = strParams
End If

ChangeFileOpenDirectory strPathToWorkgroupTemplatesFolder

Selection.EndKey unit:=wdStory

Documents.Open FileName:=strFooterFileName, ConfirmConversions:=False, ReadOnly _
:=True, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto, XMLTransform:="", Visible:=True

Documents(strFooterFileName).Shapes("PED Footer").Select
Selection.Copy

Documents(strFooterFileName).Close False

Selection.PasteSpecial Link:=False, DataType:=wdPasteShape, Placement:= _
wdFloatOverText, DisplayAsIcon:=False

ChangeMyDirectory (strUserOptionsPath)

InsertFooter_Exit:
Exit Sub

InsertFooter_Error:
strMessage = Err.Source & " generated error#" _
& Err.Number & ": " & Err.Description
MsgBox strMessage
Resume InsertFooter_Exit

End Sub

How do I change this to stick this textbox where I want?

[xCav8r]

Figured it out...

Public Sub MoveShape()
Dim MyShape As Shape
For Each MyShape In ActiveDocument.Shapes
If MyShape.Name = "PED Footer" Then
MyShape.Left = 18
MyShape.Top = 738
End If
Debug.Print "Left=" & MyShape.Left
Debug.Print "Top=" & MyShape.Top
Debug.Print "Name=" & MyShape.Name
Next MyShape
End Sub

[xCav8r]

Revised as follows...

Public Sub InsertFooter(Optional strParams As String)
On Error GoTo InsertFooter_Error:

Dim strFooterFileName As String

strPathToWorkgroupTemplatesFolder = MyAdjustedFilePath _
(strcPathToWorkgroupTemplatesFolder)

strFooterFileName = CommandBars.ActionControl.Parameter

Select Case strFooterFileName
Case Not "footer.dot", "footerwithpath.dot"
strFooterFileName = strPathToWorkgroupTemplatesFolder & strParams
End Select

Selection.EndKey unit:=wdStory

Documents.Open FileName:=strFooterFileName, _
ConfirmConversions:=False, _
ReadOnly:=True, _
Visible:=False

Documents(strFooterFileName).Shapes("PED Footer").Select
Selection.Copy

Documents(strFooterFileName).Close False

If ShapeExists("PED Footer") Then
ActiveDocument.Shapes("PED Footer").Select
Selection.Delete
End If

Selection.PasteSpecial Link:=False, _
DataType:=wdPasteShape, _
Placement:=wdFloatOverText, _
DisplayAsIcon:=False

PositionFooter "PED Footer"

InsertFooter_Exit:
Exit Sub

InsertFooter_Error:
strMessage = Err.Source & " generated error#" _
& Err.Number & ": " & Err.Description
MsgBox strMessage
Resume InsertFooter_Exit
End Sub

Private Sub PositionFooter(ShapeName As String)
Dim MyShape As Shape
For Each MyShape In ActiveDocument.Shapes
If MyShape.Name = ShapeName Then
MyShape.Left = 18
MyShape.Top = 738
Exit Sub
End If
Next MyShape
End Sub

Private Function ShapeExists(ShapeName As String) As Boolean
Dim MyShape As Shape
For Each MyShape In ActiveDocument.Shapes
If MyShape.Name = ShapeName Then
ShapeExists = True
Exit Sub
Else
ShapeExists = False
End If
Next MyShape
End Function


Comments, suggestions, criticisms welcome.