I have inserted textbox under insert --> shapes----> Textbox. now I want to resize textbox font if text-overflow textbox. I tried the following codes.
With Selection
If .TextFrame.HorizontalOverflow = msoTrue Then
Do
.TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size - 1
Loop Until .TextFrame.HorizontalOverflow = msoFalse
End If
End with
ps: its Barcode font. so if it gets wrap then it's not readable by a barcode reader. so I want to shrink it.
But no success.
Thanks
The code below seems to achieve what you are looking for for standard text. Maybe you can extract the principle and use it with your barcode style.
Option Explicit
Sub AdjustTextInTextBox()
Dim myWs As Worksheet
Set myWs = ThisWorkbook.ActiveSheet
myWs.Shapes.AddShape msoTextBox, 100, 100, 250, 50
Dim myShape As Shape
Set myShape = myWs.Shapes.Item(1)
myShape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Dim myHeight As Long
myHeight = myShape.Height
myShape.TextFrame2.TextRange.Text = "Hello world its a really really really nice day"
Do While myShape.Height > myHeight
myShape.TextFrame2.TextRange.Font.Size = myShape.TextFrame2.TextRange.Font.Size - 1
Loop
End Sub
Related
I am trying to create an excel vba macro that loops through each slide in a presentation (the presentation was created with an excel vba macro) and adds specific text to the top of each slide.
Right now, this is what I have but it is throwing an error and I can figure out the set slide_title section and the with section. I think the for loop is correct, but not understanding the "with" section. The "with" section text box characteristics are correct....but the code isn't executing because something is clearly wrong with it.
Sub update_slide_title_text()
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoCTrue
ppt.Presentations.Open ("C:\Users\Existing_Presentation.pptx")
Dim ppres As PowerPoint.Presentation
Set ppres = ppt.ActivePresentation
Dim pslide As PowerPoint.Slide
Dim pshape As PowerPoint.Shape
For Each pslide In ppres.Slides
Dim slide_title As Object
Set slide_title = pslide.Shapes.AddTextbox(1, 34.36292, -2.670787, 900, 90)
With slide_title
.Height = 54
.Left = 34.36292
.Top = 15
.Width = 190
.TextFrame.TextRange.Text = "NEED TO CHANGE THIS TO DIFFERENT TEXT FOR EACH SLIDE"
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.Font.Color = RGB(0, 133, 85)
End With
Next
End Sub
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
(Post updated with entire code, sorry about the beginner mistake)
Newbie to both coding and VBA here and I'm trying to adjust the PlotArea for a Chart in a presentation. I'm running this from Excel.
Creating and populating the Chart goes fine, sizing ChartArea is also no problems and formating all titles etc is also without problems.
When the Chart looks athe way I want it to, is the correct size and at the correct place, I want the PlotArea to be a precise size and in a precise location. Sizing goes well but the position does not work.
Here is the code that I use, Including populating the ChartData with dummy data and adding in a red box to show where I want the PlotArea to sit:
Sub CreateChart()
'Declare Excel Object Variables
Dim pptWorkBook As Excel.Workbook
Dim pptWorkSheet As Excel.Worksheet
'Declare PowerPoint Object Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTChart As PowerPoint.Chart
Dim PPTChartData As PowerPoint.ChartData
Dim SldHeight, SldWidth As Integer
Dim ChrHeight, ChrWidth As Single
Dim PlotHeight, PlotWidth As Double
'Declare Excel Object Variable
Dim ExcRange As Range
'Create a new instance of Powerpoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation within the Application
Set PPTPres = PPTApp.Presentations.Add
'Disable Snap-To-Grid
PPTPres.SnapToGrid = msoFalse
'Create a new slide within the Presentation
Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)
'Find out size (points) of Slide
SldHeight = PPTPres.PageSetup.SlideHeight
SldWidth = PPTPres.PageSetup.SlideWidth
'Calculate Chart and Plot Size
ChrWidth = 954
ChrHeight = 525 - 106
PlotWidth = 866 - 95
PlotHeight = 437 - 106 - 20
'No screen updates
Application.ScreenUpdating = False
'Create a new Chart within the Slide, give it proper size
Set PPTShape = PPTSlide.Shapes.AddChart2(-1, xlColumnClustered, 0, 106, ChrWidth, ChrHeight, True)
'Minimize ChartData
PPTShape.Chart.ChartData.Workbook.Application.WindowState = -4140
'Set chartdata
Set PPTChartData = PPTShape.Chart.ChartData
'Set Workbook object reference
Set pptWorkBook = PPTChartData.Workbook
'Set Worksheet object reference
Set pptWorkSheet = pptWorkBook.Worksheets(1)
'Add Data
pptWorkSheet.ListObjects("Table1").Resize pptWorkSheet.Range("A1:B5")
pptWorkSheet.Range("b1").Value = "Items"
pptWorkSheet.Range("a2").Value = "Bikes"
pptWorkSheet.Range("a3").Value = "Accessories"
pptWorkSheet.Range("a4").Value = "Repairs"
pptWorkSheet.Range("a5").Value = "Clothing"
pptWorkSheet.Range("b2").Value = "1000"
pptWorkSheet.Range("b3").Value = "2500"
pptWorkSheet.Range("b4").Value = "4000"
pptWorkSheet.Range("b5").Value = "3000"
'Apply Style
With PPTShape.Chart
.ChartStyle = 4
End With
'Remove title
With PPTShape.Chart
.HasTitle = False
End With
'Format legend
With PPTShape.Chart
.HasLegend = True
.Legend.Position = xlLegendPositionTop
.Legend.Top = 0
End With
'Add axis title
With PPTShape.Chart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Dollars"
End With
'Remove gridlines
With PPTShape.Chart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
'Add data labels
PPTShape.Chart.ApplyDataLabels
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideLeft = 95
.InsideTop = 20
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
End With
'Adding a red textbox with the same dimensions and position as the PlotArea
With PPTShape.Chart.Shapes.AddTextbox(msoTextOrientationDownward, 95, 20, PlotWidth, PlotHeight)
.Line.Weight = 2
.Line.DashStyle = msoLineLongDash
.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
'Quit
Set pptWorkSheet = Nothing
pptWorkBook.Application.Quit
Set pptWorkBook = Nothing
Set PPTChartData = Nothing
Set PPTChart = Nothing
'Screen updates
Application.ScreenUpdating = True
End Sub
Below you can see the result with dummy data. The red box is correct, the PlotArea is the right size but not in the right position. Am I misunderstanding something regarding the InsideLeft vs Left properties? I've been stuck here for hours now and I am not making any progress. A theory a colleague and I have is that the PlotArea is doing a Snap-To to something that can't be seen.
Any help is appreciated!
UPDATE:
I changed the order of positioning and sizing of the PlotArea and it improved.
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95
.InsideTop = 20
End With
The offset from the red box seems consistent and I'm sure it is a small thing I am missing somewhere. See attached image of the new result below.
UPDATE 2:
Here is how I solved this. I'm not entirely sure it is correct logic, but it works at least.
I need to offset the PlotArea by 3.9 points. This seems to involve spacing for TickMarks. My assumption here is that the PlotArea position (.InsideTop and .InsideLeft etc) include TickMark width and height but lacks the means to adjust for this. My workaround looks like this:
'Set the TickMark offset constant
offSet = 3.9
'Set PlotArea position and size
With theShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95 - offSet
.InsideTop = 20 - offSet
End With
As this is mostly guesswork, as far as a solution is concerned, any real answers and not workarounds would still be appreciated.
It seems you're trying to position the chart, not the plot area. Try something like this instead:
'Set PlotArea size and position
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.Left = 60
.Top = -25
End With
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
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.