Hallo! Hier ging nicht mehr so viel. Die App TOBIT kenne ich nicht. Gibt hier aber mal was, wo dein Code auch ist / war bzw. ähnlich vorhanden.
http://www.ms-office-forum.net/forum/showthread.php?t=290114
Ggf. mal dort noch nachfragen bzw. nac TOBIT suchen.
Soweit ich konnte, hier mal noch Erklärungen zum Code - einige Kommentare waren ja schon drin. VG
'allgmenes Object, dass für alle gilt, könnte eine eigene Klasse sein
Dim data As DataObject
Private Sub ToClipboard()
' Tastenkombination: Strg+J
'setzt das all. Object neu
Set data = New DataObject
Dim Text As String
'nimmt dieAnzahl der untersch. Selektieren Bereich auf - also die, die nicht zusammenhägen und gleich groß sind
nAreas = Selection.Areas.Count
For nArea = 1 To nAreas 'Schleife durch alle markierten Bereiche
'zählt die zeilen des Bereichs
nRows = Selection.Rows.Count
For nRow = 1 To nRows 'Schleife durch markierte Zeilen
nCells = Selection.Rows(nRow).Cells.Count 'alle Zelle jeder Zeile
For nCell = 1 To nCells 'Schleife durch Zellen
'verkette den INhalt aller Zeilen in einen String getrennt mit ;
Text = Text & Selection.Cells(nRow, nCell).Text & ";"
Next nCell
Text = Text & vbLf
Next nRow
Next nArea
'weist den Text aller Zellen also den String an Data
data.SetText Text
'schiebt das in die Zwischenablage
data.PutInClipboard
''''
'Anmerkung. mE ungetestet könnte man das Auslesen der Zellen auch so machen
'for each zelle in selection
' text = text und zelle.value & ";"
'next
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, (...)
'setzt wieder einen allg. Links auf die art des eintrages um sich das später zu sparen
With oMailItem
'betreff
.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
'oItem ist ein Object, dass irgendwo vermtl. global angelegt wurde
'ist als HTMl Body angelegt - die Mail wird dann auch einen HTML Text haben, damit könne auch Tabellen rein
HTML = oItem.BodyText.HTMLText
'Fix für Umlaute da diese trotz UTF-8 komischerweise nicht sauber dargestellt werden
HTML = FixHTMLUmlaute(HTML)
'nimmt die Daten vomObject oItem. Da das hier nicht erfasst ist, wird es global aus einem anderen Makro kommen
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
|