我正在使用 MS Excel 2010 我的公司为 MS Excel 2010 使用了一组标准配色方案/主题。我给它起了一个名字（companycolor）。我有一个模板，其中包含该配色方案和一个宏来执行任务。当我按下宏按钮时，它会复制活动表，保护它并将其通过电子邮件发送给预期的收件人。问题是当宏将活动表的副本复制到新工作簿中时，它不会复制模板具有的配色方案/主题，我意思是我公司的配色方案（companycolor），因此所有单元格的颜色、图表和形状的颜色都会根据 Excel 默认配色方案受到干扰和更改，这看起来很奇怪。你有什么办法可以克服这个问题或在这方面有什么建议吗
这是快照的链接！，帮助您更好地理解我的问题 * >>这是将活动工作表从活动工作簿复制到新工作簿的 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
以下是 Microsoft excel 在您创建任何新的配色方案/主题时保存的配色方案的 xml 编码，并将名为 xml 文件的配置文件保存在默认路径中 C:\Users\**UserName**\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors
到目前为止，我得出的结论是，无论如何，如果我们能够将下面的 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>