如何使用vba-excel组合形状?

时间:2017-05-24 06:30:07

标签: excel vba excel-vba

我想根据范围选择组合形状。喜欢这张照片。可能吗? 在这里我附上了图片:

combine picture 在这里,我附上了我的代码

Sub cohabitationButton_Click()
    '''''split range
    Dim s() As String
    Dim txt As String
    Dim i As Long

    s = Split(Selection.Address(False, False), ",")    

    For i = LBound(s) To UBound(s)
        Dim r As range: Set r = range(s(i))
        With r
            l = .Left - 5
            t = .Top - 5
            w = .Width + 10
            h = .Height + 10
        End With
        ShapeName = "ex"

        With ActiveSheet.Shapes.AddShape(msoShapeFlowchartTerminator, l, t, w, h)
            .Fill.Visible = msoFalse
            .Line.Weight = 1
            .Line.DashStyle = msoLineDash
            .Line.ForeColor.RGB = BASICCOLOR
            .Name = ShapeName
        End With  
    Next i
End Sub

2 个答案:

答案 0 :(得分:1)

不可能在Excel中组合形状。但是这里有一个例子,你可以如何在你的选择周围绘制组合边框。这可能是您的选择。

因此,通过选择您的示例,我们最终得到了这个:
enter image description here

      <?php 
        global $woocommerce;
        $qty = $woocommerce->cart->get_cart_contents_count(); 
        $total = $woocommerce->cart->get_cart_total();
        $cart_url = $woocommerce->cart->get_cart_url();
        echo $loginout = wp_loginout($_SERVER['REQUEST_URI'], false ); // show wp dynamic login / logout link
     ?>

           <a href="<?php echo $woocommerce->cart->get_checkout_url() ?>" title="<?php _e( 'Checkout' ) ?>">
               <?php _e( 'Checkout' ) ?>
            </a> |
           <a href="<?php echo $cart_url ?>" title="<?php _e( 'Cart' ) ?>">
               <?php _e( 'Cart ( '. $qty .' ) -'. $total ) ?>
           </a>

答案 1 :(得分:0)

尝试此操作并删除'范围前的撇号'(D5:F9,F8:H12,H11:J15“)。选择'进行测试

Sub cohabitationButton_Click()
    '''''split range
    Dim WB As Workbook
    Dim WS As Worksheet
     Dim s() As String
    Dim txt As String
    Dim i As Long
    Dim Shp As Shape
    Dim L  As Single, T  As Single, Lft As Single, Tp As Single
    Set WB = ThisWorkbook 'Set WB = Workbooks("WorkbookName")
    Set WS = WB.ActiveSheet 'Set WS = WB.WorkSheets("WorkSheetName")

 With WS
    For Each Shp In .Shapes
    If Shp.Type = 5 Then Shp.Delete
    Next

   ' Range("D5:F9,F8:H12,H11:J15").Select 'for test***
MyRange = Selection.Address
    s = Split(Selection.Address(False, False), ",")
    Dim Names(1 To 100) As Variant

    For i = LBound(s) To UBound(s)
        Dim r As Range: Set r = Range(s(i))
        With r
            L = .Left - 5
            T = .Top - 5
            w = .Width + 10
            h = .Height + 10
            If i = LBound(s) Then
            Lft = L
            Tp = T
            End If
            If Lft > L Then Lft = L
            If Tp > T Then Tp = T
        End With
        ShapeName = "ex"

        With .Shapes.AddShape(msoShapeFlowchartTerminator, L, T, w, h)
            .Fill.Visible = msoFalse
            .Line.Weight = 1
            .Line.DashStyle = msoLineDash
            .Line.ForeColor.RGB = BASICCOLOR
            .Name = Replace(.Name, "Flowchart: Terminator", ShapeName)
            Names(i + 1) = .Name

        End With
    Next i
    .Activate
    .Shapes.Range(Names).Select

        Selection.Cut
         Call MangeCombinePPTFromExcel(WS, Lft, Tp)
.Range(MyRange).Select

End With 'WS

End Sub

Public Sub MangeCombinePPTFromExcel(WS As Worksheet, Lft As Single, Tp As Single)

Dim PPT As Object
Dim Pres As Object
Dim Sld As Object
Dim Shp As Shape, Rctangl As Shape, Rctangll As Shape, MergeShape As Shape

Set PPT = CreateObject("Powerpoint.Application")
Set Pres = PPT.Presentations.Add
Set Sld = Pres.Slides.Add(1, 12)
 PPT.Activate

 ShapeName = "ex"

    With Sld
        .Shapes.Paste.Select
        On Error Resume Next
         PPT.CommandBars.ExecuteMso ("ShapesUnion")
        On Error GoTo 0
         .Shapes(.Shapes.Count).Cut


    End With
            With WS 'back to Excel
                .Paste
                With .Shapes(.Shapes.Count)
                .Name = ShapeName
                    .Left = Lft
                    .Top = Tp
                End With
            End With
  PPT.Quit
End Sub

点击查看图片 enter image description here