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.

[VBA]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[/VBA]

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

[xCav8r]

Figured it out...

[VBA]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[/VBA]

[xCav8r]

Revised as follows...

[VBA]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
[/VBA]

Comments, suggestions, criticisms welcome.