Pagina precedente | 1 | Pagina successiva
Vota | Stampa | Notifica email    
Autore

salvare file in una cartella creata in automatico

Ultimo Aggiornamento: 30/07/2022 19:48
Post: 466
Registrato il: 28/05/2011
Città: MILANO
Età: 43
Utente Senior
excel 2000/2007
OFFLINE
30/07/2022 14:34

Ciao,
questa macro è inviare via mail un file xslx.
Crea il file, lo spedisce e poi lo elimina.
Tutto questo lo faceva in
Set wk1 = ThisWorkbook
Se per caso qui c'erano altri file eliminava anche questi.
Ho pensato di inserire questi file in una cartella specifica in ThisWorkbook.


'-----------------------------------------------------------------------------------------
        
    filemail = Foglio1.Range("R1").Value
    
    
    Set wk1 = ThisWorkbook
   'il percorso
    mioperc = wk1.Path & "\" & filemail
  
    
    If Dir(mioperc, vbDirectory) = "" Then MkDir mioperc
    
    miofile = Range("A2") & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"
    NomePDF = mioperc & miofile
        
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomePDF _
   , Quality:=xlQualityStandard, IncludeDocProperties:=False, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False



la cartella viene creata ma il file non si salva dentro a questa.
Dove sbaglio?
Allego il file.
Grazie


Per non creare problemi
---------------
excel 2007
Post: 1.522
Registrato il: 27/06/2011
Utente Veteran
excel 2007
OFFLINE
30/07/2022 15:09


Prova
vb
NomePDF = mioperc & "\" & miofile

Ciao
Frank







Stretta la foglia, larga la via, dite la vostra che ho detto la mia.
Excel 2007 forse anche 2013 ... 2021 ... 365 e future...
Post: 466
Registrato il: 28/05/2011
Città: MILANO
Età: 43
Utente Senior
excel 2000/2007
OFFLINE
30/07/2022 16:32

Ciao tanimon,
grazie funziona.
---------------
excel 2007
Post: 467
Registrato il: 28/05/2011
Città: MILANO
Età: 43
Utente Senior
excel 2000/2007
OFFLINE
30/07/2022 16:40

Sempre per una cartella inserita.
Questa macro è simile per formato xlsx
E' un pò diversa.
Non ho outlook per provare, quella di prima l'ho usata per thunderbird.
Per provare questa dovrebbe creare la cartella file_mail inserire il foglio xslx inviarlo e poi all'uscita lo elimina.
Puoi provarlo e qualche altro utente?

Option Explicit

'Option Private Module



Sub Mail_outlook_2()
'foglio invia_mail

ActiveSheet.Unprotect "987654"

    
    'Dim emailRng As Range, cl As Range
    'Dim sTo As String
    'Dim emailAddr  As String
    
    
    'Dim xRg1, xRg2 As Range
    Dim xRg1, xRg2 As Variant
    Dim xCell1, xCell2  As Range
    'Dim xEmailAddr As String
    Dim emailAddr1, emailAddr2  As String
    Dim xTxt1, xTxt2 As String
    
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Ur As Long '<<< aggiunto
    Dim avviso As String
    Dim wk1 As Workbook
    'Dim miofile As String
    Dim mioperc As String
    Dim filemail As String
    
    Set Source = Nothing
    On Error Resume Next
           
        
    
  Application.DisplayAlerts = False
  
  
    
 If Range("A5") = "" Then
avviso = MsgBox("non c'è niente da inviare via mail!", vbExclamation + vbOKOnly + vbDefaultButton2, "AVVISO")
 If avviso = vbOK Then Exit Sub
 'End If
 End If
 
        
 avviso = MsgBox("Gli indirizzi mail da selezionare sono nella colonna S", _
 vbInformation + vbOKOnly + vbDefaultButton2, "AVVISO!")
 'avviso = MsgBox("The email addresses to select are in column S", _
 'vbInformation + vbOKOnly + vbDefaultButton2, "INFORMATION!")


    
   '-----------------------------------------------------------------------------------------
   'destinatari / '.To
   
    On Error Resume Next
    xTxt1 = ActiveWindow.RangeSelection.Address
    xTxt1 = Foglio11.Range("S5").Address
    
                           'strTo = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           
    Set xRg1 = Application.InputBox("scegli i nomi utenti destinatari in colonna S" & Chr(13) & _
    "clicca CTRL nell'inputbox per inserire più utenti", "nomi utenti mail", xTxt1, , , , , 8)
    
    If xRg1 Is Nothing Then
    ActiveSheet.Protect "987654"
    Exit Sub
    End If
          
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.CC
    
    On Error Resume Next
    xTxt2 = ActiveWindow.RangeSelection.Address
    xTxt2 = Foglio11.Range("S5").Address
    
                           'strCC = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           'Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S", "nomi utenti mail", xTxt2, , , , , 8)
    
     Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S " & Chr(13) & _
     "clicca CTRL nell'inputbox per inserire più utenti" & Chr(13) & _
     "clicca Annulla se non vuoi inviare", "nomi utenti mail", xTxt2, , , , , 8)
    
    'If xRg2 Is Nothing Then Exit Sub ' <<< tolto se non c'è niente
    
