Hallo Zusammen und erst mal ein frohes Neues Jahr!
Ich möchte ein Word-Formular per Outlook versenden. Mein bestehendes Makro --> siehe unten. Jetzt habe ich zwei Probleme.
1. Das Makro muss erst den Formularschutz aufheben und ich weiss nicht wie ich diesen Code in das bestehende Makro integriere.
Private Sub CommandButton1_Click()
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
ActiveDocument.Unprotect
Else
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, noreset:=True
End If
End Sub
2. Ich möchte das das ausgefüllte Formular automatisch auf dem Desktop gespeichert wird und der User gar nicht erst selber das Formular abspeichern kann.
Vielen Dank für Eure Hilfe!
Private Sub CommandButtonMail_Click()
#Const EARLYBINDING = False 'oder True
#If EARLYBINDING Then
'Wird mit Earlybinding gearbeitet muss der Verweis auf
'Microsoft Outlook 11.0 Object Library aktiviert werden.
Dim olApp As Outlook.Application
Dim olEmailItem As Outlook.MailItem
Dim olRecipients As Outlook.Recipient
'Neue Outlook-Instanz erzeugen
Set olApp = New Outlook.Application
#Else
Const olMailItem As Integer = 0
Const olCC As Integer = 2
Const olImportanceHigh As Integer = 2
Dim olApp As Object
Dim olEmailItem As Object
Dim olRecipients As Object
'Neue Outlook-Instanz erzeugen
Set olApp = CreateObject("Outlook.Application")
#End If
Dim strMSG As String
Dim strAttachment As String
Dim intRet As Single
Const c_Title As String = "Datei senden"
'Prüfen ob aktuelles Dokument gespeichert ist und ggf. speichern
Dim bSaved As Boolean: bSaved = True
Do While ActiveDocument.Saved = False Or ActiveDocument.Path = ""
If ActiveDocument.Path = "" Then ' Neues Dokument, noch nicht gespeichert
bSaved = False ' Nicht gespeichert
MsgBox "Das Dokument wurde noch nicht gespeichert." & vbCrLf & "Bitte erst speichern.", _
vbInformation, c_Title
With Dialogs(wdDialogFileSaveAs) ' Speichern-Dialog aufrufen
intRet = .Show
End With
If intRet = -1 And ActiveDocument.Saved = True Then ' Über 'Speichern' gespeichert
bSaved = ActiveDocument.Saved
ElseIf intRet = 0 Or ActiveDocument.Path = "" Then ' Abbruch gewählt
MsgBox "Das Dokument wurde nicht gespeichert, das Makro wird beendet.", vbCritical, c_Title
GoTo end_Sub
End If
ElseIf ActiveDocument.Saved = False Then
intRet = MsgBox("Das aktuelle Dokument muss speichern werden" & vbCrLf & _
"Jetzt speichern?", vbInformation + vbYesNo, c_Title)
If intRet = vbYes Then
ActiveDocument.Save
ElseIf intRet = vbNo Then
MsgBox "Das Dokument wurde nicht gespeichert, das Makro wird beendet.", vbCritical, c_Title
GoTo end_Sub
End If
End If
Loop
strAttachment = ActiveDocument.FullName
'Prüfen ob eine neue Instanz erzeugt werden konnte
If Not (olApp Is Nothing) Then
With olApp
'Neues MailItem-Objekt erstellen
Set olEmailItem = olApp.CreateItem(olMailItem)
'Mail mit Daten füllen
With olEmailItem
On Error GoTo err_Sub
' Empfänger festlegen
.To = mueller@gmx.de
' Betreff festlegen
.Subject = "Bestellformular"
strMSG = "Guten Tag," & vbCrLf & vbCrLf & _
"hiermit bitten wir um die Bearbeitung der folgenden Bestellung" & vbCrLf & vbCrLf & _
"Im Voraus recht herzlichen Dank für Ihre Mühe!"
' Wichtigkeit festlegen
.Importance = olImportanceHigh
' Textkörper um Namen des Anhangs ergänzen
.Body = strMSG & vbCrLf & "<<< " & strAttachment & " >>>"
' Anhang anf ügen
.Attachments.Add strAttachment
' Mail im Postausgang speichern
.Save
' Mail versenden
.Send
MsgBox "Das Formular wurde versendet.", vbInformation, c_Title
err_Sub:
If Err.Number > 0 Then
MsgBox "Es ist ein Fehler beim Zugriff auf Outlook aufgetreten.", vbCritical, c_Title
GoTo end_Sub
End If
End With
.Quit
End With
Else
MsgBox "Neue Instanz von Outlook konnte nicht erzeugt werden."
End If
end_Sub:
'Objektvariablen freigeben
Set olRecipients = Nothing
Set olEmailItem = Nothing
Set olApp = Nothing
End Sub
|