Лень-двигатель

[icamel]

Надоело писать анонсы обновления документа вручную.


Sub AnnounceADTSRSInMail()

Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim msgInspector As Object
Dim wdDocMsg As Object
Dim parsedUClist() As String

On Error Resume Next

'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem
'Set the recipient for the new email
.To = "Special DHL-EWF Admin Tool ; eWF SU Team "
'Set the subject

.Subject = "ADT SRS v " & ActiveDocument.CustomDocumentProperties("Версия")
'The content of the document is used as the body for the email

lastCell = ActiveDocument.bookmarks("version_history").Range.Rows.Count ' find current version in document history
lastCol = ActiveDocument.bookmarks("version_history").Range.Columns.Count
If ExistProperty("versionColumn") Then
versionColumn = ActiveDocument.CustomDocumentProperties("versionColumn")
End If
descriptionColumn = versionColumn + 1
ucListColumn = versionColumn - 1

For i = lastCell To 1 Step -1
LastVersion = Trim(Application.CleanString(ActiveDocument.bookmarks("version_history").Range.Columns(versionColumn).Cells(i).Range.Text))
VersionLength = Len(LastVersion) - 2
LastVersion = Left(LastVersion, VersionLength)
If LastVersion = ActiveDocument.CustomDocumentProperties("Версия") Then
With ActiveDocument
'when current version found let's get description and UC list from there
ucList = .bookmarks("version_history").Range.Columns(ucListColumn).Cells(i).Range.Text
updateDescription = .bookmarks("version_history").Range.Columns(descriptionColumn).Cells(i).Range.Text
End With
Exit For
End If
Next

parsedUClist = Split(ucList) ' parse UC list to display as bulleted list

Set msgInspector = .GetInspector 'get message editor body
Set wdDocMsg = msgInspector.WordEditor

For i = UBound(parsedUClist) To LBound(parsedUClist) Step -1 ' put UC list in a list one by one
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertBefore (parsedUClist(i))
wdDocMsg.Paragraphs(1).Range.ListFormat.ApplyBulletDefault
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
Next i

wdDocMsg.Paragraphs(1).Range.Characters(1).InsertBefore ("Use Cases affected:")
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertBefore (updateDescription)
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(2).Indent
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertBefore ("ADT SRS document version " & ActiveDocument.CustomDocumentProperties("Версия") & " is uploaded to RRC:")
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Characters(1).InsertBefore ("Hi all,")

.Display

End With

If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set msgInspector = Nothing
Set wdDocMsg = Nothing

End Sub

UPD. Заодно и анонсы обновления таблички .

Sub AnnounceCItableInMail()

Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim msgInspector As Object
Dim wdDocMsg As Object

On Error Resume Next

'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
Set msgInspector = oItem.GetInspector
Set wdDocMsg = msgInspector.WordEditor

With oItem
'Set the recipient for the new email
.To = "Special DHL-EWF Admin Tool ; eWF SU Team "
.CC = "Special DHL-EWF BA ; Build Team 2 "

'Set the subject
.Subject = "[Configuration Item Update]"

'Body for the email

wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore

Range("tracking[[#all],[CI]:[Change]]").SpecialCells(xlCellTypeVisible).Copy
If Err <> o Then
MsgBox ("possibly the wrong table")
End If

wdDocMsg.Paragraphs(2).Range.Characters(1).Paste
If Err <> 0 Then
MsgBox ("just try again")
End If

wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore

wdDocMsg.Paragraphs(1).Range.Characters(1).InsertBefore ("CI Table is updated in RRC:")
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Paragraphs(1).Range.Characters(1).InsertParagraphBefore
wdDocMsg.Characters(1).InsertBefore ("Hi all,")

.Display

End With

If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set msgInspector = Nothing
Set wdDocMsg = Nothing

End Sub