• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 647
  • Last Modified:

Loop in side folder and find file with same prefix in vba

i need to loop through file in afolder and search for file with the same prefix name i have a pdf file that AMR Rt.pdf and AMR Pm.pdf so i need to search and find the file with same pefix like AMR and copy it to another folder
Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch As String 'Declare the folder to search in
   Dim i  as integer
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File 
 
strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
                With Application.FileSearch
 strPdfPath1 = strPdfPath1 & "Emails\"
strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
strPdfPath2 = strPdfPath2 & "EmailsSent\"
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
    strPdfPath1 = .FoundFiles(i)
    '------------------------------------------------------------------------------------------------------
  FoundFileNameValue(1) = Trim((Mid(strPdfPath1, Len(FolderToSearch) + 1, _
     Len(strPdfPath1) - Len(FolderToSearch) - 7)))
fso.CopyFile strPdfPath1, strPdfPath2, True

Open in new window

0
osama120
Asked:
osama120
  • 26
  • 10
  • 5
1 Solution
 
donaldmaloneyCommented:
So change
    .FileName = "*.pdf"
to  
  .FileName = "AMR*.pdf"

Is this what you re looking for?

How versed are you in VB?




0
 
osama120Author Commented:
there will many duplicate files with same name what i want i want to copy files with same prefix and this "AMR*.pdf will not work
im begginer in vba
0
 
donaldmaloneyCommented:
Is the code that is in your question  -    Is it your code  or code you want changed for your application?

Do you want to select a Folder   then  select a prefix  then select a Folder to copy the files to
then click a button and have the files copied to the other folder?
Do the folder names change?



0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
osama120Author Commented:
no the folder name is not change this code i want to changed for my application i used before but in another application so i think it will be usefull here
0
 
osama120Author Commented:
but the files name change
0
 
osama120Author Commented:
no i dont want to select afolder i wanted to be automated
0
 
LedigimateCommented:
As donaldmaloney suggested, "AMR*.pdf" will find all the files with a AMR prefix and nothing else.
There won't be duplicate file names, because there are no duplicate file names in the folder being searched.  You can be sure of that.
0
 
osama120Author Commented:
the files name like this Amr rt.pdf Amr pm.pdf ,osa rtf.pdf,osa pm.pdf,adm rt.pdf,adm pm ,mikel rt.pdf ,ali pm.pdf ans soi want to copy the duplicate prefex first then the none duplicate second the code should first look for the name the duplicate copy first then the none dulicate second
0
 
LedigimateCommented:
osama120:
Okay, now i (think) i understand what you want.  At first it wasn't clear what you meant by "duplicate files", but now i understand that you mean "duplicate prefixes".  Using the file names in your last comment, i (think) you are saying that
Amr rt.pdf, Amr pm, osa rtf.pdf, osa pm.pdf
are duplicates, and
adm rt.pdf, mikel rt.pdf, ali pm.pdf
are non-duplicates, and that the duplicates should be copied to one folder first, and then the non-duplicates should be copied to another folder.  Correct me if I'm wrong.  Please bear with me while I'm trying to understand your question...
0
 
LedigimateCommented:
sorry, typo in my last comment:  Amr pm --> Amr pm.pdf
0
 
osama120Author Commented:
yes that correct
0
 
donaldmaloneyCommented:
Do you always have a space between the prefix and the rest of the file name?
If so the code you have will give you a list of file names.
Then it is a matter of extracting the like prefix names.
e.g.
set up an array the same dimension as the found files count
 Dim arrayFileNames()
Dim prefixName as string        
redim Preserve arrayFileNames(2,FoundFiles.Count)
 For i = 1 To .FoundFiles.Count
  prefixString = left(.FoundFiles(i),instr(.FoundFiles(i)," ")-1)
    arrayFileNames(1,i) = prefixString  ' puts the prefix in an array
    arrayFileNames(2,i) = 1    'sets the count of the prefix
For J = 1 to i -1
if arrayFileNames(1,j) = prefixString then arrayFileNames(2,j) = arrayFileNames(2,j)  + 1
next j
next i
' so now I have an array with prefixes and a count in each
' the duplicate prefixes will have a 2 in the second dimension
This is a start

Another way would be to create a temp table.
with fields     fld prefix and fldcount.
then do a dlookup and if the prefix is found add 1
else add a prefix record.
then go through the file names and if the prefix count is 2  (or more) copy the file to the duplicate directory
if the prefix count is 1 then copy it to the non duplicate directory.

Does this help?

Don
0
 
osama120Author Commented:
see i will give the hall code i use simply the code what will do he will search inside afolder for pdf files then if he found the files he will locate the first file for e.g amr rtf.pdf then he will trim the file name so it will be amr then he will open my table manager and check if the amr there if so
another search should be done in side the folder to check if there is another file start with amr if so
then it should copyed to gether if not the copy that file only after copy i kill the file

