Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ekim 2012 Pazartesi

Make Zip File Manager




'UserForm1

'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\Windows\SysWOW64\MSCOMCTL.OCX
'B. Available Tools List
'1) Image1, Label1, Label2
'2) Image2, Label3, CommandButton1, CommandButton2, CommandButton3
'3) ListView1
'4) Label4, CommandButton4, Label5, TextBox1, Label6, CommandButton5
'5) ListView2, ListView3
'6) CommandButton6, CommandButton7
Private i As Single
Private No As Long
Private hRow As Double
Private FSO
Private hItem
Private sFile
Private vFile
Private zFile
Private nFile As String
Private eFolder
Private hObj As Object
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Make Zip File Manager"
Call Ekran_Kur
ListView1.SetFocus
End Sub
Private Sub CommandButton1_Click() 'Add New Files
On Error Resume Next
ListView1.ListItems.Clear
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
sFile = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", MultiSelect:=True, Title:="[PBİD®] Select the files you want to zip")
If IsArray(sFile) = False Then
MsgBox "File not found.", vbInformation, "[PBİD®]"
CommandButton5.Enabled = False
Else
For No = LBound(sFile) To UBound(sFile)
vFile = IsSeparat_File(sFile(No), "\")
nFile = vFile(UBound(vFile))
If IsOpen_File(nFile) Then
MsgBox "You can not zip a file that is open!" & vbLf & "Please close it and try again; " & sFile(No), vbInformation, "[PBİD®]"
Else
Set hItem = FSO.getfile(sFile(No))
ListView1.ListItems.Add No, "Key" & No, hItem
ListView1.ListItems(No).ListSubItems.Add 1, "sKey1", VBA.Format(hItem.Size, "#,##0")
End If
Next No
CommandButton5.Enabled = True
End If
Set FSO = Nothing
Set hItem = Nothing
End Sub
Private Sub CommandButton2_Click() 'Erase Item
On Error Resume Next
hRow = ListView1.SelectedItem.Index
If hRow = 0 Then
MsgBox "Please select a record.", vbInformation, "[PBİD®]"
Else
ListView1.ListItems.Remove hRow
If ListView1.ListItems.Count = 0 Then CommandButton5.Enabled = False
End If
End Sub
Private Sub CommandButton3_Click() 'Clear List
On Error Resume Next
If ListView1.ListItems.Count = 0 Then
MsgBox "The list is empty.", vbInformation, "[PBİD®]"
Else
ListView1.ListItems.Clear
CommandButton5.Enabled = False
End If
End Sub
Private Sub CommandButton4_Click() 'Select Current Zip File
On Error Resume Next
ListView2.ListItems.Clear
Label5.Caption = ""
zFile = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False, Title:="[PBİD®] Select the file you want to archive")
If zFile = False Then
MsgBox "File not found.", vbInformation, "[PBİD®]"
Else
Label5.Caption = " " & zFile
Set hObj = CreateObject("Shell.Application")
No = 1
For Each hItem In hObj.Namespace(zFile).Items
ListView2.ListItems.Add No, "Key" & No, hItem
ListView2.ListItems(No).ListSubItems.Add 1, "sKey1", VBA.Format(hItem.Size, "#,##0")
No = No + 1
Next hItem
Set hObj = Nothing
End If
End Sub
Private Sub CommandButton5_Click() 'Make Zip
On Error Resume Next
If ListView1.ListItems.Count = 0 Then
MsgBox "Archived source file not found.", vbInformation, "[PBİD®]"
Else
Set hObj = CreateObject("Shell.Application")
If Label5.Caption <> "" Then
zFile = VBA.Trim(Label5.Caption)
ListView1.SetFocus
For Each hItem In ListView1.ListItems
ListView1.ListItems(hItem.Index).Selected = True
ListView1.ListItems(hItem.Index).EnsureVisible
If hItem <> vbNull Then
hObj.Namespace(zFile).CopyHere sFile(hItem.Index)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
End If
Next hItem
ListView2.ListItems.Clear
CommandButton6.Enabled = False
No = 1
For Each hItem In hObj.Namespace(zFile).Items
ListView2.ListItems.Add No, "Key" & No, hItem
ListView2.ListItems(No).ListSubItems.Add 1, "sKey1", VBA.Format(hItem.Size, "#,##0")
No = No + 1
Next hItem
End If
If Label6.Caption <> "" Then
zFile = VBA.Trim(Label6.Caption)
If VBA.Len(VBA.Dir(zFile)) > 0 Then VBA.Kill zFile
Open zFile For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
ListView1.SetFocus
For Each hItem In ListView1.ListItems
ListView1.ListItems(hItem.Index).Selected = True
ListView1.ListItems(hItem.Index).EnsureVisible
If hItem <> vbNull Then
hObj.Namespace(zFile).CopyHere sFile(hItem.Index)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
End If
Next hItem
ListView3.ListItems.Clear
CommandButton7.Enabled = False
No = 1
For Each hItem In hObj.Namespace(zFile).Items
ListView3.ListItems.Add No, "Key" & No, hItem
ListView3.ListItems(No).ListSubItems.Add 1, "sKey1", VBA.Format(hItem.Size, "#,##0")
No = No + 1
Next hItem
End If
Set hObj = Nothing
End If
End Sub
Private Sub CommandButton6_Click() 'Unzip from current zip file.
On Error Resume Next
hRow = ListView2.SelectedItem.Index
Set hObj = CreateObject("Shell.Application")
If hRow > 0 Then
eFolder = VBA.Left(VBA.Trim(Label5.Caption), VBA.InStr(1, VBA.Trim(Label5.Caption), Application.PathSeparator, vbTextCompare))
zFile = Label5.Caption
'hObj.Namespace(eFolder).CopyHere hObj.Namespace(VBA.Trim(zFile)).Items        

