Linked Picture to be centred on Screen

[clueless007]

Hello
I have an the following event
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
if certain range is selected than a linked picture appears.. no problem.
My problem is that it is not autocentring on screen. IE. If I was on row 300, and when I press "B300", it does the popup, but it goes back to the top around the row 30 area. I want it to pop up and stay around roww 300. (I have also a comd button that appears with the linked picture to close it). If this is not the best way, open to any other suggestions. thank you

[mikerickson]

What is the complete code for your SelectionChange event?

This will center a shape on the visible portion of the spreadsheet
Dim windowWidth As Double, widthOffset As Double
Dim windowHeight As Double, heightOffset As Double

With ActiveWindow

If 1 < .VisibleRange.Column Then
widthOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, .VisibleRange.Column - 1)).Width
End If
If 1 < .VisibleRange.Row Then
heightOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(.VisibleRange.Row - 1, 1)).Height
End If

windowWidth = .UsableWidth
windowHeight = .UsableHeight

End With

With ActiveSheet.Shapes(1)
.Top = ((windowHeight - .Height) / 2) + heightOffset
.Left = ((windowWidth - .Width) / 2) + widthOffset
End With

[clueless007]

current code


Public sCellAdd As String
Public iPic As Integer
Public sCell As String
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
If InRange(Target, Range("Board")) Then
On Error Resume Next
ActiveSheet.Range("G" & sCell).Select
ActiveSheet.Buttons.Add(467, 38.25 + (sCell * 4), 35.25, 16.5).Select
Selection.OnAction = "DeleteShapes"
ActiveSheet.Shapes("Button 5").Characters.Text = "Close"
Selection.Characters.Text = "Close"
'Range("G7").Select

Sheets("ClientDetails").Shapes("Pic1").Copy
Sheets("Sheet1").PasteSpecial Format:="Picture (GIF)", Link:=False, _
DisplayAsIcon:=False
'Sheets("Sheet1").Select

Selection.ShapeRange.IncrementLeft 341.25
Selection.ShapeRange.IncrementTop 68.25 + (sCell * 4)
ActiveSheet.Shapes.Select
End If
Application.ScreenUpdating = True
End Sub

Private Function InRange(rng1, rng2) As Boolean
' Returns True if rng1 is a subset of rng2 InRange = False
If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address Then
InRange = True

iCellAdd = rng1.Value
Sheets("ClientDetails").Range("B2") = iCellAdd
sCell = rng1.Row
End If
End If
End If
End Function

range name "Board" = =OFFSET(Sheet1!$B$3,1,0,COUNTA(Sheet1!$B:$B)-1,1)


not sure where to put your code??

[clueless007]

thanks Mike, almost there..
just need to make it centre on say if I was on row 300, it displays at around areas 107-129 centred, I need it to stay around row 300 centred
hope I explained myself..



current code

Public sCellAdd As String
Public iPic As Integer
Public sCell As String
Dim windowWidth As Double, widthOffset As Double
Dim windowHeight As Double, heightOffset As Double

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
If InRange(Target, Range("Board")) Then
On Error Resume Next
ActiveSheet.Range("G" & sCell).Select
ActiveSheet.Buttons.Add(467, 38.25 + (sCell * 4), 35.25, 16.5).Select
Selection.OnAction = "DeleteShapes"
ActiveSheet.Shapes("Button 5").Characters.Text = "Close"
Selection.Characters.Text = "Close"
'Range("G7").Select

Sheets("ClientDetails").Shapes("Pic1").Copy
Sheets("Sheet1").PasteSpecial Format:="Picture (GIF)", Link:=False, _
DisplayAsIcon:=False
'Sheets("Sheet1").Select



With ActiveWindow

If 1 < .VisibleRange.Column Then
widthOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, .VisibleRange.Column - 1)).Width
End If
If 1 < .VisibleRange.Row Then
heightOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(.VisibleRange.Row - 1, 1)).Height
End If

windowWidth = .UsableWidth
windowHeight = .UsableHeight

End With

ActiveSheet.Shapes.Select
With Selection
.Top = ((windowHeight - .Height) / 2) + heightOffset
.Left = ((windowWidth - .Width) / 2) + widthOffset
End With
End If
Application.ScreenUpdating = True
End Sub

Private Function InRange(rng1, rng2) As Boolean
' Returns True if rng1 is a subset of rng2 InRange = False
If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address Then
InRange = True

iCellAdd = rng1.Value
Sheets("ClientDetails").Range("B2") = iCellAdd
sCell = rng1.Row
End If
End If
End If
End Function

[mikerickson]

The code that I wrote is keyed to the window, not to the spreadsheet.
The techniques used to determine the value of heightOffset could be used to set it on a particular row.

This will place a shape such that Shapes(1).TopLeftCell Is someCell.Offset(1,1)
Dim someCell as Range

With ActiveSheet.Shapes(1)
.Left = Range(Range("a1"),someCell).Width
.Top = Range(Range("a1"),someCell).Height
End With

[clueless007]

Mike, I am all good, thank you for the clues before..
It is doing exactly what I want, after thinkering...
below is my working solution... thanks heap for the nudge in the right direction.


Public sCellAdd As String
Public iPic As Integer
Public sCell As String
Public iRow As Integer
Dim windowWidth As Double, widthOffset As Double
Dim windowHeight As Double, heightOffset As Double

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
If InRange(Target, Range("Board")) Then
On Error Resume Next
ActiveSheet.Range("G" & sCell).Select
'ActiveSheet.Buttons.Add(467, 38.25 + (sCell * 4), 35.25, 16.5).Select
' Selection.OnAction = "DeleteShapes"
'ActiveSheet.Shapes("Button 5").Characters.Text = "Close"
'Selection.Characters.Text = "Close"
'Range("G7").Select

Sheets("ClientDetails").Shapes("Pic1").Copy
Sheets("Sheet1").PasteSpecial Format:="Picture (GIF)", Link:=False, _
DisplayAsIcon:=False
'Sheets("Sheet1").Select



With ActiveWindow
If 1 < .VisibleRange.Column Then
widthOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, .VisibleRange.Column - 1)).Width
End If
If 1 < .VisibleRange.Row Then
heightOffset = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(.VisibleRange.Row + 1, 1)).Height
End If

windowWidth = .UsableWidth
windowHeight = .UsableHeight

End With

ActiveSheet.Shapes.Select
With Selection
.Top = ((windowHeight - .Height) / 2) + heightOffset
.Left = ((windowWidth - .Width) / 2) + widthOffset
End With
ActiveSheet.Buttons.Add(467, ((windowHeight - Height) / 2) + heightOffset, 35.25, 16.5).Select
Selection.OnAction = "DeleteShapes"
ActiveSheet.Shapes("Button 5").Characters.Text = "Close"
Selection.Characters.Text = "Close"
Cells(iRow, 3).Select

End If
Application.ScreenUpdating = True
End Sub

Private Function InRange(rng1, rng2) As Boolean
' Returns True if rng1 is a subset of rng2 InRange = False
If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address Then
InRange = True
iRow = rng1 + 3
iCellAdd = rng1.Value
Sheets("ClientDetails").Range("B2") = iCellAdd
sCell = rng1.Row
End If
End If
End If
End Function

:bow:

[mikerickson]

I'm glad it worked out for you.

[clueless007]

Mike
I am populating this Excel.xlt file from an access table. problem is that it is slowing it down, big time.. How can I disable this worksheet event, or import the module after population, any ideas? Thanking you

[mikerickson]

Application.EnableEvents = False
Call ImportRoutine
Application.EnableEvents = True