Set "away" status in meeting invites as blocker for others

Good afternoon,

here is the english version:

I would like to insert a BuiltInDocumentPropertie (to be precise the field itself) into a text box. The text box should contain the content of the quick function block "Status" (internally referred to as "Content status").

The following code only inserts the name of the field, but not the field itself.

Dim proDoc As DocumentProperty

Add a text box

Set shpCanvas = ActiveDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=1, Top:=1, Width:=100, Height:=100)

For Each proDoc In ActiveDocument.BuiltInDocumentProperties

If proDoc.Name = "Content status" Then

Set proDoc = ActiveDocument.BuiltInDocumentProperties("Content status")

shpCanvas.TextFrame.TextRange = ActiveDocument.BuiltInDocumentProperties("Content status")

End If

Next

Thank you for your help in advance!

Verabschiede Dich bitte mal von der "StartZelle", sowas gibt es nicht.

Entweder Du löscht alles, dann nimmst Du mein zweites Löschen-Makro oder Du willst nur den Block löschen in dem sich die aktive Zelle befinden, dann nimmst Du mein erstes Löschen-Makro.

Und wenn es mal passt und mal nicht, dann stimmt Deine Datei, sprich die Blockgröße nicht.

Mach eine neue Datei und lass das Makro unten laufen. Jeder Block hat 10 Spalten, im ersten ist der Bereich D4:J23 markiert und alle anderen rechts daneben sehen gleich aus.

Wie siehts aus, ist der Groschen nun gefallen? ;-)))

Andreas.

Option Explicit

Sub Markieren()

Const BlockSize = 10

Dim R As Range, B As Range, C As Range

Dim i As Integer, j As Integer

For i = 1 To 50

'Erste Zelle des Blocks berechnen in dem sich die Zelle befindet

Set R = Cells(1, (i - 1) * BlockSize + 1)



Set B = R.Resize(1, BlockSize).EntireColumn

B.Borders(xlEdgeRight).ColorIndex = 1

For j = 1 To BlockSize

B.Cells(1, j) = j

Next



Set R = R.Offset(0, 3).Resize(1, 7)

Set R = Intersect(R.EntireColumn, Range("4:23"))



R.BorderAround ColorIndex:=3

With R(1, 1).Offset(R.Rows.Count \ 2, R.Columns.Count \ 2)

.Value = "Block " & i

.Font.ColorIndex = 3

.Font.Bold = True

End With

Next

End Sub

Hallo Andreas,

mh, dann müsstest du den Pfad und den Baustein überprüfen, ob die Datei am Ort vorhanden ist und der Baustein enthalten ist.

Z.B. so:

Templates.LoadBuildingBlocks

Dim objTemplate As Template, objBB As Template

Dim objBBEntry As BuildingBlock

Dim i As Integer

For Each objTemplate In Templates

  If objTemplate.Name = "Building Blocks.dotx" Then

    Set objBB = objTemplate

    Exit For

  End If

Next objTemplate

If Not objBB Is Nothing Then

  Debug.Print objBB.FullNameElse  MsgBox "Building Blocks nicht gefunden", vbCritical  Exit SubEnd If

For i = 1 To objBB.BuildingBlockEntries.Count

  If objBB.BuildingBlockEntries(i).Name = "TOP" Then

    Set objBBEntry = objBB.BuildingBlockEntries(i)

    objBBEntry.Insert Where:=Selection.Range, RichText:= _

        True

    Exit For

  End If

Next i

If objBBEntry Is Nothing Then MsgBox "Schnellbaustein nicht gefunden", vbCritical

Man kann nicht nur Range Variablen benutzen, man sollte!
Das erste Problem an einem aufgezeichneten Makro ist SELECT, SELECTION, das macht jedes Makro langsam und fehleranfällig. Daher:
Range("A3:U30").Copy
Range("A31:U58").PasteSpecial Paste:=xlPasteFormats

bewirkt das gleich. So passiert das gleiche, nur das wir eine Range Variable benutzen
Dim Dest As Range
Set Dest = Range("A31:U58")
Range("A3:U30").Copy
Dest.PasteSpecial Paste:=xlPasteFormats

Der Vorteil ist das die Range-Variable "weiß" wo sie ist; wie groß sie ist, usw., man kann einfach alles abfragen. Wenn wir also diese Zeilen zusätzlich ausführen
Set Dest = Dest.Offset(Dest.Rows.Count)
Dest.PasteSpecial Paste:=xlPasteFormats

ist der nächste Block fertig. Das ganze 4x und fertig.
Sub Test()
Dim Dest As Range
Dim i As Integer
'Ziel festlegen
Set Dest = Range("A31:U58")
'Quelle kopieren
Range("A3:U30").Copy
For i = 1 To 4
'Formate einfügen
Dest.PasteSpecial Paste:=xlPasteFormats
'Ziel um einen Block weiter setzen
Set Dest = Dest.Offset(Dest.Rows.Count)
Next
'Kopieren aus
Application.CutCopyMode = False
End Sub
Alles klar?
Andreas.

Hallo Dietmar ,
<br />Das Thema ist auch im englischen Forum besprochen. Es gibt keine solche Funktion und du kannst deine Stimme in Uservoice geben,
<br />Mit freundlichen Grüssen
<br />Galin Karlov
<br />Microsoft Support Engineer
<br />