VBA code om alle opmaakprofiel-eigenschappen te inventariseren?

Question

Ik heb handmatig een tabel in Excel gemaakt met als rijen alle mogelijke opmaakprofiel eigenschappen en als kolommen de verschillende Opmaakprofielen. Want ik wil een duidelijke inventarisatie van alle profielen in een sjabloon hebben. Ik zoek nu een macrocode of een invoegtoepassing die zo een 'stijl' inventarisatie in een Word- of Excel tabel automatisch kan maken. Als voorbeeld plak ik hier de handgemaakte tabel (met alleen het profiel 'Standaard')

hoofdgroep	tabblad	naam	Standaard
	type	Alinea
	opmaakprofiel gebaseerd op:	(geen)
	volgende alinea:	Standaard
	automatisch bijwerken	nee
Lettertype	Lettertype	Lettertype	Verdana
	Lettertype	Tekenstijl	normaal
	Lettertype	Punten	8
	Lettertype	Tekstkleur	Automatisch
	Lettertype	Onderstrepingsstijl	(geen)
	Lettertype	Effekten (verzameling)	(geen)
Alinea	Inspringingen en afstand	Alg_uitlijnen:	links
	Inspringingen en afstand	Overzichtsniveau	platte tekst
	Inspringingen en afstand	Inspr_links	0
	Inspringingen en afstand	Inspr_rechts	0
	Inspringingen en afstand	Inspr_speciaal	(geen)
	Inspringingen en afstand	Inspr_met
	Inspringingen en afstand	Afstand_voor	0
	Inspringingen en afstand	Afstand_na	0
	Inspringingen en afstand	Regelafstand + op	ten minste 14
	Inspringingen en afstand	ruimtetoevoegen?
	Tekstdoorloop	zwevende regels voorkomen	ja
	Tekstdoorloop	bij volgende alinea houden
	Tekstdoorloop	Regels bijeenhouden
	Tekstdoorloop	Pagina-einde ervoor
	Tekstdoorloop	Regelnummers onderdrukken
	Tekstdoorloop	niet afbreken
Taal	Taal	taalinstelling	NL (standaard)
	Taal	Geen controle?
	Taal	Taal automatisch bepalen
Sneltoets	Lijstopmaakprofielen	sneltoets

Alvast bedankt voor het mee-denken!

Met vriendelijke groeten,

Sabine

Answer 1

Sabine,

Onderstaande code geeft de eerste 10 eigenschappen van elk gebruikt(?) opmaakprofiel.

Voor twee eigenschappen heb ik aparte functies geschreven om leesbaar resultaat te krijgen.

Voor de laatste 2 (kleur en onderstrepingsstijl) zal dat ook nog moeten.

Aangenomen dat je een Excelbestand hebt met de eerste drie kolommen zoals je hierboven hebt aangegeven: MapStijlen.xls kom ik tot het volgende:

Sub StijlenRubriceren()

    Dim sty As Style

    Dim XlApp As New Excel.Application

    Dim wkb As Excel.Workbook

    Dim sh As Excel.Worksheet

    Dim kol As Long

    Dim var() As Variant

    On Error Resume Next

    Set wkb = XlApp.Workbooks.Open("D:\Data\Discussieforum\MapStijlen.xls")

    Set sh = wkb.Sheets("Blad1")

    kol = 0

    ReDim var(30, 0)

    For Each sty In ActiveDocument.Styles

        With sty

            If .InUse Then

                var(0, kol) = .NameLocal

                var(1, kol) = .Type

                var(2, kol) = .BaseStyle

                If .BaseStyle = "" Then var(2, kol) = "(geen)"

                var(3, kol) = .NextParagraphStyle

                If Err > 0 Then

                    Err = 0

                    var(3, kol) = "n.v.t."

                End If

                var(4, kol) = fctUpdate(sty)

                With .Font

                    var(5, kol) = .Name

                    var(6, kol) = fctFontStyle(sty)

                    var(7, kol) = .Size

                    var(8, kol) = .Color

                    var(9, kol) = .Underline

                    kol = kol + 1

                    ReDim Preserve var(30, kol)

                End With

            End If

        End With

    Next

    XlApp.Visible = True

    sh.Range(sh.Cells(1, 4), sh.Cells(31, kol + 3)) = var

End Sub

Function fctUpdate(sty As Style)

    Dim strResult As String

    On Error Resume Next

    Select Case sty.AutomaticallyUpdate

        Case True

            strResult = "ja"

        Case False

            strResult = "nee"

    End Select

    If Err > 0 Then

        Err = 0

        strResult = "n.v.t."

    End If

    fctUpdate = strResult

End Function

Function fctFontStyle(sty As Style) As String

    Dim strResult As String

    If sty.Font.Bold And sty.Font.Italic Then

        strResult = "Vet-Cursief"

    ElseIf sty.Font.Bold Then

        strResult = "Vet"

    ElseIf sty.Font.Italic Then

        strResult = "Cursief"

    Else

        strResult = "Standaard"

    End If

    fctFontStyle = strResult

End Function

de code plaats je in een algemene module van een document;

er moet in VBA een verwijzing worden gemaakt naar de Excel-bibliotheek

de procedure "StijlenRubriceren" is de uit te voeren macro

voor de overige (21) kenmerken moeten een aantal regels (en wellicht extra functies) worden toegevoegd

Hopelijk kun je hier iets mee.

Jan

P.S. de map-verwijzing in deze regel moet uiteraard worden aangepast:

Set wkb = XlApp.Workbooks.Open("D:\Data\Discussieforum\MapStijlen.xls")

Answer 2

Sabine,

Graag gedaan, mooi dat je er iets mee kunt en prettig dat je dat even meldt.

Jan

Answer 3

Beste Jan,

heb je macro uitgeprobeerd, en het werkt precies zo als ik het bedoel! Geweldig, ik zal de code zeker nog proberen om uit te breiden, is enorm leerzaam voor me. 

HEEL ERG BEDANKT!!!

Hartelijke groet,

Sabine

Answer 4

Beste Jan,

ik baal dat ik wederom geen notificatie per e-mail had ontvangen toen je gereageerd had op mijn post. Snap het niet, heb hier zelfs al eerder over een vraag gepost, waarom bij mij de notificaties niet binnenkomen. Soms wel, soms niet....

Ging net voor iets anders naar SocialAnswers en zag nu pas dat je me zo snel en met waarschijnlijk een super code gereageerd hebt. Hiervoor wil ik je heel hartelijk alvast danken, ik moet de code nog testen, en heb daar vandaag geen tijd voor, dat wordt het weekeind, en ik zal je zeker nog laten weten wat ik ervan vindt.

nogmaals bedankt en SORRY voor de late reactie,

Sabine