VBA-粘貼后標簽丟失文本

因此，我正在嘗試創建即使作業簿被鎖定時用戶也可以移動的“卡片”。每張卡片將包含有關某個專案的資訊。我這樣做的方式：

• 創建一些形狀（一個矩形和一些標簽和圖示）
• 將它們分組
• 切組
• 粘貼為影像

問題是當我粘貼為影像時，所有標簽都會丟失它們的文本，它們會變回“label1”。如果我逐行運行代碼，它們不會丟失文本。

我已經嘗試在剪切和粘貼之間添加“時間”，添加一些代碼行，將粘貼行移動到單獨的子目錄，甚至使用 Application.Wait()，但沒有任何效果。

我需要將它們作為影像（或一個物體物件 - 只是一組不起作用），因為宏完成后，作業表再次鎖定，并且還有另一個宏允許用戶移動形狀甚至當作業簿被鎖定時。

這是一個顯示問題的示例。

Sub MyCode()

Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")

'Just two labels as exemple, the original code has more labels, more icons, and the rounded rectangle)
'The values for the constructors in the original code are defined by the user by a forms
Call GenerateLabel("plaseWork", "Name of the project", 14, 30)
Call GenerateLabel("whyCantYouJustWork", "Name of the user", 42, 30)

wsm.Shapes.Range(Array("plaseWork", "whyCantYouJustWork")).Group.Name = "myGroup"

Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position

Application.CutCopyMode = False
wsm.Shapes("myGroup").Cut

With wsm.Pictures.Paste
    .left = freeSlot.left
    .top = freeSlot.top
End With

Application.CutCopyMode = False

Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub

Sub GenerateLabel(labelDescription As String, projectName As String, top As Integer, left As Integer)

Set lbLabel = wsm.OLEObjects.Add(ClassType:="Forms.Label.1")

With lbLabel
    .Name = labelDescription
    .Object.BackStyle = fmBackStyleTransparent
    .Width = 160
    .top = top
    .left = left
End With

With wsm
    .OLEObjects(lbLabel.Name).Object.Caption = projectName
    .Shapes(lbLabel.Name).Fill.Transparency = 1
End With

End Sub

uj5u.com熱心網友回復：

使用沒有輪廓或填充的形狀代替標簽怎么樣？

Sub MyCode()

    Dim wsm As Worksheet, arr(0 To 1), grp As Shape
    
    Set wkm = Workbooks(ThisWorkbook.Name)
    Set wsm = wkm.Worksheets("TestSheet")
    
    arr(0) = AddLabel(wsm, "Name of the project", 14, 30).Name
    arr(1) = AddLabel(wsm, "Name of the user", 42, 30).Name
    
    Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
    
    wsm.Shapes.Range(arr).Group.Cut
    With wsm.Pictures.Paste
        .left = freeSlot.left
        .top = freeSlot.top
    End With
    
    Set card = wsm.Pictures(wsm.Pictures.Count)
    card.Name = "card" & projectName
End Sub

'Add a shape to a worksheet, with the text provided.
'  Return the added shape
Function AddLabel(ws As Worksheet, projectName As String, top As Integer, left As Integer)
    Dim shp
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 160, 30)
    With shp
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        With .TextFrame2.TextRange.Characters
            .Text = projectName
            .Font.Fill.ForeColor.RGB = vbBlack
            .Font.Size = 14
        End With
    End With
    Set AddLabel = shp
End Function

標籤：擅长 vba

上一篇：我如何將Django與Docker一起使用？

下一篇：WordVBA將未找到的內容標識為已找到