Set Characters and Lines Limit in a textbox

zinah

Board Regular
Joined
Nov 28, 2018
Messages
179
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have below macro which creates text boxes in a template, these text boxes depends on number of goals which it should not exceed 5 goals. What I need is to do below:

- Set the limit of characters /lines in each box to be 48 characters and 8 lines and if the characters & lines exceeded this limit, then creates a line that has this "check goals for further info"
- If number of goals are less than 5 then show exactly number of goals and this should fit the limit I have set which is "Goals_frame"

Can anyone help?

This macro is to create the boxes

Code:
Sub add_GOALS_rectangle()    Set aSht = ActiveSheet
    Set rSht = Sheets("Role Scorecard")
    
    rSht.Activate
Call reset_GOALS_rectangles
Dim goalsF As Shape, goalsR As Shape
Dim goalsObj, goalsOut, goalsCat, goalsPrg As Shape
    Set goalsF = rSht.Shapes("Goals_frame")


Dim gCnt As Long, g As Long, pix As Long
pix = 72  'use to convert inches to pixels
    gCnt = 100  'supposed to be the goals count, needs to become a formula
    If gCnt > 5 Then gCnt = 5


Dim l, t, w, h As Single
Dim gl, gt, gw, gh As Single
Dim objTxt, objLbl, outTxt, outLbl As String
Dim catTxt, prgTxt, prgLbl As String


'''NEED TO START LOOP HERE ... LOOPS THROUGH EACH GOAL UP TO gCnt VALUE'''
For g = 1 To gCnt
'all of the "txt" variables need to referene the spreadsheet...'




    
    objLbl = "Objective: " & Chr(10)
    outLbl = "Metrics/Outcomes: " & Chr(10)
    'objTxt = "Hi! I am an exampl Objective" & Chr(10) & "Look at how well I am written,... super well! Look at how well I am written,... super well! Look at how well I am written,... super well! Look at how well I am written,... super well!"
    'objTxt = Sheets("ref.").[G_Obj].Offset(1, 0).Value
    'outTxt = "Yo, yo, yo! .... " & Chr(10) & Chr(149) & " metric 1" & Chr(10) & Chr(149) & " metric 2" & Chr(10) & Chr(149) & " metric 3"
    'outTxt = Sheets("ref.").[G_Outc].Offset(1, 0).Value
    'catTxt = "Core Responsibilities"
     prgLbl = "Progress Notes: "
    'prgTxt = "TRUE"
     prgTxt = Sheets("ref.").[G_Prog].Offset(1, 0).Value
    'If Sheets("ref.").[G_Prog].Offset(1, 0).Value = "NO" Then >>>> "set the color Red if NO"
    '    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
 
 'Call popultate_obj_txt




'''BUILD EACH gCnt FRAME'''
    w = goalsF.Width
    h = goalsF.Height / gCnt
    l = goalsF.Left
    t = goalsF.Top + (h * (g - 1))
Set goalsR = rSht.Shapes.AddShape(msoShapeRectangle, l, t, w, h)
With goalsR
    .Name = "Goal_" & g & "_Row"
    .Placement = xlFreeFloating
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Visible = msoFalse
    .Line.ForeColor.RGB = RGB(100, 100, 100)
    
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 8
    .TextFrame2.TextRange.Font.Name = "Tahoma"
    .TextFrame.MarginLeft = 0.5 * pix
    .TextFrame.MarginRight = 0.05 * pix
    .TextFrame.MarginTop = 0.05 * pix
    .TextFrame.MarginBottom = 0.05 * pix
    
    '.TextFrame2.TextRange.Characters.Text = objLbl & objTxt & Chr(10) & Chr(10) & outLbl & outTxt
    '.TextFrame.Characters(InStr(1, .TextFrame2.TextRange.Characters.Text, objLbl), Len(objLbl)).Font.Bold = True
    '.TextFrame.Characters(InStr(1, .TextFrame2.TextRange.Characters.Text, outLbl), Len(outLbl)).Font.Bold = True
End With




'''BUILD THE gCnt CATEGORY BOX'''
    gl = goalsR.Left
    gt = goalsR.Top
    gw = 0.4 * pix
    gh = goalsR.Height
Set goalsCat = rSht.Shapes.AddShape(msoShapeRectangle, gl, gt, gw, gh)
With goalsCat
    .Name = "Goal_" & g & "_Cat"
    .Placement = xlFreeFloating
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Visible = msoFalse
    .Line.ForeColor.RGB = RGB(100, 100, 100)
    
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 8
    .TextFrame2.TextRange.Font.Name = "Tahoma"
    .TextFrame.MarginLeft = 0 * pix
    .TextFrame.MarginRight = 0 * pix
    .TextFrame.MarginTop = 0 * pix
    .TextFrame.MarginBottom = 0 * pix
    .TextFrame2.TextRange.Font.Bold = msoFalse
    .TextFrame2.Orientation = msoTextOrientationUpward
    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    .TextFrame2.VerticalAnchor = msoAnchorMiddle
    .TextFrame2.AutoSize = msoAutoSizeNone
    .TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
    .TextFrame.HorizontalOverflow = xlOartHorizontalOverflowOverflow
    .TextFrame2.WordWrap = msoTrue


.TextFrame2.TextRange.Characters.Text = catTxt
End With




'''BUILD THE gCnt PROGRESS NOTE BOX'''
    gw = 0.4 * pix
    gh = goalsR.Height
    gl = goalsR.Left + goalsR.Width - gw
    gt = goalsR.Top
Set goalsPrg = rSht.Shapes.AddShape(msoShapeRectangle, gl, gt, gw, gh)
With goalsPrg
    .Name = "Goal_" & g & "_Prg"
    .Placement = xlFreeFloating
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Visible = msoFalse
    .Line.ForeColor.RGB = RGB(100, 100, 100)
    
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 8
    .TextFrame2.TextRange.Font.Name = "Tahoma"
    .TextFrame.MarginLeft = 0 * pix
    .TextFrame.MarginRight = 0 * pix
    .TextFrame.MarginTop = 0 * pix
    .TextFrame.MarginBottom = 0 * pix
    .TextFrame2.TextRange.Font.Bold = msoFalse
    .TextFrame2.Orientation = msoTextOrientationUpward
    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    .TextFrame2.VerticalAnchor = msoAnchorMiddle
    .TextFrame2.AutoSize = msoAutoSizeNone
    .TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
    .TextFrame.HorizontalOverflow = xlOartHorizontalOverflowOverflow
    .TextFrame2.WordWrap = msoTrue


.TextFrame2.TextRange.Characters.Text = prgLbl & prgTxt
    .TextFrame.Characters(InStr(1, .TextFrame2.TextRange.Characters.Text, prgTxt), Len(prgTxt)).Font.Bold = True
End With




'''BUILD THE gCnt OBJECTIVE BOX'''
    gl = goalsR.Left + goalsCat.Width
    gt = goalsR.Top
    gw = (goalsR.Width - goalsCat.Width - goalsPrg.Width) / 2
    gh = goalsR.Height
Set goalsObj = rSht.Shapes.AddShape(msoShapeRectangle, gl, gt, gw, gh)
With goalsObj
    .Name = "Goal_" & g & "_Obj"
    .Placement = xlFreeFloating
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Visible = msoFalse
    '.Line.ForeColor.RGB = RGB(100, 100, 100)
    .Line.Visible = False
    
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 8
    .TextFrame2.TextRange.Font.Name = "Tahoma"
    .TextFrame.MarginLeft = 0.15 * pix
    .TextFrame.MarginRight = 0.05 * pix
    .TextFrame.MarginTop = 0.05 * pix
    .TextFrame.MarginBottom = 0.05 * pix
    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
    .TextFrame2.VerticalAnchor = msoAnchorTop
    .TextFrame2.AutoSize = msoAutoSizeNone
    .TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
    .TextFrame.HorizontalOverflow = xlOartHorizontalOverflowOverflow
    .TextFrame2.WordWrap = msoTrue


.TextFrame2.TextRange.Characters.Text = objLbl & objTxt
    .TextFrame.Characters(InStr(1, .TextFrame2.TextRange.Characters.Text, objLbl), Len(objLbl)).Font.Bold = True
End With




