title image


Smiley Wie kann ich erreichen das nur ein Datum akzeptiert wird
Ich benutze ein Makro das Dokument in Outlook auf einen Termin legt.

Jedoch kann man bei der Eingabe in das Feld "Wiedervorlage" alles eintragen.

Es soll jedoch nur ein Datum akzeptiert werden. Wie kann ich das machen.



Vielen Dank im voraus!



Hier das Makro:



Sub Wiedervor()

'

' Wiedervor Makro

' Makro erstellt am 25.11.2005

'



Selection.GoTo What:=wdGoToBookmark, Name:="Wiedervorlage"

Selection.Find.ClearFormatting

With Selection.Find

.Text = ""

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.MoveUp Unit:=wdLine, Count:=1

Selection.MoveDown Unit:=wdLine, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=1

Selection.Delete Unit:=wdCharacter, Count:=1

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = ""

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.GoTo What:=wdGoToBookmark, Name:="Wiedervorlage"

Selection.Find.ClearFormatting

With Selection.Find

.Text = ""

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.MoveLeft Unit:=wdCharacter, Count:=1

Selection.MoveRight Unit:=wdCharacter, Count:=1

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _

"FILLIN ""Bitte geben Sie das Wiedervorlagedatum ein:""", _

PreserveFormatting:=True

Selection.GoTo What:=wdGoToBookmark, Name:="Wiedervorlage"

Selection.Find.ClearFormatting

With Selection.Find

.Text = ""

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.MoveDown Unit:=wdLine, Count:=3

Selection.MoveRight Unit:=wdCharacter, Count:=1



Const TITLE = "Wiedervorlage"

Dim strFullname As String

Dim objOlApp ' As Object / Outlook.Application

Dim objAppointment ' As Object / Outlook.AppointmentItem

Dim objDoc As Document

Dim objFf As FormField

Dim strStart As String

On Error Resume Next

Set objDoc = ActiveDocument

With objDoc

Set objFf = .FormFields("Wiedervorlage")

strStart = Trim(objFf.Result)

If strStart = "" Then

MsgBox "Wiedervorlagedatum fehlt!", vbExclamation, TITLE

objFf.Range.Select

Exit Sub

End If

If CDate(strStart) < Now Then

MsgBox "Wiedervorlagedatum liegt in der Vergangenheit!", vbExclamation, TITLE

objFf.Range.Select

Exit Sub

End If

If .Path = "" Then

MsgBox "Dokument " & Chr(34) & .Name & Chr(34) & " ist noch nicht gespeichert!"

With Dialogs(wdDialogFileSaveAs)

If .Show = 0 Then Exit Sub

End With

End If

strFullname = .FullName

End With



Set objOlApp = GetObject(, "Outlook.Application")

If objOlApp Is Nothing Then Set objOlApp = CreateObject("Outlook.Application")

Set objAppointment = objOlApp.CreateItem(1)

With objAppointment

.Start = CDate(strStart) 'Das aktuelle Datum wird vorgeschlagen

If DatePart("h", .Start) = 0 And DatePart("n", .Start) = 0 Then .AllDayEvent = True ' ganztägig, bei Bedarf, bzw. Aktuelle Uhrzeit

.Subject = objDoc.Name

.Categories = objDoc.BuiltInDocumentProperties(18)

.ReminderSet = True

.ReminderMinutesBeforeStart = 15 ' Erinnerung in wieviel Minuten

.BusyStatus = 0 ' Frei

.Attachments.Add strFullname, 4, , objDoc.Name ' 4 = als Verknüpfung

.Save

.Display ' bei Bedarf

End With

Set objOlApp = Nothing



End Sub







geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: