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
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 have the following code to insert multiple images in selected range:
Private Sub CommandButton1_Click()
Dim sPicture, PhotoCell() As Variant, pic As shape
Dim PictCell As Range
Dim fname As String
Dim I, x As Integer
ActiveSheet.Unprotect Password:="123"
On Error Resume Next
PhotoCell() = Array("K6:P17", "A19:D29", "L19:P29", "A30:D40", "L30:P40", "A41:D51", "L41:P51")
sPicture = Application.GetOpenFilename _
("Pictures (*.jpeg; *.gif; *.jpg; *.bmp; *.tif; *.png), *.jpeg; *.gif; *.jpg; *.bmp; *.tif", 0, "Select Photo", "OK", True)
x = 0
If IsArray(sPicture) Then
For I = LBound(sPicture) To UBound(sPicture)
fname = sPicture(I)
If I Mod 2 = 1 Then
Set PictCell = ActiveSheet.Range(PhotoCell(x))
x = x + 1
Else
Set PictCell = ActiveSheet.Range(PhotoCell(x))
x = x + 1
End If
Set pic = ActiveSheet.Shapes.AddPicture(fname, msoFalse, msoCTrue, 0, 0, 100, 100)
pic.Delete
With pic
.LockAspectRatio = msoFalse
.Height = PictCell.Height
.Width = PictCell.Width
.Top = PictCell.Top
.Left = PictCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Next I
ActiveSheet.Protect Password:="123"
Else
MsgBox "No Picture Selected"
End If
End Sub
however, I have lost all image objects when inserting this command
pic.Delete
so actually I want to replace the old image in the selected range with the new image and make sure that the old image is completely deleted.
Try something like this:
Private Sub CommandButton1_Click()
Const PW As String = "123"
Dim sPictures, sPic, PhotoCell() As Variant, pic As Shape
Dim PictCell As Range
Dim fname As String
Dim x As Long, ws As Worksheet
Set ws = ActiveSheet
PhotoCell() = Array("K6:P17", "A19:D29", "L19:P29", "A30:D40", "L30:P40", "A41:D51", "L41:P51")
sPictures = Application.GetOpenFilename( _
"Pictures (*.jpeg; *.gif; *.jpg; *.bmp; *.tif; *.png), *.jpeg; *.gif; *.jpg; *.bmp; *.tif", 0, _
"Select Photo", "OK", MultiSelect:=True)
x = 0
If IsArray(sPictures) Then
ws.Unprotect PW
For Each sPic In sPictures
Set PictCell = ActiveSheet.Range(PhotoCell(x))
x = x + 1
RemovePicsInRange PictCell 'delete any existing shape in this range
With ws.Shapes.AddPicture(sPic, msoFalse, msoCTrue, 0, 0, 100, 100)
.LockAspectRatio = msoFalse
.Height = PictCell.Height
.Width = PictCell.Width
.Top = PictCell.Top
.Left = PictCell.Left
.Placement = xlMoveAndSize
End With
Next sPic
ActiveSheet.Protect Password:=PW
Else
MsgBox "No Picture Selected"
End If
End Sub
'Delete any shapes whose TopLeftCell intersects with range `rng`
Sub RemovePicsInRange(rng As Range)
Dim i As Long, allPics
Set allPics = rng.Parent.Shapes
For i = allPics.Count To 1 Step -1
If Not Application.Intersect(allPics(i).TopLeftCell, rng) Is Nothing Then
Debug.Print "Deleting shape at " & allPics(i).TopLeftCell.Address
allPics(i).Delete
End If
Next i
End Sub
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
I have a situation at work where people have to manually introduce pictures in a certain page of excel and resize it also manually. As a complete very beginner I've managed to find some VBA code to help introduce the picture by clicking a button and inserting it in a certain range of cells. The problem that I have is that I cannot figure out (after searching many posts) how to correctly introduce the function to save the image without making a link to it so others can see the report without getting an error that the picture doesn't exist.
Can you kindly help me and complete where the function should be introduced?
Private Sub CommandButton3_Click()
Dim strFileName As String
Dim objPic As Picture
Dim rngDest As Range
strFileName = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select an image...")
If strFileName = "False" Then Exit Sub
Set rngDest = Me.Range("B24:C26")
Set objPic = Me.Pictures.Insert(strFileName)
With objPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = rngDest.Left
.Top = rngDest.Top
.Width = rngDest.Width
.Height = rngDest.Height
End With
End Sub
Thanks in advance!
Try this:
Private Sub CommandButton3_Click()
Dim strFileName As String
Dim objPic As Shape '<<<
Dim rngDest As Range
strFileName = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select an image...")
If strFileName = "False" Then Exit Sub
Set rngDest = Me.Range("B24:C26")
Set objPic = Me.Shapes.AddPicture(Filename:=strFileName, _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=rngDest.Left, Top:=rngDest.Top, _
Width:=rngDest.Width, Height:=rngDest.Height)
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