MS Excel不自动复制颜色主题 [英] MS Excel do not copy the color theme automatically

问题描述

我使用的是MS Excel 2010
我的公司使用一套标准配色方案/主题为MS Excel 2010。我给它一个名称（companycolor）。我有一个模板包含该配色方案和一个宏来执行任务。当我按下宏按钮它制作副本的活动表，保护它，并通过电子邮件发送给预期的收件人。问题是，当宏将活动表复制到一个新的工作簿，它不复制模板的颜色方案/主题，我意味着与我的公司配色方案（公司色）由于所有单元格的颜色，图表和形状的颜色被打扰和更改根据Excel默认颜色方案，这似乎很奇怪。

这里是链接的 Snap Shot！，帮助您更好地了解我的问题
* >>这里是vba代码，使活动工作表从活动工作簿复制到一个新的工作簿，保护它和发送电子邮件。 ***

  Private Sub CommandButton2_Click（）
 
 Dim FileExtStr As String 
 Dim FileFormatNum As Long 
 Dim Sourcewb作为工作簿
 Dim Destwb as Workbook 
 Dim TempFilePath As String 
 Dim TempFileName As String 
 Dim OutApp As Object 
 Dim OutMail As Object 
 
如果（Range（AQ5）>）或（Range（AQ6））然后
范围（A5）。选择
 $ b b应用程序
 .ScreenUpdating = False 
 .EnableEvents = False 
结束于
 
设置Sourcewb = ActiveWorkbook 
 Application.ScreenUpdating = False 
 
 ActiveSheet.Copy 
 
范围（A14）。ClearContents 
 ActiveSheet.Protect密码：=1234567890
设置Destwb = ActiveWorkbook 
 
 With Destwb 
如果Val（Application.Version）< 12 Then 
 FileExtStr =.xls：FileFormatNum = -4143 
否则
如果Sourcewb.Name = .Name然后
应用程序
 .ScreenUpdating = True 
 .EnableEvents = True 
结束于
 MsgBox您的答案在安全对话框中不存在
退出Sub 
否则
选择案例Sourcewb.FileFormat 
案例51：FileExtStr =.xlsx：FileFormatNum = 51 
案例52：
如果.HasVBProject则
 FileExtStr =.xlsm：FileFormatNum = 52 
否则
 FileExtStr =.xlsx：FileFormatNum = 51 
如果
结束案例56：FileExtStr =.xls：FileFormatNum = 56 
案例Else：FileExtStr =.xlsb：FileFormatNum = 50 
结束选择
结束如果
结束如果
结束于
 
 TempFilePath = Environ $（temp）& \
 TempFileName =DI状态为&范围（A17）& 日期&格式（现在，dd-mmm-yy h-mm-ss）
 
设置OutApp = CreateObject（Outlook.Application）
设置OutMail = OutApp.CreateItem（0）
 
 With Destwb 
 .SaveAs TempFilePath& TempFileName& FileExtStr，FileFormat：= FileFormatNum 
 On Error Resume Next 
 With OutMail 
 .To = Range（AQ6）。
 .CC = Range（AQ7）。 
 .BCC =
 .Subject = Range（AQ8）。Value 
 .Body = Range（AQ9）。Value 
 .Attachments.Add Destwb.FullName 
。显示
 Application.Wait（Now + TimeValue（0:00:00））
 Application.SendKeys％s
 
结束于
 On Error GoTo 0 
。关闭savechanges：= False 
结束于
 
 
结束TempFilePath& TempFileName& FileExtStr 
 
设置OutMail =无
设置OutApp =无
 
应用程序
 .ScreenUpdating = True 
 .EnableEvents = True 
 End With 
 
 Application.ScreenUpdating = True 
设置Sourcewb =无
设置Destwb =无
设置OutApp =无
设置OutMail =无
 MsgBox（项目状态已发送）
否则
 MsgBox在To或Cc字段中必须至少有一个联系人
 End If 
 
 End Sub 
  

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

到目前为止，我得到的结论，无论如何，如果我们能够将下面的xml代码合并到上述vba代码，然后我们可以得到所需的结果。但我不知道如何。

 <？xml version =1.0encoding =UTF-8standalone = > 
  - < a：clrScheme name =mycompanytheme
 xmlns：a =http://schemas.openxmlformats.org/drawingml/2006/main> 
  - < a：dk1> 
< a：sysClr lastClr =000000val =windowText/> 
< / a：dk1> 
  - < a：lt1> 
< a：sysClr lastClr =FFFFFFval =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> 
  

解决方案

/ p>

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

  ActiveWorkbook.Theme.ThemeColorScheme.Save（C：\myThemeColorScheme.xml）
  

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

然后，粘贴下面的代码行，给出xml文件所在的路径，电子邮件发送代码。

  ActiveWorkbook.Theme.ThemeColorScheme.Load（C：\myThemeColorScheme.xml）
  

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

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

 C：\Users\UserName\AppData\Roaming\\ \\ Microsoft \Templates\DocumentThemes\Theme Colors \themefile.xml）
  

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

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.***

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

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 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>

解决方案

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.

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

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

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

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")

这篇关于MS Excel不自动复制颜色主题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！