VBA - 复制矩形形状的第一行文本

Question

不幸的是，我找到的所有解决方案都没有帮助我。

在我的工作簿中，我有一个带文字的形状。使用CommandButton我想更改第二个文本行，第一行应该保持不变。

我只找到了一种从形状中复制整个文本的方法，但我只想复制第一行。

这是我的代码到目前为止：

Private Sub CommandButton1_Click()
    Dim Sh As Shape
    Dim Headline As String

    Set Sh = ActiveSheet.Shapes("WKA_1")

    ' Try to copy first line:
    Headline = Sh.TextFrame.Characters.Text  ' Copy whole text

    Sh.TextFrame.Characters.Text = Headline & vbCrLf & "Process: " & UserForm1.Label57 & "%"

End Sub

我真的希望有人可以帮助我。

编辑：

在图片中你可以看到我的形状。使用Button“Add_Assignment”，第二个Shape将添加到工作表中。此外，文本的第一行将添加到这样的形状：

Private Sub CommandButton1_Click()
    Dim Sh As Shape

    Set Sh = ActiveSheet.Shapes("WKA_1")
    With Sh.TextFrame
        .Characters.Text = Add_Assignment.TextBox1 & ", " & Add_Assignment.TextBox2
        .HorizontalAlignment = msoAlignCenter
        .Characters.Font.ColorIndex = 0
    End With
End Sub

将添加第二行文本并使用按钮“添加工作包”进行更改

Answer 1

你可以使用Split和Join来做到这一点。

Private Sub CommandButton1_Click()
Dim Sh As Shape
Dim Headline As String

    Set Sh = ActiveSheet.Shapes("WKA_1")

    ' Try to copy first line:
    Headline = Sh.TextFrame.Characters.Text  ' Copy whole text

    Dim v As Variant
    v = Split(Headline, vbLf)
    If LBound(v) = 0 Then
        v(0) = v(0) & vbLf & "Process: " & UserForm1.Label57 & "%"
    Else
        v(1) = v(1) & vbLf & "Process: " & UserForm1.Label57 & "%"
    End If
    Headline = Join(v, vbLf)

    Sh.TextFrame.Characters.Text = Headline

End Sub

更新也许这就是你想要的。

Private Sub CommandButton1_Click()
Dim Sh As Shape
Dim Headline As String

    Set Sh = ActiveSheet.Shapes("WKA_1")

    ' Try to copy first line:
    Headline = Sh.TextFrame.Characters.Text  ' Copy whole text

    Dim v As Variant
    v = Split(Headline, vbLf)
    If LBound(v) = 0 Then
        v(0) = v(0)  & "Process: " & UserForm1.Label57 & "%"
    Else
        v(1) = v(1) & "Process: " & UserForm1.Label57 & "%"
    End If
    Headline = Join(v, vbLf)

    Sh.TextFrame.Characters.Text = Headline

End Sub

Answer 2

您可以尝试使用正则表达式，具体取决于断行的确定方式。

Option Explicit
Private Sub CommandButton1_Click()
    Dim Sh As Shape, Headline As String

    Set Sh = ThisWorkbook.Worksheets("Sheet2").Shapes("WKA_1")

    Headline = Sh.TextFrame.Characters.Text
    Headline = GetFirstLine(Headline)

    Debug.Print Headline
    'Sh.TextFrame.Characters.Text = Headline

End Sub

Public Function GetFirstLine(ByVal inputString As String) As String
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .Pattern = "^(.*)$"
        If .TEST(inputString) Then
            GetFirstLine = .Execute(inputString)(0)
        Else
            GetFirstLine = inputString
        End If
    End With
End Function

试试吧here。

---

正则表达式：

^在一条线的开头断言位置

第一捕获组(.*)

.*匹配任何字符（行终止符除外）

* Quantifier - 在零和无限次之间匹配，尽可能多次，根据需要回馈（贪婪）

$在一条线的末尾断言位置