Guten Morgen,
Wow! Super! Danke, das hilft mir sehr viel weiter. Ich hätte da noch einige andere Makros dessen Erklärung benötigt würde :) Beim Sub InitTobit gehe ich davon aus das damit das Programm gestartet wird. Tobit Infocenter ist ein Kommunikations/Mailprogramm
Hoffe das ist nicht zuviel verlangt
Liebe Grüße
Dim data As DataObject
Private Sub ToClipboard()
' Tastenkombination: Strg+J
Set data = New DataObject
Dim Text As String
nAreas = Selection.Areas.Count
For nArea = 1 To nAreas 'Schleife durch alle markierten Bereiche
nRows = Selection.Rows.Count
For nRow = 1 To nRows 'Schleife durch markierte Zeilen
nCells = Selection.Rows(nRow).Cells.Count
For nCell = 1 To nCells 'Schleife durch Zellen
Text = Text & Selection.Cells(nRow, nCell).Text & ";"
Next nCell
Text = Text & vbLf
Next nRow
Next nArea
data.SetText Text
data.PutInClipboard
End Sub
Sub InitTobit()
Dim oApp
Dim oAccount
Dim oArchive
Dim oItem
Dim oMailItem
Dim oAttachment
Dim TobitPath
Dim TSrv
Dim Template
On Error Resume Next
'Initialisiert die Tobit API
'Anwendungsverzeichnis des Tobit InfoCenters aus der Registry auslesen
Set WSHShell = CreateObject("WScript.Shell")
ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Settings\ProgramDirectory"
TobitPath = WSHShell.RegRead(ShellCmd)
'Objekt der DvISEAPI erzeugen
Set oApp = CreateObject("DVOBJAPILib.DvISEAPI")
'Account laden (des lokal angemeldeten Benutzers)
Set oAccount = oApp.Logon("", "", "", "", "", "NOAUTH")
'Alle Archive einlesen
Set oArchiveRoot = oAccount.ArchiveRoot
Set oArchives = oArchiveRoot.Archives
'Tobit Servernamen auslesen (Hostname des Tobit Servers in der Regel)
TSrv = oAccount.ServerName
'Vorlagenverzeichnis einlesen
ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Servers\" & TSrv & "\TemplateFN"
Template = WSHShell.RegRead(ShellCmd)
'Falls möglich Vorlage einlesen
If Template <> "" Then
'Den Pfad abschneiden
Path = Template
filepart = Right(Template, 13)
Path = Replace(Template, filepart, "")
'Das Archiv ermitteln
For Each oArc In oArchives
If oArc.ID = Path Then
'Das MailItem ermitteln
For Each obj In oArc.AllItems
If obj.TextSource = Template Then
Set oItem = obj
End If
Next
End If
Next
End If
End Sub
Sub Create_NewMail()
'Tobit Archiv einlesen
Set oArchive = oAccount.GetSpecialArchive(102) '102 = Ausgangsarchiv
'Neuen Archiveintrag anlegen
Set oMailItem = oArchive.CreateArchiveEntry(2) '0 = unbekannt, 1 = Adresse, 2 = Email, 3 = Fax, 4 = SMS, 5 = VoiceMail, 6 = TMAIL, 7 = Kalendereintrag, (...)
With oMailItem
.Subject = ""
'Empfänger der Nachricht
.Fields("SRTo").Value = "adress.management@skan-tours.de"
'Priorität der Nachricht
.Fields("Priority").Value = 0 '0 = Normal, 1 = Low, 2 = Important
'Daten der Vorlage einlesen
If Template <> "" Then
HTML = oItem.BodyText.HTMLText
'Fix für Umlaute da diese trotz UTF-8 komischerweise nicht sauber dargestellt werden
HTML = FixHTMLUmlaute(HTML)
Text = oItem.BodyText.PlainText
Charset = oItem.BodyText.Charset
.Fields("CONTENT").Value = Text
.Fields("HTMLDisplayContent").Value = HTML
End If
'ggf. Dateianhänge hinzufügen
' .Attachments.Add Path & "\" & FileName ', "Angezeigte Bezeichnung des Anhangs"
'Nachricht speichern
.Save
End With
'Nummer des Eintrags der soeben gespeicherten Email auslesen (wichtig für Shell Aufruf!)
oRecNo = oMailItem.Fields("RecNo").Value
'Über die Shell das InfoCenter starten und dort die soeben erzeugte Nachricht im Editor öffnen
Set WSHShell = CreateObject("WScript.Shell")
ShellCmd = TobitPath & "\DVWIN32.EXE " & oArchive.ID & " /SA=34 /POS=" & oRecNo
WSHShell.Exec (ShellCmd)
'Mail sofort wieder löschen nachdem sie geöffnet wurde, da Sie sonst doppelt versendet wird, bzw. 2x im Postausgangsarchiv liegt
oMailItem.Delete
'Objekte freigeben um sicherzustellen, dass das Script auch bei mehrmaligem Aufrufen sauber funktioniert
oAccount.Logoff
Set oAccount = Nothing
Set oApp = Nothing
Set oAttachment = Nothing
Set oMailItem = Nothing
Set oArchive = Nothing
Set oArchives = Nothing
Set oItem = Nothing
Set oArchiveRoot = Nothing
End Sub
|