Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ekim 2012 Cumartesi

Kamu Desteği Dışında Yapılan Teşvikli Yatırımlarda Yatırıma Katkıpayı Kullanımı [2]



'Module1

'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
Option Explicit
Private Sayfa As Worksheet
Private hSingle As Single
Private Logo As New OLEObject
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Private 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
Private IPic(15) As Byte
Private Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const URL1 As String = "http://3.bp.blogspot.com/-JnmFGcm3ApU/To74s1xm3iI/AAAAAAAAC30/6bT2SxszQQM/s1600/excel_2003_gif.gif"
Private URL As String
Sub Tablo_Kur()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Gelir").Select
If VBA.Err.Number > 0 Then
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Gelir"
VBA.Err.Clear
End If
Sheets("Vergi").Select
If VBA.Err.Number > 0 Then
ThisWorkbook.Worksheets.Add After:=Sheets(1)
ActiveSheet.Name = "Vergi"
VBA.Err.Clear
End If
Sheets("IRR").Select
If VBA.Err.Number > 0 Then
ThisWorkbook.Worksheets.Add After:=Sheets(2)
ActiveSheet.Name = "IRR"
VBA.Err.Clear
End If
Call Vergi_Kur
Call Vergi_Kur
Application.DisplayAlerts = True
With Application
.Iteration = True
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.Calculate
End Sub
Private Sub Vergi_Kur()
On Error Resume Next
Sheets("Vergi").Select
ActiveSheet.Unprotect
Cells.Select
Selection.Delete Shift:=xlUp
Range("B1").FormulaR1C1 = "KAMU DESTEĞİ DIŞINDA YAPILAN VE TEŞVİK KAPSAMI İÇİNDE OLAN"
Range("B2").FormulaR1C1 = "YATIRIMA KATKI PAYINDAN YARARLANACAK YATIRIMLAR İÇİN"
Range("B3").FormulaR1C1 = "KURUMLAR VERGİSİ HESABI [TL]"
Range("A5:A14") = Application.WorksheetFunction.Transpose(Array("a", "b", "c", "d", "e", "f", "g", "h", "", "Yıllar"))
For hSingle = 1 To 20
Range("A16:A35").Cells(hSingle, 1).FormulaR1C1 = hSingle
Next hSingle
Range("A36").FormulaR1C1 = "Toplam"
Range("B5").FormulaR1C1 = "Kamu Desteği Dışında Yapılan Yatırım Harcamaları"
Range("B6").FormulaR1C1 = "Yatırıma Katkı Oranı "
Range("B7").FormulaR1C1 = "Kurumlar Vergisi İndirim oranı "
Range("B8").FormulaR1C1 = "Yatırıma Katkı Payı [a * b]"
Range("B9").FormulaR1C1 = "Normal Kurumlar Vergisi Oranı"
Range("B10").FormulaR1C1 = "İndirimli Kurumlar Vergisi Oranı [e - (e * c)]"
Range("B11").FormulaR1C1 = "Faydalanılan Vergi İndirimi Oranı [e - f]"
Range("B12").FormulaR1C1 = "İndirimli Oranın Uygulanacağı Vergi Öncesi Kar Üst Limiti [d / g]"
Range("B14").FormulaR1C1 = "Vergi Öncesi Karlar"
Range("B15").FormulaR1C1 = "i"
Call Gelir_Tablo
Range("B16:B35").FormulaR1C1 = "=Gelir!R[-9]C[6]"
Range("B36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("C14").FormulaR1C1 = "Kümülatif Vergi Öncesi Karlar"
Range("C15").FormulaR1C1 = "j"
Range("C16").FormulaR1C1 = "=+RC[-1]"
Range("C17:C35").FormulaR1C1 = "=+RC[-1]+R[-1]C"
Range("C36").FormulaR1C1 = "=R[-1]C"
Range("D14").FormulaR1C1 = "İndirimli Oranın Uygulanacağı Vergi Öncesi Kar"
Range("D15").FormulaR1C1 = "k"
Range("D16").FormulaR1C1 = "=IF(0>IF(R12C8>RC[-1],RC[-2],R12C8),0,IF(R12C8>RC[-1],RC[-2],R12C8))"
Range("D17:D35").FormulaR1C1 = "=IF(0>IF(R12C8>RC[-1],RC[-2],R12C8-R[-1]C[-1]),0,IF(R12C8>RC[-1],RC[-2],R12C8-R[-1]C[-1]))"
Range("D36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("E14").FormulaR1C1 = "Normal Oranın Uygulanacağı Vergi Öncesi Kar"
Range("E15").FormulaR1C1 = "l"
Range("E16:E35").FormulaR1C1 = "=+RC[-3]-RC[-1]"
Range("E36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("F14").FormulaR1C1 = "İndirimli Kurumlar Vergisi"
Range("F15").Select
ActiveCell.FormulaR1C1 = "m= [f * k]"
Range("F16:F35").FormulaR1C1 = "=+RC[-2]*R10C8"
Range("F36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("G14").FormulaR1C1 = "Normal Kurumlar Vergisi"
Range("G15").FormulaR1C1 = "n= [e * l]"
Range("G16:G35").FormulaR1C1 = "=+RC[-2]*R9C8"
Range("G36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("H5").FormulaR1C1 = "4000000"
Range("H6").FormulaR1C1 = "30%"
Range("H7").FormulaR1C1 = "60%"
Range("H8").FormulaR1C1 = "=+R[-2]C*R[-3]C"
Range("H9").FormulaR1C1 = "20%"
Range("H10").FormulaR1C1 = "=R[-1]C-(R[-1]C*R[-3]C)"
Range("H11").FormulaR1C1 = "=R[-2]C-R[-1]C"
Range("H12").FormulaR1C1 = "=+R[-4]C/R[-1]C"
Range("H14").FormulaR1C1 = "Toplam Kurumlar Vergisi"
Range("H15").FormulaR1C1 = "o= [m + n]"
Range("H16:H35").FormulaR1C1 = "=RC[-1]+RC[-2]"
Range("H36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("J14").FormulaR1C1 = "Yararlanılan Yatırıma Katkıpayı Tutarı"
Range("J15").FormulaR1C1 = "p=k * g"
Range("J16:J35").FormulaR1C1 = "=+RC[-6]*R11C8"
Range("J36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("A38").FormulaR1C1 = "Örnek 31.12.2010 tarihine kadar yatırıma başlanması halinde Çanakkale ili II. Bölge'de "
Range("A39").FormulaR1C1 = "Yatırımlarda Devlet Yardımları Hakkında Kararda Değişiklik Yapılması'na yönelik 2009/15199 sayılı bakanlar kurulu kararının 10'uncu maddesi ve Kurumlar Vergisi Yasası'nın 32/A maddesinde uygulanması öngörülen indirim oranları ile yatırıma katkı oranları gereği hesaplanmıştır."
Range("H5,H8,H12,B16:H36,J16:J36").NumberFormat = "#,##0.00"
Range("H6,H7,H9,H10,H11").NumberFormat = "0.00%"
With Range("A14:H15,J14:J15")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.ShrinkToFit = True
End With
Range("B:B,C:C,D:D,E:E,F:F,G:G,H:H,J:J").ColumnWidth = 12
Columns("I:I").ColumnWidth = 1
Columns("A:A").ColumnWidth = 8
Range("4:4,13:13,37:37").RowHeight = 6
With Range("A1:J39").Font
.Name = "Arial"
.Size = 8
End With
With Range("B5:G5,B6:G6,B7:G7,B8:G8,B9:G9,B10:G10,B11:G11,B12:G12")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.MergeCells = True
.Merge
End With
With Range("A5:H12,H5:H12,A14:H36,J14:J36,A14:H15,J14:J15,A36:H36,J36:J36,A14:A36,H14:H36")
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
With Range("A5:A12,A16:A36")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.MergeCells = False
End With
With Range("A14:A15")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.Merge
End With
Rows("1:3").RowHeight = 15
With Range("B1:B3").Font
.Bold = True
.Name = "Arial"
.Size = 12
.ColorIndex = 5
End With
With Range("H5,H6,H7")
.Font.ColorIndex = 32
.Locked = False
End With
With Range("A39:H40")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = True
.Merge
End With
Range("A1").Select
Application.CommandBars("Control Toolbox").Visible = True
ActiveSheet.DrawingObjects.Select
Selection.Delete
Set Logo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=45, Height:=45)
'Logo.Object.Picture = LoadPicture("C:\Users\MU\Pictures\excel_2003.bmp")    

With Logo.Object
.Picture = Resim(URL1)
.PictureAlignment = 2
.PictureSizeMode = 1
End With
Application.CommandBars("Control Toolbox").Visible = False
Set Logo = Nothing
Range("H5").Select
ActiveSheet.Protect
Call IRR_Kur
End Sub
Private Sub Gelir_Tablo()
On Error Resume Next
Sheets("Gelir").Select
ActiveSheet.Unprotect
Cells.Select
Selection.Delete Shift:=xlUp
Range("B1").FormulaR1C1 = "KAMU DESTEĞİ DIŞINDA YAPILAN VE TEŞVİK KAPSAMI İÇİNDE OLAN"
Range("B2").FormulaR1C1 = "YATIRIMA KATKI PAYINDAN YARARLANACAK YATIRIMLAR İÇİN"
Range("B3").FormulaR1C1 = "PROJE YÜKÜMLÜLÜKLERİNİ KARŞILAYAN HASILAT HESABI [TL]"
Range("A5").FormulaR1C1 = "Yıllar"
For hSingle = 1 To 20
Range("A7:A26").Cells(hSingle, 1).FormulaR1C1 = hSingle
Next hSingle
Range("A27").FormulaR1C1 = "Toplam"
Range("B5").FormulaR1C1 = "Proje Gelirleri"
Range("B6").FormulaR1C1 = "A=B+D+E+F+H+I"
Range("B7:B26").FormulaR1C1 = "=RC[1]+RC[3]+RC[4]+RC[5]+RC[7]+RC[8]"
Range("B27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("C5").FormulaR1C1 = "Üretim Giderleri"
Range("C6").FormulaR1C1 = "B"
Range("C7:C26").FormulaR1C1 = "2600000"
Range("C27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("D5").FormulaR1C1 = "Amortisman ve Tükenme Payları"
Range("D6").FormulaR1C1 = "C"
Range("D7:D26").FormulaR1C1 = "=Vergi!R5C8/20"
Range("D27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("E5").FormulaR1C1 = "Yönetim Giderleri"
Range("E6").FormulaR1C1 = "D"
Range("E7:E26").FormulaR1C1 = "385000"
Range("E27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("F5").FormulaR1C1 = "Yatırıma Ait Kredi Faizleri"
Range("F6").FormulaR1C1 = "E"
Range("F7").FormulaR1C1 = "=Vergi!R5C8*0.75*0.12"
Range("F8").FormulaR1C1 = "=(Vergi!R5C8*0.75-R[-1]C[1])*0.12"
Range("F9").FormulaR1C1 = "=(Vergi!R5C8*0.75-R[-2]C[1]-R[-1]C[1])*0.12"
Range("F10").FormulaR1C1 = "=(Vergi!R5C8*0.75-R[-3]C[1]-R[-2]C[1]-R[-1]C[1])*0.12"
Range("F11").FormulaR1C1 = "=(Vergi!R5C8*0.75-R[-4]C[1]-R[-3]C[1]-R[-2]C[1]-R[-1]C[1])*0.12"
Range("F12").FormulaR1C1 = "=(Vergi!R5C8*0.75-R[-5]C[1]-R[-4]C[1]-R[-3]C[1]-R[-2]C[1]-R[-1]C[1])*0.12"
Range("F13:F26").FormulaR1C1 = ""
Range("F27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("G5").FormulaR1C1 = "Kredi Anapara Taksitleri"
Range("G6").FormulaR1C1 = "F"
Range("G7:G11").FormulaR1C1 = "=Vergi!R5C8*0.75/5"
Range("G12:G26").FormulaR1C1 = ""
Range("G27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("H5").FormulaR1C1 = "Vergi Öncesi Kar/Zarar"
Range("H6").FormulaR1C1 = "G=A-B-C-D-E"
Range("H7:H26").FormulaR1C1 = "=RC[-6]-RC[-5]-RC[-4]-RC[-3]-RC[-2]"
Range("H27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("I5").FormulaR1C1 = "Toplam Kurumlar Vergisi"
Range("I6").FormulaR1C1 = "H=[o]"
Range("I7:I26").FormulaR1C1 = "=Vergi!R[9]C[-1]"
Range("I27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("J5").FormulaR1C1 = "Makul Temettü"
Range("J6").FormulaR1C1 = "I=C"
Range("J7:J26").FormulaR1C1 = "=RC[-6]"
Range("J27").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Rows("4:4").RowHeight = 6
Columns("A:A").ColumnWidth = 8
Columns("B:J").ColumnWidth = 12
Range("A1:J27").Font.Size = 8
Range("B7:J27").NumberFormat = "#,##0.00"
With Range("B1:B3").Font
.Name = "Arial"
.Bold = True
.Size = 12
.ColorIndex = 5
End With
Rows("1:3").RowHeight = 15.75
With Range("A5:A6")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.ShrinkToFit = True
.MergeCells = True
.Merge
End With
With Range("B5:J6")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.IndentLevel = 0
.ShrinkToFit = True
End With
Range("A7:A27").HorizontalAlignment = xlCenter
With Range("A5:J27,A5:A27,H5:J27,A5:J6,A27:J27")
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
With Range("C7:C26,E7:E26")
.Locked = False
.Font.ColorIndex = 32
End With
Range("A1").Select
Application.CommandBars("Control Toolbox").Visible = True
ActiveSheet.DrawingObjects.Select
Selection.Delete
Set Logo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=45, Height:=45)
'Logo.Object.Picture = LoadPicture("C:\Users\MU\Pictures\excel_2003.bmp")    

With Logo.Object
.Picture = Resim(URL1)
.PictureAlignment = 2
.PictureSizeMode = 1
End With
Application.CommandBars("Control Toolbox").Visible = False
Set Logo = Nothing
Range("H5").Select
ActiveSheet.Protect
Sheets("Vergi").Select
End Sub
Private Sub IRR_Kur()
On Error Resume Next
Sheets("IRR").Select
ActiveSheet.Unprotect
Cells.Select
Selection.Delete Shift:=xlUp
Range("B1").FormulaR1C1 = "KAMU DESTEĞİ DIŞINDA YAPILAN VE TEŞVİK KAPSAMI İÇİNDE OLAN"
Range("B2").FormulaR1C1 = "YATIRIMA KATKI PAYINDAN YARARLANACAK YATIRIMLAR İÇİN"
Range("B3").FormulaR1C1 = "ÖDENMİŞ SERMAYENİN [TL] İÇ VERİMLİLİK ORANI"
Range("A5").FormulaR1C1 = "Yıllar"
Range("A6").FormulaR1C1 = ""
Range("A7").FormulaR1C1 = "1"
Range("A8").FormulaR1C1 = "2"
For hSingle = 1 To 20
Range("A9:A28").Cells(hSingle, 1).FormulaR1C1 = hSingle
Next hSingle
Range("A29").FormulaR1C1 = "Toplam"
Range("B5").FormulaR1C1 = "Sermaye Nakit Çıkışları"
Range("B6").FormulaR1C1 = "A"
Range("B7").FormulaR1C1 = "=Vergi!R5C8*0.25*0.4"
Range("B8").FormulaR1C1 = "=Vergi!R5C8*0.25*0.6"
Range("B9:B28").FormulaR1C1 = ""
Range("B29").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"
Range("C5").FormulaR1C1 = "Makul Temettü Nakit Girişleri"
Range("C6").FormulaR1C1 = "B"
Range("C7").FormulaR1C1 = ""
Range("C8").FormulaR1C1 = ""
Range("C9:C28").FormulaR1C1 = "=Gelir!R[-2]C[7]"
Range("C29").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"
Range("D5").FormulaR1C1 = "Net Nakit Girişleri"
Range("D6").FormulaR1C1 = "C=B-A"
Range("D7:D28").FormulaR1C1 = "=RC[-1]-RC[-2]"
Range("D29").FormulaR1C1 = "=SUM(R[-22]C:R[-1]C)"
Range("E5").FormulaR1C1 = "Sermayenin İç Verim Oranı [IRR]"
Range("E6").FormulaR1C1 = "D=IRR"
Range("E7:E28").FormulaR1C1 = "=IRR(R7C4:RC[-1])"
Range("E29").FormulaR1C1 = "=R[-1]C"
With Range("B1:B3").Font
.Name = "Arial"
.Bold = True
.Size = 12
.ColorIndex = 5
End With
Rows("1:3").RowHeight = 15.75
Range("B7:D29").NumberFormat = "#,##0.00"
Range("E7:E29").NumberFormat = "0.00%"
Range("A5:E29").Font.Size = 8
With Range("A5:A6")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.ShrinkToFit = True
.MergeCells = True
.Merge
End With
With Range("B5:E6")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.IndentLevel = 0
.ShrinkToFit = True
End With
Range("A7:A29").HorizontalAlignment = xlCenter
Columns("A:A").ColumnWidth = 8
Columns("B:E").ColumnWidth = 12
Rows("4:4").RowHeight = 6
With Range("A5:E29,A5:A29,A5:E8,A5:E6,A29:E29")
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
Range("A1").Select
Application.CommandBars("Control Toolbox").Visible = True
ActiveSheet.DrawingObjects.Select
Selection.Delete
Set Logo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=45, Height:=45)
'Logo.Object.Picture = LoadPicture("C:\Users\MU\Pictures\excel_2003.bmp")    

With Logo.Object
.Picture = Resim(URL1)
.PictureAlignment = 2
.PictureSizeMode = 1
End With
Application.CommandBars("Control Toolbox").Visible = False
Set Logo = Nothing
Range("E6").Select
ActiveSheet.Protect
Sheets("Gelir").Select
End Sub
Private 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

10 Ekim 2012 Çarşamba

Kamu Desteği Dışında Yapılan Teşvikli Yatırımlarda Yatırıma Katkıpayı Kullanımı [1]




'Module1



'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

Option Explicit
Private hSingle As Single
Private Logo As New OLEObject
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Private 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
Private IPic(15) As Byte
Private Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const URL1 As String = "
http://3.bp.blogspot.com/-JnmFGcm3ApU/To74s1xm3iI/AAAAAAAAC30/6bT2SxszQQM/s1600/excel_2003_gif.gif"
Private URL As String
Sub Tablo_Kur()
    On Error Resume Next
    Sheets(1).Select
    ActiveSheet.Unprotect
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("B1").FormulaR1C1 = "KAMU DESTEĞİ DIŞINDA YAPILAN VE TEŞVİK KAPSAMI İÇİNDE OLAN"
    Range("B2").FormulaR1C1 = "YATIRIMA KATKI PAYINDAN YARARLANACAK YATIRIMLAR İÇİN"
    Range("B3").FormulaR1C1 = "KURUMLAR VERGİSİ HESABI [TL]"
    Range("A5:A14") = Application.WorksheetFunction.Transpose(Array("a", "b", "c", "d", "e", "f", "g", "h", "", "Yıllar"))
    For hSingle = 1 To 20
        Range("A16:A35").Cells(hSingle, 1).FormulaR1C1 = hSingle
    Next hSingle
    Range("A36").FormulaR1C1 = "Toplam"
    Range("B5").FormulaR1C1 = "Kamu Desteği Dışında Yapılan Yatırım Harcamaları"
    Range("B6").FormulaR1C1 = "Yatırıma Katkı Oranı "
    Range("B7").FormulaR1C1 = "Kurumlar Vergisi İndirim oranı "
    Range("B8").FormulaR1C1 = "Yatırıma Katkı Payı [a * b]"
    Range("B9").FormulaR1C1 = "Normal Kurumlar Vergisi Oranı"
    Range("B10").FormulaR1C1 = "İndirimli Kurumlar Vergisi Oranı [e - (e * c)]"
    Range("B11").FormulaR1C1 = "Faydalanılan Vergi İndirimi Oranı [e - f]"
    Range("B12").FormulaR1C1 = "İndirimli Oranın Uygulanacağı Vergi Öncesi Kar Üst Limiti [d / g]"
    Range("B14").FormulaR1C1 = "Vergi Öncesi Karlar"
    Range("B15").FormulaR1C1 = "i"
    Range("B16.B35").FormulaR1C1 = "1500000"
    Range("B36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("C14").FormulaR1C1 = "Kümülatif Vergi Öncesi Karlar"
    Range("C15").FormulaR1C1 = "j"
    Range("C16").FormulaR1C1 = "=+RC[-1]"
    Range("C17:C35").FormulaR1C1 = "=+RC[-1]+R[-1]C"
    Range("C36").FormulaR1C1 = "=R[-1]C"
    Range("D14").FormulaR1C1 = "İndirimli Oranın Uygulanacağı Vergi Öncesi Kar"
    Range("D15").FormulaR1C1 = "k"
    Range("D16").FormulaR1C1 = "=IF(0>IF(R12C8>RC[-1],RC[-2],R12C8),0,IF(R12C8>RC[-1],RC[-2],R12C8))"
    Range("D17:D35").FormulaR1C1 = "=IF(0>IF(R12C8>RC[-1],RC[-2],R12C8-R[-1]C[-1]),0,IF(R12C8>RC[-1],RC[-2],R12C8-R[-1]C[-1]))"
    Range("D36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("E14").FormulaR1C1 = "Normal Oranın Uygulanacağı Vergi Öncesi Kar"
    Range("E15").FormulaR1C1 = "l"
    Range("E16:E35").FormulaR1C1 = "=+RC[-3]-RC[-1]"
    Range("E36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("F14").FormulaR1C1 = "İndirimli Kurumlar Vergisi"
    Range("F15").Select
    ActiveCell.FormulaR1C1 = "m= [f * k]"
    Range("F16:F35").FormulaR1C1 = "=+RC[-2]*R10C8"
    Range("F36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("G14").FormulaR1C1 = "Normal Kurumlar Vergisi"
    Range("G15").FormulaR1C1 = "n= [e * l]"
    Range("G16:G35").FormulaR1C1 = "=+RC[-2]*R9C8"
    Range("G36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("H5").FormulaR1C1 = "4000000"
    Range("H6").FormulaR1C1 = "30%"
    Range("H7").FormulaR1C1 = "60%"
    Range("H8").FormulaR1C1 = "=+R[-2]C*R[-3]C"
    Range("H9").FormulaR1C1 = "20%"
    Range("H10").FormulaR1C1 = "=R[-1]C-(R[-1]C*R[-3]C)"
    Range("H11").FormulaR1C1 = "=R[-2]C-R[-1]C"
    Range("H12").FormulaR1C1 = "=+R[-4]C/R[-1]C"
    Range("H14").FormulaR1C1 = "Toplam Kurumlar Vergisi"
    Range("H15").FormulaR1C1 = "o= [m + n]"
    Range("H16:H35").FormulaR1C1 = "=RC[-1]+RC[-2]"
    Range("H36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("J14").FormulaR1C1 = "Yararlanılan Yatırıma Katkıpayı Tutarı"
    Range("J15").FormulaR1C1 = "p=k * g"
    Range("J16:J35").FormulaR1C1 = "=+RC[-6]*R11C8"
    Range("J36").FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
    Range("A38").FormulaR1C1 = "Örnek 31.12.2010 tarihine kadar yatırıma başlanması halinde Çanakkale ili II. Bölge'de "
    Range("A39").FormulaR1C1 = "Yatırımlarda Devlet Yardımları Hakkında Kararda Değişiklik Yapılması'na yönelik 2009/15199 sayılı bakanlar kurulu kararının 10'uncu maddesi ve Kurumlar Vergisi Yasası'nın 32/A maddesinde uygulanması öngörülen indirim oranları ile yatırıma katkı oranları gereği hesaplanmıştır."
    Range("H5,H8,H12,B16:H36,J16:J36").NumberFormat = "#,##0.00"
    Range("H6,H7,H9,H10,H11").NumberFormat = "0.00%"
    With Range("A14:H15,J14:J15")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ShrinkToFit = True
    End With
    Range("B:B,C:C,D:D,E:E,F:F,G:G,H:H,J:J").ColumnWidth = 12
    Columns("I:I").ColumnWidth = 1
    Columns("A:A").ColumnWidth = 8
    Range("4:4,13:13,37:37").RowHeight = 6
    With Range("A1:J39").Font
        .Name = "Arial"
        .Size = 8
    End With
    With Range("B5:G5,B6:G6,B7:G7,B8:G8,B9:G9,B10:G10,B11:G11,B12:G12")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .MergeCells = True
        .Merge
    End With
    With Range("A5:H12,H5:H12,A14:H36,J14:J36,A14:H15,J14:J15,A36:H36,J36:J36,A14:A36,H14:H36")
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
    End With
    With Range("A5:A12,A16:A36")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .MergeCells = False
    End With
    With Range("A14:A15")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
        .Merge
    End With
    Rows("1:3").RowHeight = 15
    With Range("B1:B3").Font
        .Bold = True
        .Name = "Arial"
        .Size = 12
        .ColorIndex = 5
    End With
    With Range("H5,H6,H7,B16:B35")
        .Font.ColorIndex = 32
        .Locked = False
    End With
    With Range("A39:H40")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .MergeCells = True
        .Merge
    End With
    Range("A1").Select
    Application.CommandBars("Control Toolbox").Visible = True
    ActiveSheet.DrawingObjects.Select
    Set Logo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=40, Height:=45)
    'Logo.Object.Picture = LoadPicture("C:\Users\MU\Pictures\excel_2003.bmp")
    With Logo.Object
        .Picture = Resim(URL1)
        .PictureAlignment = 2
        .PictureSizeMode = 1
    End With
    Application.CommandBars("Control Toolbox").Visible = False
    Set Logo = Nothing
    Rows("38:38").RowHeight = 15
    Rows("39:40").RowHeight = 24
    Range("H5").Select
    ActiveSheet.Protect
End Sub
Private 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

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

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi