Sub InsertLogo1()
ActiveCell.Select
ActiveSheet.Pictures.Insert("Path").Select
End Sub
Dim Pic As Object
Set Pic = ActiveSheet.Pictures.Insert(Directory & "\" & filename)
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.LockAspectRatio = msoTrue
.Width = 225#
End With
Related
I want to insert an image on every page.
I know that the command is Next in a For loop.
Sub InsertImage()
Dim oILS As InlineShape, oShp As Shape
Set oILS = Selection.InlineShapes.AddPicture(FileName:= _
"C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png", LinkToFile:=False, _
SaveWithDocument:=True)
Set oShp = oILS.ConvertToShape
With oShp
.WrapFormat.Type = wdWrapBehind
.Left = -55
.Top = 471.1
.Height = 21.5
.Width = 522
End With
End Sub
Well, I found the way to do it on all pages. If it helps anyone, here it is:
Sub Demo()
Dim Rng As Range, i As Long, Shp As Shape, ImageName As String
ImageName = "C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png"
With ActiveDocument
Set Rng = .Range(0, 0)
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = Rng.GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
Rng.Collapse wdCollapseStart
Set Shp = .InlineShapes.AddPicture(FileName:=ImageName, SaveWithDocument:=True, Range:=Rng).ConvertToShape
With Shp
.Left = -55
.Top = 471.1
.Width = 522
.Height = 21.5
.WrapFormat.Type = wdWrapBehind
End With
Next
End With
End Sub
To get around the fact that the manual way to insert a pdf in a word don't give really good quality result.
I'm trying to insert pictures that have been nicely converted from a pdf to png with Imagemagick in a word with a macro.
The moment where i struggle is when i want the picture to get in a middle of each page and don't overlap each over.
I come up with this but i don't understand why it seems that AllowOverlap and wdShapeCenter do nothing while wdWrapTopBottom work properly. The picture get stuck to the top-left corner'
Sub Test()
Dim objShape As Shape
strPath = "Some.png"
'insert the image
Set objShape = ActiveDocument.Shapes.AddPicture( _
FileName:=strPath, LinkToFile:=False, _
SaveWithDocument:=True)
objShape.WrapFormat.AllowOverlap = False
objShape.Top = WdShapePosition.wdShapeCenter
objShape.WrapFormat.Type = wdWrapTopBottom
End Sub
I tried to use Selection.InlineShapes.AddPicture to resolve the overlap problem but i can't get the picture move from the top-left corner neither.
Thanks for your help
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Shp As Shape
With Dialogs(wdDialogInsertPicture)
.Display
If .Name <> "" Then
Set Shp = ActiveDocument.Shapes.AddPicture(FileName:=.Name, _
LinkToFile:=False, SaveWithDocument:=True, Anchor:=Selection.Range)
With Shp
.LockAspectRatio = True
.Height = InchesToPoints(2)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Top = wdShapeCenter
.WrapFormat.AllowOverlap = False
End With
End If
End With
Application.ScreenUpdating = True
End Sub
With the above code, the inserted pic will be positioned in the center of the page. If there's already one centered there, the existing pic will be pushed down.
In light of your additional information, you should use something like:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape, sWdth As Single, sHght As Single
With Dialogs(wdDialogInsertPicture)
.Display
If .Name <> "" Then
Set Shp = .InlineShapes.AddPicture(FileName:=.Name, _
LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range)
With ActiveDocument.PageSetup
sWdth = .PageWidth - .LeftMargin - .RightMargin
sHght = .PageHeight - .TopMargin - .LeftMargin
End With
With iShp
.LockAspectRatio = True
.Width = sWdth
If .Height > sHght Then .Height = sHght
End With
End If
End With
Application.ScreenUpdating = True
End Sub
Finaly with your help I come up with this.
It center and place on it's own page pictures from a Folder.
Sub Folder_Picture_To_Word()
Dim shp As Shape
Dim intResult As Integer
Dim strPath As String
Dim strFolderPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
'dispaly message box
strFolderPath = Application.FileDialog(msoFileDialogFolderPicker _
).SelectedItems(1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strFolderPath)
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'get file path
strPath = objFile.Path
Selection.InsertAfter ChrW(12)
'insert the image
Set shp = ActiveDocument.Shapes.AddPicture(FileName:=strPath, _
LinkToFile:=False, SaveWithDocument:=True, Anchor:=Selection.Range)
With shp
'.LockAspectRatio = True
'.Height = InchesToPoints(8)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Top = wdShapeCenter
.WrapFormat.Type = wdWrapTopBottom
.WrapFormat.AllowOverlap = False
End With
'Go to next Page to get ready for a new picture
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
Next objFile
Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious 'Go to second last page
'To delete the extra jump page made in the loop
Selection.Delete
End If
End Sub
I would like to move a photo to the bottom of cell but it does not work please help me?
.Top = Target.Top -> .Bottom = Target.Bottom
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Or Target.Row = 1 Then Exit Sub
On Error Resume Next
Target(, 2).Worksheet.Shapes(Target.Address).Delete
On Error GoTo Thoat
Copy_Images Target.Value
ActiveSheet.PasteSpecial
With Selection
.Name = Target.Address
.Top = Target.Top
.Left = Target(, 2).Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = Target.Height
.ShapeRange.Width = Target(, 2).Width
End With
Thoat:
Target.Offset(1, 0).Select
End Sub
Private Sub Copy_Images(imageName As String)
Dim sh As Shape
For Each sh In Sheets(2).Shapes
If sh.Name = imageName Then
sh.Copy
'Sheets(1).Pictures.Paste
End If
Next
End Sub
Thanks!
I want to Resize Column to Fit Picture please help me:
With Selection
.Name = Target.Address
.Top = Target.Top
.Left = Target(, 2).Left
.ShapeRange.LockAspectRatio = msoFalse
'.ShapeRange.Height = Target.Height
'.ShapeRange.Width = Target(, 2).Width
End With
There's no Bottom property, so you need something like
.Top = Target.Top + Target.Height
I've been working on a macro that will add an image into a cell if the cell contains an image name (image1.png) that is in a specified directory. So if it finds "image1.png" in the directory it adds the image to the cell and moves to the next row. Here is the code thus far:
Option Explicit
Sub insertPicss()
Dim ws As Worksheet, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim fPath, fDir As String
fDir = "Macintosh HD:Users:Connor:Desktop:siteimages:"
For Each cell In ws.[A1:A12]
fPath = fDir & cell.Value
With ws.Pictures.Insert(fPath)
With .ShapeRange
.Width = 48
.Height = 48
End With
.PrintObject = True
.Top = cell.Top
.Left = cell.Left
End With
Next
End Sub
The issue it stops at a row that does not have an image name that is located in the directory it is looking at.
Is there a way to skip the row if it doesn't have that image in the corresponding directory and make it to the end of all the rows.
In Windows, use Dir to check if a file/folder exists.
Below works for Windows, but not sure about Mac.
Option Explicit
Sub insertPicss()
Dim ws As Worksheet, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim fPath, fDir As String
fDir = "Macintosh HD:Users:Connor:Desktop:siteimages:"
For Each cell In ws.[A1:A12]
fPath = fDir & cell.Value
If Dir(fPath) = cell.Value Then ' If Not Dir(fPath) = "" Then
With ws.Pictures.Insert(fPath)
With .ShapeRange
.Width = 48
.Height = 48
End With
.PrintObject = True
.Top = cell.Top
.Left = cell.Left
End With
End If
Next
End Sub
I am placing picture in my worksheet using a URL. The code works great except "on error resume next" places the previous cell's (good) value in the cell where the error occurred instead of the cell it should (one row up). It then continues placing values where they belong until there is another error.
I have tried placing the "on error resume next" in different areas of the code, but haven't been able to fix the issue. Is it a matter of where the error handling is placed, or do I need to have a better error handler?
Thank you,
Andy
Sub InsertPic()
On Error Resume Next
Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim cl As Range
Set rng = Range("F2:F1131")
For Each cl In rng
pic = cl.Offset(0, -1)
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
Next
End Sub
If you need to check if the URL exists then maybe a helper function will suffice?
Sub InsertPic()
Dim pic As String
Dim myPicture As Picture
Dim rng As Range 'E3:E1132
Dim cl As Range 'iterator
Set rng = Range("F2:F1131")
For Each cl In rng
pic = cl.Offset(0, -1)
if URLExists(pic) then
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
end if
Next
End Sub
'ref: http://www.mrexcel.com/forum/excel-questions/567315-check-if-url-exists-so-then-return-true.html
Function URLExists(url As String) As Boolean
Dim Request As Object
Dim ff As Integer
Dim rc As Variant
On Error GoTo EndNow
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
With Request
.Open "GET", url, False
.Send
rc = .StatusText
End With
Set Request = Nothing
If rc = "OK" Then URLExists = True
Exit Function
EndNow:
End Function