Örnek Kod Excel Dosyanızı VBA Kodla Şifreli/Şifresiz Winzip Dosyası Yapmak

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
'Ivan F Moala
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 Dosyayi_Zip_Yap()
Dim Dosyam As String, ZipDosya As String, Winzip As String, ZipYap As Long
   Dosyam = "c:\belgelerim\deneme_dosyam.xls"
   ZipDosya = "c:\belgelerim\test.zip"
   Winzip = "c:\Program Files\WinZip\Winzip32 -a"
   ZipYap = Shell(Winzip & " " & ZipDosya & " " & Dosyam, 6)
End Sub

Sub Ziple()
    Const Klasor = "Excel"
    On Error Resume Next
    BacksupPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Klasor & "\")
    MkDir BacksupPath
    ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, ".")))
    FileNameXls = BacksupPath & Klasor & " " & Format(Now, "DD-MM-YYYY_HH-NN-SS") & "." & ext$
    FileNameZip = BacksupPath & Klasor & " " & Format(Now, "DD-MM-YYYY_HH-NN-SS") & ".zip"
    ThisWorkbook.SaveCopyAs FileNameXls
    ZIPresult = Zip_File(FileNameXls, FileNameZip, True)
    Debug.Print "Hata: " & IIf(ZIPresult, "zip", "winzip")
    Debug.Print "...: " & Dir(FileNameZip)
End Sub

Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _
Optional ByVal DeleteSourceFile As Boolean = False) As Boolean

    On Error Resume Next: Err.Clear:
    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
    If Len(Dir(FileNameXls)) = 0 Then MsgBox """" & FileNameXls & """ ...", _
       vbCritical, "Zip_File": Exit Function

    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameZip).CopyHere FileNameXls

    Do Until oApp.Namespace(FileNameZip).Items.Count = 1
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop

    If DeleteSourceFile Then Kill FileNameXls
    Zip_File = Err = 0
End Function

Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
     (ByVal hWnd As Long, _
      ByVal lpOperation As String, _
      ByVal lpFile As String, _
      ByVal lpParameters As String, _
      ByVal lpDirectory As String, _
      ByVal nShowCmd As Long) As Long

Sub ZipFile(FileName As String, Optional ByVal Password As String)

  Dim BackSlash As Long
  Dim CmdLine As String
  Dim Ext As Long
  Dim FilePath As String
  Dim RetVal As Long
  Dim ZipName As String

    BackSlash = InStrRev(FileName, "\")
    If BackSlash = 0 Then
       FilePath = CurDir & "\"
    Else
       FilePath = ""
    End If
   
   'Check if file exists
    If Dir(FilePath & FileName) = "" Then
       MsgBox "File Not Found" & vbCrLf & "  " & FilePath & FileName
       Exit Sub
    End If
   
   'Name for the zip archive
    Ext = InStrRev(FileName, ".")
      If Ext = 0 Then
         ZipName = FileName & ".zip"
      Else
         ZipName = Left(FileName, Ext) & "zip"
      End If
   
   'Command line string - file names must include quotes
    If Password = "" Then
       CmdLine = "-min -a -en " & Chr$(34) & ZipName & Chr$(34) & " " _
               & Chr$(34) & FileName & Chr$(34)
    Else
       CmdLine = "-min -a -en -s" & Chr$(34) & Password & Chr$(34) _
               & " " & Chr$(34) & ZipName & Chr$(34) & " " _
               & Chr$(34) & FileName & Chr$(34)
    End If
                 
     'Zip the file and save it in the archive
      RetVal = ShellExecute(0&, "", "WinZip32.exe", CmdLine, FilePath, 1&)

   'Check for Errors are from 0 to 32
    If RetVal <= 32 Then
       Select Case RetVal
         Case 2     'SE_ERR_FNF
           Msg = "File not found"
         Case 3      'SE_ERR_PNF
           Msg = "Path not found"
         Case 5      'SE_ERR_ACCESSDENIED
           Msg = "Access denied"
         Case 8      'SE_ERR_OOM
           Msg = "Out of memory"
         Case 32     'SE_ERR_DLLNOTFOUND
           Msg = "DLL not found"
         Case 26     'SE_ERR_SHARE
           Msg = "A sharing violation occurred"
         Case 27     'SE_ERR_ASSOCINCOMPLETE
           Msg = "Incomplete or invalid file association"
         Case 28     'SE_ERR_DDETIMEOUT
           Msg = "DDE Time out"
         Case 29     'SE_ERR_DDEFAIL
           Msg = "DDE transaction failed"
         Case 30     'SE_ERR_DDEBUSY
           Msg = "DDE busy"
         Case 31     'SE_ERR_NOASSOC
           Msg = "Default Email not configured"
         Case 11     'ERROR_BAD_FORMAT
           Msg = "Invalid EXE file or error in EXE image"
         Case Else
           Msg = "Unknown error"
       End Select
      Msg = "File Not Zipped - " & Msg & vbCrLf & "Error " & RetVal
      MsgBox Msg, vbExclamation + vbOKOnly
    End If
End Sub

Sub Test()
    Dim fname As Variant
    fname = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", MultiSelect:=False)
    If fname = False Then Exit Sub
    ZipFile FileName:=(fname), Password:="Www.ExcelTurkey.coM"
End Sub