基于复选框包含一列或更多列的代码

Question

我有这段代码，可以将范围作为图片发送到 Outlook 电子邮件中。我添加了复选框，并希望能够修改代码以发送 B4:B17 范围内的内容以及 C、D 和 E 之一或全部，具体取决于复选框是否为 true。 我不知道该怎么做，有人可以帮助我吗？ 我确实将其发布在 mrexcel 论坛上，但无法获得有效的解决方案： https://www.mrexcel.com/board/threads/code-to-include-a-column-or-more-based-on-checkbox.1265484/#post-6222439

Sub Screen2ShotMain()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Rows("11:11").Select
Selection.EntireRow.Hidden = True

Set rng = Sheets("Calc").Range("B4:C16")
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)

With Email
  '.To = "damor"
  .CC = ""
  .BCC = ""
  .Subject = "Forward Commitment" ' & Range("F5").Value
  .Body = "Please see details of forward commitment as discussed" & vbCr & vbCr
  .Display
  DoEvents
    Set wdDoc = Email.GetInspector.WordEditor
    Set wdRng = wdDoc.Application.ActiveDocument.Content
    wdRng.Collapse Direction:=wdCollapseEnd
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wdRng.PasteSpecial DataType:=3
  .Display
End With

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set Email = Nothing
Set olApp = Nothing
Rows("11:11").Select
Selection.EntireRow.Hidden = False
ActiveSheet.Protect Password:="Mortgage1"
End Sub

Answer 1

假设您的复选框是表单控件，您可以执行如下操作。 这只是一种快速而肮脏的方法，但应该让您知道该怎么做：

Sub Screen2ShotMain()
    Dim rngB As Range, rngC As Range, rngD As Range, rngE As Range, rng As Range
    Dim olApp As Object
    Dim Email As Object
    Dim wdDoc As Word.Document
    Dim wdRng As Word.Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    
    With Sheets("Calc")
        .Rows("11:11").EntireRow.Hidden = True
        Set rngB = .Range("B4:B17")
        
        'You can use .CheckBoxes("Check box name instead, click on the checkbox to check its name") instead
        If .CheckBoxes(1).Value = 1 Then Set rngC = .Range("C4:C17") Else Set rngC = Nothing
        If .CheckBoxes(2).Value = 1 Then Set rngD = .Range("D4:D17") Else Set rngD = Nothing
        If .CheckBoxes(3).Value = 1 Then Set rngE = .Range("E4:E17") Else Set rngE = Nothing
    
        Set rng = Union(rngB, rngC, rngD, rngE)
        
    End With
    
    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)
    
    With Email
      '.To = "damor"
      .CC = ""
      .BCC = ""
      .Subject = "Forward Commitment" ' & Range("F5").Value
      .Body = "Please see details of forward commitment as discussed" & vbCr & vbCr
      .Display
      DoEvents
        Set wdDoc = Email.GetInspector.WordEditor
        Set wdRng = wdDoc.Application.ActiveDocument.Content
        wdRng.Collapse Direction:=wdCollapseEnd
        rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        wdRng.PasteSpecial DataType:=3
      .Display
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set Email = Nothing
    Set olApp = Nothing
    
    With Sheets("Calc")
        .Rows("11:11").EntireRow.Hidden = False
        .Protect Password:="Mortgage1"
    End With
End Sub