VBA voor permanent opslaan

[resmatrix]

goedemorgen

ik gebruiik een code om een email te verzenden dt werkt allemaal prima

In deze code staat dat het bestand tijdelijk moet worden opgeslagen dat zit in deze code:

TempFilePath = Environ$("temp") & "\"
    TempFileName = "File" & " " & Range("F3").Value & " " & Format(Now, "dd-mmm-yy") & " " & Range("E55").Value & " " & Range("E57").Value

ik zou graag willen dat dit bestand ook permanent werd opgeslagen op de C:\

nu kan het voorkomen dat het bestand meerdere malen per dag zal worden opgeslagen. die bestanden dienen echter niet overschreven te worden

Ik heb helaas geen idee hoe ik dit voor elkaar kan krijgen

 

[spaarie]

ik zou graag willen dat dit bestand ook permanent werd opgeslagen op de C:\

Ik zou 'ook' hierin weg laten. Je kan het permanente bestand gebruiken om te mailen. Mits de temp wordt 'gekilled' loopt je temp map ook nog eens vol.

Plaats de gehele code eens.

 

[OctaFish]

nu kan het voorkomen dat het bestand meerdere malen per dag zal worden opgeslagen. die bestanden dienen echter niet overschreven te worden.

Als de inhoud in E57 niet verandert, zal je bestand altijd overschreven worden. En wat denk je dat NOW voor functie heeft in jouw Format? Al druk je 600 keer op de knop, vandaag zal de code er echt niet mee veranderen. Als je de datum wilt, kun je dus net zo goed DATE gebruiken. Wil je een tijd in je code meenemen, dan is Now een stuk logischer:

Format(Date, "yymmdd") & "-" & Format(Now, "hhmmss") & " " & Range("E55").Value & " " & Range("E57").Value[B]

[/B]
Om maar eens wat te noemen.

 

[resmatrix]

dit is de complete code

heb al wel de uren en minute toegevoegd dank daarvoor

Sub sendmail()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    With Destwb
        If Val(Application.Version) < 12 Then
            
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "New IFA Request" & " " & Range("F3").Value & " " & Format(Date, "yymmdd") & "-" & Format(Now, "hhmmss") & " " & Range("E55").Value & " " & Range("E57").Value
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = Range("BF16").Value
            .CC = Range("BF18").Value
            .BCC = ""
            .Subject = Range("E54").Value & " " & "for" & " " & Range("F3").Value & " " & Range("E58").Value
            .Body = ""& vbNewLine & _
            vbNewLine & _
            "" & Range("E54").Value & vbNewLine & _
            "" & vbNewLine & _
            vbNewLine & _
            "" & vbNewLine & _
            vbNewLine & _
            vbNewLine & _
            "& vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            "" & vbNewLine & _
            vbNewLine & _
            vbNewLine


            .Attachments.Add Destwb.FullName

            .Send
        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
End Sub

 

[OctaFish]

Wat is de bedoeling van die ongelooflijk grote hoeveelheid lege regels waar je dan ook nog eens een keer helemaal niets ( & "" & ) inzet? Je bewerkt de mail verder niet, (.Send) dus what's the point?

 

[spaarie]

@OctaFish: Kunnen we ook zeggen over deze, denk je niet?

Format(Date, "yymmdd") & "-" & Format(Now, "hhmmss")

oftewel

Format(Now, "yymmdd-hhmmss")

@resmatrix: Probeer dit eens... pas wel de naam van tabblad aan en de path waar je het bestand wilt opslaan.

Sub Spaarie()
    Application.DisplayAlerts = False
    With Sheets("NAAM VAN JE SHEET")
        p = "C:\Users\Mapje" 'plaats de locatie van je bestanden
        f = "New IFA Request " & .Range("F3").Value & Format(Now, "yymmdd-hhmmss") & " " & .Range("E55").Value & " " & .Range("E57").Value & ".xlsx" 'of .xls ligt aan je versie
        .Copy
    End With
    ActiveWorkbook.SaveAs p & f
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = [BF16]
        .Subject = [BF18]
        .Attatchement.Add = p & f
        .Body = Chr(13) & Chr(13) & "" & [E54]
        .Display 'of .Send
    End With
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True
End Sub

 

[resmatrix]

Dank je spaarie

ik heb eea aangepast en werkt perfect

@ Octafish: Dat zal ik wel fout gedaan hebben maar daar staat normal de body en ondertekening van de mail, die kan ik helaas niet delen vandaar dat er nu veel lege regels staan