I'm trying this for a few hours now, but I can't figure out how to get an image as stationery in my background in Excel 2010. In all ways it seems I just can't get it spread from the top left to bottom right corner.
Can I accomplish this with a macro, or is there some other way to do it?
See the microsoft link
To quote
"In Excel, you can use a picture as a sheet background for display purposes only. A sheet background is not printed and is not retained in an individual worksheet or in an item that you save as a Web page. It is retained only when you publish an entire workbook as a Web page.
Important Because a sheet background is not printed, it cannot be used as a watermark. You can, however, mimic a watermark by inserting a graphic in a header or footer."
This piece of code will let you choose a picture (you can already have one and adapt this code), it will resize the picture to fit the printarea and align it on the top left of the printarea:
Option Explicit
Private Sub Test()
Dim PicLocation As String
Dim MyRange As Range, TargetCell As Range
Set MyRange = Range(ActiveSheet.PageSetup.PrintArea)
Set TargetCell = MyRange.Cells(1, 1)
PicLocation = Application.GetSaveAsFilename("C:\", "Image Files (*.jpg),*.jpg", , "Specify Image Location")
If PicLocation <> "False" Then
ActiveSheet.Pictures.Insert(PicLocation).Select
Else
Exit Sub
End If
With Selection.ShapeRange
.LockAspectRatio = msoTrue
If .Width > .Height Then
.Width = MyRange.Width
If .Height > MyRange.Height Then .Height = MyRange.Height + ActiveSheet.PageSetup.HeaderMargin + ActiveSheet.PageSetup.BottomMargin
Else
.Height = MyRange.Height
If .Width > MyRange.Width Then .Width = MyRange.Width + ActiveSheet.PageSetup.LeftMargin + ActiveSheet.PageSetup.RightMargin
End If
.Left = TargetCell.Left - ActiveSheet.PageSetup.LeftMargin
.Top = TargetCell.Top - ActiveSheet.PageSetup.HeaderMargin
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
End Sub
Related
Apologies another noob question. I have been tasked with writing a document within excel, the front cover has a lot of images on it and i have grouped these images together. As there is a risk that the user could move this group. I want to set it so each time that sheet is selected it moves back to its original location. I have looked over the web and i can't seem to find anything for a group of images.
I have tried this and it doesnt work at all. :(
Private Sub Worksheet_Activate()
Dim PicGroup As GroupShapes
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
So my group of images I have called HeaderGrp I have put this on Activate Worksheet in VBA and i want this to always move or fix to cells A1.
I would also love this to fit to the page width and length if anyone knows how to do that.
Snapshot of what i would like: -
1) on sheet selection, image group moves to the correct location.
2) image group auto adjusts to page width and height.
Thank you in advance,
This works for me. Pictures appear to be treated as a type of Shape.
Private Sub Worksheet_Activate()
Dim p As Shape
With activesheet
Set p = .Shapes("Pics") 'name
p.Top = .Range("a1").Top
p.Left = .Range("a1").Left
End With
End Sub
This piece of code should get your grouped images:
Option Explicit
Private Sub Worksheet_Activate()
Dim shp As Shape
Dim PicGroup As GroupShapes
'loop through all your shapes
For Each shp In Me.Shapes
'if the shape is grouped then
'set your PicGroup variable
'and exit the loop
If shp.Type = msoGroup Then
Set PicGroup = shp.GroupItems
Exit For
End If
Next shp
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
I have two buttons in my spreadsheet and I use the following VBA to move both buttons into Range("D12:D12"):
Sub Move_Buttons()
Set Range_01 = Sheet1.Range("D12:D12")
With Sheet1.Buttons("Button 1")
.Top = Range_01.Top
.Left = Range_01.Left
.Width = Range_01.Width
.Height = Range_01.Height
End With
Set Range_02 = Sheet1.Range("D12:D12")
With Sheet1.Buttons("Button 2")
.Top = Range_02.Top
.Left = Range_02.Left
.Width = Range_02.Width
.Height = Range_02.Height
End With
End Sub
All this works fine so far.
As you can see in my code the two buttons are both moved into Range("D12:D12") so they are lying on top of each other within this cell.
Now, I am wondering if there is a way to put both buttons next to each other within the Range("D12:D12") so the user is still able to see both of them?
I know I could sove the issue by
a) putting one of the buttons into Range("E12:E12")
b) manually assinging a .Top Left .Width .Height condition to it
However, I would prefer a flexible solution in which the buttons both stay in Range("D12:D12") but with a .Width of 50/50.
However, I would prefer a flexible solution in which the buttons both stay in Range("D12:D12") but with a .Width of 50/50.
Logic
The Width of both buttons becomes half.
The placement of the 2nd Button will be after the first button. Left of Button1 + Width of Button1.
Code
Is this what you are trying? Also since you are dealing with the same range then you do not need to Range_01 and Range_02. One will do.
Sub Move_Buttons()
Dim Range_01 As Range
Set Range_01 = Sheet1.Range("D12:D12")
With Sheet1.Buttons("Button 1")
.Top = Range_01.Top
.Left = Range_01.Left
.Width = Range_01.Width / 2 '<~~ This becomes half
.Height = Range_01.Height
End With
With Sheet1.Buttons("Button 2")
.Top = Range_01.Top
'~~> And this changes as mentioned above in the LOGIC section
.Left = Sheet1.Buttons("Button 1").Left + Sheet1.Buttons("Button 1").Width
.Width = Range_01.Width / 2 '<~~ This becomes half
.Height = Range_01.Height
End With
End Sub
I want to automatically insert a picture in cell AH32 depending on value in AB32.
I am able to insert the picture but not depending on the value in AB32. How do I fix this please?
Code:
Sub Picture()
Range("AH32").Select
Dim picname As String
If Range("AB32").Value < 85# Then
picname = "C:\Users\20149308\Desktop\sucess\images" & ".png" 'Link to the Picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
ElseIf Range("AB32").Value >= 85# Then
picname = "C:\Users\20149308\Desktop\sucess\succ" & ".jpg" 'Link to the Picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End If
Range("AH32").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End Sub
Here is one way of writing it in a more condensed form with some basic error checking.
Option Explicit
Sub Picture()
Application.ScreenUpdating = True
Dim testRange As Range
Dim picname As String
Set testRange = ActiveSheet.Range("AB32")
If IsEmpty(testRange) Then
MsgBox "No value in cell AB32"
Exit Sub
End If
Select Case True
Case Not IsNumeric(testRange.Value2)
MsgBox "Value in cell AB32 is not numeric"
Exit Sub
Case testRange.Value2 < 85#
picname = "C:\Users\20149308\Desktop\sucess\images" & ".png"
Case testRange.Value2 >= 85#
picname = "C:\Users\20149308\Desktop\sucess\succ" & ".jpg"
End Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End Sub
You can do this without any VBA using the Camera. You can find this by selecting File followed by Options and Customize Ribbon and adding the camera icon to your ribbon.
Create a blank worksheet and adjust the column width/row height so each of your pictures will sit within the boundaries of a cell (in my example I'm using B2 and B4).
Select one of these cells and click the camera icon to take a photo of it.
Switch to your reporting sheet and click on it to paste the photo you just took. You'll see a picture of the cell you originally clicked on within a picture frame that you can rotate and resize.
Paste your two pictures into the cells on the blank worksheet. The picture frame on the reporting sheet will now display whichever picture is in the cell you clicked on.
Create a named range using this formula (adjust sheet names to suit):
=IF(Sheet1!$AB$32<85,Sheet2!$B$2,Sheet2!$B$4) - absolute referencing is important here.
I called the range DisplayImage.
Select the picture frame and change the formula in the formula bar to =DisplayImage.
The image will now update based on the value in cell AB32.
I am unsuccessfully trying to adjust code that was created by a previous coworker. Currently we use this code below. It is attached to a button on an excel worksheet, this inserts an image into a specified range of cells, it resizes the image then lands on a cell below to type a description. The problem we are having is our template is now being moved from our server to outside locations. So all of the images are now just broken links. I have attempted several adjustments based on other posts, but none have been successful.
Private Sub Picture1_Click()
' Select Image From File
With Application.FileDialog(msoFileDialogFilePicker)
If .Show Then
PicLocation = .SelectedItems(1)
Else
PicLocation = ""
End If
End With
' Error Check
If PicLocation = "" Then
MsgBox "No picture selected"
Exit Sub
End If
'Initialization
Dim TargetCells As Range
ActiveSheet.Unprotect
Set TargetCells = Range("B9:H24")
' Error check 2
If PicLocation <> "False" Then
Set p = ActiveSheet.Pictures.Insert(PicLocation)
Else
Exit Sub
End If
' Set image dimensions
With p.ShapeRange
.LockAspectRatio = msoTrue
.Height = TargetCells.Height
If .Width > TargetCells.Width Then .Width = TargetCells.Width
End With
' Set image location
With p
.top = TargetCells.top
.Left = TargetCells.Left
.PrintObject = True
End With
' Close out operations
Range("a25").Select
Set p = Nothing
End Sub
I had the same issues when switching versions of Excel a few years ago. My macro now uses .Shapes.addPicture Modified a piece of your code below
If PicLocation <> "False" Then
Set p = ActiveSheet.Shapes.addPicture fileName:=PicLocation, linktofile:=False, savewithdocument:=True
Else
Exit Sub
End If
I am trying to resize the text box size using VBA. To do that I change the rectangle number in the VBA every time which is not serving the purpose of VBA.
I need to resize the selected text box based on value in other cells.
Sub ResizeTextBox()
Dim shp As Shape
Set shp = ActiveSheet.Shapes("Rectangle 39")
shp.Height = Application.CentimetersToPoints(Range("Y5").Value)
shp.Width = Application.CentimetersToPoints(Range("Y6").Value)
End Sub
How do I resize the selected text box based on value in cell Y5 and Y6?
You can do something like this:
Sub ResizeTextBox()
Dim shp As Shape
'check a range is not selected
If TypeName(Selection) <> "Range" Then
With Selection
.Height = Application.CentimetersToPoints(Range("Y5").Value)
.Width = Application.CentimetersToPoints(Range("Y6").Value)
End With
Else
MsgBox "First select a a shape for resizing"
End If
End Sub