title image


Smiley Re: - die Fragen gehen mir in diesem Zusammenhang nicht aus:
Hallo Ulrich,



sorry, die Änderung war nicht ganz sauber. Da Du ohnehin Probleme mit der ActiveX-DLL (ZipLib.Dll) hast, hier nun Code für ZIP und SendMail as Attachment ohne ActiveX-Dlls (ohne Verweise). Du brauchst nur die freie InfoZIP DLL zip32.dll in Version 2.3 oder höher. Beachte bitte, dass die DLL, die ich Dir vorher genannt habe, eine ältere, fehlerhafte Version war und man unbedingt die neuere Version 2.3 verwendne sollte.

Da der ZIP-Code nun schon über APIs zu ZIP32.DLL realisiert ist, hab ich Dir auch gleich den MAPI-Mail-Teil in elemtarer Form (ohne OL-Automatisierung) reingetan. Dies funktioniert sowwohl mit SMAPI (OLEXP) als auch mit MAPI (OL in CW oder IMO Modus oder andere MAPI-kompatible Mailer).



Bestimmt sind im Code noch Unzulänglichkeiten, musst es im Fehlerfall halt debuggen..



Option Explicit



' Benötigt ZIP32.DLL v 2.3 (freie Infozip-Library)

' Die DLLs muss im Programm- oder Windows-Systemverzeichnis vorliegen



Private Declare Function ZpInit Lib "zip32.dll" _

(ByRef zipfun As ZPUSERFUNCTIONS) As Long



Private Declare Function ZpSetOptions Lib "zip32.dll" _

(ByRef opts As ZPOPTIONS) As Long



Private Declare Function ZpArchive Lib "zip32.dll" _

(ByVal argc As Long, ByVal fname As String, ByRef argv As String) As Long



Private Declare Function MAPISendMail Lib "mapi32.dll" _

(ByVal Session As Long, ByVal UIParam As Long, Message As MAPIMessage, _

ByVal Flags As Long, ByVal Reserved As Long) As Long



Private Type ZPOPTIONS

Date As String ' US Date (8 Bytes Long) "12/31/98"?

szRootDir As String ' Root Directory Pathname (Up To 256 Bytes Long)

szTempDir As String ' Temp Directory Pathname (Up To 256 Bytes Long)

fTemp As Long ' 1 If Temp dir Wanted, Else 0

fSuffix As Long ' Include Suffixes (Not Yet Implemented!)

fEncrypt As Long ' 1 If Encryption Wanted, Else 0

fSystem As Long ' 1 To Include System/Hidden Files, Else 0

fVolume As Long ' 1 If Storing Volume Label, Else 0

fExtra As Long ' 1 If Excluding Extra Attributes, Else 0

fNoDirEntries As Long ' 1 If Ignoring Directory Entries, Else 0

fExcludeDate As Long ' 1 If Excluding Files Earlier Than Specified Date, Else 0

fIncludeDate As Long ' 1 If Including Files Earlier Than Specified Date, Else 0

fVerbose As Long ' 1 If Full Messages Wanted, Else 0

fQuiet As Long ' 1 If Minimum Messages Wanted, Else 0

fCRLF_LF As Long ' 1 If Translate CR/LF To LF, Else 0

fLF_CRLF As Long ' 1 If Translate LF To CR/LF, Else 0

fJunkDir As Long ' 1 If Junking Directory Names, Else 0

fGrow As Long ' 1 If Allow Appending To Zip File, Else 0

fForce As Long ' 1 If Making Entries Using DOS File Names, Else 0

fMove As Long ' 1 If Deleting Files Added Or Updated, Else 0

fDeleteEntries As Long ' 1 If Files Passed Have To Be Deleted, Else 0

fUpdate As Long ' 1 If Updating Zip File-Overwrite Only If Newer, Else 0

fFreshen As Long ' 1 If Freshing Zip File-Overwrite Only, Else 0

fJunkSFX As Long ' 1 If Junking SFX Prefix, Else 0

fLatestTime As Long ' 1 If Setting Zip File Time To Time Of Latest File In Archive, Else 0

fComment As Long ' 1 If Putting Comment In Zip File, Else 0

fOffsets As Long ' 1 If Updating Archive Offsets For SFX Files, Else 0

fPrivilege As Long ' 1 If Not Saving Privileges, Else 0

fEncryption As Long ' Read Only Property!!!

fRecurse As Long ' 1 (-r), 2 (-R) If Recursing Into Sub-Directories, Else 0

fRepair As Long ' 1 = Fix Archive, 2 = Try Harder To Fix, Else 0

flevel As Byte ' Compression Level - 0 = Stored 6 = Default 9 = Max

End Type



Private Type ZPUSERFUNCTIONS

ZDLLPrnt As Long ' Callback Print Function

ZDLLCOMMENT As Long ' Callback Comment Function

ZDLLPASSWORD As Long ' Callback Password Function

ZDLLSERVICE As Long ' Callback Service Function

End Type



Private Type ZPCBChar

ch(4096) As Byte

End Type



Private Type MAPIRecip

Reserved As Long

RecipClass As Long

Name As String

Address As String

EIDSize As Long

EntryID As String

End Type



Private Type MAPIFile

Reserved As Long

Flags As Long

Position As Long

PathName As String

FileName As String

FileType As String

End Type



Private Type MAPIMessage

Reserved As Long

Subject As String

NoteText As String

MessageType As String

DateReceived As String

ConversationID As String

Originator As Long

Flags As Long

RecipCount As Long

Recipients As Long

FileCount As Long

Files As Long

End Type



Private Const MAPI_LOGON_UI = &H1&

Private Const MAPI_DIALOG = &H8&

Private Const MAPI_NEW_SESSION As Long = &H2&



Private CallbackMsg As String



Sub SendMAPIActiveDocumentAsZip()

Dim zUser As ZPUSERFUNCTIONS, zOpt As ZPOPTIONS

Dim FileNames(0) As String, zArgC As Long

Dim ZipFileName As String, tpath As String



If Len(ActiveDocument.path) = 0 Then MsgBox "Dokument nicht gespeichert": Exit Sub

If Not CreateTempFolder(tpath) Then MsgBox "Fehler bei CreateTempFolder": Exit Sub



ActiveDocument.Save

FileNames(0) = ActiveDocument.FullName ' zu zippen

zArgC = 1 ' Anzahl Dateien zu zippen

ZipFileName = tpath & "\" & ActiveDocument.Name & ".zip" ' Ziel



On Error Resume Next

CallbackMsg = vbNullString



zUser.ZDLLPrnt = FarPtr(AddressOf ZDLLPrnt)

zUser.ZDLLPASSWORD = FarPtr(AddressOf ZDLLPass)

zUser.ZDLLCOMMENT = FarPtr(AddressOf ZDLLComm)

zUser.ZDLLSERVICE = FarPtr(AddressOf ZDLLServ)

ZpInit zUser ' set ZIP Callback Procs



zOpt.szRootDir = vbNullString

zOpt.fJunkDir = 1

ZpSetOptions zOpt ' set ZIP options



If ZpArchive(zArgC, ZipFileName, FileNames(0)) Then ' Zip action

MsgBox "Fehler beim Packen: " & CallbackMsg: Exit Sub

Else ' ok if result=0

' Debug.Print "Zip: " & ZipFileName & " ok, " & CallbackMsg



' ZIP-File als Attachment über MAPI senden

Dim sSubj As String, sBody As String

Dim aAttachPaths(0) As String ' Attachments (Pfade)

sSubj = "Dokument " & ActiveDocument.Name ' Subject

sBody = "Anlage: gepacktes Word-Dokument (ZIP-Format)"

aAttachPaths(0) = ZipFileName ' Attachement

If SMAPISendMail(sSubj, sBody, Null, aAttachPaths) Then

' mit Empfängeradresse(n): SMAPISendMail(sSubj, sBody, aRecips, aAttachPaths)

MsgBox "Fehler bei MAPISendMail"

End If ' MAPISendMail ok



Kill ZipFileName: RmDir tpath ' Temp-Datei und Ornder löschen



End If ' ZIP ok

End Sub



Private Function FarPtr(ByVal lp As Long) As Long

FarPtr = lp

End Function



Private Function ZDLLPrnt(ByRef msg As ZPCBChar, ByVal n As Long) As Long

On Error Resume Next

CallbackMsg = CallbackMsg & Left$(StrConv(msg.ch, vbUnicode), n)

ZDLLPrnt = 0

End Function



Private Function ZDLLServ(ByRef msg As ZPCBChar, ByVal n As Long) As Long

ZDLLServ = 0

End Function



Private Function ZDLLPass(ByRef pw As ZPCBChar, ByVal n As Long, _

ByRef msg As ZPCBChar, ByRef Name As ZPCBChar) As Long

ZDLLPass = 0

End Function



Private Function ZDLLComm(ByRef s As ZPCBChar) As Long

ZDLLComm = 0

End Function



Private Function CreateTempFolder(fname As String) As Boolean

Dim tp As String, tn As String

With CreateObject("Scripting.FileSystemObject")

fname = .GetSpecialfolder(2) & "\" & .GetTempName()

On Error Resume Next

.CreateFolder fname

CreateTempFolder = Err = 0

On Error GoTo 0

End With

End Function



Private Function SMAPISendMail(ByVal sSubject As String, ByVal sMessage As String, _

ByRef aRecips As Variant, Optional ByRef aAttachPaths As Variant = Null) As Long

Dim Recips() As MAPIRecip, Files() As MAPIFile

Dim Message As MAPIMessage, i As Long, x As Variant

With Message

.NoteText = sMessage

.Subject = sSubject

If Not IsNull(aRecips) Then

ReDim Recips(UBound(aRecips))

For i = 0 To UBound(aRecips)

With Recips(i)

.RecipClass = 1

.Address = StrConv(aRecips(i), vbFromUnicode)

.Name = StrConv(aRecips(i), vbFromUnicode) ' ohne Namensauflösung

End With

Next i

.RecipCount = UBound(Recips) + 1

.Recipients = VarPtr(Recips(0))

End If

If Not IsNull(aAttachPaths) Then

ReDim Files(UBound(aAttachPaths))

For i = 0 To UBound(aAttachPaths)

With Files(i)

x = Split(aAttachPaths(i), "\") ' extract Filename from Path

.FileName = StrConv(x(UBound(x)), vbFromUnicode) ' Display-Name

.PathName = StrConv(aAttachPaths(i), vbFromUnicode) ' Path

.Position = -1& ' not specified

.FileType = vbNullString

End With

Next i

.FileCount = UBound(Files) + 1

.Files = VarPtr(Files(0))

End If

End With

SMAPISendMail = MAPISendMail(0&, 0&, Message, MAPI_LOGON_UI Or MAPI_NEW_SESSION Or IIf(IsNull(aRecips), MAPI_DIALOG, 0&), 0&)

End FunctionGrüße

Wolfram





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: