Sub MappeSchliessen()
Dim xlsName$, zipName$, Zip$
ActiveWorkbook.Save
xlsName = ActiveWorkbook.FullName
ActiveWorkbook.Close
zipName = Left(xlsName, Len(xlsName) - 4) & ".zip"
Zip = "c:\programme\winzip\winzip32.exe -a "
Shell Zip & zipName & " " & xlsName
End Sub
Sub ZipAktiveDatei()
Dim xlsName$, zipName$, Zip$, wb As Workbook
On Error GoTo fehler
Set wb = ActiveWorkbook
With wb
If .Saved = False Then
.Save
End If
xlsName = .FullName
.Close
End With
zipName = Left(xlsName, Len(xlsName) - 4) & ".zip"
Zip = "c:\programme\winzip\winzip32.exe -a "
Shell Zip & """" & zipName & """ """ & xlsName & """"
fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
End Sub
Option Explicit
Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub UnZip_ZipFile_1(FileNameZip As String, FolderName As String, Optional zipOp As String)
Dim PathWinZip As String
Dim ShellStr As String
PathWinZip = "C:\program files\winzip\"
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
ShellStr = PathWinZip & "Winzip32 -min " & zipOp _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FolderName & Chr(34)
ShellAndWait ShellStr, vbHide
End Sub
Sub StartZip()
Dim strPfad As String, tempPfad As String
' erst mal speichern
ThisWorkbook.Save
'speicherpfad ermitteln
strPfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
'Temp Ordner ermitteln + Dateiname
tempPfad = IIf(Right$(Environ$("TEMP"), 1) = "\", Environ$("TEMP"), Environ$("TEMP") & "\") & ThisWorkbook.Name
'tempDatei erstellen
ThisWorkbook.SaveCopyAs tempPfad
'Zip- File erstellen
UnZip_ZipFile_1 strPfad & "NeuerDatei.zip", tempPfad, "-a"
Kill tempPfad 'tempadatei löschen
End Sub
Gruß Tino
Sub StartZip()
Dim sPfad As String
Dim sZipName As String
'Passwort, beachte Winzip Optionen Kennwörter
Const myPass As String = "tinoseibt"
'Zip File Name
sZipName = "myExcel.zip"
'Datei erst mal speichern
ThisWorkbook.Save
'Speicherpfad
sPfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
'Zip erstellen über WZZIP.EXE
Shell ("c:\programme\winzip\wzzip -s" & myPass & " -ycAES256 " & sPfad & sZipName & " " & ThisWorkbook.FullName)
End Sub
Gruß Tino
'Option Explicit
Private Declare Function GetShortPathNameA Lib "kernel32" ( _
ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Public Function ShortPath(ByRef Path As String) As String
Dim n As Long
ShortPath = Space$(256)
n = GetShortPathNameA(Path, ShortPath, 255)
ShortPath = Left$(ShortPath, n)
End Function
Sub StartZip()
Dim sPfad As String
Dim sZipName As String
'Passwort, beachte Winzip Optionen Kennwörter
Const myPass As String = "meinpasswort"
'Zip File Name
sZipName = "myExcel.zip"
'Datei erst mal speichern
ThisWorkbook.Save
'Speicherpfad
sPfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
sPfad = ShortPath(sPfad)
'Zip erstellen über WZZIP.EXE
Shell ("c:\programme\winzip\WZZIP.EXE -s" & myPass & " -ycAES " & sPfad & sZipName & " " & ShortPath(ThisWorkbook.FullName))
End Sub
Beachte auch die Optionen zum verschlüsseln.
Gruß Tino