'-----------------------------------------------------------------------------------------
   
    
      
    'Set Source = Range("A1:Q54").SpecialCells(xlCellTypeVisible) '<<< tutte righe del range
    
    Ur = Cells(Rows.Count, 3).End(xlUp).Row '<<< solo righe non vuote del range
    Set Source = Range("A2:Q" & Ur).SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    If Source Is Nothing Then
    
        'MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        MsgBox "La sorgente non è un intervallo o il foglio è protetto, correggilo e riprova.", vbOKOnly
        
        Exit Sub
    End If
    
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        ActiveWindow.DisplayGridlines = False
        Application.CutCopyMode = False
    End With

'-----------------------------------------------------------------------------------------

    'Set wk1 = ThisWorkbook
    'il percorso
    'mioperc = wk1.Path & "\"
    'miofile = Range("A2") & ".pdf"
    'NomePDF = mioperc & miofile

    filemail = "file_mail"
     
    Set wk1 = ThisWorkbook
   'il percorso
    mioperc = wk1.Path & "\" & filemail
        
    If Dir(mioperc, vbDirectory) = "" Then MkDir mioperc

    'TempFilePath = Environ$("temp") & "\"
    TempFilePath = mioperc
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    'TempFileName = "Selection of " & wb.Name
    
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    
    
   
 '-----------------------------------------------------------------------------------------

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
 '-----------------------------------------------------------------------------------------
 'destinatari / '.To
 
    For Each xCell1 In xRg1
        If xCell1.Value Like "*@*" Then
            If emailAddr1 = "" Then
                emailAddr1 = xCell1.Value
            Else
                emailAddr1 = emailAddr1 & ";" & xCell1.Value
            End If
        End If
    Next
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.To
 
 If xRg2 <> "" Then
  
     For Each xCell2 In xRg2
        If xCell2.Value Like "*@*" Then
            If emailAddr2 = "" Then
                emailAddr2 = xCell2.Value
            Else
                emailAddr2 = emailAddr2 & ";" & xCell2.Value
            End If
        End If
    Next
    
    End If
 '-----------------------------------------------------------------------------------------
  
    'emailAddr = InputBox("Enter email address.", "Which Email Address ?")
    'emailAddr = InputBox("Inserisci indirizzo email", " Quale indirizzo email?") '<<< ins. manuale
    
 '-------------------------------------------------------------------------------------------
   'With Dest
   
       ' .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
       
    'On Error Resume Next
'-------------------------------------------------------------------------------------------
    With Dest
        
        .Worksheets(1).Cells.Locked = True
        .Worksheets(1).Protect Password:="password"
        .Worksheets(1).EnableSelection = xlUnlockedCells
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        
     On Error Resume Next
 '-------------------------------------------------------------------------------------------
        
        
        With OutMail
                    
            '.to = "frank_ciccio@abcdefg.com" '<<< destinatari
            .To = emailAddr1
            .CC = emailAddr2
            .BCC = ""
            '.Subject = "This is the Subject line"
            .Subject = "ACTION - " & ActiveSheet.Range("A2")
            .Body = "ACTION - " & ActiveSheet.Range("A2")
            '.Body = "Hi there"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            '.Send   '<<< invia subito
            .Display '<<<  mostra outlook
            
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

   ' Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing
    
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    
    'ActiveSheet.Protect "987654"
    ActiveSheet.Protect Password:="987654", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=False, AllowInsertingHyperlinks:=False, AllowFiltering:=True
        
        
        
    Application.DisplayAlerts = True
    

End Sub






