Использовал этот код в outlook для импорта документов, отправленных в один из моих почтовых ящиков пользователей, в старую программу архивации, которую мы запускаем, но вдруг этот макрос больше не хочет запускаться. Ничего не изменилось, и пользователь заметил, что компилируемые нами сертификаты складываются в ее почтовом ящике без перемещения, как обычно.
' Ver 9.0.2 2019/Feb/28 @ 17h00
' Contains an additional macro for faultFinding called : ONLY_Validate_DocLib_Emails
' DO NOT AUTOMATE the FaultFinding Macro!!
' The ONLY Macro to be AUTOMATED is called DocLib_BEE_EDL_Attachments
' Installed on Annaline's PC
' ammended minor issue - if no attachements , simply move to Error
' - if more than one .pdf arrives in future emails , we add suffix _i_
' Which references are needed:
' ----------------------------------------------------
' MS Scripting RunTime scrrun.dll
' MS Office 16.0 Object Library MSO.dll
' MS Outlook 16.0 Object Library MSOutl.olb
' ----------------------------------------------------
' What Outlook rule(s) do we need?
' --------------------------------
' Move any email with "EDL" in subject to "Document Library" Folder in outlook
' email pre-requisites?
' --------------------
' Email must contain only 'EDL' , followed by a companyNumber, no spaces and no additional text
' output is the attached .pdf file that is saved to M-drive , where DocLib system expects to find it
Option Explicit
Const BEEFileExt = ".pdf"
Const BEESubjectID = "Document Library"
Const BEESubjectID2 = "EDL"
Const BEESubjectID3 = "Document Library"
Const BEEFilePath = "M:\EzCapture\Document Library\Unmapped"
'Const BEEFilePath = "M:\EzCapture\Document Library\John Test"
Const BEEErrorFolderPath = "Inbox\Document Library\Error"
Const BEESuccessFolderPath = "Inbox\Document Library\Done"
Const BEERootMessageStore = "Personal Folders"
Dim HasErrors As Boolean
Dim BEESuccessFolder As MAPIFolder
Dim BEEErrorFolder As MAPIFolder
Public Function BEEScanAndExtract(mfolder As MAPIFolder) As Boolean
Dim mmail As MailItem
Set BEESuccessFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Document Library").Folders("Done")
Set BEEErrorFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Document Library").Folders("Error")
For Each mmail In mfolder.Items
HasErrors = True ' changed BCS False
If (InStr(1, mmail.Subject, BEESubjectID, vbTextCompare) <> 0) Or (InStr(1, mmail.Subject, BEESubjectID2, vbTextCompare) <> 0) Or (InStr(1, mmail.Subject, BEESubjectID3, vbTextCompare) <> 0) Then
If BEEHasEDXAttachments(mmail) Then
BEEExtractAttachments mmail
End If
BEEMoveToFolder mmail.EntryID
End If
Next
Set BEESuccessFolder = Nothing
Set BEEErrorFolder = Nothing
Set mfolder = Nothing
BEEScanAndExtract = True
End Function
Public Function BEEExtractAttachments(mmail As MailItem) As Boolean
On Error GoTo BEEExtractAttachments_Error
Dim sFilePath As String
Dim fso As Scripting.FileSystemObject
If (mmail.Attachments.Count <> 0) Then
Dim attach As Attachment
For Each attach In mmail.Attachments
If UCase(Mid(attach.FileName, Len(attach.FileName) - 3, 4)) = UCase(BEEFileExt) Then
Dim iCount As Integer
iCount = 1
sFilePath = BEEFilePath & "\" & GetCpNumberFromSubject(mmail) & "_" & iCount & BEEFileExt
Set fso = CreateObject("Scripting.FileSystemObject")
While (fso.FileExists(sFilePath))
sFilePath = BEEFilePath & "\" & GetCpNumberFromSubject(mmail) & "_" & iCount & BEEFileExt
iCount = iCount + 1
Wend
attach.SaveAsFile sFilePath
'Set fso = Nothing
HasErrors = False ' bcs new
End If
Next
End If
BEEExtractAttachments = True
Exit Function
BEEExtractAttachments_Error:
BEEExtractAttachments = False
HasErrors = True
End Function
Private Function BEEHasEDXAttachments(mmail As MailItem) As Boolean
Dim res As Boolean
res = False
If (mmail.Attachments.Count <> 0) Then
Dim attach As Attachment
For Each attach In mmail.Attachments
If UCase(Mid(attach.FileName, Len(attach.FileName) - 3, 4)) = UCase(BEEFileExt) Then
res = True
End If
Next
End If
BEEHasEDXAttachments = res
'If Not res Then
' HasErrors = res
'End If
' bcs i.e. pdf not found then an error
If res = False Then
HasErrors = True
End If
End Function
'Private Function GetCpNumber(mmail As MailItem) As Long
Private Function GetCpNumberFromSubject(mmail As MailItem) As Long
On Error GoTo GetCpNumber_Error
Dim s As String
Dim cpnumber As Long
s = UCase(mmail.Subject)
's = Replace(s, " ", " ")
cpnumber = 0
If (InStr(s, "DOCUMENT LIBRARY C") <> 0) Then
cpnumber = CLng(Trim(Mid(mmail.Subject, InStr(s, "DOCUMENT LIBRARY C") + 18))) ' legacy from older version
End If
If (InStr(s, "DOCUNENT LIBRARY C") <> 0) Then
cpnumber = CLng(Trim(Mid(mmail.Subject, InStr(s, "DOCUNENT LIBRARY C") + 18))) ' legacy from older version
End If
If (InStr(s, "EDL") <> 0) Then
cpnumber = CLng(Trim(Mid(mmail.Subject, InStr(s, "EDL") + 3)))
End If
GetCpNumberFromSubject = cpnumber
Exit Function
GetCpNumber_Error:
cpnumber = 0
HasErrors = True
End Function
Private Function GetCpNumberFromPDF(mFile As String) As Long
On Error GoTo GetCpNumber_Error
Dim s As String
Dim cpnumber As Long
s = UCase(mFile)
's = Replace(s, " ", " ")
cpnumber = 0
If (InStr(s, "EDL") <> 0) Then
cpnumber = CLng(Trim(Mid(mFile, InStr(s, "EDL") + 3)))
End If
GetCpNumberFromPDF = cpnumber
Exit Function
GetCpNumber_Error:
cpnumber = 0
HasErrors = True
End Function
Private Function BEEGetOutlookFolderFromRoot(sRootMessageStore As String, sFolderPath As String) As MAPIFolder
On Error GoTo BEEGetOutlookFolder_ErrorExit
Dim sPath() As String
Dim tFolder As MAPIFolder
Dim sFolder As Variant
sPath = Split(sFolderPath, "\", , vbTextCompare)
For Each sFolder In sPath
If (tFolder Is Nothing) Then
Set tFolder = Application.GetNamespace("MAPI").Folders(sRootMessageStore).Folders(sFolder)
Else:
Set tFolder = tFolder.Folders(sFolder)
End If
Next
Set BEEGetOutlookFolderFromRoot = tFolder
Exit Function
BEEGetOutlookFolder_ErrorExit:
Set BEEGetOutlookFolderFromRoot = Nothing
End Function
Private Function BEEMoveToFolder(mmailID As String) As Boolean
On Error GoTo BEEMoveToFolder_ErrorExit
Dim mmail As MailItem
Set mmail = Application.Session.GetItemFromID(mmailID)
If (HasErrors) Then
mmail.Move BEEErrorFolder
Else:
mmail.Move BEESuccessFolder
End If
BEEMoveToFolder = True
Exit Function
BEEMoveToFolder_ErrorExit:
BEEMoveToFolder = False
End Function
' WIP NEW NEW NEW
Sub NEW_DocLib_BEE_EDL_Attachements()
Dim msg As Outlook.MailItem
'Dim msg2 As Outlook.MailItem
'Dim oAttached As Outlook.Attachment
Dim sT1 As String
Dim iAttachment As Integer
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String
Dim sSavePathFS As String ' bcs
Dim Bflag As Boolean ' bcs
Dim sFilePath As String ' bcs BEEExtractAttachments
Dim fso As Scripting.FileSystemObject ' bcs BEEExtractAttachments
Dim olFolder As Outlook.Folder
' NEW_DocLib_BEE_EDL_Attachements ********
Set olFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Dim Item As Outlook.Folders
'Dim iC As Integer
'Dim InBoxFolderCount As Integer
'iC = 0
'InBoxFolderCount = 0
'InBoxFolderCount = olFolder.Folders.Count
Dim myOlFolder As Object
Set myOlFolder = olFolder.Folders.Item("Document Library")
Set olFolder = myOlFolder
Dim MsgCount As Integer
'Dim AttachCount As Integer
'Dim ErrorCount As Integer
'Dim subjCpNo As Long
'Dim HaveOnePDF As Boolean
'HaveOnePDF = False
'Dim iAttachCount As Integer
Dim iMsgCount As Integer
'Dim iCurrentMsg As Integer
'Dim iCurrentPDF As Integer
'Dim DoneWithMSG As Boolean
'DoneWithMSG = False
'iCurrentMsg = 0
'iCurrentPDF = 0
'iAttachCount = 0
'subjCpNo = 0
iMsgCount = olFolder.Items.Count
If (iMsgCount = 0) Then
'MsgBox ("No more DocLib emails in [Document Library] folder.Will auto-start later")
Exit Sub
End If
' NEW_DocLib_BEE_EDL_Attachments ********
'iCurrentMsg = 1
I For Each msg In olFolder.Items
'DoneWithMSG = False
'iCurrentPDF = 0
'Set msg2 = msg
If (SavedValidAttached(msg.EntryID) = True) Then ' KEEP Works
'MsgBox ("100% VALID DocLib email found : " + msg.Subject)
HasErrors = False
Brett_BEEMoveToFolder msg.EntryID, myOlFolder
'Brett_BEEMoveToFolder msg.EntryID, myOlFolder
Else ' keep - WORKS
'MsgBox (" INVALID DocLib email found (Moving to Error) : " + msg.Subject)
HasErrors = True
Brett_BEEMoveToFolder msg.EntryID, myOlFolder
End If
'iCurrentMsg = iCurrentMsg + 1
Next 'msg
End Sub
'NEW_DocLib_BEE_EDL_Attachements ********
Function IsSaved(sPdfPayLoad As String) As Boolean
' ?? NOT USED AT ALL ????
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim oAttached As Outlook.Attachment
Dim sT1 As String
Dim iAttachment As Integer
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String
Dim sSavePathFS As String ' bcs
Dim Bflag As Boolean ' bcs
Dim sFilePath As String ' bcs BEEExtractAttachments
Dim fso As Scripting.FileSystemObject ' bcs BEEExtractAttachments
' John Feb 19 - Objects were not defined
Dim olFolder As Outlook.Folder
strFilePath = "C:\_temp\"
strTmpMsg = "Template_macro.msg"
sT1 = strFilePath & strTmpMsg
Set fso = CreateObject("Scripting.FileSystemObject")
' Cleanup Old files in C:\_temp.
' WHY? might have Template_macro.msg files left if
' POWER WENT out due to ESKOM load Shedding
If (fso.FileExists(sT1) = True) Then ' on Macro startup cleanup
fso.DeleteFile (sT1)
End If
Set olFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Dim Item As Outlook.Folders
Dim iC As Integer
Dim InBoxFolderCount As Integer
iC = 0
InBoxFolderCount = 0
InBoxFolderCount = olFolder.Folders.Count
Dim myOlFolder As Object
Set myOlFolder = olFolder.Folders.Item("Document Library")
Set olFolder = myOlFolder
If olFolder Is Nothing Then Exit Function
Dim MsgCount As Integer
Dim AttachCount As Integer
Dim ErrorCount As Integer
Dim subjCpNo As Long
Dim HaveOnePDF As Boolean
HaveOnePDF = False
Dim iAttachCount As Integer
Dim iMsgCount As Integer
Dim iCurrentMsg As Integer
Dim iCurrentPDF As Integer
Dim DoneWithMSG As Boolean
DoneWithMSG = False
iCurrentMsg = 0
iCurrentPDF = 0
iAttachCount = 0
subjCpNo = 0
MsgCount = 1
iMsgCount = olFolder.Items.Count
For Each msg In olFolder.Items
DoneWithMSG = False
iCurrentMsg = 1
iCurrentPDF = 0
iAttachCount = msg.Attachments.Count
If (iAttachment = 0) Then
HasErrors = True
Set msg2 = msg
Brett_BEEMoveToFolder msg2.EntryID, myOlFolder
HasErrors = False
'Exit Sub
End If
Set oAttached = msg.Attachments.Item(iCurrentMsg)
If (fso.FileExists(sT1) = False) Then ' 1st time for new msg, create new local_work_file, set msg2 to it
Set fso = CreateObject("Scripting.FileSystemObject")
oAttached.SaveAsFile (sT1)
Set msg2 = msg
End If
subjCpNo = GetCpNumberFromSubject(msg2)
ErrorCount = 0
HasErrors = True ' Assume NOT A .PDF file
Dim sFileType As String
Dim sSubject As String
For iCurrentPDF = 1 To iAttachCount
sFileType = UCase(Right$(msg.Attachments(iCurrentPDF).FileName, 3))
sSubject = msg.Subject
If ((sFileType = "PDF") And InStr(sSubject, "EDL") = 0) Then ' not EDL subject
'If (InStr(sSubject, "EDL") = 0) Then
DoneWithMSG = True
Brett_BEEMoveToFolder msg2.EntryID, myOlFolder
HasErrors = True
ErrorCount = ErrorCount + 1 ' ???
End If
' have .pdf && have an EDL in Subject
If ((sFileType = "PDF") And InStr(sSubject, "EDL") <> 0) Then
HasErrors = False
HaveOnePDF = True 'BUSINESS RULE: only one .pdf per email, so we may exit now
Dim pdfCpNo As Long
sSavePathFS = BEEFilePath & "\" & subjCpNo & "_" & iCurrentPDF & BEEFileExt
Set fso = CreateObject("Scripting.FileSystemObject") ' ?????
While ((fso.FileExists(sSavePathFS)) And (HaveOnePDF = False))
msg2.Attachments(iCurrentPDF).SaveAsFile sSavePathFS
'iCurrentPDF = iCurrentPDF + 1 ' This is the ROOT of my HEADACHE!!
HaveOnePDF = True ' to signal exit
Wend
End If ' PDF
' BUSINESS LOGIC says: We only want one .pdf per msg, so Move & exit on the first .pdf
DoneWithMSG = False
While ((HaveOnePDF = True) And (DoneWithMSG = False))
If Not (msg2 Is Nothing) Then
' have a for loop to repeatedly check for last used number
Dim iScan As Integer
iScan = 1
sSavePathFS = BEEFilePath & "\" & subjCpNo & "_1" & BEEFileExt
While (fso.FileExists(sSavePathFS) = True)
iScan = iScan + 1
sSavePathFS = BEEFilePath & "\" & subjCpNo & "_" & iScan & BEEFileExt
Wend
msg2.Attachments(iCurrentPDF).SaveAsFile sSavePathFS '??? overwrite??
Brett_BEEMoveToFolder msg2.EntryID, myOlFolder
DoneWithMSG = True
HaveOnePDF = False ' latest change
' once here on Friday, could not find marker ??
If (fso.FileExists(sT1) = True) Then
fso.DeleteFile (sT1) ' Housekeeping
End If
End If
Wend
If HasErrors = True Then
ErrorCount = ErrorCount + 1
Brett_BEEMoveToFolder msg2.EntryID, myOlFolder
'MsgBox ("There were " & MsgCount & " emails of which " & MsgCount - ErrorCount & " were processed successfully, " & ErrorCount & " had errors which need to be manually resolved! " & AttachCount & " PDF files were extracted!")
'fso.DeleteFile (sT1) ' Housekeeping
DoneWithMSG = True
End If
Next iCurrentPDF
If ((iCurrentMsg = iMsgCount) And (fso.FileExists(sT1) = True)) Then 'housekeeping B4 closing macro
fso.DeleteFile (sT1)
End If
MsgCount = MsgCount + 1 ' to report in msgBox to usr
Next ' for each msg
End Function
' **********************************************************************
' This one stays as a FAULT-FindingTool for Annaline to QUICKLY establish what is going wrong !!
' This Macro is not run AUTOMATICALLY-Never-Ever.
' It WILL NOT save .pdf files on the network.
' It also WILL NOT move emails to Done nor to Error SubFolders
' Fault Finding Tool ********
Sub ONLY_Validate_DocLib_Emails()
' NOTE: This Macro will CONFLICT with the real macro.
' Thus to prevent this CONFLICT, I point this Validate macro to subFolder [TEST_Macro_InBox]
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim oAttached As Outlook.Attachment
Dim sT1 As String
Dim iAttachment As Integer
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String
Dim sSavePathFS As String ' bcs
Dim Bflag As Boolean ' bcs
Dim sFilePath As String ' bcs BEEExtractAttachments
Dim fso As Scripting.FileSystemObject ' bcs BEEExtractAttachments
Dim olFolder As Outlook.Folder
' Fault Finding Tool ********
Set olFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Dim Item As Outlook.Folders
Dim iC As Integer
Dim InBoxFolderCount As Integer
iC = 0
InBoxFolderCount = 0
InBoxFolderCount = olFolder.Folders.Count
Dim myOlFolder As Object
Set myOlFolder = olFolder.Folders.Item("Document Library")
Set olFolder = myOlFolder
' Fault Finding Tool ********
If olFolder Is Nothing Then Exit Sub
Dim MsgCount As Integer
Dim AttachCount As Integer
Dim ErrorCount As Integer
Dim subjCpNo As Long
Dim HaveOnePDF As Boolean
HaveOnePDF = False
Dim iAttachCount As Integer
Dim iMsgCount As Integer
Dim iCurrentMsg As Integer
Dim iCurrentPDF As Integer
Dim DoneWithMSG As Boolean
DoneWithMSG = False
iCurrentMsg = 0
iCurrentPDF = 0
iAttachCount = 0
subjCpNo = 0
MsgCount = 1
iMsgCount = olFolder.Items.Count
' Fault Finding Tool ********
For Each msg In olFolder.Items
DoneWithMSG = False
iCurrentMsg = 1
iCurrentPDF = 0
Set msg2 = msg
If (SavedValidAttached(msg2.EntryID)) Then
MsgBox ("100% VALID DocLib email foun : [" + msg.Subject + "]; see M:\EzCapture\Document Library\John Test ")
Else
MsgBox (" INVALID DocLib email found : " + msg.Subject)
End If
Next 'msg
End Sub
' Fault Finding Tool ********
' This one stays as a FAULT-FindingTool
' **********************************************************************
Private Function Brett_BEEMoveToFolder(mmailID As String, pFolder As Object) As Boolean
On Error GoTo BEEMoveToFolder_ErrorExit
Dim mmail As MailItem
Dim Brett_BEESuccessFolder As MAPIFolder
Dim Brett_BEEErrorFolder As MAPIFolder
Set Brett_BEESuccessFolder = pFolder.Folders("Done")
Set Brett_BEEErrorFolder = pFolder.Folders("Error")
Set mmail = Application.Session.GetItemFromID(mmailID)
If (HasErrors) Then
mmail.Move Brett_BEEErrorFolder
Else:
mmail.Move Brett_BEESuccessFolder
End If
Brett_BEEMoveToFolder = True
Exit Function
BEEMoveToFolder_ErrorExit:
Brett_BEEMoveToFolder = False
End Function
Private Function SavedValidAttached(mmailID As String) As Boolean
' What makes a DocLib email valid? (EDL in SUBJECT, followed by CompNo) && (a .pdf as attachment)
' What makes a DocLib email IN-valid? (Absence of EDL in subject) || (absence of CompanyNo after EDL) || (no attachment) || (no .pdf attached))
'On Error GoTo BEEMoveToFolder_ErrorExit
Dim mmail As MailItem
Dim iAttach As Integer
Dim subjCpNo As Long
Dim iAttachCount As Integer
Dim Brett_BEESuccessFolder As MAPIFolder
Dim Brett_BEEErrorFolder As MAPIFolder
Dim iCurrentPDF As Integer
Dim sPdfPayLoad As String
Set mmail = Application.Session.GetItemFromID(mmailID)
' have to loop through all attachements -> nowadays we have signatures that contains 2 x GIF-attachements !!
Dim sFileType As String
Dim sSubject As String
SavedValidAttached = False ' Default
iAttachCount = mmail.Attachments.Count()
sSubject = mmail.Subject
If ((iAttachCount = 0) Or (InStr(sSubject, "EDL") = 0)) Then
SavedValidAttached = False
Exit Function
End If
For iCurrentPDF = 1 To iAttachCount
sFileType = UCase(Right$(mmail.Attachments(iCurrentPDF).FileName, 3))
If ((sFileType = "PDF") And InStr(sSubject, "EDL") <> 0) Then ' subject contains EDL and .pdf found
subjCpNo = GetCpNumberFromSubject(mmail)
sPdfPayLoad = mmail.Attachments(iCurrentPDF).FileName
If (SavedPDF(mmail.Attachments(iCurrentPDF), subjCpNo, BEEFilePath, BEEFileExt) = True) Then
SavedValidAttached = True
'Exit Function
Else
SavedValidAttached = False
'Exit Function
End If
'Exit Function ??perhaps 28Feb @ 17h00
End If
Next
End Function
' WIP **********
' sSavePathFS = BEEFilePath & "\" & CpNo & "_1" & BEEFileExt
Function SavedPDF(pOnePdfAttachment As Outlook.Attachment, CpNo As Long, sBEEFilePath As String, sBEEFileExt As String) As Boolean
On Error GoTo SavedPDF_Error
Dim sSavePathFS As String
Dim bPDFSaved As Boolean
bPDFSaved = False ' internal usage
Dim HaveOnePDF As Boolean
SavedPDF = False 'default
sSavePathFS = ""
'sSavePathFS = sBEEFilePath & "\" & CpNo & "_1" & sBEEFileExt ' Trivial case
'=================================
Dim sFilePath As String ' bcs BEEExtractAttachments
Dim fso As Scripting.FileSystemObject ' bcs BEEExtractAttachments
Dim olFolder As Outlook.Folder
Dim strFilePath As String
Dim strTmpMsg As String
Dim sT1 As String
strFilePath = "C:\_temp\"
strTmpMsg = "Template_macro.msg"
sT1 = strFilePath & strTmpMsg
Set fso = CreateObject("Scripting.FileSystemObject")
' Cleanup Old files in C:\_temp.
If (fso.FileExists(sT1) = True) Then ' on Macro startup cleanup
fso.DeleteFile (sT1)
End If
Set fso = CreateObject("Scripting.FileSystemObject")
' ************************* BuildNextFileName **************************************
Dim NextPdfName As String
NextPdfName = "-"
' ISSUE here on Valid email save, it returned False, which caused SavedValidAttach also to be False ???
NextPdfName = GetNextPdfSequence(sBEEFilePath, CpNo)
If (InStr(NextPdfName, "-") <> 0) Then
MsgBox ("? Network Error saving next .pdf! ")
Exit Function
Else
'MsgBox ("About to save Next .pdf file as: " + NextPdfName)
pOnePdfAttachment.SaveAsFile (NextPdfName)
End If
If (fso.FileExists(sT1) = True) Then
fso.DeleteFile (sT1) ' Housekeeping
End If
SavedPDF = True
Exit Function
SavedPDF_Error:
SavedPDF = False
End Function 'SavedPDF
' ***************** OFFICIALY TESTED & NEEDED **************************************
Public Function GetNextPdfSequence(sPath As String, sTargetCpNo As Long) As String
' THE microsoft way is TOO SLOW, there is no FILTERING option in FileSystemObject that I could find ???
' Hence the fact that I do the following !! 100% WORKING
' ERROR!!!!! DUPLICATE DECLARATION sPath!!!!!
'Dim sPath As String
Dim f As Scripting.File
'Dim GetNextFileCount As Long ' This will be the functions name !! , so drop once in a new fumction
'GetNextFileCount = 0
Dim fso As FileSystemObject
Dim pos As Integer
Dim newName As String
Set fso = CreateObject("Scripting.FileSystemObject")
' Remove this , once in NEW function!!!!
'sPath = "M:\EzCapture\Document Library\John Test"
'Dim sTargetCpNo As Long
Dim sNewPDF As String
Dim iCC As Integer
iCC = 1
' use sPath !!
' sNewPDF = "M:\EzCapture\Document Library\John Test\" + Trim(Str(sTargetCpNo)) + "_" + Trim(Str(iCC)) + ".pdf"
sNewPDF = sPath + "\" + Trim(Str(sTargetCpNo)) + "_" + Trim(Str(iCC)) + ".pdf"
While (fso.FileExists(sNewPDF))
iCC = iCC + 1
' use sPath !!
'sNewPDF = "M:\EzCapture\Document Library\John Test\" + Trim(Str(sTargetCpNo)) + "_" + Trim(Str(iCC)) + ".pdf"
sNewPDF = sPath + "\" + Trim(Str(sTargetCpNo)) + "_" + Trim(Str(iCC)) + ".pdf"
Wend
If Not (fso.FileExists(sNewPDF)) Then
'MsgBox ("Stepped through existing Company PDFs: NewFileName should be : " + sNewPDF)
GetNextPdfSequence = sNewPDF
Exit Function
End If
Exit Function
End Function
' ***************** OFFICIALY TESTED & NEEDED **************************************