VBA e-mail versturen via een Windows Small Business Server Remote Web Workplace

[HWV]

Beste,

Is het mogelijk om vanuit een excel VBA een e-mail te versturen via een Windows Small Business Server Remote Web Workplace. Ik maak nu gebruik van onderstaande code, maar geen rekening gehouden dat de buitendienst via de Windows Small Business Server Remote Web Workplace werken.

https://222.444.252.104/remote (geen originele code)

Sub Mail_Every_Worksheet()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
'Working in 97-2007
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String

Dim Klant
Set Klant = Worksheets("Orderbon").Range("G6")

Dim Plaatsnaam
Set Plaatsnaam = Worksheets("Orderbon").Range("G7")

Dim DebNr
Set DebNr = Worksheets("Orderbon").Range("G5")

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

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

    For Each sh In ThisWorkbook.Worksheets
        If sh.Range("P6").Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = "" & Klant & " " & Plaatsnaam & " " _
                         & DebNr & " " _
                         & Format(Now, "dd-mmm-yy h mm")

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, _
                        FileFormat:=FileFormatNum
                On Error Resume Next
                .SendMail sh.Range("P6").Value, _
                          "" & Klant & " " & Plaatsnaam & " " _
                         & DebNr & " " _
                         & Format(Now, "dd-mmm-yy h mm")
                On Error GoTo 0
                .Close SaveChanges:=False
            End With

        '    Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
        Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

De vraag is dit mogelijk, en zo ja hoe kan zoiets verwerkt worden in mijn code.

Alvast bedankt voor het meedenken

Groet HWV

 

[snb]

Begin met wieden:

Sub Mail_Every_Worksheet()
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  end with

  x=val(Application.version)
  For Each sh In ThisWorkbook.sheets
    If instr(sh.[P6],"@")>0 Then
      sh.Copy
      With ActiveWorkbook
        .saveas C:\tijdelijk & ".xls" & IIf(x<12,"","m") ,IIf (x < 12,-4143,52) 
        .SendMail sh.Range("P6").Value, C:\tijdelijk & ".xls" & IIf(x<12,"","m")
        .Close False
      End With
    End If
  Next 

  Kill C:\tijdelijk & ".xls*"

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

 

[HWV]

Syntaxisfout

Beste SNB,

Bedankt voor de input

Ik krijg helaas zodra ik mijn code plaats in mijn module1 de volgende regels in het rood met de volgende melding :
Compileerfout: Syntaxisfout

Sub Mail_Every_Worksheet()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

x = Val(Application.Version)
For Each sh In ThisWorkbook.Sheets
If InStr(sh.[P6], "@") > 0 Then
sh.Copy
With ActiveWorkbook
.saveas C:\tijdelijk & ".xls" & IIf(x<12,"","m") ,IIf (x < 12,-4143,52)
.SendMail sh.Range("P6").Value, C:\tijdelijk & ".xls" & IIf(x<12,"","m")
.Close False
End With
End If
Next

Kill C:\tijdelijk & ".xls*"

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub


Groet HWV

 

[Warme bakkertje]

Sub Mail_Every_Worksheet()
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

x = Val(Application.Version)
For Each sh In ThisWorkbook.Sheets
    If InStr(sh.[P6], "@") > 0 Then
    sh.Copy
        With ActiveWorkbook
            .SaveAs "C:\tijdelijk" & ".xls" & IIf(x < 12, "", "m"), IIf(x < 12, -4143, 52)
            .SendMail sh.Range("P6").Value, "C:\tijdelijk" & ".xls" & IIf(x < 12, "", "m")
            .Close False
        End With
    End If
Next

Kill "C:\tijdelijk" & ".xls*"

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[HWV]

Gelukt

Beste SNB en Rudi,

Bedankt voor de input, dit heeft als resultaat opgeleverd dat ik nu het bestand opslaat op de C: en dat hij daarvandaan de e-mail gaat zenden.

Zodra er iemand binnen is met de laptop kan ik het testen.

Moet de Windows Small Business Server Remote Web Workplace open staan, want daar moet ik op inloggen met wachtwoord en loginnaam.

Ik had een bestandsnaam samengesteld vanuit verschillende cellen, is dit nu ook nog mogelijk. Ik heb het getracht met

P:\Bestellijsten\Bestellijsten\" & .[E7] & " " & .[F9] & " " & .[E6] & Format(Date, " dd-mm-yyyy") & ".xls

Groet HWV

 

[snb]

Het heeft totaal geen zin moeilijk te doen met een bestandsnaam als je het bestand na verzending toch weer verwijdert.

Van seniormembers verwacht ik dat ze code-tags gebruiken als ze VBA-code plaatsen.

Met 1 minuut uitzoekwerk had je de reden voor de rode markering zelf kunnen vinden (word je wijzer van dan van vragen stellen).

De verzending van emails uit Excel gaat via het de op het systeem geïnstalleerde emailfaiciliteit; dat is geen webmail.
Als je gebruik wil maken van webmail wordt het een geheel ander verhaal.

 

[HWV]

Antwoord op uw vragen

BesteSNB,

a)
Het is wel degelijk van belang om de bestands naam goed te hebben ivm dat de ontvanger wel moet weten wat de inhoud van de e-mail inhoud. Doormiddel van de naam en andere speerpunten in de naam te zetten weet de ontvanger in één ogenblik wat het inhoud.
Zonder de e-mail te openen, en tevens makkelijk terug te vinden.

b)
Ben ik inderdaad vergeten te plaatsen, normaal gesproken probeer ik daar wel rekening mee te houden.

