I have the following macro which is supposed to create a box linking to a certain worksheet in the workbook, on each sheet of the workbook:
Option Explicit
Sub gndhnkl()
Dim ws As Worksheet
Dim sh As Shape
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, "Summering", vbBinaryCompare) <= 0 Then
For Each sh In ws.Shapes
sh.Delete
Next sh
Call Macro1(ws)
End If
Next ws
End Sub
Sub Macro1(ws As Worksheet)
Dim venstre As Double, topp As Double, breidde As Double, høgde As Double
Dim sh As Shape
venstre = ws.Range("B16").Left
topp = ws.Range("B16").Top
breidde = 110
høgde = 68
Set sh = ws.Shapes.AddShape(msoShapeRoundedRectangle, venstre, topp, breidde, høgde)
With sh.TextFrame2.TextRange
.Characters.Text = "Til summering, person"
.Font.Size = 13
.ParagraphFormat.Alignment = msoAlignCenter
.Parent.VerticalAnchor = msoAnchorMiddle
End With
ws.Hyperlinks.Add Anchor:=sh, Address:="", SubAddress:=Replace(Summering_person.Range("A1").Address(external:=True), "[" & ThisWorkbook.Name & "]", "", 1, -1, vbBinaryCompare)
End Sub
For the most part it works just like I expect it too, but for some reason the font size in the added shape is not set to 13 as I expect, but remains 11.
I.e. it seems that the line .Font.Size = 13 (sh.TextFrame2.TextRange.Font.Size = 13) is not executed.
Where is my mistake here, and what do I need to do in order for the macro to set the font size for the shape?
You have to change the order, first set the font size (and any other font properties) before you write the text. Once the text is set, it's getting trickier to change the font - every character of the TextFrame may have it's own characteristics.
.Font.Size = 13
.Characters.Text = "Til summering, person"
Update The comment of SJR is right, when using the TextFrame rather than TextFrame2, you can set the font properties of the whole text as once after the text was written.
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
First of all I'm not very good at Excel macro.
After going through multiple forums, I managed to come up with a code to Crop images in a folder using Excel VBA.
the code opens up each image in Excel, paste in a chart, crop the image, resize to match the height & width and then replace the original image with the edited image.
Macro is working fine with F8 but when I run the macro fully, Images are not getting replaced with the edited one, instead it's replacing with blank image.
After digging through multiple options, the only conclusion I came up with is the macro is running fine in Excel 2013 but it's not running properly with office 365.
Can anybody help me, how to resolve this or have any better code to run?
Option Explicit
Sub ImportData()
Dim XL As Object
Dim thisPath As String
Dim BooksPAth As String
BooksPAth = "C:\Images\"
thisPath = ActivePresentation.path
Set XL = CreateObject("Excel.Application")
Run "Crop_vis", BooksPAth
End Sub
Sub DeleteAllShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
Next Shp
End Sub
Sub Crop_Vis(ByVal folderPath As String)
Dim Shp As Object, path As String, sht As Worksheet, s As Shape, TempChart As String
'Dim folderPath As String
Application.ScreenUpdating = True
If folderPath = "" Then Exit Sub
Set sht = Sheet1
sht.Activate
sht.Range("A10").Activate
path = Dir(folderPath & "\*.jpg")
Do While path <> ""
DeleteAllShapes
Set Shp = sht.Pictures.Insert(folderPath & "\" & path)
' Use picture's height and width.
Set s = sht.Shapes(sht.Shapes.Count)
s.PictureFormat.CropTop = 50
s.Width = 768
s.Height = 720
'Add a temporary chart in sheet1
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=sht.Name
Selection.Border.LineStyle = 0
TempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With sht
'Change the dimensions of the chart to suit your need
With .Shapes(TempChart)
.Width = s.Width
.Height = s.Height
End With
'Copy the picture
s.Copy
'Paste the picture in the chart
With ActiveChart
.ChartArea.Select
.Paste
End With
'Finally export the chart
.ChartObjects(1).Chart.Export fileName:=folderPath & "\" & path, FilterName:="jpg"
'Destroy the chart. You may want to delete it...
.Shapes(TempChart).Cut
End With
path = Dir
Loop
DeleteAllShapes
Application.DisplayAlerts = False
End Sub
Before
'Finally export the chart
insert something like this, to make sure that pasting of the image into the chart has finished:
Do
If ActiveChart.Shapes.Count > 0 Then
Exit Do
End If
Loop
The problem is with the pasting. When you tell it to paste the clipboard (image) into the chart, sometimes it ignores you. When you go to export the chart, you end up with an empty image.
It's not that you have to wait for it to paste, because it's not going to - it ignored you. I have no idea why it ignores you, or why it doesn't error out when it ignores you - it just ignores you with no warning. Maybe Windows is just too busy under the hood to paste.
Basically, what you have to do is check to see if it pasted, and if not, paste again....and again....until it finally sees fit to process your instruction.
I debugged, Googled, trialed and errored and banged my head on the wall for week on this and finally ended up with this:
Sub SavePictureFromExcel(shp As Shape, SavePath As String)
Dim Imagews As Worksheet
Dim tempChartObj As ChartObject
Dim ImageFullPath As String
Set Imagews = Sheets("Image Files")
Set tempChartObj = Imagews.ChartObjects.Add(0, 0, shp.Width, shp.Height)
shp.Copy
tempChartObj.Chart.ChartArea.Format.Line.Visible = msoFalse 'No Outline
tempChartObj.Chart.ChartArea.Format.Fill.Visible = msoFalse 'No Background
Do
DoEvents
tempChartObj.Chart.Paste
Loop While tempChartObj.Chart.Shapes.Count < 1
ImageFullPath = SavePath & "\" & shp.Name & ".png"
tempChartObj.Chart.Export ImageFullPath, Filtername:="png"
tempChartObj.Delete
End Sub
Can you change the font format of a value you add into the footer of a document ?
I could already achieve the value itself but can't seems to find the way to change the format of it.
This is the code I have:
Sub SetValueInFooter()
Dim WorkRng As Range
On Error Resume Next
'make variable with the number
Dim TextINeed As String
TextINeed = ActiveWorkbook.Sheets("Sheet1").Range("A1").Value
'add the number into the footer left
Application.ActiveSheet.PageSetup.LeftFooter = TextINeed
'define style of the number (this 'with' section has no effect, text stays black font size 10)
With ActiveSheet.PageSetup.LeftFooter
.Font.Size = 8
.Font.Color = RGB(192, 80, 77)
End With
End Sub
Thanks for your time & help
The page setting is different from that of the normal cell. It is helpful to record macros to identify patterns.
Sub SetValueInFooter()
Dim WorkRng As Range
Dim Ws As Worksheet
Dim TextINeed As String
Set Ws = ActiveSheet
'On Error Resume Next
'make variable with the number
TextINeed = ActiveWorkbook.Sheets("Sheet1").Range("A1").Value
'add the number into the footer left
'Application.ActiveSheet.PageSetup.LeftFooter = TextINeed
'define style of the number (this 'with' section has no effect, text stays black font size 10)
With Ws.PageSetup
.LeftFooter = "&8&kc0504d" & TextINeed '<~~ 8:=font.size / c0504d:=font.color (html color) / TextINeed:= text
End With
End Sub
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 have part drawings that I mark up with welds. Each drawing is the same but has unique serial numbers. Each weld is represented by a Circle Shape (msoShapeOval). After I hit my save function, I want all Circle Shapes (and ONLY circle shapes) removed from the drawing so that I can begin the next serial number.
I tried If statements with Shape.Type commands to delete all msoShapeOval, but the file doesn't recognize the shapes.
I also tried the opposite where If Not (textbox, OLE, picture, etc) delete shape, however that deleted ALL shapes.
Sub DeleteAllWelds()
Dim shp As Shape
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
For Each shp In ws.Shapes
If shp.Type = msoShapeOval Then shp.Delete
Next shp
End Sub
This is the CommandButton which calls the DeleteWelds sub
Private Sub CommandButton2_Click() 'Save and create new Weld Map for same Part Number
'Remove all weld shapes 'Reset any counters 'Reset fields in UserForm1 but not all
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Call SaveDoc
If UserForm3_Exit.Tag = "Go" Then
ws.Range("I2, I3, A6:K80").Value = ""
Call DeleteAllWelds
Unload Me
ElseIf UserForm3_Exit.Tag = "Cancel" Then
Unload Me
End If
End Sub
Finally the Sub which creates the Oval shapes to begin with.
Sub ShapeWithNum()
ActiveSheet.Shapes.AddShape(msoShapeOval, 20, 40, 20, 20).Select
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = buttonCell
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.name = "+mn-lt"
End With
End Sub
The method where I only delete msoShapeOval doesn't delete any objects, but when I use If not (mso(insert ones I need)) all objects are deleted.
You need to use shp.AutoShapeType instead of shp.Type as commented by #AhmedAU in the comments (The comment is now deleted).
There are different kinds of shapes in Excel. For example 3D model, AutoShape, Callout etc. You can get the entire list in MsoShapeType enumeration (Office)
So when you say Shape.Type, then it refers to MsoShapeType. Let's take an example. Insert these shapes in the worksheet
Now run this code
Sub Sample()
Dim ws As Worksheet
Dim Shp As Shape
Set ws = Sheet1
For Each Shp In ws.Shapes
Debug.Print "(" & Shp.Name & ")"; "---"; Shp.Type
Next Shp
End Sub
You will get this output
(Oval 1)--- 1
(TextBox 2)--- 17
(Straight Connector 4)--- 9
(Right Arrow 5)--- 1
(Explosion 1 6)--- 1
So you will notice that Oval 1, Right Arrow 5 and Explosion 1 6 have a shape type of 1. This means (if you refer to the above link) these are AutoShapes
When you Print the value of msoShapeOval in the Immediate Window using ?msoShapeOval, you will notice that the value is 9. It definitely is not 1 So what is this value? This is the Shape.AutoShapeType property which has a value of 9 for msoShapeOval
Read up on Shape.AutoShapeType property (Excel). It says Returns or sets the shape type for the specified Shape or ShapeRange object, which must represent an AutoShape other than a line, freeform drawing, or connector.
So one should know when to use the Shp.Type and when to use the Shp.AutoShapeType
Now try this code
Sub Sample()
Dim ws As Worksheet
Dim Shp As Shape
Set ws = Sheet1
For Each Shp In ws.Shapes
Debug.Print "(" & Shp.Name & ")"; "--- Shape Type: "; Shp.Type; "--- AutoShape Type: "; Shp.AutoShapeType
Next Shp
End Sub
You will see the output as
(Oval 1)--- Shape Type: 1 --- AutoShape Type: 9
(TextBox 2)--- Shape Type: 17 --- AutoShape Type: 1
(Straight Connector 4)--- Shape Type: 9 --- AutoShape Type: -2
(Right Arrow 5)--- Shape Type: 1 --- AutoShape Type: 33
(Explosion 1 6)--- Shape Type: 1 --- AutoShape Type: 89
So in your code, simply change
If shp.Type = msoShapeOval
to
If shp.AutoShapeType = msoShapeOval