Mrrrr
AdMiN
 Inregistrat: acum 17 ani
Postari: 2186
|
|
Source (Chinese site, use google translate):
I was searching for a tab stop add function to help this guy:
And the simple line I found was:
ActiveWorkbook.Worksheets("Sheet1").Shapes("TextBox 1").TextFrame2.TextRange.ParagraphFormat.TabStops.Add msoTabStopLeft, 10
More text box manipulation codes below - the codes are copy/pasted from the site above, all credits to them.
Macro to change default value of selected text box tab to 20
Sub ChangeTabSpace ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim tss As TabStops2
Set tss = s.TextFrame2.TextRange.ParagraphFormat.TabStops
tss.DefaultSpacing = 20 'Change tab default value
End Sub
Sub ChangeTabSpace2 ()
Selection.ShapeRange.Item (1) .TextFrame2.TextRange.ParagraphFormat.TabStops.DefaultSpacing = 20 'Change default value of tab
End Sub
Macro to add a tab position of 20 points to the selected text box
Sub AddTabStop ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim tss As TabStops2
Set tss = s.TextFrame2.TextRange.ParagraphFormat.TabStops
tss.Add msoTabStopLeft, 20 'Add tab position
End Sub
'Macro to erase all tab positions (modified on 2017/01/17)
Sub DeleteTabStops ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim ps As TextRange2
Set ps = s.TextFrame2.TextRange.Paragraphs
Dim tss As TabStops2
Dim i As Long
Dim ts As TabStop2
For i = 1 To Ps.Count
Set tss = Ps.Item (i) .ParagraphFormat.TabStops
the For Each ts an In tss
Ts.Clear 'Clear
Next
Next
End Sub
Macro testTableTextBox to make selected cell range into one text box
Sub testTableTextBox ()
'If nothing is selected, exit without doing
If TypeName (Selection) <> "Range" Then Exit Sub
Dim myCells As Range
Set myCells = Selection
Dim tlCell As Range
Set tlCell = myCells.Cells (1)
Create a string to be displayed in the 'top left cell ' text box
Dim str As String
Dim rRow As Range
str = testGetString (myCells)
'Create a text box
Dim myTB As Shape
Set myTB = ActiveSheet.Shapes.AddTextbox (_
msoTextOrientationHorizontal , _
tlCell.Left, tlCell.Top, 100, 10)
myTB.TextFrame.AutoSize = True 'Enable auto size
myTB.Placement = xlMove'Move to cell but do not resize
'myTB.Placement = xlFreeFloating' No moving or resizing
With MyTB.TextFrame2.TextRange
.text = str
'Font specification (same as selected cell font)
Dim myFont As Font: Set myFont = tlCell.Font
With .Font
. Name = myFont.Name
.NameFarEast = myFont.Name
.Size = myFont.Size
End With
End With
End Sub
' Connect and return the passed cell range value (text) for table format
' Connect the value of one line with a tab character and connect it with a line feed character when the line changes
Function testGetString (r As Range) As String
Dim str As String
Dim rr As Range
Set rr = r.Cells.Rows (1)
str = GenerateString (rr, True)
'
If there are two or more rows If r.Rows.Count> 1 Then
Dim i As Long
For i = 2 To r .Rows.Count
Set rr = r.Cells.Rows (i)
str = str & vbNewLine & GenerateString (rr, True)
Next
End If
testGetString = str
End Function
' Create a string, ' Connect
and return strings in the
passed cell range '. The cell range to be passed is either one row or one column.
' Hori is Horizontal and
'True is connected with a tab character.'False is connected with a
newline character.
Function GenerateString (r As Range, Optional hori As Boolean = False) As String
Dim str As String
str = r.Cells (1) .text
If r.Cells.Count = 1 Then
GenerateString = str
Exit Function
End If
'2 cells or more when
Dim I As Long
If Hori Then
'lead with a tab character
for i = 2 to R.Cells.Count
Str = Str Ando VbTab Ando R.Cells (I) .Text
Next
Else
connect with the' newline character
for i = 2 to r.Cells.Count
str = str & vbNewLine & r.Cells (i) .text
Next
End If
GenerateString = str
End Function
Select the range you want to make a text box
When you run testTableTextBox
It is necessary to specify the tab position
I want to be right aligned
Determining tab positions
Left align
Use the previous cell width and add more for each column, and use this as the reference value
Centered
Add half of your cell width to the reference value
Right align
Near the value obtained by adding the cell width to the reference value
Macro that turns a selected cell range into a text box Part 2
Executing testTableTextBox2 creates a text box
'Corresponds to center and right alignment
' Cell range text box
Sub testTableTextBox2 ()
'If nothing is selected except cell, exit without doing
If TypeName (Selection) <> "Range" Then Exit Sub
Dim myCells As Range: Set myCells = Selection
Dim tlCell As Range: Set tlCell = myCells.Cells (1)
Create 'upper cell ' text box
Dim myTB As Shape
Set myTB = ActiveSheet.Shapes.AddTextbox (_
msoTextOrientationHorizontal, _
tlCell.Left, tlCell .Top, 100, 10)
myTB.TextFrame.AutoSize = True '
Enable autosize myTB.Placement = xlMove' Move to cell but do not resize
'myTB.Placement = xlFreeFloating' No move or resize
'Create a string to be displayed in the text box
Dim str As String
Dim rRow As Range
str = testGetString2 (myCells)
'Specify text in text box
myTB.TextFrame2.TextRange.text = str
' Set font color and font
Call SetFontColorAndFont (myTB, myCells)
'Tab according to cell width setting the position
Call AddTabPosition (mytb, MyCells)
End Sub
' Connect and return the passed cell range value (text) for table format
' Connect the value of one line with a tab character and connect it with a line feed character when the line changes
Function testGetString2 (r As Range) As String
Dim str String as
Dim rr as Range
Set rr = R.Cells.Rows (1)
'the top to have put a tab character
' character in the horizontal position in order to correspond to other left-justified
'first character and this is not column is always will, starting from 0
'if from the first cell becomes 0 even when other than left-justified
Str = VbTab Ando GenerateString (Rr, True)
' 2 or more lines there when
If r.Rows.Count> 1 Then
Dim i As Long
For i = 2 To r.Rows.Count
Set rr = r.Cells.Rows (i)
str = str & vbNewLine & vbTab & GenerateString (rr,True)
Next
End If
testGetString2 = str
End Function
' Create a string, ' Connect
and return strings in the
passed cell range '. The cell range to be passed is either one row or one column.
' Hori is Horizontal and
'True is connected with a tab character.'False is connected with a
newline character.
Function GenerateString (r As Range, Optional hori As Boolean = False) As String
Dim str As String
str = r.Cells (1) .text
If r.Cells.Count = 1 Then
GenerateString = str
Exit Function
End If
'2 cells or more when
Dim I As Long
If Hori Then
'lead with a tab character
for i = 2 to R.Cells.Count
Str = Str Ando VbTab Ando R.Cells (I) .Text
Next
Else
connect with the' newline character
for i = 2 to r.Cells.Count
str = str & vbNewLine & r.Cells (i) .text
Next
End If
GenerateString = str
End Function
'
Set the font color and font of the text box to be the same as the cell ''s text box (shape), pass the cell range to tableR
Sub SetFontColorAndFont (s As Shape, tableR As Range)
Dim i As Long, j As Long, k As Long
Dim r As Range, rowR As Range
Dim p As TextRange2
'Process every Paragraph (1 line)
' Paragraph character strings are arranged as tab, text, tab, text ...
For k = 1 To tableR.Rows.Count
Set p = s.TextFrame2.TextRange.Paragraphs (k)
Set rowR = tableR.Cells.Rows (k) '1 row
Dim cStart As Long' Start position of character to be processed
'First character is tab character The start position is 1
cStart = 1
'Process every cell
Dim char As TextRange2' Characters
For i = 1 To rowR.Cells.Count
Set r = rowR.Cells (i) '1 cell
' Skip processing if blank cell
If Len (r.text) = 0 Then GoTo myErr
Set char = p.Characters (cStart + 1, Len (r.text))
' If the font color of the cell is Null, multiple colors are specified, so
'Specify the color for each character
If IfNull (r.Font.Color) Then
For j = 1 To r.Characters.Count
p.Characters (cStart + j, 1) .Font.Fill.ForeColor.Rgb _
= r.Characters (j, 1) .Font.Color
Next
Else
'Color
specification for each cell p.Font.Fill.ForeColor.Rgb = r.Font.Color
End If
'Font setting for each cell
With char.Font
.Name = r.Font.Name
.NameFarEast = r.Font.Name
.Size = r.Font.Size
End With
myErr:
'Start position of next character to be processed
cStart = cStart + Len (r.text ) + 1
Next
Next k
End Sub
'Add a tab stop to the text in a
shape
' ' Pass cell range and shape ' Use cell width so text and cell values must correspond
Sub AddTabPosition (tb As Shape, r As Range)
Call ClearTabStops (tb) 'Erase all tab positions
Dim ps As TextRange2
Set ps = tb.TextFrame2.TextRange.Paragraphs
Dim i As Long
' Add tab positions per line
For i = 1 To ps.Count
'The default value of tabs is because disturbing to 0
Ps.Item (i) .ParagraphFormat.TabStops.DefaultSpacing = 0
'1 line per tab stop adding
' Call AddTabPositionSub (Ps.Item (i), R.Cells.Rows (i))
'centered corresponding Edition
Call AddTabPositionSub2 (ps.Item (i), r.Cells.Rows (i))
Next
End Sub
'Clear all tab positions' Clear
text tab positions in the passed shape
Sub ClearTabStops (s As Shape)
' If there is no text in the shape, exit without doing anything
If s.TextFrame2.HasText = msoFalse Then Exit Sub
Dim ps As TextRange2
Set ps = s.TextFrame2.TextRange.Paragraphs
Dim tss As TabStops2
Dim i As Long
Dim ts As TabStop2
For i = 1 To ps.Count
Set tss = ps.Item (i) .ParagraphFormat.TabStops
For Each ts In tss
ts.Clear
Next
Next
End Sub
'Add a tab position, position sets the cell width based on
' Left, center, corresponding to the right-aligned
'pf is Paragraph, r is the range of cells of one row
' used with AddTabPosition
Sub AddTabPositionSub2 (pf As TextRange2 , r As Range)
Dim po As Single 'Tab position Position
Dim tss As TabStops2
Set tss = pf.ParagraphFormat.TabStops
Dim nowR As Range: Set nowR = r.Cells (1)
' Add the first tab position
Call SetTabStop (nowR , tss, 0)
po = tss.Item (1) .Position
'
If there is only one cell, end here If r.Cells.Count = 1 Then Exit Sub
' If there are more than two cells, then
'second Add tab stops
Dim BeforeR As Range
Dim i As Long
the for i = 2 the to R.Cells.Count
Set BeforeR = R.Cells (i - 1)
Set NOWR = r.Cells (i)
'Add the previous cell width to the previous tab position
' This is the reference for the next tab position
po = po + beforeR.Width
'Adjust the tab position
If beforeR.HorizontalAlignment = xlCenter Then
' When the cell is center aligned,
subtract half the width of the previous cell po = po-(beforeR.Width / 2)
ElseIf beforeR.HorizontalAlignment = xlRight _
Or (IsNumeric (beforeR.Value2) _
And beforeR.HorizontalAlignment = xlGeneral ) Then
'If the previous cell is right-aligned,
subtract the previous cell width, 4 is adjusted po = po-beforeR.Width + 4
End If
' Add a tab position
Call SetTabStop (nowR, tss , po)
Next
End Sub
'Adjust tab position and then add
' Adjust with cell HorizontalAlignment and cell width
Sub SetTabStop (r As Range, tss As TabStops2, po As Single)
'Add tab position
If r.HorizontalAlignment = xlCenter Then
' cell When is center aligned, add half the cell width
po = po + (r.Width / 2)
tss.Add msoTabStopCenter, po
ElseIf r.HorizontalAlignment = xlRight _
Or (IsNumeric (r.Value2) _
And r.HorizontalAlignment = xlGeneral) Then
'
Adjustment is -4 only when right-aligned or numeric (numbers are usually right-aligned if not specified) , so
tab alignment overlaps when right-aligned and then left-aligned it will prevent, looks better
Po = Po Tasu R.Width - 4
Tss.Add MsoTabStopRight, Po
Else
when the 'left-aligned or without a specified character string
tss.Add msoTabStopLeft, po
End If
End Sub
The color of the text box frame is
MsoThemeColorLight1 is specified in Shape.Line.ForeColor.ObjectThemeColor, and TintAndShade for color shading is specified as -0.5.When specifying with a macro, I want to use RGB, so once specify the theme color and output RGB. And specify again.
The thickness of the frame is Shape.Line.Weight
After that, the background color is different, this is vbWhite (white) specified for Shape.Fill.ForeColor.RGB
Summary
To add text to the shape rectangle and make it look like a text box
Shape (square)
TextFrame2.ParagraphFormat.Alignment = msoAlignLeft
TextFrame.HorizontalAlignment = xlHAlignLeft
TextFrame.VerticalAlignment = xlVAlignTop
Line.Weight = 0.75
Line.ForeColor.ObjectThemeColor = msoThemeColorLight1
Line.ForeColor.TintAndShade = -0.5
Line.ForeColor.RGB = Line.ForeColor.RGB
Fill.ForeColor = vbWhite
TableTextBoxtest was created by modifying the previous testTableTextBox2 method
'Add text version to shape rectangle
'2017/01/23
Sub TableTextBoxtest ()
'If nothing is selected, exit without doing
If TypeName (Selection) <> "Range" Then Exit Sub
Dim myCells As Range: Set myCells = Selection
Dim tlCell As Range: Set tlCell = myCells .Cells (1)
Create 'top left cell ' text box
Dim myTB As Shape
Dim ws As Worksheet: Set ws = ActiveSheet
Set myTB = ws.Shapes.AddShape (msoShapeRectangle, _
tlCell.Left, tlCell.Top, 100, 100)
'Create a string to be displayed in the text box
Dim str As String
Dim rRow As Range
str = testGetString2 (myCells)
With myTB
With .TextFrame2.TextRange
' Specify text in the text box.text
= str
'Designated left-aligned horizontal position of the entire paragraph
.ParagraphFormat.Alignment = MsoAlignLeft
End With
With .TextFrame
' specify left justified the horizontal position of the entire text
.HorizontalAlignment = XlHAlignLeft
specify 'text entire vertical position on pulling
.VerticalAlignment = xlVAlignTop
.AutoSize = True ' Enable autosize
End With
.AlternativeText = "TextBox"' Name for identification
.Placement = xlMove 'Move to cell but do not resize
' .Placement = xlFreeFloating 'Move also Do not
resize Fill.ForeColor.Rgb = vbWhite 'Background color is white
'Setting the border
With .Line
.Weight = 0.75 'thickness.Style
= msoLineSingle' 1 line
'border color
With .ForeColor
' Theme color Light1 Shade-0.5 is specified by
RGB.ObjectThemeColor = msoThemeColorLight1
.TintAndShade = -0.5
.Rgb = .Rgb
End With
End With
End With
'Set font color and font
Call SetFontColorAndFont (myTB, myCells)
' Set tab position according to cell width
Call AddTabPosition (myTB, myCells)
End Sub
All other methods are exactly the same
Macro to display strikethrough on all characters in selected text box
Sub testFont2 ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
f2.Strikethrough = msoTrue
End Sub
Since the font setting is the font setting of the text box
TextFrame2.TextRange.Font for text box
It seems like you can set various settings, like the font size of the last time
Macro to make all characters in the selected text box superscript
Sub testFont2 ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
'f2.Strikethrough = msoTrue
f2.Superscript = msoTrue'
'f2.Subscript = msoTrue'
End Sub to subscript
It's nice to be superscript just by specifying msoTrue for Font2 Superscript
I do not know where the relative position to specify the display position is, and I can not find it even if I google
In such a case, if you can record a macro, you can understand it once
Macro to make all characters in the selected text box bold and italic
Sub testFont2 ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
'f2.Strikethrough = msoTrue
' f2.Superscript = msoTrue ' to
'f2.Subscript = msoTrue' to subscript
f2.Bold = msoTrue 'bold
f2.Italic = msoTrue' italics
End Sub
Same as strikethrough
There are a lot of candidates, but I use
Single line msoUnderlineSingleLine
MsoUnderlineDoubleLine for double line
Only one of
Macro to display underline on all characters in selected text box
Sub testFont2 ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
f2.UnderlineStyle = msoUnderlineSingleLine 'underline
' f2.UnderlineStyle = msoUnderlineDoubleLine 'double line' underlined
End Sub
Cell font settings can be specified for each cell as well as for each cell
If you check each character and set the character in the text box, it is the most certain, but it takes too much processing time! It took 5 seconds or more with 100 characters when executed for trial
It is possible to determine whether there are multiple settings in a cell, so if they are the same, set them in units of cells, and if they are different, set them individually for each character
Judgment method
For example, if all cells in one cell are bold
The Font.Bold value of the cell is True
If a cell contains bold and unspecified characters
Font.Bold value of cell is Null
So if Null you can judge mixed
This is the same as underline and it is Null if mixed
sText is the text box text, r is the cell
'Font Bold
Sub SetFontBoldSub (sText As TextRange2, r As Range)
If IsNull (r.Font.Bold) Then
For i = 1 To sText.Characters.Count
sText.Characters (i, 1) .Font.Bold = _
r. Characters (i, 1) .Font.Bold
Next
Else
sText.Font.Bold = r.Font.Bold
End If
End Sub
If everything is bold or standard
sText.Font.Bold = r.Font.Bold
If bold and standard are mixed, it is one character, so use Characters
For i = 1 To sText.Characters.Count
sText.Characters (i, 1) .Font.Bold = _
r.Characters (i, 1) .Font.Bold
Next
In case of underline, it is a little different because True and False are not specified
'Font Underline
Sub SetFontUnderLineSub (sText As TextRange2, r As Range)
Dim rf As Font
Dim sf As Font2
If IsNull (r.Font.Underline) Then
For i = 1 To sText.Characters.Count
Set rf = r.Characters (i , 1) .Font
Set Sf = SText.Characters (I, 1) .Font
Select Case Rf.Underline
Case XlUnderlineStyleSingle, EkkusueruyuenudiiarulineStyleSingleAccounting
Sf.UnderlineStyle = MsoUnderlineSingleLine
Case XlUnderlineStyleDouble, EkkusueruyuenudiiarulineStyleDoubleAccounting
Sf.UnderlineStyle = MsoUnderlineDoubleLine
End Select
Next
Else
Set Rf = R. Font
Sf = SText.Font Set
Select Case Rf.Underline
Case XlUnderlineStyleSingle, EkkusueruyuenudiiarulineStyleSingleAccounting
Sf.UnderlineStyle = MsoUnderlineSingleLine
Case XlUnderlineStyleDouble, EkkusueruyuenudiiarulineStyleDoubleAccounting
Sf.UnderlineStyle = MsoUnderlineDoubleLine
End Select
End If
End Sub
Case xlUnderlineStyleSingle, xlUnderlineStyleSingleAccounting
sf.UnderlineStyle = msoUnderlineSingleLine
Case Underline or underline (accounting)
Text box text = underline
I wrote the same thing twice ... I wonder if it would have been better to use a different method for Select Case
If you write the other settings in the same way with this feeling, the code will be 400 lines long and it can not be posted on the blog but the processing speed will be much improved
Cell range size, margins, text alignment
Adjust these to create a text box that looks exactly like a cell range
Since the placement of the characters has been completed up to the last time
Set text box margins
Image 6
Can be done from the format settings of the shape
Macro
Text box
Specify values for the four Margin properties of TextFrame2
This value is not a centimeter but a point
0.25cm becomes 7.2, 0.13cm becomes 3.6
Macro that sets the margin of the selected text box to the initial value
Sub yohaku ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
With s.TextFrame2
.MarginBottom = 3.6
.MarginLeft = 7.2
.MarginRight = 7.2
.MarginTop = 3.6
End With
End Sub
When you select characters, it is easy to understand where the margin is treated from
With zero margins
In the middle, the left and 0 of the character are selected, so you can see that the left and right margins are 0
All the selected items on the right side are outside the frame on the right side, which means that the line feed character is outside and the line feed character is not included in the character range
The top and bottom margins are also 0, but it seems that there is a margin, maybe the space between lines looks like a margin
Set text box line spacing
Made from paragraphs
Try selecting all lines and change the line spacing from 1 line to 2 lines
Certainly, it spread about twice, the upper part spreads more than the lower part.
Looking at the bottom, it seems to be outside the frame ignoring margins
Line spacing, fixed value
If I set the line spacing to a fixed value, the numerical value of the interval is displayed as 19.2 pt
You can now change this number
Changed from 19.2 to 40
Feeling a little different from the previous line specification
Specify a multiple between lines
If you specify a multiple, the initial value was 3, so press OK as it is
It spreads greatly, maybe three lines worth it
Even so, it is not evenly up and down, the upper side of the character spreads greatly
Spacing before and after paragraph
24pt before paragraph
24pt after paragraph
These line spacing
Where to specify in case of macro
To specify the entire text box
In TextFrame2.TextRange.ParagraphFormat
When specifying by line (paragraph) unit, if it is the first line (paragraph),
TextFrame2.TextRange.Paragraphs.Item (1) .ParagraphFormat
SpaceAfter after paragraph
SpaceBefore before paragraph
SpaceWithin is line spacing and spacing
LineRuleAfter, LineRuleBefore, and LineRuleWithin are used to switch the specified numerical value between points and lines, and specify either msoTrue or msoFalse.
For example , when LineRuleAfter = msoTrue , SpaceAfter = 1
One line of space after a paragraph makes sense
= LineRuleAfter MsoFalse when SpaceAfter = 1 is
One point of space after a paragraph makes sense
Sub Macro that sets the line spacing of the selected text box to 07 lines ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
With s.TextFrame2.TextRange.ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = 0.7
End With
End Sub
Sub Macro to set the line spacing of the selected text box to 15 points ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
With s.TextFrame2.TextRange.ParagraphFormat
.LineRuleWithin = msoFalse
.SpaceWithin = 15
End With
End Sub
Sub Macro that sets the space before the paragraph of the selected text box to one line ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
With s.TextFrame2.TextRange.ParagraphFormat
.LineRuleBefore = msoTrue
.SpaceBefore = 1
End With
End Sub
This means that even if you specify one line, the display is converted to points
Sub Macro that sets the line spacing of the second line of the selected text box to 50 points ()
Dim s As Shape
Set s = Selection.ShapeRange.Item (1)
With s.TextFrame2.TextRange.Paragraphs.Item (2) .ParagraphFormat
.LineRuleWithin = msoFalse
.SpaceWithin = 50
End With
End Sub
'Margin (margin) setting
With myTB.TextFrame2
.MarginBottom = 0
.MarginLeft = WorksheetFunction.RoundUp (myCells (1) .Height / 10, 0)
.MarginRight = .MarginLeft '2
.MarginTop = 0
End With
'Adjust line spacing, reproduce cell height
With myTB.TextFrame2.TextRange
For i = 1 To .Paragraphs.Count
With .Paragraphs (i) .ParagraphFormat
.LineRuleWithin = msoFalse
.SpaceWithin = myCells.Rows (i) .Height * 0.98
End With
Next
End With
Set margins and line spacing based on cell height
There is no basis, just adjusting, so if the font and font size are different, it may shift more
Now I can do 3,4,5,6 ... but it's easier to see the second one, just the column width adjustment, then the sixth one, with column width adjustment and row spacing adjustment. The 3rd and 4th that are being adjusted are not good if you say with ease
I found that margins are important
|
_______________________________________
|
|
