Hi i'm making sheet in VBA and I need to fit my open picture to cell from A:59 to F59, i tried change Width and height but it doesn't work nice for me.
Code:
Sub CommandButton1_Click()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
If fNameAndPath = False Then Exit Sub
'Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
With img
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 125
.Height = 225
End With
.Left = ActiveSheet.Cells(59, 1).Left
.Top = ActiveSheet.Cells(59, 1).Top
.Placement = 1
.PrintObject = True
End With
End Sub
you can simply achieve this using range
.Left = ActiveSheet.Range("B59").Left
.Top = ActiveSheet.Range("F59").Top
Related
I am using the following code to add a picture and load an image in it on worksheet.
Sub Test()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddPicture("Sample.jpg", msoFalse, msoTrue, 100, 100, 100, 100)
shp.Name = "MyPhoto"
End Sub
How can I unload the picture from the shape?
I tried these lines but none worked for me
Sub Unload_Picture()
Dim shp As Shape
Set shp = ActiveWorkbook.Sheets(1).Shapes("MyPhoto")
'shp.Picture = Nothing
'shp.Picture = LoadPicture("")
End Sub
Add image control with vba
Sub ImageCTRL()
Dim Img As OLEObject, pic As MSForms.Image
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Set Img = .OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=20, Top:=20, Width:=400, Height:=400)
With Img
.Name = "MyImg"
Set pic = Img.Object
pic.Picture = LoadPicture("C:\Users\yourpic.pdf Page 1 image 1.jpeg")
End With
End With
End Sub
To change the picture in the control.
Sub changeImg()
Me.MyImg.Picture = LoadPicture("C:\Users\otherpic.jpg")
End Sub
I have these codes in the worksheet module.
The image control has an autofit feature, check the cntrl properties window.
You can also resize the control to a specified size, same as when you added it.
Sub changeImg()
Me.MyImg.Picture = LoadPicture("C:\Users\newPic.jpeg")
With Me.MyImg
.Top = 20
.Left = 20
.Width = 400
.Height = 400
End With
End Sub
I am relatively new to VBA so perhaps there is a simple solution to this? I am using the code below to import multiple pictures into a column. However, I need to center the pictures in their cells too. Is there a way to alter the current code? Which works great! (except the pictures are not centered).
Thank you
Sub InsertMultipleRGPictures()
Dim Pictures() As Variant
Dim PictureFormat As String
Dim PicRng As Range
Dim PicShape As Shape
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Sheets("Auto Post").Range("AZ3:AZ9").Select
Columns("AZ:AZ").ColumnWidth = 57
Set xRg = Range("AZ3:AZ14")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
Next
On Error Resume Next
PictureFormat = "Test Files (*.png; *.jpeg), *.png; *.jpeg"
Pictures = Application.GetOpenFilename(PictureFormat, MultiSelect:=True)
PicColIndex = Application.ActiveCell.Column
If IsArray(Pictures) Then
PicRowIndex = Application.ActiveCell.Row
For lLoop = LBound(Pictures) To UBound(Pictures)
Set PicRng = Cells(PicRowIndex, PicColIndex)
With ActiveSheet.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, msoFalse, msoCTrue, PicRng.Left, PicRng.Top, -1, -1)
.LockAspectRatio = msoTrue
.Height = 250 * 3 / 4
Rng.RowHeight = .Height
Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
End With
PicRowIndex = PicRowIndex + 1
Next
MsgBox "Import Complete- Pictures"
End If
Columns("AZ:AZ").ColumnWidth = 50
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
End Sub
Please bear with me, I'm new to code, I'm trying to embed an image in an excel file, however it keeps crapping out on me when I run this code. I have searched form after form and cannot find the answer.
'Import Image
Sub GetPic()
Dim fNameAndPath As String
Dim img As Object
ChDir ActiveWorkbook.Path
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
'set img line is highlighted hovering displays a message. img = nothing
Set img = ActiveSheet.Shapes.AddPicture(Filename:=fNameAndPath, Pathlinktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
With img
'Move and Resize Image
img.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Left = ActiveSheet.Range("H10").Left
Selection.Top = ActiveSheet.Range("H10").Top
Selection.Width = ActiveSheet.Range("H10:O10").Width
Selection.Height = ActiveSheet.Range("H10:O24").Height
End With
End Sub
This code is tested and works:
'Import Image
Sub GetPic()
Dim fNameAndPath As String
Dim img As Object
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
With img
'Move and Resize Image
.ShapeRange.LockAspectRatio = msoFalse
.Left = ActiveSheet.Range("H10").Left
.Top = ActiveSheet.Range("H10").Top
.Width = ActiveSheet.Range("H10:O10").Width
.Height = ActiveSheet.Range("H10:O24").Height
End With
End Sub
Try this
Sub GetPic()
Dim fNameAndPath As String
Dim img As Excel.Shape
ChDir ActiveWorkbook.Path
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
Set img = ActiveSheet.Shapes.AddPicture( _
fNameAndPath, msoFalse, msoCTrue, ActiveSheet.Range("H10").Left, _
ActiveSheet.Range("H10").Top, ActiveSheet.Range("H10:O10").Width, _
ActiveSheet.Range("H10:O24").Height)
img.LockAspectRatio = msoFalse
'Just for fun:
img.IncrementRotation 45
End Sub
I'm using the following script to automatically insert a signature PDF image into a document to act as a signature. However when the pdf is inserted is automatically puts a border on the image which i don't want. how can i amend the format of the object to have no borders or lines.
I have tried using 'ActiveSheet.Shapes.Line.Visible = msoFalse' but this doesn't work.
Option Explicit
Sub Insert_signature()
' this part of the script creates a temp filename in the temp folder.
Dim strPathname As String
On Error Resume Next
strPathname = "http://Clearance Handover/Forms/Signature.pdf"
'MsgBox = ("you are formally authorising the sign off")
Call insert_pdf_to_Checklist1(strPathname)
End Sub
Sub insert_pdf_to_Checklist1(pdfpath As String)
Dim Xl, Ws, Ol
' This creates an image of the pdf created and
Set Ws = ActiveWorkbook.Worksheets("Checklist1")
Set Ol = Ws.OLEObjects.Add(, pdfpath, False, False)
With Ol
.Left = Ws.Range("E48:E48").Left
.Height = Ws.Range("E48:E48").Height
.Width = Ws.Range("E48:E48").Width
.Top = Ws.Range("E48:E48").Top
End With
End Sub
Cheers Guys!
Below Code should work :) . Tested
Option Explicit
Sub Insert_signature()
Dim strPathname As String
strPathname = "C:\Users\ksathis\Documents\Outlook Files\VBASQL.pdf"
Call insert_pdf_to_Checklist1(strPathname)
End Sub
Sub insert_pdf_to_Checklist1(pdfpath As String)
Dim Xl, Ws
Dim ole As OLEObject
Set Ws = ActiveWorkbook.Worksheets("Checklist1")
Set ole = Ws.OLEObjects.Add(, pdfpath, False, False)
With ole
.Left = Ws.Range("E48:E48").Left
.Height = Ws.Range("E48:E48").Height
.Width = Ws.Range("E48:E48").Width
.Top = Ws.Range("E48:E48").Top
.Interior.Color = vbWhite
.Border.LineStyle = 0
.Border.Color = vbWhite
End With
End Sub
I would like to paste an image into a powerpoint slide, and then resize it once I have it pasted,
I dont know the image idex so it needs to be able to be resized immediately afterr being pasted
below doesnt work, please can someone help
Sub PasteOnSlide()
Dim strPresPath As String
strPresPath = "c://myfile"
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
oPPTFile.Slides(4).Shapes.PasteSpecial(ppPasteEnhancedMetafile).select
With Selection
.Height = 270
.Width = 680
.Left = 20
.Top = 120
.ZOrder msoSendToBack
End With
End Sub
i also tried:
set MyShape = oPPTFile.Slides(4).Shapes.PasteSpecial(ppPasteEnhancedMetafile).select
With MyShape
.Height = 270
.Width = 680
.Left = 20
.Top = 120
.ZOrder msoSendToBack
End With
End Sub
Oh so close...
Avoid useing Select, (and declare all your variables!)
Sub PasteOnSlide()
Dim strPresPath As String
Dim MyShape As Shape
Dim oPPTFile As Presentation
Dim oPPTApp As Application
Set oPPTApp = Application
strPresPath = "c://myfile"
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
Set MyShape = oPPTFile.Slides(4).Shapes.PasteSpecial(ppPasteEnhancedMetafile).Item(1)
With MyShape
.Height = 270
.Width = 680
.Left = 20
.Top = 120
.ZOrder msoSendToBack
End With
End Sub
You should add error handling, including to cover the case where there is nothing in the clipboard to paste, or where strPresPath does not point to an existing presentation file.