winrar olarak kaydetme

[monopol]

arkadaşlar merhaba,
benim sorum şu ki; bir excel dosyasını winrar ya da winzip olarak nasıl kaydedebiliriz?

 

[N.Ziya Hiçdurmaz]

yanıt

Elimdeki iki adet kodu ekliyorum denersiniz

Winrar ile excel'de sıkıştırma.

Sub Win_Rar()
Dim WinRar, Arsiv, Kaynak
  WinRar = "C:\Program Files\WinRAR\WinRAR.exe"
  'WinRar uygulamasının tam yolunu yazın
  Kaynak = "C:\Belgelerim\Test.xls"
  'Sıkıştırılacak dosyanın ve ya klasörün tam adı,
  Arsiv = "A:\" & Left(Dir(Kaynak), Application.Find(".", Dir(Kaynak)) - 1)
  'Sıkıştırıldıktan sonra rar dosyasına verilecek isim
 
  'Rar dosyası oluşturuluyor
  ShellExecute 0, "open", WinRar, _
      "a " & Arsiv & " " & Kaynak, "", vbHide
  For i = 1 To 10: DoEvents: Next
  Application.Wait Now + TimeValue("00:00:03")
  'Setup dosyası oluşturuluyor
  ShellExecute 0, "open", WinRar, _
      "s " & Arsiv & ".rar", "", vbHide
  For i = 1 To 10: DoEvents: Next
  Application.Wait Now + TimeValue("00:00:10")
   
    Kill Arsiv & ".rar"
End Sub
****************************************
AKTİF EXCEL DOSYASININ WINZIP İLE SIKIŞTIRILMASI

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
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Zip_ActiveWorkbook()
Dim PathWinZip As String, FileNameZip As String, FileNameXls As String
Dim ShellStr As String, strDate As String
 
PathWinZip = "C:\program files\winzip\"
'This will check if this is the path where WinZip is installed.
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "WINZIP PROGRAMI BULUNAMADI"
Exit Sub
End If
' Build the path and name for the zip file
FileNameZip = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & "1.zip"
' Build the path and name for the xls file
FileNameXls = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & "1.xls"
 
' Use SaveCopyAs to save the file with a Date/Time stamp
ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
 
'Zip the file
ShellStr = PathWinZip & "Winzip32 -min -a" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FileNameXls & Chr(34)
ShellAndWait ShellStr, vbHide
'Delete the file that you saved with SaveCopyAs
Kill FileNameXls
MsgBox "SIKIŞTIRMA TAMAMLANDI"
End Sub

 

[monopol]

teşekkür ederim.