vba MS Excel 不会自动复制颜色主题

MS Excel do not copy the color theme automatically

提问by Syed Chowdhury

I am using MS Excel 2010 My Company uses a set of standard color scheme / theme for MS Excel 2010 .I gave it a name (companycolor). I have a template contains that color scheme and a macro in it to perform tasks. When I press macro button it makes a copy of activesheet,protect it and email it to intended recipient.Problem is that when macro makes a copy of activesheet into a new workbook it doesn't copy the color scheme / theme that template have, I mean with the my company color scheme (companycolor) due to which all cells color, color of charts and shapes get disturbed and changed according to Excel default color scheme which seems very odd. Do you have any way forward to overcome this issue or any suggestion in this regards

我正在使用 MS Excel 2010 我的公司为 MS Excel 2010 使用了一套标准配色方案/主题。我给它起了一个名字（公司颜色）。我有一个模板，其中包含该配色方案和一个宏来执行任务。当我按下宏按钮时，它会复制一份 activesheet，保护它并将其通过电子邮件发送给预期的收件人。问题在于，当宏将 activesheet 的副本复制到新工作簿中时，它不会复制模板具有的配色方案/主题，我意思是我公司的配色方案 (companycolor) 由于所有单元格颜色、图表颜色和形状都受到干扰并根据 Excel 默认配色方案进行更改，这看起来很奇怪。您有什么办法可以克服这个问题或在这方面有任何建议吗？

Here is the link of Snap Shot!, help you to understand my problem better*>>Here is the vba code that makes copy of active worksheet from active workbook into a new workbook, protect it and email it.***

这是快照的链接！，帮助您更好地理解我的问题* >>这是将活动工作表从活动工作簿复制到新工作簿中的 vba 代码，保护它并通过电子邮件发送。***

Private Sub CommandButton2_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

If (Range("AQ5") <> "") Or (Range("AQ6") <> "") Then
Range("A5").Select

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook
Application.ScreenUpdating = False

ActiveSheet.Copy

Range("A14").ClearContents
ActiveSheet.Protect Password:="1234567890"
Set Destwb = ActiveWorkbook

With Destwb
If Val(Application.Version) < 12 Then
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    If Sourcewb.Name = .Name Then
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        MsgBox "Your answer is NO in the security dialog"
        Exit Sub
    Else
        Select Case Sourcewb.FileFormat
        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
            If .HasVBProject Then
                FileExtStr = ".xlsm": FileFormatNum = 52
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        Case 56: FileExtStr = ".xls": FileFormatNum = 56
        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
 End If
 End With

 TempFilePath = Environ$("temp") & "\"
 TempFileName = "DI Status for " & Range("A17") & " Dated " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
 On Error Resume Next
 With OutMail
    .To = Range("AQ6").Value
    .CC = Range("AQ7").Value
    .BCC = ""
    .Subject = Range("AQ8").Value
    .Body = Range("AQ9").Value
    .Attachments.Add Destwb.FullName
    .Display
    Application.Wait (Now + TimeValue("0:00:00"))
    Application.SendKeys "%s"

End With
On Error GoTo 0
.Close savechanges:=False
End With


Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

Application.ScreenUpdating = True
Set Sourcewb = Nothing
Set Destwb = Nothing
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox ("Project Status Has been Sent")
 Else
MsgBox "There must be atleast one contact in the To, or Cc, field"
End If

End Sub

Below is xml coding of color scheme which Microsoft excel save when you create any new color scheme / theme and it save the configuration file called xml file in the default path C:\Users\**UserName**\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors

下面是Microsoft excel在创建任何新的配色方案/主题时保存的配色方案的xml编码，并将名为xml文件的配置文件保存在默认路径中 C:\Users\**UserName**\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors

so far i have reached to the conclusion that anyhow if we get able to incorporate that below xml code into the above vba code then we can get the desired result. But i dont know how.

到目前为止，我得出的结论是，无论如何，如果我们能够将下面的 xml 代码合并到上面的 vba 代码中，那么我们就可以获得所需的结果。但我不知道如何。