this the  acode snippet
Sub TrnsfearPDf()
   Dim strMessage As String
   Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch1, FolderToSearch2 As String 'Declare the folder to search in
   Dim i, k, j As Integer 'Counter
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File
   Dim KillFile, kilFile1 As String 'To Delete the pffs files
 
             'path1 to locate the folder in the same database directory
       
        strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
 
'------------------------------------------------------------------------------------------------------
 
    'Locate the folder to search and loop in
    
     With Application.FileSearch
     FolderToSearch1 = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch1
    .FileName = "*.pdf"
    If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
    strPdfPath1 = .FoundFiles(i)
'------------------------------------------------------------------------------------------------------
 
  FoundFileNameValue(1) = Trim((Mid(strPdfPath1, Len(FolderToSearch1) + 1, _
     Len(strPdfPath1) - Len(FolderToSearch1) - 7)))
   
   Dim Mydb As DAO.Database
   Dim Record As Object
   Dim sql As String
 'Open Current db to loop through the shadow account records
      Set Mydb = CurrentDb
      Set Record = Mydb.OpenRecordset("tblAreaManagers")
        If Not Record.BOF Then Record.MoveFirst
            While Not Record.EOF
  
              sql = Trim(Record![AreaManagerName])
  
                  If FoundFileNameValue(1) = sql Then
'------------------------------------------------------------------------------------------------------  
 
   With Application.FileSearch
   FolderToSearch2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare)) & "Emails\"
   .LookIn = FolderToSearch2
   .FileName = FoundFileNameValue(1) & "*.pdf"
   If .Execute() > 1 Then
      For j = 1 To .FoundFiles.Count
    
     Next
        strPdfPath1 = .FoundFiles(j - 1)
        strPdfPath0 = .FoundFiles(j - 2)
     End If
     End With
  
'------------------------------------------------------------------------------------------------------  
'here i copy the files
 
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
   
   If strPdfPath0 <> "" Then
       fso.CopyFile strPdfPath0, strPdfPath2, True
   End If
'------------------------------------------------------------------------------------------------------   
'here i kill the files after copy them
 
    KillFile = strPdfPath1 'Delete the File
    KillFile1 = strPdfPath0
       'Check that file exists
          If Len(Dir$(KillFile)) > 0 Then
              'First remove readonly attribute, if set
           SetAttr KillFile, vbNormal
          'Then delete the file
          Kill KillFile
         End If
        
       If strPdfPath0 <> "" Then
          If Len(Dir$(KillFile1)) > 0 Then
             'First remove readonly attribute, if set
              SetAttr KillFile1, vbNormal
             'Then delete the file
          Kill KillFile1
         End If
       End If
 
 
    If Err.Number <> 0 Then Exit Sub
 
   If Not Record.EOF Then Record.MoveNext
   Wend
  
 
  Next
 
  End If
Set fso = Nothing
 
   
 
End With
 
 
End Sub

Open in new window

0
 
osama120Author Commented:
did u get my point
0
 
osama120Author Commented:
this code always give subscript out of range
0
 
osama120Author Commented:
when i use this code it giveme object required
 Dim arrayFileNames()
Dim prefixName as string        
redim Preserve arrayFileNames(2,FoundFiles.Count)
 For i = 1 To .FoundFiles.Count
  prefixString = left(.FoundFiles(i),instr(.FoundFiles(i)," ")-1)
    arrayFileNames(1,i) = prefixString  ' puts the prefix in an array
    arrayFileNames(2,i) = 1    'sets the count of the prefix
For J = 1 to i -1
if arrayFileNames(1,j) = prefixString then arrayFileNames(2,j) = arrayFileNames(2,j)  + 1
next j
next i
0
 
donaldmaloneyCommented:
Change
redim Preserve arrayFileNames(2,FoundFiles.Count)


to
ReDim Preserve arrayFileNames(2,.FoundFiles.Count)


I forgot the "."  before the FoundFiles.count

Don
0
 
osama120Author Commented:
now how can assign the path strpdfpath1 for single file  for double file strpdfpath0& strpdfpath1
     With Application.FileSearch
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
Dim arrayFileNames() As Variant
Dim prefixName As String
ReDim Preserve arrayFileNames(2, .FoundFiles.Count)

 For i = 1 To .FoundFiles.Count
  prefixString = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  prefixString = Trim(Mid(prefixString, 1, Len(prefixString) - 6))
    arrayFileNames(1, i) = prefixString ' puts the prefix in an array
    arrayFileNames(2, i) = 2   'sets the count of the prefix
For j = 1 To i - 1
If arrayFileNames(1, j) = prefixString Then arrayFileNames(2, j) = arrayFileNames(2, j) + 1
strPdfPath1 = .FoundFiles(i)
strPdfPath0 = .FoundFiles(i)
Next j
strPdfPath1 = .FoundFiles(i)
Next i
0
 
