AW: ZIP-Dateien auswählen und Namen ausgeben
10.12.2006 11:23:55
Dominik
Leider ist das problemwieder aufgetaucht und ich kann wieder nicht die zip files auswaehlen.
hier mal mein code:
Option Explicit
Private Sub CommandButton1_Click()
Dim strDate As String, DefPath As String, strbody As String
Dim oApp As Object
Dim FileNameZip, FileNameXls
Dim noSession As Object, noDatabase As Object
Dim noDocument As Object, noAttachment As Object
Dim vaFiles As Variant, vaRecipient As Variant
Dim i As Long
Dim Dateiname As Variant, msg, z
Const EMBED_ATTACHMENT = 1454
Const stSubject As String = "For information only"
Const stMsg As String = "with attachment."
'Creat ZIP ##############################################
DefPath = "C:\Temp"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xls/zip file names
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Populate the variant-array with recipients.
vaRecipient = VBA.Array("123@123.com")
'Open zip file
vaFiles = Application.GetOpenFilename( _
FileFilter:="Alle ZIP-Dateien (*.zip), *.zip", _
Title:="Datei auswählen", MultiSelect:=False)
'If user(s) cancel the operation.
If Not IsArray(vaFiles) Then Exit Sub
'Instantiate the Lotus Notes COM objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Check if mail-database is open or not.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Instantiate the Lotus E-mailobject.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("Body")
'Add the selected Excel-files to the E-mail.
With noAttachment
For i = 1 To UBound(vaFiles)
.EmbedObject EMBED_ATTACHMENT, "", vaFiles(i)
Next i
End With
'Populate mainproperties of the created E-mail and save & send
'the e-mail.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
.Body = stMsg
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Return to Excel.
AppActivate "Microsoft Excel"
MsgBox "The e-mail has successfully been created and sent!", vbInformation
Kill FileNameZip
Kill FileNameXls
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
evtl findest du ja ein fehler oder so
mfg
Dominik