Extern programma starten met SHELL

Status
Niet open voor verdere reacties.
S

Schipper1994

Gebruiker
Lid geworden
10 mrt 2021
Berichten
158
ik start via een VBA form automatisch met de SHELL functie mijn OUTLOOK

Dit doe ik omdat ik al gemerkt heb dat als mijn outlook niet open staat, mijn mails niet versturen. die blijven dan in het postvak uit zitten tot ik een keer outlook opstart.

Nu bots ik tegen het volgende..
als ik 3 of 4 of maakt niet uit hoeveel mailtjes verstuur vanuit mijn form, staat outlook 4keer open.

kan je een if functie maken dat outlook opstart als het nog niet opgestart is en als die al wel op gestart is, dat hij die shell functie dan niet uitvoert?
 
Je kan in VBA direct een Outlook object maken.
Het starten van Outlook via een Shell opdracht is overkill.
 
Code: 
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim sbody As String

Code: 
Dim Handtekening As String
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.createitem(0)
    Set xaccount = xOutlookObj.Session.accounts.Item(1)
    Set asht = Worksheets("mijnsheet")
    Dim bestand As String
    bestand = xSht.Cells(1, 3)

staat hier dan iets in verkeerd ofzo?

Hij start outlook wel op zoals het hoort. het werkt dus wel MAAR hij verzend het niet zolang ik niet handmatig een keer outlook opstart nadien.
 
Daar mist e.e.a. aan code en er staat geen Shell opdracht in.
Geen idee dus wat je daar allemaal doet.
 
ik heb nu dit (ik moest eventjes nog alles eruithalen voor privacy)

Code: 
Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim sbody As String


 
Set xSht = Worksheets("sjabloon")
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

    With xFileDlg
       .InitialFileName = Sheets("blad1").Range("b2")
    End With
    

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If

xFolder = xFolder + "\" & xSht.Cells(20, 4) & " " & xSht.Cells(23, 9) & ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & "Bestaat al." & vbCrLf & vbCrLf & "Wilt u deze overschrijven?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "niet opgeslagen." _
                    & vbCrLf & vbCrLf & "Druk OK om af te sluiten", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
Dim xaccount As Object


If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
     
   
    
    
    'Create Outlook email
    Dim i As Integer


    'Shell ("OUTLOOK")   'deze mag dus weg blijkbaar

    Dim Handtekening As String
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.createitem(0)
    Set xaccount = xOutlookObj.Session.accounts.Item(1)
    Set asht = Worksheets("blad2")
    Dim bestand As String
    bestand = xSht.Cells(1, 3)

    

    
    
    With xEmailObj
    Set .Sendusingaccount = xaccount
        .display
        Handtekening = .HTMLBody
        .To = xSht.Cells(12, 3)
        .CC = xSht.Cells(11, 3)
        .HTMLBody = ****verwijderd voor privacy****
        .Subject = xSht.Cells(20, 4) & " " & xSht.Cells(23, 9)
        .Attachments.Add xFolder
            
            If Not Dir(bestand) = vbNullString Then
        .Attachments.Add bestand
    Else
                MsgBox ("Kan de locatie: " & bestand & " niet vinden!")
    End If
        If DisplayEmail = False Then
    End If
    End With
 
  
Else
  MsgBox "niet blanco"
  Exit Sub
End If
End Sub
 
Je hebt dan niet Outlook open staan maar 4 email berichten.
Dat klopt omdat je niet .Send gebruikt
 
ik wil ze zelf nog verzenden. dus ik druk op zenden zelf.

maar daarna blijft de mail in postvak uit staan omdat het e-mailprogramma (outlook) zelf niet open heeft gestaan.
enkel maar een email bericht.
Kan ik dus outlook zelf ook laten opstarten is de vraag zodat deze mails WEL verzenden.
 
Gebruik dan .Save in plaats van .Send.
Dan komen ze in de Concepten map te staan.
 
ook niet de bedoeling.
ik wil dat de mail openspringt. dat ik eventueel nog iets kan aanpassen en dan dat ik op verzenden druk.
maar daarvoor moet OUTLOOK zelf ook openstaan. anders verzend en ontvangt hij zijn mails niet.
 
Dan zo.
Code: 
 On Error Resume Next
  With GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then Application.ActivateMicrosoftApp xlMicrosoftMail
  End With
 
HSV dat is het ook niet.
Hij opent outlook inderdaad maar hij opent het ook als het al geopend is. dus dan runt het programma 2x
 
Laatst bewerkt:
Dan heb je de code niet goed in je eigen code geplaatst.
 
waar zou die dan hier ergens tussen moeten?
Code: 
Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim sbody As String


 
Set xSht = Worksheets("sjabloon")
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

    With xFileDlg
       .InitialFileName = Sheets("blad1").Range("b2")
    End With
    

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If

xFolder = xFolder + "\" & xSht.Cells(20, 4) & " " & xSht.Cells(23, 9) & ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & "Bestaat al." & vbCrLf & vbCrLf & "Wilt u deze overschrijven?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "niet opgeslagen." _
                    & vbCrLf & vbCrLf & "Druk OK om af te sluiten", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
Dim xaccount As Object


If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
     
   
    
    
    'Create Outlook email
    Dim i As Integer


    'Shell ("OUTLOOK")   'deze mag dus weg blijkbaar

    Dim Handtekening As String
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.createitem(0)
    Set xaccount = xOutlookObj.Session.accounts.Item(1)
    Set asht = Worksheets("blad2")
    Dim bestand As String
    bestand = xSht.Cells(1, 3)

    

    
    
    With xEmailObj
    Set .Sendusingaccount = xaccount
        .display
        Handtekening = .HTMLBody
        .To = xSht.Cells(12, 3)
        .CC = xSht.Cells(11, 3)
        .HTMLBody = ****verwijderd voor privacy****
        .Subject = xSht.Cells(20, 4) & " " & xSht.Cells(23, 9)
        .Attachments.Add xFolder
            
            If Not Dir(bestand) = vbNullString Then
        .Attachments.Add bestand
    Else
                MsgBox ("Kan de locatie: " & bestand & " niet vinden!")
    End If
        If DisplayEmail = False Then
    End If
    End With
 
  
Else
  MsgBox "niet blanco"
  Exit Sub
End If
End Sub
 
Zelf implementeren leer je veel van.
Code: 
Sub hsv()
 On Error Resume Next
  With GetObject(, "Outlook.Application")
   If Err.Number <> 0 Then Application.ActivateMicrosoftApp xlMlicrosoftMail
        On Error GoTo 0
      With CreateObject("Outlook.Application").createitem(0)
        .to = "hsv"
        .display
      End With
  End With
End Sub
 
Laatst bewerkt:
ksnap er de balle van.. ik probeer het overal maar lukt me niet..
makt ni uit.. ik doe het wel zonder..
 
Ik vind het prima.
Je geeft wel erg snel op; je bent amper een kwartier bezig geweest.
Waarschijnlijk stond er een 'End if' teveel in, .. code aangepast maar niet getest.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan