Could not complete operation on some files - vb.net

The below code basically takes a directory, copies it the zips it up. This has worked perfectly for me for the last 6 months
Dim tempMail As String = Temp
Dim startpath As String = tempMail & tvProgress.SelectedNode.FullPath
Dim outMail As String = "c:\LTEMP\"
Dim fileout As String = outMail & tvProgress.SelectedNode.Text
Dim tempfolder As String = "c:\LTEMP" & "\" & tvProgress.SelectedNode.FullPath
Dim Reality As String = "\Reality Stock Report"
Dim enUK As New CultureInfo("en-GB")
Try
Dim x As Integer
Dim q As Integer
Dim inMail As String = FileStr
If CheckInternet() = False Then
MessageBox.Show("No internet connection is detected!" & vbNewLine & vbNewLine & "This job will still be added to completed but you will need to connect to the internet to complete sending this file to CIS", "Internet Connection Check", MessageBoxButtons.OK, MessageBoxIcon.Exclamation, MessageBoxDefaultButton.Button1)
End If
If tvProgress.SelectedNode.Parent.Text = "Archive" Then Call INIDate()
Dim Datey As String = Nothing
If tvProgress.SelectedNode.Parent.Text <> "Archive" Then
Datey = Date.ParseExact(Convert.ToDateTime(tvProgress.SelectedNode.Parent.Text), "dd/MM/yy", enUK)
Else
For q = 0 To UBound(INIdet)
If tvProgress.SelectedNode.Parent.Text = "Archive" Then Datey = INIdet(q).iDate
Next
End If
If My.Computer.FileSystem.FileExists(startpath & Reality & ".docx") Then
Call Word2Pdf(startpath & Reality & ".docx", startpath & Reality & ".pdf")
End If
System.Threading.Thread.Sleep(150)
For x = 0 To UBound(AllDetails)
If AllDetails(x).uName & " - " & AllDetails(x).uCode & " - " & AllDetails(x).uOps = tvProgress.SelectedNode.Text Then
If AllDetails(x).uPlan <> Datey Then
DateCh.Show()
Exit Sub
End If
End If
If AllDetails(x).uName & " - " & AllDetails(x).uCode & " - " & AllDetails(x).uOps & " - " & AllDetails(x).uPlan = tvProgress.SelectedNode.Text & " - " & Datey Then
Application.DoEvents()
My.Computer.FileSystem.CopyDirectory(startpath, tempfolder, True)
Directory.CreateDirectory(fileout & "\")
With tempfolder
For Each xDir As String In Directory.GetFiles(tempfolder)
If Not ((UCase(Path.GetDirectoryName(xDir)).Contains("BACKUP")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("BARS")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("TCMS"))) Then
File.Copy(xDir, Path.Combine(fileout, Path.GetFileName(xDir)), True)
End If
Next
If Directory.Exists(tempfolder & "\Controller") Then
For Each xDir As String In Directory.GetFiles(tempfolder & "\Controller")
If Not ((UCase(Path.GetDirectoryName(xDir)).Contains("BACKUP")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("BARS")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("TCMS"))) Then
File.Copy(xDir, Path.Combine(fileout, Path.GetFileName(xDir)), True)
End If
Next
End If
If Directory.Exists(tempfolder & "\Capcon") Then
For Each xDir As String In Directory.GetFiles(tempfolder & "\Capcon")
If Not ((UCase(Path.GetDirectoryName(xDir)).Contains("BACKUP")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("BARS")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("TCMS"))) Then
File.Copy(xDir, Path.Combine(fileout, Path.GetFileName(xDir)), True)
End If
Next
End If
If Directory.Exists(tempfolder & "\Capcas") Then
For Each xDir As String In Directory.GetFiles(tempfolder & "\Capcas")
If Not ((UCase(Path.GetDirectoryName(xDir)).Contains("BACKUP")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("BARS")) Or (UCase(Path.GetDirectoryName(xDir)).Contains("TCMS"))) Then
File.Copy(xDir, Path.Combine(fileout, Path.GetFileName(xDir)), True)
End If
Next
End If
End With
Dim zip As String = inMail & AllDetails(x).uFile & ".zip"
Dim txt As String = inMail & AllDetails(x).uFile & ".txt"
Dim pdf As String = inMail & AllDetails(x).uFile & ".pdf"
Dim fldr As String = FileStr & AllDetails(x).uFile
ZipFile.CreateFromDirectory(fileout & "\", fileout & ".zip", CompressionLevel.Optimal, False)
My.Computer.FileSystem.CopyFile(fileout & ".zip", ArcFolder & tvProgress.SelectedNode.Text & Date.Parse(AllDetails(x).pDate).ToString(" - dd-MM-yyyy") & ".zip", True)
My.Computer.FileSystem.MoveFile(fileout & ".zip", FileStrOut & tvProgress.SelectedNode.Text & ".zip", True)
My.Computer.FileSystem.DeleteDirectory(fileout, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin, FileIO.UICancelOption.DoNothing)
If My.Computer.FileSystem.FileExists(zip) Then
My.Computer.FileSystem.MoveFile(zip, "c:\LTEMP\" & AllDetails(x).uFile & ".zip", True)
End If
If My.Computer.FileSystem.FileExists(txt) Then
My.Computer.FileSystem.CopyFile(txt, ArcFolder & AllDetails(x).uFile & ".txt", True)
My.Computer.FileSystem.MoveFile(txt, "c:\LTEMP\" & AllDetails(x).uFile & ".txt", True)
End If
If My.Computer.FileSystem.FileExists(pdf) Then
My.Computer.FileSystem.MoveFile(pdf, "c:\LTEMP\" & AllDetails(x).uFile & ".pdf", True)
End If
With fldr
If My.Computer.FileSystem.DirectoryExists(fldr) Then
Directory.Delete(fldr, True)
End If
End With
System.Threading.Thread.Sleep(150)
End If
Next
My.Computer.FileSystem.DeleteDirectory(tempMail & tvProgress.SelectedNode.FullPath, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin)
tvProgress.BeginUpdate()
tvProgress.SelectedNode.Remove()
tvProgress.EndUpdate()
Dim sRoot As String = tempMail
Dim sPath As String = tempMail
DeleteEmptyFolders(sPath, sRoot)
lstPlanned.BeginUpdate()
Call TxtRfrsh()
Call RfshArray()
Call CompleteArray()
Call ltempfiles()
lstPlanned.EndUpdate()
Catch ex As Exception
MsgBox(ex.Message)
End Try
I've recently added the following bit of code which calls a routine that converst a docx file to a pdf (works fine on its own)
If My.Computer.FileSystem.FileExists(startpath & Reality & ".docx") Then
Call Word2Pdf(startpath & Reality & ".docx", startpath & Reality & ".pdf")
End If
System.Threading.Thread.Sleep(150)
The called sub
Public Sub Word2Pdf(ByVal infile As String, ByVal outfile As String)
Dim wordApp As Word.Application = Nothing
Try
wordApp = New Word.Application()
wordApp.Documents.Open(infile)
wordApp.ActiveDocument.ExportAsFixedFormat(outfile, Word.WdExportFormat.wdExportFormatPDF)
Finally
If wordApp IsNot Nothing Then
wordApp.Quit()
End If
End Try
End Sub
Now when the criteria is met to call the above sub I'm getting the Could not complete operation on some files error. When I check the directory the PDF has been created but its not then completing the rest of the zip and copy routine.
Any ideas??

WordApp probably has one of the files locked. Check to make sure WordApp has finished execution before you continue. The Sleep(150) is apparently not long enough.

Related

To move files from multiple source folders to multiple destination folders based on two hour delay

Yesterday we have finalized and tested the code (the first part of the code is VBScript) and the second part of the code is (in Excel VBA) to move file from one source folder to one destination folder successfully based on two hour delay (i.e. each file which will come to source folder will upload 2 hour delay), however the situation is that i have actually 15 source folders and 15 destination folders.
One method is that i should create 15 VBScript files and 15 Excel files that contains the code for each source and destination folder which i believe is not efficient way. I have tried a lot to add multiple source and destination folder options in the below mentioned code(s) but i am not successful, can anyone help me, i will be thankful.
the below mentioned code is VBscript
Dim oExcel, strWB, nameWB, wb
strWB = "E:\Delta\Folder monitor.xlsm"
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "E:\\\\Delta\\\\Source" 'use here your path
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
' msgbox "OK"
'MsgBox "A new file was just created: " & _
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
'// Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)
End Select
Loop
and the second code for this purpose should be copied in a standard module:
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\Delta\Source\"
Sub startMonitoring()
Dim strVBSPath As String
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
TerminateMonintoringScript 'to terminate monitoring script, if running..
Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg
As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"
Debug.Print "start " & Now 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(strFileName As String)
Const toPath As String = "E:\Delta\Destination\"
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
you can see the previous query here on the link Previous Query
Please, use the next scenario. It assumes that you will fill the necessary path in an existing Excel sheet. Since, it will take the necessary paths based on a cell selection, it is necessary to name the sheet in discussion as "Folders". In Column A:A you should fill the 'Source' folder path (ending in backslash "") and in B:B, the 'Destination' folder path (also ending in backslash).
The proposed solution takes the necessary paths based on your selection in A:A column. The 'Destination' path is extracted based on the selection row.
Please, replace the existing string with the next one, adapting the two necessary paths:
Dim oExcel, strWB, nameWB, wb
strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here your workbook path!!!
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "C:\\\\test\\\\test" 'use here your path !!!
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")' and " _
' & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
' Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile, Now, strDirToMonitor)
End Select
Loop
The adapted script sends also the source path to the waiting workbook...
TerminateMonintoringScript Sub remains exactly as it is.
Please, copy the next adapted code instead of existing one, in the used standard module (TerminateMonintoringScript included, even not modified):
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private fromPath As String, toPath As String
Sub startMonitoring()
Dim strVBSPath As String, actCell As Range, strTxt As String, pos As Long, endP As Long, oldPath As String
Set actCell = ActiveCell
If actCell.Parent.Name <> "Folders" Then MsgBox "Wrong activated sheet...": Exit Sub
fromPath = actCell.Value
If actCell.Column <> 1 Or Dir(fromPath, vbDirectory) = "" Then Exit Sub 'not a valid path in the selected cell
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
'change the script necessary "strDirToMonitor" variable path, if the case:__________________________
strTxt = ReadFile(strVBSPath)
pos = InStr(strTxt, Replace(fromPath, "\", "\\\\"))
If pos = 0 Then 'if not the correct path already exists
pos = InStr(strTxt, "strDirToMonitor = """) 'start position of the existing path
endP = InStr(strTxt, """ 'use here your path") 'end position of the existing path
'extract existing path:
oldPath = Mid(strTxt, pos + Len("strDirToMonitor = """), endP - (pos + Len("strDirToMonitor = """)))
strTxt = Replace(strTxt, oldPath, _
Replace(Left(fromPath, Len(fromPath) - 1), "\", "\\\\")) 'replacing existing with the new one
'drop back the updated string in the vbs file:
Dim iFileNum As Long: iFileNum = FreeFile
Open strVBSPath For Output As iFileNum
Print #iFileNum, strTxt
Close iFileNum
End If
'__________________________________________________________________________________________________
TerminateMonintoringScript 'to terminate monitoring script, if running...
Application.Wait Now + TimeValue("00:00:02") 'to be sure that the next line will load the updated file...
Shell "cmd.exe /c """ & strVBSPath & """", 0 'run the VBScript
End Sub
Function ReadFile(strFile As String) As String 'function to read the vbscript string content
Dim iTxtFile As Integer
iTxtFile = FreeFile
Open strFile For Input As iTxtFile
ReadFile = Input(LOF(iTxtFile), iTxtFile)
Close iTxtFile
End Function
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
fromPath = Replace(arr(2), "\\\\", "\")
Dim rngFrom As Range: Set rngFrom = ThisWorkbook.Sheets("Folders").Range("A:A").Find(what:=fromPath)
toPath = rngFrom.Offset(, 1).Value
Application.OnTime CDate(arr(1)) + TimeValue("00:00:30"), "'DoSomething """ & fromPath & "\" & CStr(arr(0)) & """, """ & toPath & CStr(arr(0)) & """'"
Debug.Print Now; " start " & arr(0) & fromPath & "\" & CStr(arr(0)) 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(sourceFileName As String, destFilename As String)
If Dir(destFilename) = "" Then
Name sourceFileName As destFilename
Debug.Print sourceFileName & " moved to " & destFilename 'just for testing...
Else
Debug.Print "File """ & destFilename & """ already exists in this location..."
End If
End Sub
Sub DoSomething_(strFileName As String) 'cancelled
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
So, you only need to replace the existing VBA code with the above adapted one, to place the 'source'/'destination' paths in columns A:B of one of Excel sheets, which to be named "Folders".
Select in column A:A a 'Source' cell and run startMonitoring.
Play with files creation and check their moving from the new 'source' to the new 'destination'...
But you have to understand that only a session of the WMI class can run at a specific moment. This means that you cannot simultaneously monitor more than one folder...
I am still documenting regarding the possibility to use a query able to be common for multiple folders. But I never could see such an approach till now and it may not be possible...

Is it possible to identify through OUTLOOK triggers/events to which shared mail box has received a new email?

We are trying to store new mail item components into excel and assign tkt id, have tried doing it with single shared mailbox and succeeded but we want to implement same for 20 shared mail boxes. how can outlook vba event/trigger identify as soon as new email arrives to one of the 20 shared mail boxes.
this is code which will only work for default inbox:
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
Dim cn As Object
Dim sCon As String
Dim sSQL As String
Dim bytHasAttachment As String
Dim strAddress As String
Dim objSender, exUser
Dim olRecipient As Outlook.Recipient
Dim strToEmails, strCcEmails, strBCcEmails As String
For Each olRecipient In Item.Recipients
Dim mail As String
If olRecipient.AddressEntry Is Nothing Then
mail = olRecipient.Address
ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
mail = olRecipient.Address
Else
mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
strToEmails = strToEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
strCcEmails = strCcEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
strBCcEmails = strBCcEmails + mail & ";"
End If
Next
With Item
If Item.Attachments.Count > 0 Then
bytHasAttachment = 1
Else
bytHasAttachment = 0
End If
End With
'On Error Resume Next 'PropertyAccessor can raise an exception if a property is not found
If Item.SenderEmailType = "SMTP" Then
strAddress = Item.SenderEmailAddress
Else
'read PidTagSenderSmtpAddress
strAddress = Item.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
If Len(strAddress) = 0 Then
Set objSender = Item.Sender
If Not (objSender Is Nothing) Then
'read PR_SMTP_ADDRESS_W
strAddress = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
If Len(strAddress) = 0 Then
Set exUser = objSender.GetExchangeUser
If Not (exUser Is Nothing) Then
strAddress = exUser.PrimarySmtpAddress
End If
End If
End If
End If
End If
On Error GoTo ErrorHandler
Set cn = CreateObject("ADODB.Connection")
sCon = "Driver=MySQL ODBC 8.0 ANSI Driver;SERVER=localhost;UID=root;PWD={Platinum#123};DATABASE=liva_dev_gm;PORT=3306;COLUMN_SIZE_S32=1;DFLT_BIGINT_BIND_STR=1"
cn.Open sCon
sSQL = "INSERT INTO tbl_gmna_emailmaster_inbox (eMail_Icon, eMail_MessageID, eMail_Folder, eMail_Act_Subject, eMail_From, eMail_TO, eMail_CC, " & _
"eMail_BCC, eMail_Body, eMail_DateReceived, eMail_TimeReceived, eMail_Anti_Post_Meridiem, eMail_Importance, eMail_HasAttachment) " & _
"VALUES (""" & Item.MessageClass & """, " & _
"""" & Item.EntryID & """, " & _
"""Inbox""" & ", " & _
"""" & Item.Subject & """, " & _
"""" & strAddress & """, " & _
"""" & strToEmails & """, " & _
"""" & strCcEmails & """, " & _
"""" & strBCcEmails & """, " & _
"""" & Item.Body & """, " & "'" & Format(Item.ReceivedTime, "YYYY-MM-DD") & "', " & "'" & Format(Item.ReceivedTime, "hh:mm:ss") & "', " & "'" & Format(Item.ReceivedTime, "am/pm") & "', " & "'" & Item.Importance & "', " & "'" & bytHasAttachment & "')"
cn.Execute sSQL
End If
ExitNewItem:
bytHasAttachment = ""
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
If the 20 shared mailboxes are in the navigation pane.
Option Explicit
Private WithEvents inboxItms As Items
Private WithEvents sharedInboxItms1 As Items
' ...
Private WithEvents sharedInboxItms20 As Items
Private Sub Application_Startup()
Dim defaultInbox As Folder
Dim sharedMailbox1 As Folder
Dim sharedInbox1 As Folder
' ...
Dim sharedMailbox20 As Folder
Dim sharedInbox20 As Folder
Set defaultInbox = Session.GetDefaultFolder(olFolderInbox)
Set inboxItms = defaultInbox.Items
Set sharedMailbox1 = Session.Folders("SharedMailbox1#somewhere.com")
Set sharedInbox1 = sharedMailbox1.Folders("Inbox")
' typo fixed
'Set sharedInboxItms1 = sharedInbox1.Folders("Inbox").Items
Set sharedInboxItms1 = sharedInbox1.Items
' ...
Set sharedMailbox20 = Session.Folders("SharedMailbox20#somewhere.com")
Set sharedInbox20 = sharedMailbox20.Folders("Inbox")
' typo fixed
'Set sharedInboxItms20 = sharedInbox20.Folders("Inbox").Items
Set sharedInboxItms20 = sharedInbox20.Items
End Sub
Private Sub inboxItms_ItemAdd(ByVal Item As Object)
' current code for default inbox
End Sub
Private Sub sharedInboxItms1_ItemAdd(ByVal Item As Object)
inboxItms_ItemAdd Item
End Sub
' ...
Private Sub sharedInboxItms20_ItemAdd(ByVal Item As Object)
inboxItms_ItemAdd Item
End Sub

Create array of PDF files in directory that start with the letters "AB"

I'm trying to create a list of files in a specific directory folder where I am renaming the files, but because there is a chance some files should not be renamed, I only need to rename the PDF files that begin with the letters "AB".
The renaming works fine, I just need to make sure it only renames specific files.
Private Sub CMD_RENAME_FILES_Click()
On Error GoTo CMD_RENAME_FILES_ERR
Dim varDir As String
varDir = Me.TXT_BILLING_STATEMENT_PATH
If MsgBox("Are you sure you want to rename all of the files in the directory " & "'" & varDir & "'", vbYesNo, "Confirm") = vbNo Then
Exit Sub
Else
Dim strFileName, varDateString As String
Dim strFolder As String: strFolder = Nz(Me.TXT_BILLING_STATEMENT_PATH, "Z:\")
Dim strFileSpec As String: strFileSpec = strFolder & "*.pdf"
Dim FileList() As String
Dim intFoundFiles As Integer
DoCmd.RunSQL ("UPDATE tblDirFileList SET tblDirFileList.RenameSelection = -1 WHERE FileName LIKE 'AB*'")
strFileName = Dir(strFileSpec, "AB*.PDF") 'THIS AB* DOESN'T WORK"
varDateString = Format(Date, "mmddyy")
Do While Len(strFileName) > 0
ReDim Preserve FileList(intFoundFiles)
FileList(intFoundFiles) = strFileName
intFoundFiles = intFoundFiles + 1
varLoanNumString = Mid(strFileName, 4, 9)
varNewStrFile = varLoanNumString & " - BILL STMT - " & varDateString & ".pdf"
On Error Resume Next
Name strFolder & strFileName As strFolder & varNewStrFile
strFileName = Dir
Loop
Call CMD_GET_FILE_NAMES_Click
End If
CMD_RENAME_FILES_ERR_EXIT:
Exit Sub
CMD_RENAME_FILES_ERR:
Call LogError(Err.Number, Err.Description, "CMD_RENAME_FILES_Click()")
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume CMD_RENAME_FILES_ERR_EXIT
End Sub

VBA Replace last field in ALL rows within csv around double quotes?

On Error Resume Next
Set FileSysObj = CreateObject("Scripting.FileSystemObject")
Const ForReading = 1 ' Declare constant for reading for more clarity
Dim cntFile, strCSVFullFile, strCSVFile, strDIR, cntBadLines, cntAllLines, strArchiveDir, strSafeTime,strSafeDate
' -------------------------------------------------------------------------------------------
' Specify CSV file name from the input argument
strCSVFile = Wscript.Arguments(1) ' Transactions
strDIR = Wscript.Arguments(2) & "\" ' C:\Temp
strArchiveDir = Wscript.Arguments(3) & "\"
strSafeTime = Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
strSafeDate = Year(Date) & Month(Date) & day(Date)
set folder = FileSysObj.getFolder(strDIR)
cntFile = 0
cntBadLines = 0
cntAllLines = 0
for each file in folder.Files
' check if the file is there and echo it.
if InStr(1,file.name,strCSVFile,1) <> 0 then
strCSVFullFile = file.name
cntFile = cntFile + 1
end if
next
if cntFile > 1 or cntFile = 0 then
' error and end
Wscript.Echo "Error - only 1 file required for this process. There are " & cntFile & " file(s) in the directory"
WScript.Quit
end if
wscript.echo "Checking the file " & strCSVFullFile & " in " & strDIR
NoOfCols = Wscript.Arguments(0) ' usually 8
strTemp = "temp.csv"
strmissing = "missingdata.csv"
Set objOutFile = FileSysObj.CreateTextFile(strDIR & strTemp,True)
Set objOutFileM = FileSysObj.CreateTextFile(strDIR & strmissing,True)
Set inputFile = FileSysObj.OpenTextFile(strDIR & strCSVFullFile, ForReading, True)
' Set inputFile as file to be read from
Dim row, column, outline
Dim fields '(7) '8 fields per line
inputFile.ReadAll 'read to end of file
outline = ""
ReDim MyArray(inputFile.Line-2,NoOfCols) 'current line, minus one for header, and minus one for starting at zero
inputFile.close 'close file so that MyArray can be filled with data starting at the top
Set inputFile = FileSysObj.OpenTextFile(strDIR & strCSVFullFile, ForReading, True) 'back at top
strheadLine = inputFile.ReadLine 'skip header , but keep it for the output file
objOutFile.Write(strheadLine & vbCrLf)
anyBadlines = False
badlineflag = False
Do Until inputFile.AtEndOfStream
fullLine = inputFile.Readline
fields = Split(fullLine,",") 'store line in temp array
For column = 0 To NoOfCols-1 'iterate through the fields of the temp array
myArray(row,column) = fields(column) 'store each field in the 2D array with the given coordinates
'Wscript.Echo myArray(row,column)
if myArray(row,0) = " " or myArray(row,1) = " " then
badlineflag = True
'missline = myArray(row,0) & ", " & myArray(row,1) & ", " & myArray(row,2) & ", " & myArray(row,3) & ", " & myArray(row,4) & ", " & myArray(row,5) & ", " & myArray(row,6) & ", " & myArray(row,7)
'Wscript.Echo missline
'Exit For
end if
if column = NoOfCols-1 then
outline = outline & myArray(row,column) & vbCrLf
else
outline = outline & myArray(row,column) & ","
'csvFile = Regex.Replace(csvFile, "(,\s*?"".*?)(,)(\s+.*?""\s*?,)", "$1$3") 'TEST
end if
Next
cntAllLines = cntAllLines + 1
' Wscript.Echo outline
if badlineflag = False then
objOutFile.Write(fullLine & vbCrLf)
else
' write it somewhere else, drop a header in the first time
if anyBadlines = False Then
objOutFileM.Write(strheadLine & vbCrLf)
End if
objOutFileM.Write(outline)
cntBadLines = cntBadLines + 1
badlineflag = False
anyBadlines = True
end if
outline = ""
row = row + 1 'next line
Loop
objOutFile.Close
objOutFileM.Close
inputFile.close
Wscript.Echo "Total lines in the transaction file = " & cntAllLines
Wscript.Echo "Total bad lines in the file = " & cntBadLines
The below line is able to work as it contains 7 commas (8 columns).
URXW_99,BYQ0JC6,2603834418,2017-10-30,Test,4.962644,2278.0000,ABC
The below line will throw an error as a result of more commas than 7 in the script.
URXW_99,BYQ0JC6,2603834418,2017-10-30,Test,4.962644,2278.0000,Redburn, Europe. Limited
If greater than 7 commas in the CSV file line, the aim is to wrap it all greater than 7 into one field.
E.g. how do you replace Redburn, Europe. Limited string with double quotes as it is one name.
For example, in a text file it would appear like below:
URXW_99,BYQ0JC6,2603834418,2017-10-30,Test,4.962644,2278.0000,"Redburn, Europe. Limited"
Is there a way to write a VB or VBA script to do the above and save it as a .csv file (which is opened via notepad to check the double quotes)?
Option Explicit
Option Compare Text
Public Sub ConvertFile()
Dim lngRowNumber As Long
Dim strLineFromFile As String
Dim strSourceFile As String
Dim strDestinationFile As String
strSourceFile = "U:\Book3.csv"
strDestinationFile = "U:\Book4.csv"
Open strSourceFile For Input As #1
Open strDestinationFile For Output As #2
lngRowNumber = 0
Do Until EOF(1)
Line Input #1, strLineFromFile
strLineFromFile = Right(Replace(strLineFromFile, ",", " ", 1), 1000)
Write #2, strLineFromFile
strLineFromFile = vbNullString
Loop
Close #1
Close #2
End Sub
As I see, you use MS Access (due to Option Compare Text line), so there is better built-in instruments for this task.
Use DoCmd.TransferText for it.
1st step is to create output specification via:
Here you can setup delimiters, even that differs from ", and handle other options.
After that you can use your set-up specification via following command
DoCmd.TransferText acExportDelim, "TblCustomers_export_spec", "TblCustomers", "C:\test\1.txt", True
In this case all characters escaping would be done through built-in instruments. It seems to be more easier to correct this code further.
As mentioned, there is VBScript workaround. For given input data, following function will do desired actions for given string:
Option Explicit
Function funAddLastQuotes( _
strInput _
)
Dim arrInput
arrInput = Split(strInput, ",")
Dim intArrSize
intArrSize = UBound(arrInput)
Dim intCurrentElement
Dim strOutput
Dim intPreLastElement
intPreLastElement = 6
For intCurrentElement = 1 To intPreLastElement
strOutput = strOutput & "," & arrInput(intCurrentElement)
Next
Dim strOutputLastField
For intCurrentElement = intPreLastElement + 1 To intArrSize
strOutputLastField = strOutputLastField & "," & arrInput(intCurrentElement)
Next
strOutputLastField = Right(strOutputLastField, Len(strOutputLastField) - 1)
strOutput = Right(strOutput, Len(strOutput) - 1)
strOutput = strOutput & "," & """" & strOutputLastField & """"
funAddLastQuotes = strOutput
End Function
MsgBox funAddLastQuotes("RXW_99,BYQ0JC6,2603834418,2017-10-30,Test,4.962644,2278.0000,Redburn, Europe,,, Limited")
Finally, here is working VBScript solution.
Option Explicit
Const ColumnsBeforeCommadColumn = 6
Function funAddLastQuotes( _
strInput _
)
Dim arrInput
arrInput = Split(strInput, ",")
Dim intArrSize
intArrSize = UBound(arrInput)
Dim intCurrentElement
Dim strOutput
Dim intPreLastElement
intPreLastElement = ColumnsBeforeCommadColumn
For intCurrentElement = 1 To intPreLastElement
strOutput = strOutput & "," & arrInput(intCurrentElement)
Next
Dim strOutputLastField
If (intPreLastElement + 1) < intArrSize _
Then
For intCurrentElement = intPreLastElement + 1 To intArrSize
strOutputLastField = strOutputLastField & "," & arrInput(intCurrentElement)
Next
Else
strOutputLastField = strOutputLastField & "," & arrInput(intArrSize)
End If
strOutputLastField = Right(strOutputLastField, Len(strOutputLastField) - 1)
strOutput = Right(strOutput, Len(strOutput) - 1)
strOutput = strOutput & "," & """" & strOutputLastField & """"
funAddLastQuotes = strOutput
End Function
Public Sub ConvertFile( _
strSourceFile _
)
Dim objFS
Dim strFile
Dim strTemp
Dim ts
Dim objOutFile
Dim objFile
Set objFS = CreateObject("Scripting.FileSystemObject")
Dim strLine
Dim strOutput
Dim strRow
strFile = strSourceFile
strTemp = strSourceFile & ".tmp"
Set objFile = objFS.GetFile(strFile)
Set objOutFile = objFS.CreateTextFile(strTemp,True)
Set ts = objFile.OpenAsTextStream(1,-2)
Do Until ts.AtEndOfStream
strLine = ts.ReadLine
objOutFile.WriteLine funAddLastQuotes(strLine)
Loop
objOutFile.Close
ts.Close
objFS.DeleteFile(strFile)
objFS.MoveFile strTemp,strFile
End Sub
ConvertFile "C:\!accsoft\_in.csv"
You should change following part: ConvertFile "C:\!accsoft\_in.csv as path to your file.
And ColumnsBeforeCommadColumn = 6 is the setting, at which column the chaos with commas begins

Scan image in vba with cannon scanner not work

I have a vba code that scan image from scanner , the code works and doesnt have any problem with type hp an brother scanner but when I used it with canon can not find the scanner and send message no wia device. How can solve this problem
Private Sub Command10_Click()
Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
On Error GoTo Handle_Err
Dim Dialog1 As New WIA.CommonDialog, DPI As Integer, PP As Integer, l As Integer
Dim Scanner As WIA.Device
Dim img As WIA.ImageFile
Dim intPages As Integer
Dim strFileJPG As String
Dim blnContScan As Boolean ' to activate the scanner to start scan
Dim ContScan As String 'msgbox to chk if more pages are to be scanned
Dim strFilePDF As String
Dim RptName As String
Dim strProcName As String
strProcName = "ScanDocs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp"
DoCmd.SetWarnings False
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
Set Scanner = Dialog1.ShowSelectDevice(WIA.WiaDeviceType.ScannerDeviceType, True, False)
Set img = Dialog1.ShowTransfer(Scanner.Items(1), wiaFormatJPEG, True)
strFileJPG = ""
intPages = intPages + 1
strFileJPG = "\\User-pc\saveimage\" & num & Trim(str(intPages)) & ".jpg"
img.SaveFile (strFileJPG)
DoCmd.RunSQL "insert into scantemp (picture) values ('" & strFileJPG & "')"
DoCmd.SetWarnings False
Set Scanner = Nothing
Set img = Nothing
' strFileJPG = ""
'Prompt user if there are additional pages to scan
ContScan = MsgBox("?save another page ", vbQuestion + vbYesNoCancel)
If ContScan = vbNo Then
blnContScan = False
ElseIf ContScan = vbCancel Then
DoCmd.RunSQL "delete from scantemp where picture = '" & strFileJPG & "'"
End If
'''''''''''''''
Loop
Dim Image_Path As String
GoTo StartPDFConversion
StartPDFConversion:
Dim s As String
strFilePDF = "\\User-pc\saveimage\" & (num) & ".pdf"
RptName = "rptScan"
DoCmd.OpenReport RptName, acViewReport, , , acHidden
DoCmd.Close acReport, RptName, acSaveYes
DoCmd.OutputTo acOutputReport, RptName, acFormatPDF, strFilePDF
Me.imgp = strFilePDF
DoCmd.RunSQL "delete from scantemp" 'delete all data from table scantemp after converted it to pdf
'/*******************************\
'/********************************************\
Handle_Exit:
Exit Sub
Handle_Err:
Select Case Err.Number
Case 2501
Resume Handle_Exit
Case Else
MsgBox "the." & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, 0, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume Handle_Exit
End Select
Exit Sub
End Sub
Option Compare Database
Private Declare Function TWAIN_AcquireToFilename Lib "TWAIN32d.DLL" (ByVal hwndApp As Long, ByVal bmpFileName As String) As Integer
Private Declare Function TWAIN_IsAvailable Lib "TWAIN32d.DLL" () As Long
Private Declare Function TWAIN_SelectImageSource Lib "TWAIN32d.DLL" (ByVal hwndApp As Long) As Long
Private Sub cmdScan_Click()
Dim Ret As Long, PictureFile As String
Dim intPages As Integer
Dim blnContScan As Boolean
Dim ContScan As String 'msgbox to chk if more pages are to be scanned
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
intPages = intPages + 1
PictureFile = CurrentProject.Path & "\" & myfolder & "\" & Me.number & Trim(Str(intPages)) & ".jpg"
Ret = TWAIN_AcquireToFilename(Me.hwnd, PictureFile)
ContScan = MsgBox("? ÍÝÙ ÕæÑÉ ÇÎÑì ", vbQuestion + vbYesNo, "ÊäÈíÉ")
If ContScan = vbNo Then
blnContScan = False
End If
Loop