'''BUILD THE gCnt OUTCOME BOX'''
    gl = goalsR.Left + goalsCat.Width + goalsObj.Width
    gt = goalsR.Top
    gw = (goalsR.Width - goalsCat.Width - goalsPrg.Width) / 2
    gh = goalsR.Height
Set goalsOut = rSht.Shapes.AddShape(msoShapeRectangle, gl, gt, gw, gh)
With goalsOut
    .Name = "Goal_" & g & "_Out"
    .Placement = xlFreeFloating
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Fill.Visible = msoFalse
    '.Line.ForeColor.RGB = RGB(100, 100, 100)
    .Line.Visible = False
    
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 8
    .TextFrame2.TextRange.Font.Name = "Tahoma"
    .TextFrame.MarginLeft = 0.15 * pix
    .TextFrame.MarginRight = 0.05 * pix
    .TextFrame.MarginTop = 0.05 * pix
    .TextFrame.MarginBottom = 0.05 * pix
    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
    .TextFrame2.VerticalAnchor = msoAnchorTop
    .TextFrame2.AutoSize = msoAutoSizeNone
    .TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
    .TextFrame.HorizontalOverflow = xlOartHorizontalOverflowOverflow
    .TextFrame2.WordWrap = msoTrue


.TextFrame2.TextRange.Characters.Text = outLbl & outTxt
    .TextFrame.Characters(InStr(1, .TextFrame2.TextRange.Characters.Text, outLbl), Len(outLbl)).Font.Bold = True
End With


goalsR.ZOrder msoBringToFront
Next g


aSht.Activate
End Sub


And this macro is to populate the text of goals into boxes

Code:
Private Sub popultate_obj_txt()    Set aSht = ActiveSheet
    Set rSht = Sheets("Role Scorecard")


'Dim oCnt As Long, o As Long >>>set the limit of objectives count
Dim shp As Shape
Dim ObjRng As Range, MetRng As Range, catRng As Range
Dim objLbl As Shape, outLbl As Shape, catLbl As Shape


'oCnt = 16
'If oCnt > 5 Then oCnt = 5


    Set ObjRng = Sheets("ref.").[ObjRange]
    Set MetRng = Sheets("ref.").[MetRange]
    Set numRng = Sheets("ref.").[NumRange]
    Set catRng = Sheets("ref.").[CatRange]
'For o = 1 To oCnt


 '   i = 0
    
For lbl = ObjRng.Row To (ObjRng.Row + ObjRng.Rows.Count - 1)
    i = i + 1
    
    For Each shp In ActiveSheet.Shapes
    If InStr(1, shp.Name, "Goal_" & i & "_Obj") > 0 Then
        With shp
            .TextFrame2.TextRange.Characters.Text = Sheets("ref.").Cells(lbl, numRng.Column) & " " & "Objective: " & Chr(10) & Sheets("ref.").Cells(lbl, ObjRng.Column).Value
            .TextFrame2.TextRange.Font.Bold = msoFalse
            .TextFrame2.TextRange.Characters(1, 14).Font.Bold = msoCTrue
            
        End With
    End If
    
    If InStr(1, shp.Name, "Goal_" & i & "_Out") > 0 Then
        With shp
        .TextFrame2.TextRange.Characters.Text = "Metrics/Outcomes: " & Chr(10) & Sheets("ref.").Cells(lbl, MetRng.Column).Value
        .TextFrame2.TextRange.Font.Bold = msoFalse
        .TextFrame2.TextRange.Characters(1, 17).Font.Bold = msoCTrue
        End With
    End If
    
    If InStr(1, shp.Name, "Goal_" & i & "_Cat") > 0 Then
        With shp
        .TextFrame2.TextRange.Characters.Text = Sheets("ref.").Cells(lbl, catRng.Column).Value
        .TextFrame2.TextRange.Font.Bold = msoFalse
        End With
    End If
    
    Next shp
Next lbl
'Next o


End Sub


Thanks!
 

Some videos you may like

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

zinah

Board Regular
Joined
Nov 28, 2018
Messages
179
Office Version
  1. 365
Platform
  1. Windows
@Fluff Hi, can you please check my macro and see if you could help?
 

Watch MrExcel Video

Forum statistics

Threads
1,108,509
Messages
5,523,312
Members
409,511
Latest member
hitesh222002

This Week's Hot Topics

Top