I am working on an Excel application that creates reports from a inventory of data. This application is intended to be distributed to a large number of staff with potentially older/slower computers. As part of generating reports, a large number of shapes (80ish) are to be resized and re-positioned. I am running into problems with only some computers where the shapes are not doing what the code is dictating.
I am able to step through the code with consistent successful results regardless of the host computer. I've tried adding DoEvents and Workbook.RefreshAll statements with varying degrees of success. I also am unlinking any linked pictures.
The x1, x2, y1, y2 are points (from xWhereAmI and yWhereAmI) obtained from selecting the mid point of a cell location saved in a table dictating reference for the shape position. I can confirm that these are correct points regardless of screen resolution.
'Resize and formatting
'(x1,y1)-----------------(x2)
' |
' |
' |
' |
' |
' |
' (y2)
i = 0
Set myRange = Codebackground.Range("pSOIRobjects")
For Each Pic In PSOIR.Shapes
If Pic.Type = msoPicture Then
'for rotated shapes
If Pic.Rotation = 270 Then
'x1
myX1 = GlobalOp.yWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 3))
'x2
myX2 = GlobalOp.yWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 4))
'y1
myY1 = GlobalOp.xWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 3))
'y2
myY2 = GlobalOp.xWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 5))
'resize and position
Pic.LockAspectRatio = msoFalse
Pic.Width = myX1 - myX2
Pic.Height = myY2 - myY1
Pic.Left = 0
Pic.IncrementLeft myY1 - (Pic.Width - Pic.Height) / 2
Pic.Top = myX2 + (Pic.Width - Pic.Height) / 2
'for unrotated shapes
Else
'x1
myX1 = GlobalOp.xWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 3))
'x2
myX2 = GlobalOp.xWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 4))
'y1
myY1 = GlobalOp.yWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 3))
'y2
myY2 = GlobalOp.yWhereAmI(Application.WorksheetFunction.VLookup(Pic.name, myRange, 5))
Pic.LockAspectRatio = msoFalse
Pic.Width = myX2 - myX1
Pic.Height = myY2 - myY1
Pic.Left = myX1
Pic.Top = myY1
End If
End If
i = i + 1
Application.StatusBar = "Formatting shape "& i
DoEvents
Next
x point function
Public Function xWhereAmI(myCell As String) As Double
Dim cell2find As String
Dim cellWidth As Double
Dim myRange As Range
cell2find = myCell
Set myRange = ThisWorkbook.Worksheets("PSOIR").Range(""& cell2find & "")
xWhereAmI = myRange.Left + (myRange.Width / 2)
End Function
y point function
Public Function yWhereAmI(myCell As String) As Double
Dim cell2find As String
Dim cellWidth As Double
Dim myRange As Range
cell2find = myCell
Set myRange = ThisWorkbook.Worksheets("PSOIR").Range(""& cell2find & "")
yWhereAmI = myRange.Top + (myRange.RowHeight / 2)
End Function
I expect the output to be shapes that are re-positioned and resized according to the x1, x2, y1, y2 values. However, the shapes seem to sometimes be in a lower position depending on what computer is used. On some computers the code runs flawlessly, however, on other computers the shapes are positioned incorrectly. Any thoughts or ideas are much appreciated!
I've tested this with over 10 computers now with mostly successful results. I think the problem arises in the lines where the shape size and position is manipulated. Strangely enough, on computers that the code doesn't run properly, even if DoEvent statements or Wait statements are added between the shape manipulation lines (.height, .width, .top, .left), the result is the same.
Does anyone have suggestions to make the code run slower?