View Full Version : Need help in generating WordArt in VBA
marswu
04-11-2006, 02:48 AM
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
04-11-2006, 03:33 AM
This any help?
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
Killian
04-11-2006, 04:17 AM
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'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
marswu
04-11-2006, 06:18 PM
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
04-11-2006, 07:10 PM
Hi Killian, thanks for your solution.
Thanks Johnske as well.
:)
marswu
04-11-2006, 07:16 PM
However, it is quite slow, since i have lots of such WordArt to draw dynamicly, any way to improve the performance? thanks
johnske
04-11-2006, 07:23 PM
Put Application.ScreenUpdating = False at the head of the code and Application.ScreenUpdating = True at the end :)
marswu
04-11-2006, 09:13 PM
Any idea how to set the Text in WordArt to multiline in VBA code?
johnske
04-11-2006, 09:22 PM
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...
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.