Cacher is the code snippet organizer for pro developers

Function Get_ComDocSubject(TargetDocument As Document) As String

' version 0.1 - Adapted from old "Copie_CoteMat_Subject" (pre-office 2010 migration code)

' Copie continutul ultimei celule din ultima coloana a primului tabel din documentul SGC original, daca e deschis, in
' documentul SGC versiunea romaneasca. Rudimentar.

Dim k As Integer
Let k = 0

Dim odoc As Document
Dim cmR As Range, cmRC As Range
Dim Its_CommDoc As Boolean

Dim tGather(8) As String
Dim lSep As String

If Is_GSC_Doc(TargetDocument.Name, "SilentMode") And Is_ULg_Doc(TargetDocument.Name) Then
    
        For Each adv In ActiveDocument.Variables
            If adv.Name = "LW_DocType" And adv.Value <> "<UNUSED>" Then
                If adv.Value = "COM" Or adv.Value = "SEC" Or _
                    adv.Value = "D" Or adv.Value = "DEC" Or _
                    adv.Value = "C" Or adv.Value = "NORMAL" Then
                    Its_CommDoc = True
                End If
                Exit For
            End If
        Next adv
                        
        If Its_CommDoc = True Then
                                            
            For Each adv In ActiveDocument.Variables
                If adv.Name = "LW_STATUT.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(1) = adv.Value
                ElseIf adv.Name = "LW_TYPE.DOC.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(2) = adv.Value
                ElseIf adv.Name = "LW_DATE.ADOPT.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(3) = adv.Value
                ElseIf adv.Name = "LW_TITRE.OBJ.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(4) = adv.Value
                ElseIf adv.Name = "LW_ACCOMPAGNANT.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(5) = adv.Value
                ElseIf adv.Name = "LW_TYPEACTEPRINCIPAL.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(6) = adv.Value
                ElseIf adv.Name = "LW_OBJETACTEPRINCIPAL.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(7) = adv.Value
                ElseIf adv.Name = "LW_SOUS.TITRE.OBJ.CP" And (adv.Value <> "" And adv.Value <> "<UNUSED>") Then
                    tGather(8) = adv.Value
                End If
            Next adv
                                    
            For l = 1 To 8
                If tGather(l) <> "" Then
                    tGatherTxt = tGatherTxt & " " & tGather(l) & " "
                End If
            Next l
            tGatherTxt = Trim(tGatherTxt)
                    
            For Each adb In ActiveDocument.Bookmarks
                If Left$(adb.Name, 7) = "Subject" Then
                    Set cmR = ActiveDocument.Bookmarks(adb).Range
                    cmR.Collapse (wdCollapseEnd)
                    cmR.MoveEndUntil (vbCr)
                    cmR.Text = tGatherTxt
                                                
                    cmR.Expand (wdCell): cmR.MoveEnd wdCharacter, -1: cmR.Select

findNO:             Set cmRC = cmR.Duplicate
                    With cmRC.Find
                        .ClearFormatting
                        .ClearAllFuzzyOptions
                        .Forward = True
                        .Wrap = wdFindStop
                        .Format = False
                        .MatchWildcards = True
                        .Text = "\u[0-9]{3" & lSep & "}?"
                        .Replacement.Text = ""
                        .Execute
                        
                        If .found = True Then
                            cmRC.MoveStart wdCharacter, -1
                            cmRC.Text = ChrW(Mid$(cmRC.Text, 3, Len(cmRC.Text) - 3))
                            GoTo findNO
                        End If
                    End With
                    
                    cmR.Select
'                   gsc.FndRpl "\u537?", ChrW(537), , 0: gsc.FndRpl "\u539?", ChrW(539), , 0
'                   gsc.FndRpl "\u355?", ChrW(355), , 0 ': gsc.FndRpl "\u539?", ChrW(539), , 0
'                   gsc.FndRpl "\u536?", ChrW(536), , 0: gsc.FndRpl "\u538?", ChrW(538), , 0
'                   gsc.FndRpl "\u259?", ChrW(259), , 0: gsc.FndRpl "\u238?", ChrW(238), , 0
'                   gsc.FndRpl "\u206?", ChrW(206), , 0: gsc.FndRpl "\u258?", ChrW(258), , 0
'                   gsc.FndRpl "\u194?", ChrW(194), , 0: gsc.FndRpl "\u226?", ChrW(226), , 0
                    gsc.FndRpl ChrW(11) & ChrW(11) & ChrW(11), ChrW(11), , 0
                    gsc.FndRpl ChrW(11) & ChrW(11), ChrW(11), , 0
                    gsc.FndRpl "  ", " ", , 0
                    Selection.Collapse (wdCollapseEnd)
                    
                    StatusBar = "Get_ComDocSubject: ComDoc title extracted!"
                    Exit For
                End If
            Next adb
            
        End If
        
    Else    ' Target Document does not contain necessary LW metadata!
        ' De folosit cumva "OpenDoc" al GSC-ului pentru a aduce originalul de pe M:\Prod?
        'Set groCleanUp.msgBal = Assistant.NewBalloon
        'Call groCleanUp.msg_Bal(msoModeAutoDown, msoBalloonTypeBullets, msoAnimationWritingNotingSomething, _
        'msoIconAlertCritical, msoButtonSetNone, "Originalul nu este deschis!", "Rugam deschideti documentul original si reincercati.", True)
        StatusBar = "Get_ComDocSubject: Provided document NOT Com Doc! (" & TargetDocument.Name & ")"
    End If
    
End If


End Function