?

Log in

iCamel
Разрозненные обрывки
Лень-двигатель 
21st-Mar-2016 06:02 pm
lazy
Надоело писать анонсы обновления документа вручную.

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
This page was loaded Feb 27th 2017, 8:44 pm GMT.