更新时间:2023-11-22 08:08:22
这里的问题是使用:
The issue here is the use of :
Dim Smthg As Object
或 Dim Smthg As Range
而不是 Dim Smthg As Excel.Range
或 Dim Smthg As Word.Range
Dim Smthg As Object
or Dim Smthg As Range
instead of Dim Smthg As Excel.Range
or Dim Smthg As Word.Range
所以你需要完全限定你设置的所有变量(我已经在你的代码中做到了)
So you need to fully qualified all the variables that you set (I've done that in your code)
您使用多个 Word 实例,并且只需要一个来处理多个文档.
所以不要每次都创建一个新的:
So instead of creating a new one each time with :
Set WordApp = CreateObject("Word.Application")
您可以获得一个开放的实例(如果有)或使用该代码创建一个:
You can get an open instance (if there is one) or create one with that code :
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0
并且一旦你把它放在你的过程的开始,你就可以使用这个实例直到过程结束和结束之前,退出以避免运行多个实例.
And once you've put this at the start of your proc, you can use this instance until the end of the proc and before the end, quit it to avoid having multiple instances running.
这是您检查和清理的代码,请看:
Here is your code reviewed and cleaned, take a look :
Sub Docs()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
' Control if folder exists, if not create folder
If Len(Dir("F:documents" & Year(Date), vbDirectory)) = 0 Then MkDir "F:documents" & Year(Date)
' Get or Create a Word Instance
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0
Workbooks("exampleworkbook.xlsm").Sheets("examplesheet").Range("A1:C33").Copy
With WordApp
.Visible = True
.Activate
Set WordDoc = .Documents.Add
.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
End With
With Application
.Wait (Now + TimeValue("0:00:02"))
.CutCopyMode = False
End With
With WordDoc
.PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4)
.PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5)
.PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5)
.SaveAs "F:documents" & Year(Date) & "examplename " & Format(Now, "YYYYMMDD") & ".docx"
.Close
End With
' export sheet 2 to Word
Workbooks("exampleworkbook.xlsm").Sheets("examplesheet2").Range("A1:C33").Copy
Set WordDoc = WordApp.Documents.Add
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
Application.Wait (Now + TimeValue("0:00:02"))
With WordDoc
.PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5)
.PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4)
.PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5)
.SaveAs "F:files" & Year(Date) & "
ame" & Format(Now, "YYYYMMDD") & ".docx"
.Close
End With
Application.CutCopyMode = False
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
' Variables Outlook
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim rngTo As Excel.Range
Dim rngCc As Excel.Range
Dim rngSubject As Excel.Range
Dim rngBody As Excel.Range
Dim rngAttach1 As Excel.Range
Dim rngAttach2 As Excel.Range
Dim numSend As Integer
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set objOutlook = CreateObject("Outlook.Application")
On Error GoTo 0
Set objMail = objOutlook.CreateItem(0)
' Outlook
On Error GoTo handleError
With Sheets("Mail")
Set rngTo = .Range("B11")
Set rngCc = .Range("B12")
Set rngSubject = .Range("B13")
Set rngBody = .Range("B14")
Set rngAttach1 = .Range("B15")
Set rngAttach2 = .Range("B16")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.CC = rngCc.Value
'.Body = rngBody.Value
.Body = "Hi," & _
vbNewLine & vbNewLine & _
rngBody.Value & _
vbNewLine & vbNewLine & _
"Kind regards,"
.Attachments.Add rngAttach1.Value
.Attachments.Add rngAttach2.Value
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%s"
' .Send ' Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
numSend = numSend + 1
GoTo skipError
handleError:
numErr = numErr + 1
oFile.WriteLine "*** ERROR *** Email for account" & broker & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:
On Error GoTo 0
MsgBox "Sent emails: " & numSend & vbNewLine & "Number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
GoTo endProgram
cancelProgram:
MsgBox "No mails were sent.", vbOKOnly + vbExclamation, "Operation cancelled"
endProgram:
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach1 = Nothing
Set rngAttach2 = Nothing
End Sub