VBA - Label lose text after paste-CodePudding

So, I'm trying to create "cards" that the user can move around even when the the workbook is locked. Each card will contain info about a certain project. The way I'm doing it:

Create a few shapes (an rectangle and a few labels and icons)
Group them
Cut the group
Paste as image

The problem is that when I paste as image, all labels loose their text, they change back to "label1". If I run the code line by line, they don't lose the text.

I've tried already to add "time" between the cut and paste, adding some lines of code, moving the paste line to a separated sub, and even using Application.Wait(), but nothing worked.

I need to have them as an image (or one solid object - just a group doesn't work), because after the macro is finished, the worksheet is locked back again, and there is another macro to allow the user to move shapes even when the workbook is locked.

Here is a sample to show the problem.

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

CodePudding user response：

What about using shapes with no outline or fill, in place of labels?

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