Kleurthema aanpassen in VBA

[BabsM]

Hi!

Wanneer ik een tabblad kopieer naar een nieuwe map, verandert het kleurthema van dat tabblad.
Normaal gesproken los ik dat op door via het blad van pagina-indeling mijn kleurinstellingen weer aan te passen.
Daarna sla ik dit tabblad op en zet dit in de mail.

Ondertussen heb ik de macro zover ingericht dat hij mijn tabblad verplaatst naar een nieuwe map, opslaat en in de mail zet en mijn tijdelijke bestand ook weer verwijdert.
Helaas niet in het juiste kleurthema.

Hoe kan ik de macro zo maken dat hij het juiste kleurenschema aanhoudt?
Een simpel opnemen brengt me helaas niet verder, want dan is de macro puur aan mijn account gekoppeld en ik wil dit kunnen delen met anderen

 

[VenA]

Plaats even een voorbeeldbestand met de code die je nu al hebt. Een macro is normaal gesproken document gebonden. Dus met een opname moet het ook lukken.

 

[BabsM]

Ik heb een bestand voor je bijgevoegd. Vrij ver uitgekleed, maar dat moet geen problemen opleveren

En de code die ik nu heb staan.. Zonder de aanpassing in kleuren..

Sub emailen()


    Dim ObjOutlook As Object
    Dim ObjMail As Object
    Dim ws As Worksheet
    Dim strAan As String
    Dim strCC As String
    Dim strOnderwerp As String
    Dim strBericht As String
    Dim strFrom As String

    Set ObjOutlook = CreateObject("Outlook.Application")
    Set ObjMail = ObjOutlook.CreateItem(0)

Naam = Sheets("Dagprognose").Range("B2").Value
Sheets(Array("Dagprognose")).Copy

For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
    .Value = .Value
    
    End With
Next ws

Application.DisplayAlerts = False
With ActiveWorkbook
    .SaveAs Filename:=Environ$("temp") & "\" & Naam, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True
    .Close
End With

 Sheets("Dagverslag").Select
 
    strFrom = "van email"
    strAan = "aan email"
    strCC = "cc email"
    strBCC = "bcc email"
    strOnderwerp = [B2] & " " & [O2]
    strBericht = "Goedendag," & vbCr & vbCr & "Hierbij het dagverslag van " & Format(Now(), "dddd d-m-yyyy") & "." & vbCr & vbCr
            
    Range("A1:W137").Select
    Selection.Copy

With ObjMail
        .SentOnBehalfOfName = strFrom
        .To = strAan
        .CC = strCC
        .BCC = strBCC
        .Subject = strOnderwerp
        .Body = strBericht
        .Attachments.Add (Environ$("temp") & "\" & Naam & ".xlsx")
        .Display
End With

    Set ObjMail = Nothing
    Set ObjOutlook = Nothing

Kill Environ$("temp") & "\" & Naam & ".xlsx"

End Sub

 

[edmoor]

Probeer het eens zo:

Sub emailen()
    ActiveWorkbook.Theme.ThemeColorScheme.Save (Environ("temp") & "\Kleurenschema.xml")
    Sheets("Dagprognose").Copy
    Application.OnTime Now + TimeValue("00:00:01"), "Kleurtjes"
End Sub

Sub Kleurtjes()
    ActiveWorkbook.Theme.ThemeColorScheme.Load (Environ("temp") & "\Kleurenschema.xml")
End Sub

De Sub Kleurtjes moet in een Module staan.

 

[BabsM]

Ik ga eens kijken.
Op de een of andere manier loopt ie nu vast op het selecteren van de sheet voor de mail.

 Sheets("Dagverslag").Select
 
    strFrom = "van email"
    strAan = "aan email"
    strCC = "cc email"
    strBCC = "bcc email"
    strOnderwerp = [B2] & " " & [O2]
    strBericht = "Goedendag," & vbCr & vbCr & "Hierbij het dagverslag van " & Format(Now(), "dddd d-m-yyyy") & "." & vbCr & vbCr
            
    Range("A1:W137").Select
    Selection.Copy

Ik snap 't wel, want hij zit nu natuurlijk nog in het nieuwe excelbestand dat gecreëerd is, maar dan moet ik 'm dus terugverwijzen naar het originele bestand.

 

[edmoor]

Gebruik voor code die in het originele document moet worden uitgevoerd niet ActiveWorkbook maar ThisWorkbook.

 

[BabsM]

Aangepast, maar loop nu tegen 2 dingen aan.
Kleuren worden niet juist aangepast (wellicht doe ik het verkeerd) en hij opent nu 3 keer hetzelfde bestand en sluit er 1 af.

Waarschijnlijk zet ik het niet op de juiste plek of zo.
Of zijn dit twee subs/modules die ik nog extra moet aanmaken?

 

[edmoor]

Ik begrijp niet wat er moeilijk aan is.
Je hebt dit al staan:

Sheets(Array("Dagprognose")).Copy

Maak daar dit van:

ActiveWorkbook.Theme.ThemeColorScheme.Save (Environ("temp") & "\Kleurenschema.xml")
Sheets("Dagprognose").Copy
Application.OnTime Now + TimeValue("00:00:01"), "Kleurtjes"

En zet dit in een module:

Sub Kleurtjes()
    ActiveWorkbook.Theme.ThemeColorScheme.Load (Environ("temp") & "\Kleurenschema.xml")
End Sub

 

[BabsM]

Aii... Ik heb er overheen gelezen, wat stom zeg..

Helaas geen kleuraanpassingen (en 1 extra sheet open)

 

[edmoor]

Werkt hier prima.
Plaats dus je document.

 

[VenA]

Als alternatief:
Maak een copy van het werkboek, verwijder de overbodige tabjes en gebruik dit bestand als bijlage in de E-mail.

Sub VenA()
  c00 = "E:\Temp\" & Sheets("Dagprognose").Range("B2") & ".xlsx"
  Application.DisplayAlerts = False
  ThisWorkbook.SaveCopyAs c00
  With GetObject(c00)
    For Each sh In .Sheets
      If sh.Name <> "Dagprognose" Then sh.Delete
    Next sh
    .Close True
  End With
  Application.DisplayAlerts = True
End Sub

 

[BabsM]

Met macroknop ingebouwd.
Twee modules; 1 voor e-mailen en 1 voor de kleurtjes

Als ik de bijlage in de mail open, heeft hij een groene/oranje kleurstelling, in plaats van de roze/blauwe kleurstelling die ik nu heb.

 

[edmoor]

Dat komt omdat je document veel te snel gesloten wordt.
Na het kopiëren moet je dus volledig doorgaan in de Sub Kleurtjes.
Probeer dit maar eens:
Bekijk bijlage Voorbeeld.xlsm

 

[BabsM]

Ah, top!
Ik snap wat je hebt gedaan en op zich heel logisch dat het zo moet.
Ik adem nog geen VBA, dat zal wel het probleem zijn
Dank je wel!

 

[edmoor]

Je had het prima begrepen
Dat stukje van document sluiten had ik ook over het hoofd gezien.