<?xml version="1.0" encoding="UTF-8" standalone="true"?>
-<a:clrScheme name="mycompanytheme"
xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main">
-<a:dk1>
      <a:sysClr lastClr="000000" val="windowText"/>
</a:dk1>
-<a:lt1>
      <a:sysClr lastClr="FFFFFF" val="window"/>
</a:lt1>
-<a:dk2>
      <a:srgbClr val="1F497D"/>
</a:dk2>
-<a:lt2>
      <a:srgbClr val="EEECE1"/>
</a:lt2>
-<a:accent1>
      <a:srgbClr val="D60037"/>
</a:accent1>
-<a:accent2>
      <a:srgbClr val="B21DAC"/>
</a:accent2>
+<a:accent3>
      -<a:accent4><a:srgbClr val="FFCE00"/>
</a:accent4>
-<a:accent5>
      <a:srgbClr val="009DD9"/>
</a:accent5>
-<a:accent6>
      <a:srgbClr val="AF0637"/>
</a:accent6>
      -<a:hlink><a:srgbClr val="80076B"/>
</a:hlink>
      -<a:folHlink><a:srgbClr val="218535"/>
</a:folHlink>
</a:clrScheme>

回答by Syed Chowdhury

Finally I found a way to get it worked!

最后我找到了让它工作的方法！

Describing solution so others can get help from this! Here is the conclusion and it worked! First of all by giving convenient path to the this vba code,paste it on the file that has any specific color scheme theme.

描述解决方案，以便其他人可以从中获得帮助！这是结论，它奏效了！首先，通过提供此 vba 代码的便捷路径，将其粘贴到具有任何特定配色方案主题的文件上。

   ActiveWorkbook.Theme.ThemeColorScheme.Save("C:\myThemeColorScheme.xml")

The above code will generate an xml file in your specified path.

上面的代码会在你指定的路径中生成一个xml文件。

Then, paste the below line of code giving the same path where your xml file resided, above your "email sending" code.

然后，将下面的代码行粘贴到您的 xml 文件所在的相同路径，在您的“电子邮件发送”代码上方。

ActiveWorkbook.Theme.ThemeColorScheme.Load("C:\myThemeColorScheme.xml")

Now it will it copy the theme in a new workbook.

现在它将在新工作簿中复制主题。

By default the theme configuration reside on

默认情况下，主题配置驻留在

"C:\Users\UserName\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\themefile.xml")

回答by Santosh

At the end of code you can call the below function which will set you color pallete for the activeworkbook. You need to adjust the RBG as per you company standard color theme.

在代码的末尾，您可以调用以下函数，该函数将为您设置活动工作簿的颜色调色板。您需要根据公司标准颜色主题调整 RBG。

 Sub SetColours()

        ActiveWorkbook.Colors(1) = RGB(140, 6, 12)
        ActiveWorkbook.Colors(2) = RGB(255, 255, 255)
        ActiveWorkbook.Colors(3) = RGB(255, 0, 0)
        ActiveWorkbook.Colors(4) = RGB(152, 196, 120)
        ActiveWorkbook.Colors(5) = RGB(0, 0, 255)
        ActiveWorkbook.Colors(6) = RGB(255, 215, 101)
        ActiveWorkbook.Colors(7) = RGB(248, 116, 122)
        ActiveWorkbook.Colors(8) = RGB(97, 176, 255)
        ActiveWorkbook.Colors(9) = RGB(128, 0, 0)
        ActiveWorkbook.Colors(10) = RGB(0, 128, 0)
        ActiveWorkbook.Colors(11) = RGB(19, 38, 78)
        ActiveWorkbook.Colors(12) = RGB(128, 128, 0)
        ActiveWorkbook.Colors(13) = RGB(128, 0, 128)
        ActiveWorkbook.Colors(14) = RGB(0, 128, 128)
        ActiveWorkbook.Colors(15) = RGB(192, 192, 100)
        ActiveWorkbook.Colors(16) = RGB(127, 114, 99)
        ActiveWorkbook.Colors(17) = RGB(153, 153, 255)
        ActiveWorkbook.Colors(18) = RGB(153, 51, 102)
        ActiveWorkbook.Colors(19) = RGB(255, 255, 204)
        ActiveWorkbook.Colors(20) = RGB(204, 255, 255)
        ActiveWorkbook.Colors(21) = RGB(102, 0, 102)
        ActiveWorkbook.Colors(22) = RGB(255, 128, 128)
        ActiveWorkbook.Colors(23) = RGB(0, 102, 204)
        ActiveWorkbook.Colors(24) = RGB(225, 225, 255)
        ActiveWorkbook.Colors(25) = RGB(0, 0, 128)
        ActiveWorkbook.Colors(26) = RGB(255, 0, 255)
        ActiveWorkbook.Colors(27) = RGB(255, 255, 0)
        ActiveWorkbook.Colors(28) = RGB(0, 255, 255)
        ActiveWorkbook.Colors(29) = RGB(128, 0, 128)
        ActiveWorkbook.Colors(30) = RGB(128, 0, 0)
        ActiveWorkbook.Colors(31) = RGB(0, 128, 128)
        ActiveWorkbook.Colors(32) = RGB(0, 0, 255)
        ActiveWorkbook.Colors(33) = RGB(131, 162, 225)
        ActiveWorkbook.Colors(34) = RGB(204, 255, 255)
        ActiveWorkbook.Colors(35) = RGB(204, 255, 204)
        ActiveWorkbook.Colors(36) = RGB(255, 255, 153)
        ActiveWorkbook.Colors(37) = RGB(153, 204, 255)
        ActiveWorkbook.Colors(38) = RGB(255, 153, 204)
        ActiveWorkbook.Colors(39) = RGB(204, 153, 255)
        ActiveWorkbook.Colors(40) = RGB(255, 204, 153)
        ActiveWorkbook.Colors(41) = RGB(51, 102, 255)
        ActiveWorkbook.Colors(42) = RGB(51, 204, 204)
        ActiveWorkbook.Colors(43) = RGB(153, 204, 0)
        ActiveWorkbook.Colors(44) = RGB(234, 148, 118)
        ActiveWorkbook.Colors(45) = RGB(255, 153, 0)
        ActiveWorkbook.Colors(46) = RGB(255, 102, 0)
        ActiveWorkbook.Colors(47) = RGB(102, 102, 153)
        ActiveWorkbook.Colors(48) = RGB(199, 190, 182)
        ActiveWorkbook.Colors(49) = RGB(0, 51, 102)
        ActiveWorkbook.Colors(50) = RGB(51, 153, 102)
        ActiveWorkbook.Colors(51) = RGB(40, 70, 55)
        ActiveWorkbook.Colors(52) = RGB(225, 168, 0)
        ActiveWorkbook.Colors(53) = RGB(212, 81, 33)
        ActiveWorkbook.Colors(54) = RGB(204, 160, 123)
        ActiveWorkbook.Colors(55) = RGB(98, 52, 72)
        ActiveWorkbook.Colors(56) = RGB(0, 0, 40)

    End Sub

回答by AlexB

You can also try the following

您也可以尝试以下方法

'Copy current colorscheme to the new Workbook
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim Destwb As Workbook
Set Destwb = ActiveWorkbook
For i = 1 To 56
  Destwb.Colors(i) = Sourcewb.Colors(i)
Next i

回答by Alze

Another, perhaps more elegant, solution would be taking the same template the ActiveWorkbook is using and applying it to the newly create workbook:

另一个可能更优雅的解决方案是采用 ActiveWorkbook 正在使用的相同模板并将其应用于新创建的工作簿：

Set NewBook = Workbooks.Add("OriginalTemplate")

In this case 'OriginalTemplate' is the name of the template of the ActiveWorkbook

在这种情况下，'OriginalTemplate' 是 ActiveWorkbook 的模板名称

回答by Syed Chowdhury

Use PasteSpecial Method.

使用 PasteSpecial 方法。

 With Range("A1:K1")
     .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
     SkipBlanks:=False, Transpose:=False
     Application.CutCopyMode = False
 End With

Refer this Link for more about PasteSpecial

有关 PasteSpecial 的更多信息，请参阅此 链接