Excel VBA复制msoShapeCube后AutoShapeType变为msoShapeMixed的问题求助

问题描述 #

在项目中需多次将msoShapeCube类型的立方体形状从一个工作表复制到另一个，为了正确排列需要获取其比例（通过Adjustments.Item(1)）。但粘贴后，原形状的AutoShapeType变为msoShapeMixed（该类型无Adjustments属性）。目前已用原形状的Adjustments.Item(1)作为临时解决方法，但想了解形状样式被修改的原因，以及如何保留原ShapeType或可靠获取比例。

用户提供的代码片段：

Dim thisBox As Shape
Dim refBox As Shape
 
boxLength = Feuil23.Range("E33").Value
boxWidth = Feuil23.Range("E34").Value
boxHeight = Feuil23.Range("E35").Value
nbBoxInLength = Feuil23.Range("I33").Value
nbBoxInWidth = Feuil23.Range("I34").Value
nbLayers = Feuil23.Range("I35").Value

nomCarton = boxLength & "x" & boxWidth & "x" & boxHeight
Count = 1

'FindCarton is a sub returning the Shape index of my box, if found, or -1 if not found.
If (FindCarton(nomCarton) <> -1) Then
    Set refBox = Feuil13.Shapes(nomCarton)
    ' I checked the AutoShapeStyle of refBox ; it is =14 (msoShapeCube)
    ' a spy on refBox clearly states "msoShapeCube" for this variable.
    ' Loop to stack layers
    For iInLayers = 1 To nbLayers
        ' Loop to add boxes in horizontal direction
        For iInLength = 1 To nbBoxInLength
            ' Loop to add boxes in opposite direction
            For iInWidth = 1 To nbBoxInWidth
                refBox.Copy
                Feuil23.Range("E11").Select
                Feuil23.Paste
                Feuil23.Shapes(nomCarton).Name = nomCarton & "_" & Count
                Set thisBox = Feuil23.Shapes(nomCarton & "_" & Count)
                ' a spy on thisBox says "msoShapeMixed" for this variable.
                ' I do not understand why...

原因分析 #

使用Copy/Paste复制形状时，Excel剪贴板可能会将形状及其关联格式、元数据打包为复合对象，而非单一的自动形状。这种情况下，系统无法识别为纯msoShapeCube类型，因此AutoShapeType返回msoShapeMixed。

解决方案 #

1. 直接创建新形状（推荐） #

放弃剪贴板复制，改用Shapes.AddShape方法直接创建msoShapeCube类型的形状，同时继承原形状的调整值、格式等参数，完全避免类型转换问题。

优化后的代码示例：

Dim thisBox As Shape
Dim refBox As Shape
 
boxLength = Feuil23.Range("E33").Value
boxWidth = Feuil23.Range("E34").Value
boxHeight = Feuil23.Range("E35").Value
nbBoxInLength = Feuil23.Range("I33").Value
nbBoxInWidth = Feuil23.Range("I34").Value
nbLayers = Feuil23.Range("I35").Value

nomCarton = boxLength & "x" & boxWidth & "x" & boxHeight
Count = 1

If (FindCarton(nomCarton) <> -1) Then
    Set refBox = Feuil13.Shapes(nomCarton)
    ' 提取原形状的关键参数
    Dim cubeAdjustment As Single
    cubeAdjustment = refBox.Adjustments.Item(1)
    Dim baseLeft As Single, baseTop As Single, baseWidth As Single, baseHeight As Single
    baseLeft = refBox.Left
    baseTop = refBox.Top
    baseWidth = refBox.Width
    baseHeight = refBox.Height
    
    ' 循环创建形状并排列
    For iInLayers = 1 To nbLayers
        For iInLength = 1 To nbBoxInLength
            For iInWidth = 1 To nbBoxInWidth
                ' 直接创建立方体形状
                Set thisBox = Feuil23.Shapes.AddShape( _
                    Type:=msoShapeCube, _
                    Left:=baseLeft + (iInLength - 1) * baseWidth, _
                    Top:=baseTop + (iInLayers - 1) * baseHeight + (iInWidth - 1) * (baseWidth * 0.5), ' 根据需求调整位置逻辑
                    Width:=baseWidth, _
                    Height:=baseHeight _
                )
                ' 设置调整值和名称
                thisBox.Adjustments.Item(1) = cubeAdjustment
                thisBox.Name = nomCarton & "_" & Count
                ' 复制原形状的格式（保持视觉一致）
                refBox.Copy
                thisBox.PasteFormat
                
                Count = Count + 1
            Next iInWidth
        Next iInLength
    Next iInLayers
End If

2. 保留剪贴板复制的兼容处理 #

若必须使用Copy/Paste，可直接从原形状复制Adjustments值到新形状，无需依赖新形状的属性：

' 粘贴后直接应用原形状的调整值
Set thisBox = Feuil23.Shapes(nomCarton & "_" & Count)
thisBox.Adjustments.Item(1) = refBox.Adjustments.Item(1)

这种方法虽然新形状的AutoShapeType仍可能是msoShapeMixed，但可以正常设置和使用比例调整值。

内容的提问来源于stack exchange，提问作者TomTomZJ