c)
Ik ben er inderdaad mee bezig geweest en kwam er niet gelijk mee uit. Ik was er wel weer mee bezig toen Rudi met de oplossing is gekomen.

Het is niet mijn bedoeling geweest om mensen onnodig met mijn vragen te bestoken als het niet noodzakelijk zou zijn voor mij.

Als het over is gekomen dat dit wel zo is dan "Sorry"

Ik heb net de test gedaan maar helaas.
De situatie is nu als volgt
- Via de terminal server vraag ik het bestand op.
- Hij geef dan de melding dat hij C: niet kan vinden, dus heb ik hem op P: gezet die hij wel ziet, hij maak een bestand aan en verzend deze en verwijderd weer het bestand
Nu gebruiken wij via de terminal service geen outlook maar de Windows Small Business Server Remote Web Workplace maar nu zet hij de e-mail in de outlook.

Hoe kan ik hem sturen naar de Windows Small Business Server Remote Web Workplace


Groet HWV

 

[snb]

Kijk ook eens in de hulpfunktie van de VBEditor bij sendmail.

Sub Mail_Every_Worksheet()
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  x = Val(Application.Version)
  c0="P:\Bestellijsten\" & [E7] & " " & [F9] & " " & [E6] & Format(Date, " dd-mm-yyyy") & ".xls" & IIf(x < 12, "", "m")
  For Each sh In ThisWorkbook.Sheets
    If InStr(sh.[P6], "@") > 0 Then
      sh.Copy
      With ActiveWorkbook
        .SaveAs c0, IIf(x < 12, -4143, 52)
        .SendMail sh.[P6]
        .Close False
      End With
    End If
  Next
  Kill c0

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

 

[HWV]

nog niet

Beste,

Ik heb de code geprobeerd maar kreeg de zelfde fout als eerder in deze topic.
Het rode veranderd in de code, en de code was weer normaal van kleur.

Sub Mail_Every_Worksheet()
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  x = Val(Application.Version)
  For Each sh In ThisWorkbook.Sheets
    If InStr(sh.[P6], "@") > 0 Then
      sh.Copy
      With ActiveWorkbook
        .SaveAs [COLOR="Red"]"[/COLOR]P:\Bestellijsten\" & .[E7] & " " & .[F9] & " " & .[E6] & Format(Date, " dd-mm-yyyy") & ".xls" & IIf(x < 12, "", "m"), IIf(x < 12, -4143, 52)
        .SendMail sh.Range("P6").Value
        .Close False
      End With
    End If
  Next

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Helaas kijg ik een melding:

Fout 438 tijdens uitvoering
Deze eigenschap of methode wordt niet ondersteund door dit object.

de foutmelding geef hij aan op onderstaande regel

.SaveAs "P:\Bestellijsten\" & .[E7] & " " & .[F9] & " " & .[E6] & Format(Date, " dd-mm-yyyy") & ".xls" & IIf(x < 12, "", "m"), IIf(x < 12, -4143, 52)

Ik heb de code nagelopen of ik de fout eruit kan halen of dat ik iets verkeerd doet.
maar het laatste stukje

 & IIf(x < 12, "", "m"), IIf(x < 12, -4143, 52)

snap ik nog niet wat hiermee bedoeld wordt

Groet HWV

 

[HWV]

Krijg het niet voor elkaar

Beste ,

Met uw code krijg ik nog steeds een foutmelding
:

Sub Mail_Every_Worksheet()
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  x = Val(Application.Version)
  c0 = "C:\Documents and Settings\hverschoor\Desktop\test formulier\" & .[E7] & " " & .[F9] & " " & .[E6] & Format(Date, " dd-mm-yyyy") & ".xls" & IIf(x < 12, "", "m")
  For Each sh In ThisWorkbook.Sheets
    If InStr(sh.[P6], "@") > 0 Then
      sh.Copy
      With ActiveWorkbook
        .SaveAs c0, IIf(x < 12, -4143, 52)
        .SendMail sh.[P6]
        .Close False
      End With
    End If
  Next
  Kill c0

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Hier krijg ik een melding op :
Complimeerfout:
ongeldige of niet gekwalificeerde verwijzing

ik heb de code aangepast, wel niet het geen wat ik voor ogen had maar nu kan ik wel de naam in het bestand meesturen zonder de foutmelding in de naam.
Ik kan hem nu verzenden met Outlook. Maar hoe krijg ik het vol elkaar om het via Windows Small Business Server Remote Web Workplace te versturen.

moet ik geen IP adres invullen met gebruikersnaam en wachtwoord.?

Sub Mail_Every_Worksheet()

Dim Naam
Set Naam = Worksheets("MailTest").Range("D10")

Dim Plaats
Set Plaats = Worksheets("MailTest").Range("F12")

Dim Debnummer
Set Debnummer = Worksheets("MailTest").Range("D9")

Dim Formulier
Set Formulier = Worksheets("MailTest").Range("F3")


  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  x = Val(Application.Version)
  For Each sh In ThisWorkbook.Sheets
    If InStr(sh.[P6], "@") > 0 Then
      sh.Copy
      With ActiveWorkbook
        .SaveAs "C:\Documents and Settings\hverschoor\Desktop\test formulier\" & Naam & " - " & Plaats & " - " & Debnummer & " - " & Format(Date, " dd-mm-yyyy") & " - " & Formulier & ".xls" & IIf(x < 12, "", "m"), IIf(x < 12, -4143, 52)
        .SendMail sh.Range("P6").Value
        .Close True
      End With
    End If
  Next

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Ik hoor graag van u

groet HWV