Sub delete_file_outlook_xlsx_2()
 
   On Error Resume Next

    Dim wk1 As Workbook
    'Dim miofile As String
    Dim mioperc As String
    Dim NomeXLSX As String
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim filemail As String
    'Dim FileExtStr As String
    'Dim FileFormatNum As Long
    
      
    Set wk1 = ThisWorkbook
    Set wb = ActiveWorkbook
   
    'il percorso
    'mioperc = wk1.Path & "\"
    
    filemail = "file_mail"
     
    'Set wk1 = ThisWorkbook
    'il percorso
    mioperc = wk1.Path & "\" & filemail
  
  
    TempFilePath = mioperc
    'TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx"
    'TempFileName = "Selection of " & wb.Name & ".xlsx"
    TempFileName = "Selection of " & wb.Name & " *.*" '<<< tutti i file
         
    'NomeXLSX = mioperc & miofile
    NomeXLSX = TempFilePath & TempFileName
         
       
Kill NomeXLSX

  End Sub






---------------
excel 2007
Post: 468
Registrato il: 28/05/2011
Città: MILANO
Età: 43
Utente Senior
excel 2000/2007
OFFLINE
30/07/2022 17:39

Ho corretto come spiegato da tanimon

TempFilePath = mioperc & "\" & filemail


Sub Mail_outlook_2()
'foglio invia_mail

ActiveSheet.Unprotect "987654"

    
    'Dim emailRng As Range, cl As Range
    'Dim sTo As String
    'Dim emailAddr  As String
    
    
    'Dim xRg1, xRg2 As Range
    Dim xRg1, xRg2 As Variant
    Dim xCell1, xCell2  As Range
    'Dim xEmailAddr As String
    Dim emailAddr1, emailAddr2  As String
    Dim xTxt1, xTxt2 As String
    
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Ur As Long '<<< aggiunto
    Dim avviso As String
    Dim wk1 As Workbook
    'Dim miofile As String
    Dim mioperc As String
    Dim filemail As String
    
    Set Source = Nothing
    On Error Resume Next
           
        
    
  Application.DisplayAlerts = False
  
  
    
 If Range("A5") = "" Then
avviso = MsgBox("non c'è niente da inviare via mail!", vbExclamation + vbOKOnly + vbDefaultButton2, "AVVISO")
 If avviso = vbOK Then Exit Sub
 'End If
 End If
 
        
 avviso = MsgBox("Gli indirizzi mail da selezionare sono nella colonna S", _
 vbInformation + vbOKOnly + vbDefaultButton2, "AVVISO!")
 'avviso = MsgBox("The email addresses to select are in column S", _
 'vbInformation + vbOKOnly + vbDefaultButton2, "INFORMATION!")


    
   '-----------------------------------------------------------------------------------------
   'destinatari / '.To
   
    On Error Resume Next
    xTxt1 = ActiveWindow.RangeSelection.Address
    xTxt1 = Foglio11.Range("S5").Address
    
                           'strTo = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           
    Set xRg1 = Application.InputBox("scegli i nomi utenti destinatari in colonna S" & Chr(13) & _
    "clicca CTRL nell'inputbox per inserire più utenti", "nomi utenti mail", xTxt1, , , , , 8)
    
    If xRg1 Is Nothing Then
    ActiveSheet.Protect "987654"
    Exit Sub
    End If
          
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.CC
    
    On Error Resume Next
    xTxt2 = ActiveWindow.RangeSelection.Address
    xTxt2 = Foglio11.Range("S5").Address
    
                           'strCC = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           'Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S", "nomi utenti mail", xTxt2, , , , , 8)
    
     Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S " & Chr(13) & _
     "clicca CTRL nell'inputbox per inserire più utenti" & Chr(13) & _
     "clicca Annulla se non vuoi inviare", "nomi utenti mail", xTxt2, , , , , 8)
    
    'If xRg2 Is Nothing Then Exit Sub ' <<< tolto se non c'è niente
    
'-----------------------------------------------------------------------------------------
   
    
      
    'Set Source = Range("A1:Q54").SpecialCells(xlCellTypeVisible) '<<< tutte righe del range
    
    Ur = Cells(Rows.Count, 3).End(xlUp).Row '<<< solo righe non vuote del range
    Set Source = Range("A2:Q" & Ur).SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    If Source Is Nothing Then
    
        'MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        MsgBox "La sorgente non è un intervallo o il foglio è protetto, correggilo e riprova.", vbOKOnly
        
        Exit Sub
    End If
    
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        ActiveWindow.DisplayGridlines = False
        Application.CutCopyMode = False
    End With

 '-----------------------------------------------------------------------------------------
 
    filemail = "file_mail"
      
    Set wk1 = ThisWorkbook
   'il percorso
    mioperc = wk1.Path & "\" & filemail
         
    If Dir(mioperc, vbDirectory) = "" Then MkDir mioperc

    'TempFilePath = Environ$("temp") & "\"
    TempFilePath = mioperc & "\" & filemail
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    'TempFileName = "Selection of " & wb.Name
    
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
        
    
   
 '-----------------------------------------------------------------------------------------

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
 '-----------------------------------------------------------------------------------------
 'destinatari / '.To
 
    For Each xCell1 In xRg1
        If xCell1.Value Like "*@*" Then
            If emailAddr1 = "" Then
                emailAddr1 = xCell1.Value
            Else
                emailAddr1 = emailAddr1 & ";" & xCell1.Value
            End If
        End If
    Next
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.To
 
 If xRg2 <> "" Then
  
     For Each xCell2 In xRg2
        If xCell2.Value Like "*@*" Then
            If emailAddr2 = "" Then
                emailAddr2 = xCell2.Value
            Else
                emailAddr2 = emailAddr2 & ";" & xCell2.Value
            End If
        End If
    Next
    
    End If
 '-----------------------------------------------------------------------------------------
  
    'emailAddr = InputBox("Enter email address.", "Which Email Address ?")
    'emailAddr = InputBox("Inserisci indirizzo email", " Quale indirizzo email?") '<<< ins. manuale
    
 '-------------------------------------------------------------------------------------------
   'With Dest
   
       ' .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
       
    'On Error Resume Next
'-------------------------------------------------------------------------------------------
    With Dest
        
        .Worksheets(1).Cells.Locked = True
        .Worksheets(1).Protect password:="password"
        .Worksheets(1).EnableSelection = xlUnlockedCells
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        
     On Error Resume Next
 '-------------------------------------------------------------------------------------------
        
        
        With OutMail
                    
            '.to = "frank_ciccio@abcdefg.com" '<<< destinatari
            .To = emailAddr1
            .CC = emailAddr2
            .BCC = ""
            '.Subject = "This is the Subject line"
            .Subject = "ACTION - " & ActiveSheet.Range("A2")
            .Body = "ACTION - " & ActiveSheet.Range("A2")
            '.Body = "Hi there"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            '.Send   '<<< invia subito
            .Display '<<<  mostra outlook
            
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

   ' Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing
    
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    
    'ActiveSheet.Protect "987654"
    ActiveSheet.Protect password:="987654", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=False, AllowInsertingHyperlinks:=False, AllowFiltering:=True
        
        
        
    Application.DisplayAlerts = True
    

End Sub






Sub delete_file_outlook_xlsx_2()
 
   On Error Resume Next

    Dim wk1 As Workbook
    'Dim miofile As String
    Dim mioperc As String
    Dim NomeXLSX As String
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim filemail As String
    'Dim FileExtStr As String
    'Dim FileFormatNum As Long
    
      
   
    Set wk1 = ThisWorkbook
    Set wb = ActiveWorkbook
   
    filemail = "file_mail"
   
   'il percorso
    'mioperc = wk1.Path & "\"
    mioperc = wk1.Path & "\" & filemail
    
    'TempFilePath = mioperc
    TempFilePath = mioperc & "\" & filemail
    'TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx"
    'TempFileName = "Selection of " & wb.Name & ".xlsx"
    TempFileName = "Selection of " & wb.Name & " *.*" '<<< tutti i file
         
    'NomeXLSX = mioperc & miofile
    NomeXLSX = TempFilePath & TempFileName
    
       
Kill NomeXLSX

  End Sub


Per provare questa dovrebbe creare la cartella file_mail inserire il foglio xslx inviarlo e poi all'uscita lo elimina.
Non ho outlook, qualcuno può farlo?
[Modificato da john_cash 30/07/2022 17:51]
---------------
excel 2007
Post: 469
Registrato il: 28/05/2011
Città: MILANO
Età: 43
Utente Senior
excel 2000/2007
OFFLINE
30/07/2022 19:48

La modifica funziona, crea la cartella con dentro i file
H'ho provata con thunder ma non so se è anche con outlook.
Nel nome del file creato c'è anche il nome della cartella creata

file_mail-Selection of Action List_C_v_P.xlsb 30-lug-22 19-44-00

non dovrebbe farlo
---------------
excel 2007
Vota:
Amministra Discussione: | Chiudi | Sposta | Cancella | Modifica | Notifica email Pagina precedente | 1 | Pagina successiva
Nuova Discussione
 | 
Rispondi
Cerca nel forum
Tag discussione
Discussioni Simili   [vedi tutte]
Feed | Forum | Bacheca | Album | Utenti | Cerca | Login | Registrati | Amministra
Tutti gli orari sono GMT+01:00. Adesso sono le 10:55. Versione: Stampabile | Mobile | Regolamento | Privacy
FreeForumZone [v.6.1] - Copyright © 2000-2024 FFZ srl - www.freeforumzone.com