1

このワークブックを開き、データを更新し、自動的に送信してから閉じるには、vba を追加する必要があります。

これは、単独で正常に動作する私のコードですが、これを毎日自動化する必要があります。

Sub Mail_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String



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

With OutMail
.To = "me.meeee@company.com"
.CC = ""
.BCC = ""
.Subject = "***TEST*** " & Subj
.Body = Subj
.Attachments.Add ActiveWorkbook.FullName
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%S"
End With
Set OutMail = Nothing
End Sub
4

1 に答える 1

1

以下のようなものを試すことができます。ワークブックを開くと、プロシージャが呼び出されますRunMacro。

RunMacroプロシージャは、範囲から値を読み取り、プロシージャを呼び出す必要がある時間を設定しますMIS 。

MIS手順はワークブックを開き、更新し、ファイルを保存するパスを取得し、最後にメールを送信します。

メールでは、ワークブックのリンクが送信され、ワー​​クブックは添付されません。そのため、ワークブックを任意の共有ドライブに保存できます。

ThisWorkbookこのコードをコードセクションに置きます

 Private Sub Workbook_Open()
    RunMacro
End Sub


このコードを任意の標準モジュールに入れます。

Sub RunMacro()


    Dim a As String, b As String, c As String, d As String, e As String

    a = Format(Range("A3"), "hh:mm:ss")
    b = Format(Range("A4"), "hh:mm:ss")
    c = Format(Range("A5"), "hh:mm:ss")
    d = Format(Range("A6"), "hh:mm:ss")
    e = Format(Range("A7"), "hh:mm:ss")


    Application.OnTime TimeValue(a), "MIS"
    Application.OnTime TimeValue(b), "MIS"
    Application.OnTime TimeValue(c), "MIS"
    Application.OnTime TimeValue(d), "MIS"
    Application.OnTime TimeValue(e), "MIS"
End Sub

Sub MIS()

'open the workbook
    Dim wkb As Workbook
    Dim Path As String, strFile As String, strFilePath As String

    strFile = "file1.xlsx"
    Path = ThisWorkbook.Path & "\" & strFile

    If IsWorkBookOpen(Path) Then
        Set wkb = Workbooks(strFile)
    Else
        Set wkb = Workbooks.Open(Path)
    End If

    'Refresh the data
    wkb.RefreshAll

    'get new filePath
    strFilePath = getFileLink

    wkb.SaveAs Filename:=strFilePath 
    wkb.Close

    'send mail
    SendMail strFilePath


End Sub

Function IsWorkBookOpen(FileName As String)
'Check if workbooks is open
'IsOpen Return true

    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0: IsWorkBookOpen = False
    Case 70: IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Sub SendMail(myDest As String)
'procedure to send mail
'you need to configure the server & port

    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant


    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields

    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "test-svr-002"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With

    With iMsg

        Set .Configuration = iConf
        .To = "test@gmail.com"
        .From = "test@gmail.com"
        .Subject = "MIS Reports" & " " & Date & " " & Time
        .TextBody = "Link to Mis Report :" & vbNewLine & "<" & myDest & ">"
        .Send
    End With

    Set iMsg = Nothing
    Set iConf = Nothing

End Sub

Function getFileLink() As String

    Dim fso As Object, MyFolder As String
    Set fso = CreateObject("Scripting.FileSystemObject")

    MyFolder = ThisWorkbook.Path & "\Reports"


    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If

    MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")

    If fso.FolderExists(MyFolder) = False Then
        fso.CreateFolder (MyFolder)
    End If

    getFileLink = MyFolder & "\MIS " & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xls"
    Set fso = Nothing

End Function
于 2013-05-15T02:49:17.613 に答える