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
Related
Hi there I have the code below which calls "Delete_Image_Click" and deletes the shape in a specified cell range and then inserts a new image from a selected filepath into the same cell range.
I need to then delete images in other ranges (on the same worksheet and other worksheets) and then add the same image into the other cell ranges on the same worksheet and then go into another named worksheet and insert the same image into two more ranges.
Could anyone help me with how I go about this?
Sub RectangleRoundedCorners6_Click()
Call Delete_Image_Click
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png), *.gif;*.png; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoTrue
.Height = Range("Q36:W41").Height
.Top = Range("Q36:W41").Top
.Left = Range("Q36:W41").Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
Sub Delete_Image_Click()
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Application.ScreenUpdating = False
Set xRg = Range("Q36:W41")
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
Application.ScreenUpdating = True
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
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("D2:D3")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("D2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
Mostly, the stated code can help me to transfer the urls to images. But some urls won't work.
such as this link:
https://www.revolvecn888.com/images/p4/n/d/AGOL-WJ95_V1.jpg
it can not be transfered to images.
I want to disable buttons after they are clicked in Excel 2013.
My code works fine but for just one specific button.
How can apply the same logic to all buttons in a Sheet?
ActiveSheet.Shapes("Button 1").OnAction = Empty
ActiveSheet.Shapes("Button 1").DrawingObject.Font.ColorIndex = 16
It's not clear from your question whether you want pressing Button1 to "disable" all controls on the sheet, or whether you want each button to disable itself.
Button1 disables all controls
Sub Button1_Click
Dim shp As Shape
For Each shp In Sheet1.Shapes
With shp
If .Type = msoFormControl Then
.OnAction = ""
.DrawingObject.Font.ColorIndex = 16
End If
End With
Next shp
End Sub
Each button disables itself
Use a common button disabler helper procedure...
Sub Button1_Click()
DisableButton Sheet1, "Button 1"
End Sub
Sub Button2_Click()
DisableButton Sheet1, "Button 2"
End Sub
Sub DisableButton(hostSheet As Worksheet, shapeName As String)
Dim shp As Shape
On Error Resume Next
Set shp = hostSheet.Shapes(shapeName)
On Error GoTo 0
If Not shp Is Nothing Then
With shp
If .Type = msoFormControl Then
.OnAction = ""
.DrawingObject.Font.ColorIndex = 16
End If
End With
End If
End Sub
I would guess this is what you're looking for:
Sub Answer()
dim sh as shape
For Each Sh In ActiveSheet.Shapes
Sh.OnAction = Empty
Sh.DrawingObject.Font.ColorIndex = 16
Next
End Sub
This should hide all form control (including buttons) in the worksheet.
Dim ws_export As Worksheet
Dim shp_hide As Shape
For Each shp_hide In ws_export.Shapes
If shp_hide.Type = msoFormControl Then shp_hide.Visible = FALSE
Next shp_hide
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