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

Question

我正在使用MS Excel 2010我的公司为MS Excel 2010使用了一套标准配色方案/主题.我给它起了一个名字(companycolor).我有一个模板包含该颜色方案和一个宏来执行任务.当我按下宏按钮时,它会生成活动表的副本,保护它并通过电子邮件发送给预期的收件人.问题是,当宏将活动表复制到新工作簿时,它不会复制模板具有的配色方案/主题,我我的公司配色方案(companycolor)意味着所有单元格的颜色,图表和形状的颜色会受到干扰,并根据Excel默认颜色方案进行更改,这似乎很奇怪.您是否有任何方法可以解决这个问题或在这方面的任何建议

这是Snap Shot的链接!,帮助您更好地理解我的问题 *>>这是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代码中的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>

Answer 1

最后,我找到了一种方法让它工作!

描述解决方案,以便其他人可以从中获得帮助!这是结论,它的工作原理!首先,通过提供此vba代码的便捷路径,将其粘贴到具有任何特定颜色方案主题的文件上.

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

上面的代码将在您指定的路径中生成一个xml文件.

然后,粘贴下面的代码行,为您的"电子邮件发送"代码上方提供xml文件所在的路径.

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

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

默认情况下,主题配置位于

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