View Full Version : Linked Picture to be centred on Screen
clueless007
06-29-2008, 05:46 PM
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
06-29-2008, 06:54 PM
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
06-29-2008, 07:04 PM
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
06-29-2008, 07:24 PM
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
06-29-2008, 07:32 PM
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
06-29-2008, 07:45 PM
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
06-29-2008, 08:49 PM
I'm glad it worked out for you.
clueless007
06-29-2008, 10:07 PM
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
06-30-2008, 05:46 AM
Application.EnableEvents = False
Call ImportRoutine
Application.EnableEvents = True
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.