For Each hItem In hObj.Namespace(VBA.Trim(zFile)).Items
If hItem.Name = VBA.CStr(ListView2.ListItems(hRow)) Then hObj.Namespace(eFolder).CopyHere hItem
Next hItem
End If
Set hObj = Nothing
End Sub
Private Sub CommandButton7_Click() 'Unzip from new zip file.
On Error Resume Next
hRow = ListView3.SelectedItem.Index
Set hObj = CreateObject("Shell.Application")
If hRow > 0 Then
eFolder = VBA.Left(VBA.Trim(Label6.Caption), VBA.InStr(1, VBA.Trim(Label6.Caption), Application.PathSeparator, vbTextCompare))
zFile = Label6.Caption
'hObj.Namespace(eFolder).CopyHere hObj.Namespace(VBA.Trim(zFile)).Items
For Each hItem In hObj.Namespace(VBA.Trim(zFile)).Items
If hItem.Name = VBA.CStr(ListView3.ListItems(hRow)) Then hObj.Namespace(eFolder).CopyHere hItem
Next hItem
End If
Set hObj = Nothing
End Sub
Private Sub TextBox1_Change() 'New zip file name.
On Error Resume Next
If TextBox1.Text = "" Then
Label6.Caption = ""
Else
Label6.Caption = " " & ThisWorkbook.Path & Application.PathSeparator & TextBox1.Text & ".zip"
End If
End Sub
Private Sub ListView2_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error Resume Next
CommandButton6.Enabled = True
End Sub
Private Sub ListView3_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error Resume Next
CommandButton7.Enabled = True
End Sub
Function IsOpen_File(ByRef hName As String) As Boolean
On Error Resume Next
IsOpen_File = Not (Application.Workbooks(hName) Is Nothing)
End Function
Function IsSeparat_File(hName As Variant, hSeparator As String) As Variant
On Error Resume Next
IsSeparat_File = Evaluate("{""" & Application.Substitute(hName, hSeparator, """,""") & """}")
End Function
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 364
.Width = 472
'.Picture = Resim(URL1) .PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 318
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Image2
.Top = 36
.Left = 6
.Height = 300
.Width = 96
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
End With
With Label3
.Left = 102 + 1
.Top = 36
.Height = 12
.Width = 360 - 1
.Caption = "Source Files"
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Font.Bold = True
.Font.Size = 7
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With CommandButton1
.Left = 102 + 1
.Top = 48 + 1
.Height = 18 - 1
.Width = 120 - 1
.Caption = "Add New Files"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL4)
.PicturePosition = fmPicturePositionLeftCenter
End With
With CommandButton2
.Left = 222 + 1
.Top = 48 + 1
.Height = 18 - 1
.Width = 120 - 1
.Caption = "Erase Item"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL6)
.PicturePosition = fmPicturePositionLeftCenter
End With
With CommandButton3
.Left = 342 + 1
.Top = 48 + 1
.Height = 18 - 1
.Width = 120 - 1
.Caption = "Clear List"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL7)
.PicturePosition = fmPicturePositionLeftCenter
End With
With ListView1
.Left = 102 + 1
.Top = 66 + 1
.Height = 102 - 1
.Width = 360 - 1
.Font.Bold = False
.ForeColor = &H808000
.BorderStyle = fmBorderStyleSingle
.Appearance = ccFlat
.ColumnHeaders.Add 1, "Key1", "Source Files Full Name", 288, 0
.ColumnHeaders.Add 2, "Key2", "File Size", 54, 1
.FlatScrollBar = False
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
End With
With Label4
.Left = 102 + 1
.Top = 168 + 1
.Height = 12 - 1
.Width = 360 - 1
.Caption = "Archive Zip File"
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Font.Bold = True
.Font.Size = 7
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With CommandButton4
.Left = 102 + 1
.Top = 180 + 1
.Height = 18 - 1
.Width = 120 - 1
.Caption = "Select Current Zip File"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL5)
.PicturePosition = fmPicturePositionLeftCenter
End With
With Label5
.Left = 222 + 1
.Top = 180 + 1
.Height = 18 - 1
.Width = 204 - 1
.Caption = ""
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.TextAlign = fmTextAlignLeft
End With
With TextBox1
.Left = 102 + 1
.Top = 198 + 1
.Height = 18 - 1
.Width = 120 - 1
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Font.Bold = False
.Font.Size = 7
.ForeColor = vbBlue
.TextAlign = fmTextAlignLeft
.BackColor = vbWhite
End With
With Label6
.Left = 222 + 1
.Top = 198 + 1
.Height = 18 - 1
.Width = 204 - 1
.Caption = ""
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H80000006
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.TextAlign = fmTextAlignLeft
End With
With CommandButton5
.Left = 426 + 1
.Top = 180 + 1
.Height = 36 - 1
.Width = 36 - 1
.Caption = "Make Zip"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL8)
.PicturePosition = fmPicturePositionAboveCenter
.Enabled = False
End With
With ListView2
.Left = 102 + 1
.Top = 216 + 1
.Height = 102 - 1
.Width = 180 - 1
.Font.Bold = False
.ForeColor = &H8000&
.BorderStyle = fmBorderStyleSingle
.Appearance = ccFlat
.ColumnHeaders.Add 1, "Key1", "Source Files Full Name", 114, 0
.ColumnHeaders.Add 2, "Key2", "File Size", 54, 1
.FlatScrollBar = False
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
End With
With ListView3
.Left = 282 + 1
.Top = 216 + 1
.Height = 102 - 1
.Width = 180 - 1
.Font.Bold = False
.ForeColor = &H8000&
.BorderStyle = fmBorderStyleSingle
.Appearance = ccFlat
.ColumnHeaders.Add 1, "Key1", "Source Files Full Name", 114, 0
.ColumnHeaders.Add 2, "Key2", "File Size", 54, 1
.FlatScrollBar = False
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
End With
With CommandButton6
.Left = 102 + 1
.Top = 318 + 1
.Height = 18 - 1
.Width = 180 - 1
.Caption = "Make UnZip From Current Zip File"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL9)
.PicturePosition = fmPicturePositionLeftCenter
.Enabled = False
End With
With CommandButton7
.Left = 282 + 1
.Top = 318 + 1
.Height = 18 - 1
.Width = 180 - 1
.Caption = "Make UnZip From New Zip File"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Size = 7
.ForeColor = &H808000
.Picture = Resim(URL9)
.PicturePosition = fmPicturePositionLeftCenter
.Enabled = False
End With
End With
End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public Const URL3 As String = "http://3.bp.blogspot.com/-KMW11eDG94Q/Tsj04DmZXgI/AAAAAAAADAw/lCWXD6NTS_U/s1600/winzip_pbid_gray.bmp"
Public Const URL4 As String = "http://3.bp.blogspot.com/-T8LAuWdsz_U/TcXIq0lIpPI/AAAAAAAACw4/UnomGxo3OEM/s1600/Dosya_A%25C3%25A7.gif"
Public Const URL5 As String = "http://3.bp.blogspot.com/-bwRSkWprDNs/Tiszo7ThzFI/AAAAAAAACyI/SGmlxMCgQWo/s1600/Mercek_bmp.bmp"
Public Const URL6 As String = "http://4.bp.blogspot.com/-mbPIN6nca24/TslXl7aZIRI/AAAAAAAADBA/ueEWgq_1TJE/s1600/Delete_Gif.gif"
Public Const URL7 As String = "http://1.bp.blogspot.com/-5niXHJf6Vnk/TslXkSYk74I/AAAAAAAADA4/su3T24_-2Vo/s1600/clear_gif.gif"
Public Const URL8 As String = "http://4.bp.blogspot.com/-nrmnyrGu0Kw/TslXsXTT9SI/AAAAAAAADBQ/CMnI4BGHT4c/s1600/Zip_Gif.gif"
Public Const URL9 As String = "http://1.bp.blogspot.com/-BDTBDqWu4BA/TslXo7TxCYI/AAAAAAAADBI/GIk4X_tVMdg/s1600/Unzip_Gif.gif"
Public URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...
On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
'Sub References_List()
' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul