私は 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
以下は、新しい配色/テーマを作成し、xmlファイルと呼ばれる構成ファイルをデフォルトパスに保存するときに、Microsoft Excelが保存する配色の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>