Komprimera arbetsböcker och
skapa e-post i MS Outlook
Det är vanligt att vi skickar arbetsböcker mellan kollegor och samarbetspartners. Här kan det också vara aktuellt att krympa storleken på bifogad arbetsbok. Det vanligast programmet för komprimering är WinZip.
Därför visas här ett tips på hur vi kan komprimera en arbetsbok med WinZip och därefter lägga den komprimerade filen som en bilaga till ett e-post i MS Outlook.
Ett stort tack till min gode vän Ivan F Moala, Auckland Nya Zeeland, för att han har gett mig tillåtelse att publicera detta tips på min webbplats.
OBS! Det går inte att komprimera den aktiva arbetsboken och som innehåller denna kod.
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal lnghProcess As Long, _
lpExitCode As Long) As Long
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Function ShlProc_IsRunning(ShellReturnValue As Long) As Boolean
'© 2002 Ivan F Moala
'Denna funktion hämtar upp statusen för Winzip och returnerar "True" om
'Winzip fortfarande exekveras eller "False" om den är avslutad.
Dim lnghProcess As Long
Dim lExitCode As Long
lnghProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ShellReturnValue)
If lnghProcess <> 0 Then
GetExitCodeProcess lnghProcess, lExitCode
If lExitCode <> 0 Then
ShlProc_IsRunning = True
Else
ShlProc_IsRunning = False
End If
End If
End Function
Sub Zip_E_Post()
'© 2002 Ivan F Moala
'Reviderad av XL-Dennis
Dim ZipItPID As Long
Dim stKallFil As String, stMalFil As String, stWinZipExe As String
'---------------------Komprimerar en arbetsbok med Winzip------------------------
stKallFil = "c:\Dennis.xls"
stMalFil = "c:\Test\Dennis.zip"
'Här anges sökvägen till Winzip samt kommandot för att komprimera en fil
stWinZipExe = "c:\Program\WinZip\Winzip32 -a"
ZipItPID = Shell(stWinZipExe & " " & stMalFil & " " & stKallFil, 6)
On Error Resume Next
If ZipItPID = 0 Then
MsgBox "Vänligen kontrollera sökvägen till käll- respektive målfil", vbExclamation
Exit Sub
End If
On Error GoTo 0
'Här väntar Excel på att Winzip ska avslutas.
Do While ShlProc_IsRunning(ZipItPID) = True
DoEvents
Loop
'---------------------Skapa e-post i MS Outlook --------------------------------
'Här använder vi oss av early binding
Dim olApp As Outlook.Application
Dim olNewMail As Outlook.MailItem
Set olApp = New Outlook.Application
Set olNewMail = CreateItem(olMailItem)
With olNewMail
.Recipients.Add "Dennis"
.Recipients.Add "Frun"
.CC = "Team 2000"
.BCC = "Evaluering"
.Subject = "Ärende: Programlista"
.Body = "Underlag enligt ök."
.Attachments.Add stMalFil
.Save
.Display
End With
Set olNewMail = Nothing
Set olApp = Nothing
'Städa upp
Kill stMalFil
End Sub
Ovanstående procedur har en begränsning, den kan inte hantera långa filnamn med mellanslag i namnet, såsom "Dennis arbetsbok". Nedanstående procedur avhjälper denna begränsning:
Sub Zip_E_Post()
'© 2002 Ivan F Moala - Reviderad av XL-Dennis 2003-02-07
Dim ZipItPID As Long
Dim stKallFil As String, stMalFil As String, stWinZipExe As String
Dim stSokVag As String, stFilnamn As String, stHamtaFil As String
Dim stSparaFil As String
Dim fsoObj As Object
ChDrive "c"
ChDir "c:\XLDennis\ZipMapp\Original"
stHamtaFil = Application.GetOpenFilename("MS Excel-filer (*.xls),*.xls", , "Välj fil för komprimering...")
If stHamtaFil = "Falskt" Then Exit Sub
Set fsoObj = CreateObject("Scripting.FileSystemObject")
stSokVag = fsoObj.GetFile(stHamtaFil).ParentFolder.Path
stFilnamn = fsoObj.GetFile(stHamtaFil).Name
If stSokVag <> "C:\XLDennis\ZipMapp\Original" Then
MsgBox "Fel mapp är vald."
Exit Sub
End If
stKallFil = "c:\XLDennis\ZipMapp\Original\" & stFilnamn
If InStr(1, stKallFil, " ", vbTextCompare) <> 0 Then
stKallFil = Chr(34) & stKallFil & Chr(34)
End If
stFilnamn = Left(stFilnamn, Application.WorksheetFunction.Find(".", stFilnamn, 1) - 1)
stMalFil = "c:\XLDennis\ZipMapp\Packad\" & stFilnamn & ".zip"
If InStr(1, stMalFil, " ", vbTextCompare) <> 0 Then
stMalFil = Chr(34) & stMalFil & Chr(34)
End If
stWinZipExe = "c:\Program\WinZip\Winzip32.exe -min -a"
ZipItPID = Shell(stWinZipExe & " " & stMalFil & " " & stKallFil, 6)
On Error Resume Next
If ZipItPID = 0 Then
MsgBox "Vänligen kontrollera sökvägen till käll- respektive målfil", vbExclamation
Kill "c:\XLDennis\ZipMapp\Original\*.*"
Kill "c:\XLDennis\ZipMapp\Packad\*.*"
Exit Sub
End If
On Error GoTo 0
Do While ShlProc_IsRunning(ZipItPID) = True
DoEvents
Loop
stMalFil = Mid(stMalFil, 2, Len(stMalFil) - 2)
stKallFil = Mid(stKallFil, 2, Len(stKallFil) - 2)
'---------------------Skapa e-post i MS Outlook --------------------------------
Dim olApp As Outlook.Application
Dim olNewMail As Outlook.MailItem
Set olApp = New Outlook.Application
Set olNewMail = CreateItem(olMailItem)
With olNewMail
.Recipients.Add "Dennis"
.Recipients.Add "Frun"
.CC = "Team 2000"
.BCC = "Evaluering"
.Subject = "Ärende: Programlista"
.Body = "Underlag enligt ök."
.Attachments.Add stMalFil
.Save
.Display
End With
Set olNewMail = Nothing
Set olApp = Nothing
Kill "c:\XLDennis\ZipMapp\Original\*.*"
Kill "c:\XLDennis\ZipMapp\Packad\*.*"
End Sub