LedigimateCommented:
If I understand correctly, you want to copy the files with "duplicate" prefixes only if the prefix is found in the table called "tblAreaManagers", right?
0
 
LedigimateCommented:
... and if the prefix is not found in the "tblAreaManagers" table, then that file should be copied to the "non-duplicate" directory?
0
 
donaldmaloneyCommented:
osama
Do you want an app that will do th efollowing?
I will have two windows.  and a button to select "Duplicates"  or "Singles"
The left will have all of the filenames.
If you select Duplicates  The Left will have all of the file names with duplicate prefix names.
If you select Singles  The Left will have all of the file names which DO NOT have duplicate prefix names.
There will be a button on top for you to select the input folder
and a button for you to select the Output Folder

Then buttons for you to move files from one to the other
You can select all or one at a time.

Is this what you want?
Don
0
 
osama120Author Commented:
no sir what i want exactly one button only if the files are singel transfeart to single file if file are duplicate send it to duplicate file
0
 
osama120Author Commented:
'here is the code i  copy the files
 
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
   
   If strPdfPath0 <> "" Then
       fso.CopyFile strPdfPath0, strPdfPath2, True
   End If
'------------------------------------------------------------------------------------------------------  
'here i kill the files after copy them
 
    KillFile = strPdfPath1 'Delete the File
    KillFile1 = strPdfPath0
       'Check that file exists
          If Len(Dir$(KillFile)) > 0 Then
              'First remove readonly attribute, if set
           SetAttr KillFile, vbNormal
          'Then delete the file
          Kill KillFile
         End If
       
       If strPdfPath0 <> "" Then
          If Len(Dir$(KillFile1)) > 0 Then
             'First remove readonly attribute, if set
              SetAttr KillFile1, vbNormal
             'Then delete the file
          Kill KillFile1
         End If
       End If
0
 
osama120Author Commented:
the button should should count all the files then if there is duplicate files send it to  folder1 and if there is singel file send it to  folder2
0
 
osama120Author Commented:
i can creat the folder automatical by this by this code
   strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
0
 
osama120Author Commented:
can u ignor the last 3  commets i will send a file that will explain every thing
0
 
osama120Author Commented:
the button will search fo pdf files then if there 2 pdf with same prefix the send by mail to that person in my table if it was one also send it the file will explain every think
0
 
osama120Author Commented:
this asample file that will explain what i want the button should searf in email folder for pdf file if there there two file with the same prefix then send it by one mail if it one file send it by one email also
Test.zip
0
 
donaldmaloneyCommented:
OK Got it.

I will work on it today.

Don
0
 
donaldmaloneyCommented:
osama,

THis will create an array of prefix names and then set the duplicates with a 2 as the second dimension.
Then it goes through and clears up the array so there will be OND prefix name and either a 0,1,or 2 as the second dimension.
Magdi ali mohd Pm.pdf
saju kk Rt.pdf
Osama khalid ad Rt.pdf
Osama khalid ad Pm.pdf
Magdi ali mohd Rt.pdf

Becomes
Magdi ,1
saju ,1
Osama ,1
Osama ,2
Magdi ,2

Then
Magdi ,2
saju ,1
Osama ,0
Osama ,2
Magdi ,0

Then going through the loop and select statement
the Magdi    files will go to the duplicate folder
saju files will go to the Single folder
Osama files will go to the duplicate folder

The code will need to be adjusted so that the actual moves will be at the
    ====================The FILE MOVE   EMAIL MOVE SHOULD  BE IN HERE

I think it would be the
 Dim Mydb As DAO.Database

to

If Not Record.EOF Then Record.MoveNext

But I need to run this some more   since I gete  a server connnect issue ( I cannot send the email from my pc)
Does this help??
Don



Option Compare Database
Sub TrnsfearPDf()
   
   Dim strMessage As String
   Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch As String 'Declare the folder to search in
   Dim i, k As Integer 'Counter
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File
   Dim KillFile As String 'To Delete the pffs files
             'path1 to locate the folder in the same database directory
    Stop
        strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
'------------------------------------------------------------------------------------------------------
    'Locate the folder to search and loop in
    
     With Application.FileSearch
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
Dim arrayFileNames() As Variant
Dim prefixName As String
ReDim Preserve arrayFileNames(.FoundFiles.Count, 2)
 For i = 1 To .FoundFiles.Count  'first move prefixes to an array
 
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), " ") - 1)
  prefixstring = Left(prefixstring, InStr(1, prefixstring, " ") - 1)
 ' prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
    arrayFileNames(i, 1) = prefixstring ' puts the prefix in an array
    arrayFileNames(i, 2) = 1   'sets the count of the prefix
 Next i
 
For i = 1 To .FoundFiles.Count   ' run trough array to see if there are duplicate prefix names
prefixstring = arrayFileNames(i, 1) ' Stert with the first prefix name
For j = i + 1 To .FoundFiles.Count    ' start checking with the second name and see if there are 2 of them
 
If arrayFileNames(j, 1) = prefixstring Then
   arrayFileNames(j, 2) = 2  ' we have two of these
   arrayFileNames(i, 2) = 0  'Clear out original count
   GoTo GetNexti
End If
Next j
GetNexti:
Next i
' Now clean up array
      ' Loop through array   if second ,X  = 0 skip
      '  if second = 1  then we have 1  and no duplicate prefix
      ' if second = 2 then it is a duplicate prefix
 
'----------------  NMow loop through array and .found files to send email to correct folder ---------------
 
For i = 1 To .FoundFiles.Count
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), " ") - 1)
  prefixstring = Left(prefixstring, InStr(1, prefixstring, " ") - 1)
  
For j = i To .FoundFiles.Count  ' Now check the emails that match the prefix
If arrayFileNames(j, 1) <> prefixstring Then GoTo SelectNextJ
Select Case arrayFileNames(j, 2)   ' 0 skip   1 send to single   2 send to duplicate
   Case 0
        GoTo SelectNextJ
   Case 1
        strPdfPath1 = .FoundFiles(i)  ' the filename prefix  of .FoundFiles(i) matches a Single
        
   Case 2
        strPdfPath0 = .FoundFiles(i)     ' the filename prefix  of .FoundFiles(i) matches a duplicate
End Select
 
'                ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE
 
SelectNextJ:
Next j       ' ==================   These should be AFTER THE FILE IS MOVED
'strPdfPath1 = .FoundFiles(i)
SelectNextI:
Next i        '====================  MOVE THIS AFTER THE FILE IS MOVED +++++++
  
      
    
    
    
'-----------------------------------------------------------------------------------------------------
 
 
  
   
   Dim Mydb As DAO.Database
   Dim Record As Object
   Dim sql As String
   'Open Current db to loop through the shadow account records
   Set Mydb = CurrentDb
      
If Forms![FrmReport]![SendEmail].Value = 1 Then Set Record = Mydb.OpenRecordset("tblAreaManagers")
    
If Not Record.BOF Then Record.MoveFirst
   While Not Record.EOF
  
  If Forms![FrmReport]![SendEmail].Value = 1 Then sql = Trim(Record![AreaManagerName])
 
  
  If prefixstring = Left(sql, Len(prefixstring)) Then   ' sql
 
  
 
 'ConvertReportToPDF "Report_ByAcccount", vbNullString, Me![txtAccountNo] & ".pdf", False, False, 150, "", "", 0, 0, 0
  
   
  '------------------------------------------------------------------------------------------------------
    
    'Send Email to the customer with same A/C Number
strMessage = "Dear," & vbCrLf
strMessage = strMessage + "Kindly find the attached Of your Monthly MIS Report" & vbCrLf & vbCrLf
strMessage = strMessage + "AAAAAAAAAA" & vbCrLf
strMessage = strMessage + "http://www.wwwww.com"
If strPdfPath0 = "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1
Else
 
 SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1, strPdfPath0
  
  End If
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
If strPdfPath0 <> "" Then
 fso.CopyFile strPdfPath0, strPdfPath2, True
 End If
 KillFile = strPdfPath1 'Delete the File
 KillFile1 = strPdfPath0
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile, vbNormal
    'Then delete the file
     Kill KillFile
     
End If
If strPdfPath0 <> "" Then
 
