Need help in generating WordArt in VBA

[marswu]

I need to generate some WordArt in VBA with dynamic text values, however I must make it at a specific position and with a consistent shape.
I tried to add in empty space to make the text consistent length, however the pixel length is different even for same number of characters.
Any ppl has any idea to solve my problem?
thx

[johnske]

This any help?
[vba]Option Explicit

Sub MakeWordArt()

'insert your text and preferred text effect
ActiveSheet.Shapes.AddTextEffect(msoTextEffect16, "My Text", "Arial Black", _
36#, msoFalse, msoFalse, 233.25, 153#).Select

With Selection.ShapeRange
'set your own height and width below
.Height = 100
.Width = 300
End With

Selection.Cut
'insert the cell where you want the WordArt
Range("C3").Select
ActiveSheet.Paste

End Sub[/vba]

[Killian]

Because the WordArt shape automatically sets the width of the object based on it's content, there are two options that I can see:

1. set the width after it's inserted, as johnske suggests - this will distort the text but give you an exact width match

2. if you don't want to distort the text, calculate the expected width of the new wordart, then add spaces until it hits a specified size - this won't be exact in terms of width, within the width of a space of the font/size you use. Hopefully the text distortion would then be minimized[VBA]'left position of inserted wordart, although you could resize the shape at the end if you need an exact width.
Const SHP_LEFT As Single = 100
'max width allowed
Const MAX_SHP_WIDTH As Long = 150

Sub test()
Dim strWAtext As String
Dim shpNewWA As Shape

strWAtext = "Test string 2"

If GetNewWALength(strWAtext) < MAX_SHP_WIDTH Then
Do
strWAtext = strWAtext & " "
Loop Until GetNewWALength(strWAtext) >= MAX_SHP_WIDTH
End If
Set shpNewWA = AddWordArt(strWAtext, 200)
shpNewWA.Width = MAX_SHP_WIDTH
End Sub

Function GetNewWALength(str As String) As Single
' paramater: text of wordart
' returns: expected width of wordart
Dim shpTempWA As Shape
Dim i As Long
Dim totalwidth As Single

For i = 1 To Len(str)
Set shpTempWA = AddWordArt(Mid(str, i, 1), 100)
totalwidth = totalwidth + shpTempWA.Width
shpTempWA.Delete
Next i
GetNewWALength = totalwidth

End Function

Function AddWordArt(str As String, shptop As Single) As Shape
' paramaters: text of wordart, position from top
' returns: inserted wordart shape object
Dim shp As Shape

Set shp = ActiveSheet.Shapes.AddTextEffect( _
msoTextEffect8, str, "Arial", 24#, msoFalse, msoFalse, SHP_LEFT, shptop)
Set AddWordArt = shp

End Function[/VBA]

[marswu]

Actually I need to create lots of WordArt with msoTextEffect3, and make them pararllel. Those WordArt may have dynamic text. If that one with shorter text, I still want them to be as same size as others.

[marswu]

Hi Killian, thanks for your solution.
Thanks Johnske as well.

[marswu]

However, it is quite slow, since i have lots of such WordArt to draw dynamicly, any way to improve the performance? thanks

[johnske]

Put Application.ScreenUpdating = False at the head of the code and Application.ScreenUpdating = True at the end

[marswu]

Any idea how to set the Text in WordArt to multiline in VBA code?

[johnske]

Any idea how to set the Text in WordArt to multiline in VBA code?

Use & vbNewLine & wherever a new line's needed, as in this example...
[VBA]
Sub MakeWordArt()

Application.ScreenUpdating = False

'insert your text and preferred text effect
ActiveSheet.Shapes.AddTextEffect(msoTextEffect16, "My Text" & vbNewLine & "By John", "Arial Black", _
36#, msoFalse, msoFalse, 0, 0).Select

With Selection.ShapeRange
'set your own height and width below
.Height = 100
.Width = 300
End With

Selection.Cut
'insert the cell where you want the WordArt
Range("C3").Select
ActiveSheet.Paste
Application.ScreenUpdating = True
End Sub[/VBA]