I'm working on a project using VBA with Excel. By clicking a button, we generate an array. One line refers to one product. The information is stored in each column (column A = reference, column B = name...). The generation is made with some code using VBA.
The problem concerns the pictures. I managed the shape of the pictures, so they are placed in the cell, with a certain height, width, placement...
When I generate the array from my computer, there's no problem, the pictures are placed perfectly.
When the array is generated from another computer, the pictures look stretched and shifted. That's it from the 12th line to the end (but the first 11 lines are okay). I don't understand why it starts from the 12th line because the code is exactly the same for every line of the array. And above all, I don't understand why the array isn't well generated on every computer.
The Excel version is the same and the pictures options too.
Have you heard about something like that?
Thanks a lot for your comments!
Here's the code:
Function SetImageViewer(Ref As String, Cell As Range) As String
Dim cmt As Comment
Dim sPicName As String
Dim ImageCell As Range
Dim OrderFormWS As Worksheet
sPicName = GetParameter("PicturesPath") & "\" & Ref & ".jpg"
Set ImageCell = Cell.MergeArea
Set OrderFormWS = ThisWorkbook.Sheets("OrderForm")
sPicFile = Dir(sPicName)
If sPicFile <> vbNullString Then
Set Pic = OrderFormWS.Shapes.AddPicture(sPicName, linktofile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=0, Top:=0, Width:=0, Height:=0)
With Pic
.LockAspectRatio = msoTrue
.Left = ImageCell.Left + 5
.Top = ImageCell.Top + 5
.Width = 40
.Height = 40
.Placement = xlMoveAndSize
End With
Set cmt = Cell.Comment
If cmt Is Nothing Then Set cmt = Cell.AddComment()
cmt.Text " "
cmt.Shape.Fill.UserPicture sPicName
cmt.Shape.Height = 300
cmt.Shape.Width = 300
SetImageViewer = ChrW(&H25BA)
Else
Set cmt = Cell.Comment
If Not cmt Is Nothing Then cmt.Delete
SetImageViewer = "No picture"
End If
End Function
Related
So, I'm trying to create "cards" that the user can move around even when the the workbook is locked. Each card will contain info about a certain project.
The way I'm doing it:
Create a few shapes (an rectangle and a few labels and icons)
Group them
Cut the group
Paste as image
The problem is that when I paste as image, all labels loose their text, they change back to "label1".
If I run the code line by line, they don't lose the text.
I've tried already to add "time" between the cut and paste, adding some lines of code, moving the paste line to a separated sub, and even using Application.Wait(), but nothing worked.
I need to have them as an image (or one solid object - just a group doesn't work), because after the macro is finished, the worksheet is locked back again, and there is another macro to allow the user to move shapes even when the workbook is locked.
Here is a sample to show the problem.
Sub MyCode()
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
'Just two labels as exemple, the original code has more labels, more icons, and the rounded rectangle)
'The values for the constructors in the original code are defined by the user by a forms
Call GenerateLabel("plaseWork", "Name of the project", 14, 30)
Call GenerateLabel("whyCantYouJustWork", "Name of the user", 42, 30)
wsm.Shapes.Range(Array("plaseWork", "whyCantYouJustWork")).Group.Name = "myGroup"
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
Application.CutCopyMode = False
wsm.Shapes("myGroup").Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Application.CutCopyMode = False
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
Sub GenerateLabel(labelDescription As String, projectName As String, top As Integer, left As Integer)
Set lbLabel = wsm.OLEObjects.Add(ClassType:="Forms.Label.1")
With lbLabel
.Name = labelDescription
.Object.BackStyle = fmBackStyleTransparent
.Width = 160
.top = top
.left = left
End With
With wsm
.OLEObjects(lbLabel.Name).Object.Caption = projectName
.Shapes(lbLabel.Name).Fill.Transparency = 1
End With
End Sub
What about using shapes with no outline or fill, in place of labels?
Sub MyCode()
Dim wsm As Worksheet, arr(0 To 1), grp As Shape
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
arr(0) = AddLabel(wsm, "Name of the project", 14, 30).Name
arr(1) = AddLabel(wsm, "Name of the user", 42, 30).Name
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
wsm.Shapes.Range(arr).Group.Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
'Add a shape to a worksheet, with the text provided.
' Return the added shape
Function AddLabel(ws As Worksheet, projectName As String, top As Integer, left As Integer)
Dim shp
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 160, 30)
With shp
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
With .TextFrame2.TextRange.Characters
.Text = projectName
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 14
End With
End With
Set AddLabel = shp
End Function
This question already has answers here:
How to resize all images on a worksheet?
(2 answers)
Closed 3 years ago.
Ok i have an image that a 3rd part software is placing into an excel file. in order to get the resolution needed it has to be sized much larger than needed. It will always be placed in the same location and be a specific size. I need to resize it. Ideally it would be automatic when the excel file opens but i think any vba code would end up acting before the information is inserted, but if there was a small delay that would be cool too. Alternatively i could make do with a button that runs a bit of code. The code below works, but only when the picture is specifically named "Picture 179" which it won't be ever again or at least until the counter recycles.
The image is inserted at Cell A45 specifically but it extends through roughly cell AZ60.
Here is what i've got that doesn't work.
Private Sub Resize_Graph_Click()
ActiveSheet.Shapes.Range(Array("Picture 179")).Select
Selection.ShapeRange.Height = 104.4
Selection.ShapeRange.Width = 486.72
End Sub
You still need to work out when to resize the picture, but the example code below shows how you can specifically access a picture where the Top-Left corner of the picture is located within a given cell.
Option Explicit
Sub TestMe()
Dim thePicture As Shape
Set thePicture = GetPictureAt(Range("A45"))
If Not thePicture Is Nothing Then
Debug.Print "found it! (" & thePicture.Name & ")"
With thePicture
.Height = 75
.Width = 75
Debug.Print "resized to h=" & .Height & ", w=" & .Width
End With
Else
Debug.Print "couldn't find the picture!"
End If
End Sub
Private Function GetPictureAt(ByRef thisCell As Range) As Shape
Dim thisCellTop As Long
Dim thisCellBottom As Long
Dim thisCellLeft As Long
Dim thisCellRight As Long
With thisCell
thisCellTop = .Top
thisCellLeft = .Left
thisCellBottom = thisCellTop + .Height
thisCellRight = thisCellLeft + .Width
End With
Dim shp As Variant
With Sheet1
For Each shp In .Shapes
If shp.Type = msoPicture Then
If (shp.Top >= thisCellTop) And (shp.Top <= thisCellBottom) Then
If (shp.Left >= thisCellLeft) And (shp.Left <= thisCellRight) Then
Set GetPictureAt = shp
Exit Function
End If
End If
End If
Next shp
End With
End Function
Here is what i settled on.
Private Sub Resize_Graph_Click()
'resize all shapes
Dim s As Shape
Dim ws As Worksheet
Set ws = ActiveSheet
For Each s In ActiveSheet.Shapes
s.LockAspectRatio = msoFalse
s.Width = 491.72
s.Height = 106.56
Next s
'set header shapes and button back to original size
ActiveSheet.Shapes.Range(Array("Company Label")).Select
Selection.ShapeRange.Height = 43.92
Selection.ShapeRange.Width = 131.76
ActiveSheet.Shapes.Range(Array("Product Label")).Select
Selection.ShapeRange.Height = 49.68
Selection.ShapeRange.Width = 134.64
ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
ActiveSheet.Shapes("Resize_Graph").Height = 38.16
ActiveSheet.Shapes("Resize_Graph").Width = 105.12
'keep button from moving after changing shape back and forth
ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
ActiveSheet.Shapes("Resize_Graph").Left = 380
ActiveSheet.Shapes("Resize_Graph").Top = 5
ActiveWorkbook.Close Savechanges:=True
End Sub
I get an excel report each week with images in the comments.
I am trying to loop through all comments in the file, and paste all the comments to the worksheet as pictures
I have tried the method found on the "Ku Tools" website...
https://www.extendoffice.com/documents/excel/4328-excel-extract-image-from-comment.html
Here is the code from the website (that i use exactly)...
Sub CommentPictures()
'Updateby Extendoffcie 20161207
Dim cmt As Comment
Dim xRg As Range
Dim visBool As Boolean
Dim cmtTxt As String
Dim jpgPath As String
Dim shpHeight As Integer, shpWidth As Integer
Application.ScreenUpdating = False
For Each cmt In ActiveSheet.Comments
With cmt
cmtTxt = .Text
shpHeight = .Shape.Height
shpWidth = .Shape.Width
.Text Text:="" & Chr(10) & ""
visBool = .Visible
.Visible = True
On Error Resume Next
Set xRg = .Parent.Offset(0, 1)
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
xRg.PasteSpecial
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Width = xRg.Width
Selection.Height = xRg.Height
.Visible = visBool
.Text Text:=cmtTxt
End With
Next cmt
Application.ScreenUpdating = True
End Sub
When I use this code, it works sporadically
When it "doesn't work", the macro creates an invisible rectangle object
When it does work, it creates a visible rectangle image/object (rectangle shape that can be seen).
In the below screenshot, row 715 contains a visible image (when the macro works right) and row 755 contains an invisible image (when it doesn't work right)
Visible vs Non-Visible
I want to make all 700+ image comments actual images as easily as possible, if anyone has any ideas, they would be greatly appreciated.
My hypothesis is that there might be a size limit, because the macro worked perfectly when I ran it in a small batch of a couple dozen images
Thanks
I've looked around on a few different ways to insert .jpg by a macro and there seem to be few, but some different ways. I tried to follow this helpful guide, but are unsuccessful.
MY macro doesn't find the image location. I want the macro to look for images saved in a folder named "Pictures" in the same location the current workbook, compare it to references in column A and insert in column B if match.
I get this error message: "Unable to get the insert property of the Pictures class." Does mean my link is wrong?
As you can see (Worksheet) my references are in Column A, starting at A7, but I have merged cells(A7:A16), so the next reference is in A18, A29.. etc.
ex.
Any help appreciated. Thanks.
Sub ImageMacro()
'Used to import picture files from a pre-sorted file. (Each picture must have a unique name, duplicates removed).
'Sub Picture()
Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Integer
lThisRow = 7
Do While (Cells(lThisRow, 1) <> "")
'Range("B7").Select 'This is where picture will be inserted
pasteAt = Cells(lThisRow, 2)
' Cells(pasteAt, 2).Select 'This is where picture will be inserted (IS THIS A DUPLICATE OF ABOVE?)
'Dim picname As String
'picname = Range("A7") 'This is the picture name
picname = Cells(lThisRow, 1) 'This is the picture name
ActiveSheet.Pictures.Insert("smb://pnld-svr-02._smb._tcp.local/Business Administration/Staff Folders/Ida Moe Evensen/0000 Templates/Pictures/" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
lThisRow = lThisRow + 11
Loop
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End Sub
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If