Запускать один и тот же макрос в разных версиях Excel / Outlook / Word - PullRequest
Новая
       51

Запускать один и тот же макрос в разных версиях Excel / Outlook / Word

0 голосов
/ 07 ноября 2018

Я генерирую отчеты для отправки в разные филиалы. Я запускаю макрос, который создает защищенные отчеты (* .xlsm). В этих отчетах есть место для комментариев для руководителей филиалов с кнопкой «отправить комментарии», которая запускает этот макрос ниже.

Я предложил добавить ссылки , если макрос не работает.

Менеджеры филиалов имеют на своих ноутбуках разные версии MS Office (Excel, Outlook и т. Д.). Когда они пытаются выполнить, он показывает ошибки, такие как: «Ошибка в Loadind DLL»; Ошибка2 и т. Д.

Что нужно сделать на стороне менеджера филиала, чтобы запустить этот макрос? 

Sub CommentsEmail()

Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String

UpdateScreen = False

Shell ("Outlook")

Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))

template.Activate


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor

Set objSel = wordDoc.Windows(1).Selection

        'construct the body of the email here
        With objSel

            'first text
            .InsertAfter "Dear All," & vbCrLf
            .Move wdParagraph, 1

            'second text
            .InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
            .Move wdParagraph, 1

            'copy a range and paste a picture
            commentsrange.Copy ''again, you need to modify your target range
            .PasteAndFormat wdChartPicture
            .Move wdParagraph, 1

            .InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
            .Move wdParagraph, 1

            .InsertAfter vbCrLf & "Kind Regards," & vbCrLf
        End With

        OutMail.To = OutMail.To & ";" & Sendto

        With OutMail

         .Subject = "Comments on Flash Indicator Results - " & branch
         .Attachments.Add (ActiveWorkbook.FullName)
         .Display
        End With

On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing


        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        Exit Sub

End Sub

Это все еще рано связывать? Если да, я полностью потерян. 

Sub CommentsEmail2()

Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object

Dim TempFilePath As String
Dim xHTMLBody As String

Dim commentsrange As Range
Dim branch As String
Dim Sendto As String

UpdateScreen = False

Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))

branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)

template.Activate

 On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    Set OleMail = olApp.CreateItem(0)

Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
        TempFilePath = Environ$("temp") & "\"
        xHTMLBody = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "Hello, this is the data range that you want:<br> " _
                & "<br>" _
                & "<img src='cid:DashboardFile.jpg'>" _
                & "<br>Best Regards!</font></span>"
        With OleMail
            .Subject = "test"
            .HTMLBody = xHTMLBody
          .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
          .Attachments.Add (ActiveWorkbook.FullName)
            .To = " "
            .Cc = " "
            .Display
        End With




        Set OleMail = Nothing
        Set OlaApp = Nothing


        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        Exit Sub

End Sub

Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(comments).Activate
    Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
...