If Len(Dir$(KillFile1)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile1, vbNormal
    'Then delete the file
     Kill KillFile1
     
End If
End If
'strPdfPath0 = ""
'strPdfPath5 = ""
k = k + 1
 
 End If
 
 If Err.Number <> 0 Then Exit Sub
 
 If Not Record.EOF Then Record.MoveNext
 Wend
 
End If
Set fso = Nothing
'If k <= 0 Then k = 1
  If Forms![FrmReport]![SendEmail].Value = 1 Then MsgBox "You Send " & k & " Area Managers Emails ", vbCritical
  
   
End With
 
End Sub

Open in new window

0
 
osama120Author Commented:
what i shlould move here
 ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE
 
0
 
donaldmaloneyCommented:
At that place :  

The code that moves the emails to the single and duplicate folders.
And the code that deletes the emails from the original directory.


I was running a test but got a server error
Your code accesses your server and I do not have one.

Before testing this please back up your email folders.
Don
0
 
osama120Author Commented:
see sir the after i press the email button i code should search for the pdf files in the email folder if  there single prefixx sen it using email with one attachment if it double send it using email with two attachment anfter sending move the pdf to the email send folder thats it

SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1 or
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1, strPdfPath0
and keep looping untile u finsh all the pdf
0
 
donaldmaloneyCommented:
osama

Is that what lines 72 through 112 of your original code does?


I would remove lines 96 to 175 from your current code  and insert lines 72 through 112 of your original code  to here
'                ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE


then run the application to see if the files are moved.

I will be on from my pc occasionally tomorrow but will revisit this tyhe day after tomorrow (Sunday  East Coast USA)

And runn a more complete diagnostic.

Don
0
 
osama120Author Commented:
 i try this code but it will send one attachment not two
   Dim strMessage As String
   Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch As String 'Declare the folder to search in
   Dim i, k As Integer 'Counter
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File
   Dim KillFile As String 'To Delete the pffs files
             'path1 to locate the folder in the same database directory
   
        strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
'------------------------------------------------------------------------------------------------------
    'Locate the folder to search and loop in
  Stop
     With Application.FileSearch
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
Dim arrayFileNames() As Variant
Dim prefixName As String
ReDim Preserve arrayFileNames(.FoundFiles.Count, 2)
 For i = 1 To .FoundFiles.Count  'first move prefixes to an array
 
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  'prefixstring = Left(prefixstring, InStr(1, prefixstring, " ") - 1)
  prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
    arrayFileNames(i, 1) = prefixstring ' puts the prefix in an array
    arrayFileNames(i, 2) = 1   'sets the count of the prefix
 Next i
 
For i = 1 To .FoundFiles.Count   ' run trough array to see if there are duplicate prefix names
prefixstring = arrayFileNames(i, 1) ' Stert with the first prefix name
For j = i + 1 To .FoundFiles.Count    ' start checking with the second name and see if there are 2 of them
 
If arrayFileNames(j, 1) = prefixstring Then
   arrayFileNames(j, 2) = 2  ' we have two of these
   arrayFileNames(i, 2) = 0  'Clear out original count
   GoTo GetNexti
End If
Next j
GetNexti:
Next i
' Now clean up array
      ' Loop through array   if second ,X  = 0 skip
      '  if second = 1  then we have 1  and no duplicate prefix
      ' if second = 2 then it is a duplicate prefix
 
'----------------  NMow loop through array and .found files to send email to correct folder ---------------
 
For i = 1 To .FoundFiles.Count
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
 
For j = i To .FoundFiles.Count  ' Now check the emails that match the prefix
If arrayFileNames(j, 1) <> prefixstring Then GoTo SelectNextJ
Select Case arrayFileNames(j, 2)   ' 0 skip   1 send to single   2 send to duplicate
   Case 0
        GoTo SelectNextJ
   Case 1
        strPdfPath1 = .FoundFiles(i)  ' the filename prefix  of .FoundFiles(i) matches a Single
       
   Case 2
        strPdfPath0 = .FoundFiles(i)     ' the filename prefix  of .FoundFiles(i) matches a duplicate
End Select
 
'                ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE
 
   Dim Mydb As DAO.Database
   Dim Record As Object
   Dim sql As String
   'Open Current db to loop through the shadow account records
   Set Mydb = CurrentDb
     
 If Forms![FrmReport]![SendEmail].Value = 1 Then Set Record = Mydb.OpenRecordset("tblAreaManagers")
 If Forms![FrmReport]![SendEmail].Value = 2 Then Set Record = Mydb.OpenRecordset("Branches")
 If Forms![FrmReport]![SendEmail].Value = 3 Then Set Record = Mydb.OpenRecordset("QPBCode")
     
   
If Not Record.BOF Then Record.MoveFirst
   While Not Record.EOF
 
  If Forms![FrmReport]![SendEmail].Value = 1 Then sql = Trim(Record![AreaManagerName])
  If Forms![FrmReport]![SendEmail].Value = 2 Then sql = Trim(Record![BrancheName])
  If Forms![FrmReport]![SendEmail].Value = 3 Then sql = Trim(Record![StaffName])
 
 
  If prefixstring = sql Then
 
 
 
 'ConvertReportToPDF "Report_ByAcccount", vbNullString, Me![txtAccountNo] & ".pdf", False, False, 150, "", "", 0, 0, 0
 
   
  '------------------------------------------------------------------------------------------------------
   
    'Send Email to the customer with same A/C Number
strMessage = "Dear," & vbCrLf
strMessage = strMessage + "Kindly find the attached Of your Monthly MIS Report" & vbCrLf & vbCrLf
strMessage = strMessage + "AAAAAAAAAA" & vbCrLf
strMessage = strMessage + "http://www.wwwww.com"
If strPdfPath0 = "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1
Else
 
 SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath0
 
  End If
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
If strPdfPath0 <> "" Then
 fso.CopyFile strPdfPath0, strPdfPath2, True
 End If
 KillFile = strPdfPath1 'Delete the File
 KillFile1 = strPdfPath0
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile, vbNormal
    'Then delete the file
     Kill KillFile
     
End If
If strPdfPath0 <> "" Then
 
If Len(Dir$(KillFile1)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile1, vbNormal
    'Then delete the file
     Kill KillFile1
     
End If
End If
'strPdfPath0 = ""
'strPdfPath5 = ""
k = k + 1
 
 End If
 
 If Err.Number <> 0 Then Exit Sub
 
 If Not Record.EOF Then Record.MoveNext
 Wend
 
SelectNextJ:
Next j       ' ==================   These should be AFTER THE FILE IS MOVED
'strPdfPath1 = .FoundFiles(i)
SelectNextI:
Next i        '====================  MOVE THIS AFTER THE FILE IS MOVED +++++++
 
     
   
   
   
'-----------------------------------------------------------------------------------------------------
 
 
 
 
 
End If
Set fso = Nothing
'If k <= 0 Then k = 1
  If Forms![FrmReport]![SendEmail].Value = 1 Then MsgBox "You Send " & k & " Area Managers Emails ", vbCritical
 
   
End With
 
End Sub
0
 
osama120Author Commented:
sorry this one
Option Compare Database
Sub TrnsfearPDf()
   
   Dim strMessage As String
   Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch As String 'Declare the folder to search in
   Dim i, k As Integer 'Counter
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File
   Dim KillFile As String 'To Delete the pffs files
             'path1 to locate the folder in the same database directory
    
        strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
'------------------------------------------------------------------------------------------------------
    'Locate the folder to search and loop in
  Stop
     With Application.FileSearch
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
Dim arrayFileNames() As Variant
Dim prefixName As String
ReDim Preserve arrayFileNames(.FoundFiles.Count, 2)
 For i = 1 To .FoundFiles.Count  'first move prefixes to an array
 
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  'prefixstring = Left(prefixstring, InStr(1, prefixstring, " ") - 1)
  prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
    arrayFileNames(i, 1) = prefixstring ' puts the prefix in an array
    arrayFileNames(i, 2) = 1   'sets the count of the prefix
 Next i
 
For i = 1 To .FoundFiles.Count   ' run trough array to see if there are duplicate prefix names
prefixstring = arrayFileNames(i, 1) ' Stert with the first prefix name
For j = i + 1 To .FoundFiles.Count    ' start checking with the second name and see if there are 2 of them
 
If arrayFileNames(j, 1) = prefixstring Then
   arrayFileNames(j, 2) = 2  ' we have two of these
   arrayFileNames(i, 2) = 0  'Clear out original count
   GoTo GetNexti
End If
Next j
GetNexti:
Next i
' Now clean up array
      ' Loop through array   if second ,X  = 0 skip
      '  if second = 1  then we have 1  and no duplicate prefix
      ' if second = 2 then it is a duplicate prefix
 
'----------------  NMow loop through array and .found files to send email to correct folder ---------------
 
For i = 1 To .FoundFiles.Count
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
  
For j = i To .FoundFiles.Count  ' Now check the emails that match the prefix
If arrayFileNames(j, 1) <> prefixstring Then GoTo SelectNextJ
Select Case arrayFileNames(j, 2)   ' 0 skip   1 send to single   2 send to duplicate
   Case 0
        GoTo SelectNextJ
   Case 1
        strPdfPath1 = .FoundFiles(i)  ' the filename prefix  of .FoundFiles(i) matches a Single
        
   Case 2
        strPdfPath0 = .FoundFiles(i)     ' the filename prefix  of .FoundFiles(i) matches a duplicate
End Select
 
'                ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE
 
   Dim Mydb As DAO.Database
   Dim Record As Object
   Dim sql As String
   'Open Current db to loop through the shadow account records
   Set Mydb = CurrentDb
      
 If Forms![FrmReport]![SendEmail].Value = 1 Then Set Record = Mydb.OpenRecordset("tblAreaManagers")
 If Forms![FrmReport]![SendEmail].Value = 2 Then Set Record = Mydb.OpenRecordset("Branches")
 If Forms![FrmReport]![SendEmail].Value = 3 Then Set Record = Mydb.OpenRecordset("QPBCode")
      
    
If Not Record.BOF Then Record.MoveFirst
   While Not Record.EOF
  
  If Forms![FrmReport]![SendEmail].Value = 1 Then sql = Trim(Record![AreaManagerName])
  If Forms![FrmReport]![SendEmail].Value = 2 Then sql = Trim(Record![BrancheName])
  If Forms![FrmReport]![SendEmail].Value = 3 Then sql = Trim(Record![StaffName])
 
  
  If prefixstring = sql Then
 
  
 
 'ConvertReportToPDF "Report_ByAcccount", vbNullString, Me![txtAccountNo] & ".pdf", False, False, 150, "", "", 0, 0, 0
  
   
  '------------------------------------------------------------------------------------------------------
    
    'Send Email to the customer with same A/C Number
strMessage = "Dear," & vbCrLf
strMessage = strMessage + "Kindly find the attached Of your Monthly MIS Report" & vbCrLf & vbCrLf
strMessage = strMessage + "AAAAAAAAAA" & vbCrLf
strMessage = strMessage + "http://www.wwwww.com"
If strPdfPath0 = "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1
Else
 
 SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath0, strPdfPath1
  
  End If
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
If strPdfPath0 <> "" Then
 fso.CopyFile strPdfPath0, strPdfPath2, True
 End If
 KillFile = strPdfPath1 'Delete the File
 KillFile1 = strPdfPath0
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile, vbNormal
    'Then delete the file
     Kill KillFile
     
End If
If strPdfPath0 <> "" Then
 
If Len(Dir$(KillFile1)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile1, vbNormal
    'Then delete the file
     Kill KillFile1
     
End If
End If
'strPdfPath0 = ""
'strPdfPath5 = ""
k = k + 1
 
 End If
 
 If Err.Number <> 0 Then Exit Sub
 
 If Not Record.EOF Then Record.MoveNext
 Wend
 
SelectNextJ:
Next j       ' ==================   These should be AFTER THE FILE IS MOVED
'strPdfPath1 = .FoundFiles(i)
SelectNextI:
Next i        '====================  MOVE THIS AFTER THE FILE IS MOVED +++++++
  
      
    
    
    
'-----------------------------------------------------------------------------------------------------
 
 
  
  
 
End If
Set fso = Nothing
'If k <= 0 Then k = 1
  If Forms![FrmReport]![SendEmail].Value = 1 Then MsgBox "You Send " & k & " Area Managers Emails ", vbCritical
  
   
End With
 
End Sub
 

Open in new window

0
 
osama120Author Commented:
the code should search for pdf file if there is twon file with same prefix then the email should have 2 attachment if it is one then one attachment
0
 
osama120Author Commented:
this code will send email with two qattachment how can send email with three attachment
Sub TrnsfearPDf()
   
   Dim strMessage As String
   Dim strPdfPath0, strPdfPath1, strPdfPath2 As String 'Declare path1 for unsend mails and path2 for send mails
   Dim FolderToSearch As String 'Declare the folder to search in
   Dim i, k As Integer 'Counter
   Dim FoundFileNameValue(2) As String
   Dim fso As New Scripting.FileSystemObject 'Declare FileSystemObject to Copy and  Delete the File
   Dim KillFile As String 'To Delete the pffs files
             'path1 to locate the folder in the same database directory
    Stop
        strPdfPath1 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
            ' make sure reports folder exists
         If Dir(strPdfPath1 & "Emails\", vbDirectory) = "" Then
             MkDir strPdfPath1 & "Emails\"
          End If
       ' registry key needs "\\" in file path
        strPdfPath1 = strPdfPath1 & "Emails\"
'-----------------------------------------------------------------------------------------------------
    'path2 to locate the folder in the same database directory
    strPdfPath2 = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", , vbTextCompare))
      ' make sure reports folder exists
    If Dir(strPdfPath2 & "EmailsSent\", vbDirectory) = "" Then
        MkDir strPdfPath2 & "EmailsSent\"
    End If
       ' registry key needs "\\" in file path
    strPdfPath2 = strPdfPath2 & "EmailsSent\"
'------------------------------------------------------------------------------------------------------
    'Locate the folder to search and loop in
    
     With Application.FileSearch
     FolderToSearch = strPdfPath1 'edit this to your path
    .LookIn = FolderToSearch
    .FileName = "*.pdf"
    If .Execute() > 0 Then
Dim arrayFileNames() As Variant
Dim prefixName As String
ReDim Preserve arrayFileNames(.FoundFiles.Count, 3)
 For i = 1 To .FoundFiles.Count  'first move prefixes to an array
 
  prefixstring = Left(Dir(.FoundFiles(i)), InStr(.FoundFiles(i), ".") - 1)
  'prefixstring = Left(prefixstring, InStr(1, prefixstring, " ") - 1)
  prefixstring = Trim(Mid(prefixstring, 1, Len(prefixstring) - 6))
    arrayFileNames(i, 1) = prefixstring ' puts the prefix in an array
    arrayFileNames(i, 2) = 1   'sets the count of the prefix
    arrayFileNames(i, 3) = 2
 Next i
For i = 1 To .FoundFiles.Count   ' run trough array to see if there are duplicate prefix names
prefixstring = arrayFileNames(i, 1) ' Stert with the first prefix name
For j = i + 1 To .FoundFiles.Count    ' start checking with the second name and see if there are 2 of them
 
If arrayFileNames(j, 1) = prefixstring Then
   arrayFileNames(j, 2) = 2  ' we have two of these
    strPdfPath0 = .FoundFiles(i)
    strPdfPath1 = .FoundFiles(j)
    
        arrayFileNames(i, 2) = 0  'Clear out original count
    GoTo GetNexti
    
   
End If
Next j
For k = j + 1 To .FoundFiles.Count  ' start checking with the second name and see if there are 2 of them
 
If arrayFileNames(k, 1) = prefixstring Then
   arrayFileNames(k, 3) = 3  ' we have two of these
    strPdfPath0 = .FoundFiles(i)
    strPdfPath1 = .FoundFiles(j)
    strPdfPath1 = .FoundFiles(k)
        arrayFileNames(i, 3) = 0  'Clear out original count
    GoTo GetNexti
    
   
End If
Next k
 
  
strPdfPath1 = .FoundFiles(i)
 
' Now clean up array
      ' Loop through array   if second ,X  = 0 skip
      '  if second = 1  then we have 1  and no duplicate prefix
      ' if second = 2 then it is a duplicate prefix
 
'----------------  NMow loop through array and .found files to send email to correct folder ---------------
 
 
 
'                ====================The FILE MOVE   EMAIL MOVE SHOULD BE IN HERE
   Dim Mydb As DAO.Database
   Dim Record As Object
   Dim sql As String
   'Open Current db to loop through the shadow account records
   Set Mydb = CurrentDb
      
If Forms![FrmReport]![SendEmail].Value = 1 Then Set Record = Mydb.OpenRecordset("tblAreaManagers")
 If Forms![FrmReport]![SendEmail].Value = 2 Then Set Record = Mydb.OpenRecordset("Branches")
 If Forms![FrmReport]![SendEmail].Value = 3 Then Set Record = Mydb.OpenRecordset("QPBCode")
    
If Not Record.BOF Then Record.MoveFirst
   While Not Record.EOF
  
   
  If Forms![FrmReport]![SendEmail].Value = 1 Then sql = Trim(Record![AreaManagerName])
  If Forms![FrmReport]![SendEmail].Value = 2 Then sql = Trim(Record![BrancheName])
  If Forms![FrmReport]![SendEmail].Value = 3 Then sql = Trim(Record![StaffName])
 
 
  
  If prefixstring = sql Then
 
  
 
 'ConvertReportToPDF "Report_ByAcccount", vbNullString, Me![txtAccountNo] & ".pdf", False, False, 150, "", "", 0, 0, 0
  
   
  '------------------------------------------------------------------------------------------------------
    
    'Send Email to the customer with same A/C Number
strMessage = "Dear," & vbCrLf
strMessage = strMessage + "Kindly find the attached Of your Monthly MIS Report" & vbCrLf & vbCrLf
strMessage = strMessage + "AAAAAAAAAA" & vbCrLf
strMessage = strMessage + "http://www.wwwww.com"
If strPdfPath0 = "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1
End If
If strPdfPath0 <> "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1, strPdfPath0
End If
If strPdfPath0 <> "" And strPdfPath3 <> "" Then
SendEmailCDO Trim(Record![Email]), strMessage, "Your MIS Report", strPdfPath1, strPdfPath0, strPdfPath3
End If
 
 fso.CopyFile strPdfPath1, strPdfPath2, True 'copy the file that has been sent
If strPdfPath0 <> "" Then
 fso.CopyFile strPdfPath0, strPdfPath2, True
 End If
 If strPdfPath3 <> "" Then
 fso.CopyFile strPdfPath3, strPdfPath2, True
 End If
 KillFile = strPdfPath1 'Delete the File
 KillFile1 = strPdfPath0
 KillFile2 = strPdfPath3
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile, vbNormal
    'Then delete the file
     Kill KillFile
     
End If
If strPdfPath0 <> "" Then
 
If Len(Dir$(KillFile1)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile1, vbNormal
    'Then delete the file
     Kill KillFile1
     
End If
End If
If strPdfPath3 <> "" Then
 
If Len(Dir$(KillFile1)) > 0 Then
    'First remove readonly attribute, if set
    SetAttr KillFile2, vbNormal
    'Then delete the file
     Kill KillFile2
     
End If
End If
'strPdfPath0 = ""
'strPdfPath5 = ""
k = k + 1
  
End If
 
 If Err.Number <> 0 Then Exit Sub
 
 If Not Record.EOF Then Record.MoveNext
 Wend
 
 
GetNexti:
 
 
 
Next i
 
    
'-----------------------------------------------------------------------------------------------------
 
 
  
   
 
 
End If
Set fso = Nothing
End With
 
'If k <= 0 Then k = 1
  If Forms![FrmReport]![SendEmail].Value = 1 Then MsgBox "You Send " & k & " Area Managers Emails ", vbCritical
  
 
 
End Sub
 
 

Open in new window

0
 
donaldmaloneyCommented:
Osama,

If there are three do you want them to go to a Third eamil folder?

Otherwize the code that you have moves the three duplicates to the duplicate folder.

I tested with different names and the duplicates all moved to the same folder.

Don
0
 
osama120Author Commented:
i have only 2 folders one call email and one called emailsent only now the code should search for pdf files in email folder if found adf with one prefixx then send email with one attachment if two pdf with same prefix then send one email with 2 attachment if three pdf with ame prefix then send email with three attachment the maximun is three attachment  and send it copy it from email folder to emailsent folder then delete in the email folder
0
 
osama120Author Commented:
thank u alot
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 26
  • 10
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now