Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mayıs 2011 Cuma

Degree Of Operating Leverage Affects Profitability Analysis Of The Paid-Up Capital in Excel





'Module1


'A) Windows XP® Office 2003® Normal Referance List

'Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL

'Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE'Description: OLE Automation, FullPath: C:\WINDOWS\system32\stdole2.tlb
'Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL

'B) LEVERAGE AFFECTS PROFİTABİLİTY ANALYSİS OF THE PAİD-UP CAPİTAL

'Dr. Öztin AKGÜÇ; 1998 Finansal Yönetim ISBN:9757429090

Option Explicit
Sub OLFLCLDüzenle()

On Error Resume Next
Sheets("OL").Select
If VBA.Err.Number = 0 Then

Call DüzenlemeYap("OL", "DEGREE OF OPERATİNG LEVERAGE AFFECTS PROFİTABİLİTY ANALYSİS OF THE PAİD-UP CAPİTAL.", "=+R[25]C[-4]", "=+R[25]C[-6]", "=+R[13]C[-5]", "=+R[23]C[-5]", "=+R[10]C[-5]", "=+R[13]C[-7]", "=+R[23]C[-7]", "=+R[10]C[-7]", "=R[18]C[-7]", "=+R[18]C[-8]", 3850000, 1875000, 635000, 519000, 912500, 835000, 278500, 34800, 65000, 2400000, 0, 0, 0.1, 0, 0)

Else

VBA.Err.Number = 0
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
ActiveSheet.Name = "OL"
Call DüzenlemeYap("OL", "DEGREE OF OPERATİNG LEVERAGE AFFECTS PROFİTABİLİTY ANALYSİS OF THE PAİD-UP CAPİTAL.", "=+R[25]C[-4]", "=+R[25]C[-6]", "=+R[13]C[-5]", "=+R[23]C[-5]", "=+R[10]C[-5]", "=+R[13]C[-7]", "=+R[23]C[-7]", "=+R[10]C[-7]", "=R[18]C[-7]", "=+R[18]C[-8]", 3850000, 1875000, 635000, 519000, 912500, 835000, 278500, 34800, 65000, 2400000, 0, 0, 0.1, 0, 0)

End If
Sheets("FL").Select
If VBA.Err.Number = 0 Then

Call DüzenlemeYap("FL", "DEGREE OF FINANCIAL LEVERAGE AFFECTS PROFITABILITY ANALYSIS OF THE PAID-UP CAPITAL.", "=+R[25]C[-4]", "=+R[25]C[-6]", "=+R[17]C[-5]", "=+R[13]C[-5]", "=+R[13]C[-5]", "=+R[17]C[-7]", "=+R[13]C[-7]", "=+R[13]C[-7]", "=R[19]C[-7]", "=+R[19]C[-8]", 3850000, 1875000, 0, 519000, 912500, 0, 0, 0, 65000, 2400000, 789000, 255000, 0.1, 0.09, 0.12)

Else

VBA.Err.Number = 0
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
ActiveSheet.Name = "FL"
Call DüzenlemeYap("FL", "DEGREE OF FINANCIAL LEVERAGE AFFECTS PROFITABILITY ANALYSIS OF THE PAID-UP CAPITAL.", "=+R[25]C[-4]", "=+R[25]C[-6]", "=+R[17]C[-5]", "=+R[13]C[-5]", "=+R[13]C[-5]", "=+R[17]C[-7]", "=+R[13]C[-7]", "=+R[13]C[-7]", "=R[19]C[-7]", "=+R[19]C[-8]", 3850000, 1875000, 0, 519000, 912500, 0, 0, 0, 65000, 2400000, 789000, 255000, 0.1, 0.09, 0.12)

End If
Sheets("CL").Select
If VBA.Err.Number = 0 Then

Call DüzenlemeYap("CL", "AFFECT THE DEGREE OF LEVERAGE COMBİNED PAİD-İN CAPİTAL PROFİTABİLİTY ANALYSİS.", "=+R[13]C[-4]", "=+R[13]C[-6]", "=+R[17]C[-5]", "=+R[13]C[-5]", "=+R[13]C[-5]", "=+R[17]C[-7]", "=+R[13]C[-7]", "=+R[13]C[-7]", "=R[20]C[-7]", "=+R[20]C[-8]", 3850000, 1875000, 635000, 519000, 912500, 835000, 278500, 34800, 65000, 2400000, 789000, 255000, 0.1, 0.09, 0.12)

Else

VBA.Err.Number = 0
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
ActiveSheet.Name = "CL"
Call DüzenlemeYap("CL", "AFFECT THE DEGREE OF LEVERAGE COMBİNED PAİD-İN CAPİTAL PROFİTABİLİTY ANALYSİS.", "=+R[13]C[-4]", "=+R[13]C[-6]", "=+R[17]C[-5]", "=+R[13]C[-5]", "=+R[13]C[-5]", "=+R[17]C[-7]", "=+R[13]C[-7]", "=+R[13]C[-7]", "=R[20]C[-7]", "=+R[20]C[-8]", 3850000, 1875000, 635000, 519000, 912500, 835000, 278500, 34800, 65000, 2400000, 789000, 255000, 0.1, 0.09, 0.12)

End If

End Sub
Private Function DüzenlemeYap(Sayfa, Etiket, Kay1, Kay2, Use1, Use2, Use3, Use4, Use5, Use6, Kon1, Kon2, a, b, c, e, f, j, k, l, s, ac, ad, ae, ag, ah, ai)

On Error Resume Next
Sheets(Sayfa).Select
ActiveSheet.Unprotect
Cells.Select
With Selection.Font

.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone

End With
[A1].Select
Range("B4").FormulaR1C1 = "Description (İşlem Tanımı)"
Range("B6").FormulaR1C1 = "a"
Range("B7").FormulaR1C1 = "b"
Range("B8").FormulaR1C1 = "c"
Range("B9").FormulaR1C1 = "d=b+c"
Range("B10").FormulaR1C1 = "e"
Range("B11").FormulaR1C1 = "f"
Range("B12").FormulaR1C1 = "g=e-f"
Range("B13").FormulaR1C1 = "h=d+g"
Range("B14").FormulaR1C1 = "i=a-h"
Range("B15").FormulaR1C1 = "j"
Range("B16").FormulaR1C1 = "k"
Range("B17").FormulaR1C1 = "l"
Range("B18").FormulaR1C1 = "m=j+k+l"
Range("B19").FormulaR1C1 = "n=i-m"
Range("B20").FormulaR1C1 = "o"
Range("B21").FormulaR1C1 = "p"
Range("B22").FormulaR1C1 = "q=o+p"
Range("B23").FormulaR1C1 = "r=n-q"
Range("B24").FormulaR1C1 = "s"
Range("B25").FormulaR1C1 = "t=r+s"
Range("B26").FormulaR1C1 = "u=t*%40"
Range("B27").FormulaR1C1 = "v=t-u"
Range("B28").FormulaR1C1 = "w=r/af"
Range("B29").FormulaR1C1 = "x1=b-(f*b/d)"
Range("B30").FormulaR1C1 = "x2=b-(f*b/d)"
Range("B31").FormulaR1C1 = "y=a-x1"
Range("B32").FormulaR1C1 = "z=y/n"
Range("B33").FormulaR1C1 = "aa=n/r"
Range("B34").FormulaR1C1 = "ab=z*aa"
Range("B35").FormulaR1C1 = "ac"
Range("B36").FormulaR1C1 = "ad"
Range("B37").FormulaR1C1 = "ae"
Range("B38").FormulaR1C1 = "af=ac-(ad+ae)"
Range("B39").FormulaR1C1 = "ag"
Range("B40").FormulaR1C1 = "ah"
Range("B41").FormulaR1C1 = "ai"
Range("B42").FormulaR1C1 = "aj"
Range("C6").FormulaR1C1 = "Net Sales"
Range("C7").FormulaR1C1 = "Variable Production Cost"
Range("C8").FormulaR1C1 = "Semi-Fixed and variable costs of production"
Range("C9").FormulaR1C1 = "Total Production Costs"
Range("C10").FormulaR1C1 = "Products per semester Stocks"
Range("C11").FormulaR1C1 = "Final Product Stocks"
Range("C12").FormulaR1C1 = "Change in product inventory"
Range("C13").FormulaR1C1 = "Cost of Sales"
Range("C14").FormulaR1C1 = "Gross Profit / Loss"
Range("C15").FormulaR1C1 = "Marketing Sales and Distribution Expenses"
Range("C16").FormulaR1C1 = "General and Administrative Expenses"
Range("C17").FormulaR1C1 = "Research and development (R & D) Expenses"
Range("C18").FormulaR1C1 = "Collect Operating Expenses"
Range("C19").FormulaR1C1 = "Operating Profit / Loss"
Range("C20").FormulaR1C1 = "Short Term Loan Interest and Expenses"
Range("C21").FormulaR1C1 = "Medium-and Long-Term Credit Interest Expenses"
Range("C22").FormulaR1C1 = "Total Financing Costs"
Range("C23").FormulaR1C1 = "Operating Profit / Loss"
Range("C24").FormulaR1C1 = "Non-Profit or Loss for Business"
Range("C25").FormulaR1C1 = "Profit Before Tax and Legal Liabilities or Loss"
Range("C26").FormulaR1C1 = "Institutions Etc. Gain Tax. Legal Provisions"
Range("C27").FormulaR1C1 = "Profit or Loss After Tax and Legal Liabilities"
Range("C28").FormulaR1C1 = "Return on Paid-In Capital"
Range("C29").FormulaR1C1 = "Total Variable Manufacturing Costs"
Range("C30").FormulaR1C1 = "Total Semi-Fixed Manufacturing Costs"
Range("C31").FormulaR1C1 = "Total Net Contribution"
Range("C32").FormulaR1C1 = "Degree of Operating Leverage"
Range("C33").FormulaR1C1 = "Degree of Financial Leverage"
Range("C34").FormulaR1C1 = "Degree of Combined Leverage"
Range("C35").FormulaR1C1 = "Total Resources"
Range("C36").FormulaR1C1 = "Short Term Loans"
Range("C37").FormulaR1C1 = "Medium Term Loans"
Range("C38").FormulaR1C1 = "Paid-in Capital"
Range("C39").FormulaR1C1 = "Capacity Change Rate"
Range("C40").FormulaR1C1 = "Short Term Loan Interest Rates and Charges"
Range("C41").FormulaR1C1 = "Medium Term Loan Interest Rates and Charges"
Range("C42").FormulaR1C1 = "Control"
Range("D6").FormulaR1C1 = "Net Satış Hasılatı"
Range("D7").FormulaR1C1 = "Deişken Üretim Maliyetleri"
Range("D8").FormulaR1C1 = "Sabit ve Yarı Değişken Üretim Maliyetleri"
Range("D9").FormulaR1C1 = "Toplam Üretim Maliyetleri"
Range("D10").FormulaR1C1 = "Dönem Başı Mamul Stokları"
Range("D11").FormulaR1C1 = "Dönem Sonu Mamul Stokları"
Range("D12").FormulaR1C1 = "Mamul Stoklarındaki Değişim"
Range("D13").FormulaR1C1 = "Satışların Maliyeti"
Range("D14").FormulaR1C1 = "Brüt Satış Karı / Zararı"
Range("D15").FormulaR1C1 = "Pazarlama Satış ve Dağıtım Giderleri"
Range("D16").FormulaR1C1 = "Genel Yönetim Giderleri"
Range("D17").FormulaR1C1 = "Araştırma ve Geliştirme (AR-GE) Giderleri"
Range("D18").FormulaR1C1 = "Toplama Faaliyet Giderleri"
Range("D19").FormulaR1C1 = "Faaliyet Karı / Zararı"
Range("D20").FormulaR1C1 = "Kısa Vadeli Kredi Faiz ve Giderleri"
Range("D21").FormulaR1C1 = "Orta-Uzun Vadeli Kredi Faiz ve Giderleri"
Range("D22").FormulaR1C1 = "Toplam Finansman Giderleri"
Range("D23").FormulaR1C1 = "İşletme Karı / Zararı"
Range("D24").FormulaR1C1 = "İşletme Dışı Kar veya Zarar"
Range("D25").FormulaR1C1 = "Vergi ve Yasal Yükümlülükler Öncesi Kar veya Zarar"
Range("D26").FormulaR1C1 = "Kurum Kazancı Vergi vb. Yasal Yükümlülük Karşılıkları"
Range("D27").FormulaR1C1 = "Vergi ve Yasal Yükümlülükler Sonrası Kar veya Zarar"
Range("D28").FormulaR1C1 = "Ödenmiş Sermaye Karlılığı"
Range("D29").FormulaR1C1 = "Toplam Değişken Üretim Maliyetleri"
Range("D30").FormulaR1C1 = "Toplam Sabit Üretim Maliyetleri"
Range("D31").FormulaR1C1 = "Toplam Net Katkı Payı"
Range("D32").FormulaR1C1 = "Faaliyet Kaldıraç Derecesi"
Range("D33").FormulaR1C1 = "Finansal Kaldıraç Derecesi"
Range("D34").FormulaR1C1 = "Bileşik Kaldıraç Derecesi"
Range("D35").FormulaR1C1 = "Toplam Kaynak"
Range("D36").FormulaR1C1 = "Kısa Vadeli Kredi"
Range("D37").FormulaR1C1 = "Orta Vadeli Kredi"
Range("D38").FormulaR1C1 = "Ödenmiş Sermaye"
Range("D39").FormulaR1C1 = "Kapasite Değişikliği Oranı"
Range("D40").FormulaR1C1 = "Kısa Vadeli Kredi Faiz ve Masraf Oranı"
Range("D41").FormulaR1C1 = "Orta Vadeli Kredi Faiz ve Masraf Oranı"
Range("D42").FormulaR1C1 = "Kontrol"
Range("E4").FormulaR1C1 = "Capacity Change (Kapasite Değişikliği)"
Range("E5").FormulaR1C1 = "Before (Öncesi)"
Range("E6").FormulaR1C1 = a
Range("E7").FormulaR1C1 = b
Range("E8").FormulaR1C1 = c
Range("E9").FormulaR1C1 = "=+R[-1]C+R[-2]C"
Range("E10").FormulaR1C1 = e
Range("E11").FormulaR1C1 = f
Range("E12").FormulaR1C1 = "=+R[-2]C-R[-1]C"
Range("E13").FormulaR1C1 = "=+R[-4]C+R[-1]C"
Range("E14").FormulaR1C1 = "=+R[-8]C-R[-1]C"
Range("E15").FormulaR1C1 = j
Range("E16").FormulaR1C1 = k
Range("E17").FormulaR1C1 = l
Range("E18").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("E19").FormulaR1C1 = "=+R[-5]C-R[-1]C"
Range("E20").FormulaR1C1 = "=+R[16]C*R[20]C"
Range("E21").FormulaR1C1 = "=+R[16]C*R[20]C"
Range("E22").FormulaR1C1 = "=+R[-1]C+R[-2]C"
Range("E23").FormulaR1C1 = "=+R[-4]C-R[-1]C"
Range("E24").FormulaR1C1 = s
Range("E25").FormulaR1C1 = "=+R[-2]C+R[-1]C"
Range("E26").FormulaR1C1 = "=R[-1]C*0.4"
Range("E27").FormulaR1C1 = "=+R[-2]C-R[-1]C"
Range("E28").FormulaR1C1 = "=R[-5]C/R[10]C"
Range("E29").FormulaR1C1 = "=+R[-22]C+IF(R[-20]C=0,0,(R[-17]C*R[-22]C/R[-20]C))"
Range("E30").FormulaR1C1 = "=+R[-17]C-R[-1]C"
Range("E31").FormulaR1C1 = "=+R[-25]C-R[-2]C"
Range("E32").FormulaR1C1 = "=IF(R[-13]C=0,0,R[-1]C/R[-13]C)"
Range("E33").FormulaR1C1 = "=IF(R[-10]C=0,1,R[-14]C/R[-10]C)"
Range("E34").FormulaR1C1 = "=+R[-1]C*R[-2]C"
Range("E35").FormulaR1C1 = ac
Range("E36").FormulaR1C1 = ad
Range("E37").FormulaR1C1 = ae
Range("E38").FormulaR1C1 = "=R[-3]C-R[-2]C-R[-1]C"
Range("E39").FormulaR1C1 = ag
Range("E40").FormulaR1C1 = ah
Range("E41").FormulaR1C1 = ai
Range("E42").FormulaR1C1 = "=R[-14]C[2]/R[-8]C-R[-3]C"
Range("F5").FormulaR1C1 = "After (Sonrası)"
Range("F6").FormulaR1C1 = "=+RC[-1]*(1+R[33]C[-1])"
Range("F7").FormulaR1C1 = "=+RC[-1]*(1+R[32]C[-1])"
Range("F8").FormulaR1C1 = "=+RC[-1]"
Range("F9").FormulaR1C1 = "=+R[-1]C+R[-2]C"
Range("F10").FormulaR1C1 = "=+RC[-1]"
Range("F11").FormulaR1C1 = "=-R[1]C[-1]*(1+R[-2]C[1])+R[-1]C"
Range("F12").FormulaR1C1 = "=+R[-2]C-R[-1]C"
Range("F13").FormulaR1C1 = "=+R[-4]C+R[-1]C"
Range("F14").FormulaR1C1 = "=+R[-8]C-R[-1]C"
Range("F15").FormulaR1C1 = "=+RC[-1]"
Range("F16").FormulaR1C1 = "=+RC[-1]"
Range("F17").FormulaR1C1 = "=+RC[-1]"
Range("F18").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("F19").FormulaR1C1 = "=+R[-5]C-R[-1]C"
Range("F20").FormulaR1C1 = "=+RC[-1]"
Range("F21").FormulaR1C1 = "=+RC[-1]"
Range("F22").FormulaR1C1 = "=+R[-1]C+R[-2]C"
Range("F23").FormulaR1C1 = "=+R[-4]C-R[-1]C"
Range("F24").FormulaR1C1 = "=+RC[-1]"
Range("F25").FormulaR1C1 = "=+R[-2]C+R[-1]C"
Range("F26").FormulaR1C1 = "=R[-1]C*0.4"
Range("F27").FormulaR1C1 = "=+R[-2]C-R[-1]C"
Range("F28").FormulaR1C1 = "=R[-5]C/R[10]C[-1]"
Range("F29").FormulaR1C1 = "=+R[-22]C+IF(R[-20]C=0,0,(R[-17]C*R[-22]C/R[-20]C))"
Range("F30").FormulaR1C1 = "=+R[-17]C-R[-1]C"
Range("F31").FormulaR1C1 = "=+R[-25]C-R[-2]C"
Range("G5").FormulaR1C1 = "Rate (Oranı)"
Range("G6").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G7").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G8").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G9").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G10").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G11").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G12").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G13").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G14").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G15").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G16").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G17").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G18").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G19").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G20").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G21").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G22").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G23").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G24").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G25").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G26").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G27").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G28").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G29").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G30").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("G31").FormulaR1C1 = "=IF(RC[-2]=0,0,(RC[-1]-RC[-2])/RC[-2])"
Range("I4").FormulaR1C1 = "Before Capaciti Change"
Range("I5").FormulaR1C1 = "Resources"
Range("I6").FormulaR1C1 = Kay1
Range("I9").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("I11").FormulaR1C1 = "i"
Range("I12").FormulaR1C1 = "ii"
Range("I13").FormulaR1C1 = "iii = i * ii"
Range("I14").FormulaR1C1 = "iv"
Range("I15").FormulaR1C1 = "v = iii * iv"
Range("I16").FormulaR1C1 = "vi = i + v"
Range("J5").FormulaR1C1 = "Use"
Range("J6").FormulaR1C1 = Use1
Range("J7").FormulaR1C1 = Use2
Range("J8").FormulaR1C1 = Use3
Range("J9").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("J11").FormulaR1C1 = "Operating Profit / Loss [Before Capaciti Change]"
Range("J12").FormulaR1C1 = "Capacity Change Rate"
Range("J13").FormulaR1C1 = "Operating Profit / Loss Change [1]"
Range("J14").FormulaR1C1 = Kon1
Range("J15").FormulaR1C1 = "Operating Profit / Loss Change [2]"
Range("J16").FormulaR1C1 = "Operating Profit / Loss [After Capaciti Change]"
Range("L4").FormulaR1C1 = "After Capaciti Change"
Range("L5").FormulaR1C1 = "Resources"
Range("L6").FormulaR1C1 = Kay2
Range("L9").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("M5").FormulaR1C1 = "Use"
Range("M6").FormulaR1C1 = Use4
Range("M7").FormulaR1C1 = Use5
Range("M8").FormulaR1C1 = Use6
Range("M9").FormulaR1C1 = "=+R[-1]C+R[-2]C+R[-3]C"
Range("M11").FormulaR1C1 = "=+R[-5]C[-3]"
Range("M12").FormulaR1C1 = "=+R[27]C[-8]"
Range("M13").FormulaR1C1 = "=R[-1]C*R[-2]C"
Range("M14").FormulaR1C1 = Kon2
Range("M15").FormulaR1C1 = "=+R[-1]C*R[-2]C"
Range("M16").FormulaR1C1 = "=+R[-1]C+R[-5]C"
Range("B2").FormulaR1C1 = Etiket
Columns("A:A").ColumnWidth = 1
Columns("H:H").ColumnWidth = 1
Columns("B:B").ColumnWidth = 12
Columns("C:C").ColumnWidth = 42
Columns("D:D").ColumnWidth = 42
Columns("E:F").ColumnWidth = 16
Columns("G:G").ColumnWidth = 12
Columns("I:J").ColumnWidth = 18
Columns("L:M").ColumnWidth = 18
Columns("K:K").ColumnWidth = 1
Rows("3:3").RowHeight = 6
Call MergeAlan1("B4:D5")
Call MergeAlan2("E4:G4")
Call NormalAlan("E5:G5")
With Range("B4:G5")

.Font.Bold = True
With .Interior

.ColorIndex = 34
.Pattern = xlSolid

End With

End With
Call LineTip1("B4:G42")
Call LineTip1("E4:G42")
Call LineTip1("B6:G31")
Call LineTip1("E6:G31")
Call MergeAlan2("F32:G42")
Range("G6:G31").NumberFormat = "0.00%"
Range("E32:E34").NumberFormat = "#,##0.0000"
Range("E35:E38").NumberFormat = "#,##0.00"
Range("E39:E42").NumberFormat = "0.00%"
Range("E6:E27").NumberFormat = "#,##0.00"
Range("E28").NumberFormat = "0.00%"
Range("E29:E31").NumberFormat = "#,##0.00"
Range("F6:F27").NumberFormat = "#,##0.00"
Range("F28").NumberFormat = "0.00%"
Range("F29:F31").NumberFormat = "#,##0.00"
Call MergeAlan2("I4:J4")
Call MergeAlan2("L4:M4")
Call NormalAlan("I5:J5")
Call NormalAlan("L5:M5")
With Range("I4:J5")

.Font.Bold = True
With .Interior

.ColorIndex = 34
.Pattern = xlSolid

End With

End With
With Range("L4:M5")

.Font.Bold = True
With .Interior

.ColorIndex = 34
.Pattern = xlSolid

End With

End With
Call LineTip1("I4:J9")
Call LineTip1("I4:J5")
Call LineTip1("L4:M9")
Call LineTip1("L4:M5")
Range("I6:J9").NumberFormat = "#,##0.00"
Range("L6:M9").NumberFormat = "#,##0.00"
Call MergeAlan1("I6:I8")
Call MergeAlan1("L6:L8")
With Range("I9:J9")

.Interior.ColorIndex = 34
.Interior.Pattern = xlSolid
.Font.Bold = True

End With
With Range("L9:M9")

.Font.Bold = True
With .Interior

.ColorIndex = 34
.Pattern = xlSolid

End With

End With
Range("M11").NumberFormat = "#,##0.00"
Range("M12").NumberFormat = "0.00%"
Range("M13").NumberFormat = "#,##0.00"
Range("M14").NumberFormat = "#,##0.0000"
Range("M15:M16").NumberFormat = "#,##0.00"
Call LineTip1("I11:M16")
Call LineTip1("M11:M16")
Call MergeAlan2("B2:M2")
With Range("B2:M2")

With .Font

.Bold = True
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic

End With
With .Interior

.ColorIndex = 11
.Pattern = xlSolid

End With
.Font.ColorIndex = 2
.Interior.ColorIndex = 5

End With
Call UnProtectAlan("E6:E8")
Call UnProtectAlan("E10:E11")
Call UnProtectAlan("E15:E17")
Call UnProtectAlan("E24")
Call UnProtectAlan("E35:E37")
Call UnProtectAlan("E39:E41")
Range("I11:M11").Font.Bold = True
Range("I12:M12").Font.Bold = True
Range("I14:M14").Font.Bold = True
Range("I16:M16").Font.Bold = True
With Range("J6").Interior

.ColorIndex = 40
.Pattern = xlSolid
.PatternColorIndex = 46

End With
With Range("M11").Interior

.ColorIndex = 40
.Pattern = xlSolid
.PatternColorIndex = 46

End With
With Range("M6").Interior

.ColorIndex = 37
.Pattern = xlSolid
.PatternColorIndex = 32

End With
With Range("M16").Interior

.ColorIndex = 37
.Pattern = xlSolid
.PatternColorIndex = 32

End With
Call MergeAlan3("J11:L11")
Call MergeAlan3("J12:L12")
Call MergeAlan3("J13:L13")
Call MergeAlan3("J14:L14")
Call MergeAlan3("J15:L15")
Call MergeAlan3("J16:L16")
Call Terazile
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Function
Private Function NormalAlan(Adres As String)

On Error Resume Next
With Range(Adres)

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False

End With

End Function
Private Function MergeAlan1(Adres As String)

On Error Resume Next
With Range(Adres)

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
.Merge

End With

End Function
Private Function MergeAlan2(Adres As String)

On Error Resume Next
With Range(Adres)

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Merge

End With

End Function
Private Function MergeAlan3(Adres As String)

On Error Resume Next
With Range(Adres)

.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Merge

End With

End Function
Private Function UnProtectAlan(Adres As String)

On Error Resume Next
With Range(Adres)

With .Font

.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 32

End With
.Locked = False
.FormulaHidden = False

End With

End Function
Private Function LineTip1(Adres As String)

On Error Resume Next
With Range(Adres)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.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

End Function
Private Function LineTip2(Adres As String)

On Error Resume Next
With Range(Adres)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium

End With

End Function
Private Sub Terazile()

On Error Resume Next
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 858.75, 102#, 15#, 8.25).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.IncrementLeft 6.75
Selection.ShapeRange.IncrementLeft 1.5
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 1065#, 102#, 14.25, 9#).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.IncrementLeft 6.75
Selection.ShapeRange.IncrementLeft 0.75

 End Sub

 

17 Mayıs 2011 Salı

Asal Sayı Üretimi ve Goldbach Kestirimi Testi


'UserForm1
'Mustafa ULUSARAÇ 17.Mayıs.2011


'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
'2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) İmage1
'2) Label1
'3) Label2
'4) CheckBox1
'5) ListBox1
'6) Label3
'7) Label4
'8) Label5
'9) TextBox1
'10) TextBox2
'11) TextBox3
'12) Label6
'13) ComboBox1
'14) Label7, CommandButton1
'C. Paylaşım Yolu (Share URL)
'http://cid-453d1b1a593a53f0.office.live.com/browse.aspx/GoldbachTest.xls
Option Explicit
Private i As Single, ii As Single
Private TS As Double, KS As Double, Fark As Double, Bas As Double, Son As Double, Adet As Double, No As Double
Private Kolon As Double
Private MKolon As Double
Private AS1 As Double
Private AS2 As Double
Private Kalan As Double
Private Aranan As Double
Private En As String
Private Durum As Boolean
Private Bellek(1 To 1, 1 To 99)
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Asal Sayı Üretimi (Prime Number Generation) ve Goldbach Kestirimi Testi"
Call Ekran_Duzenle
End Sub
Private Sub CheckBox1_Click()
On Error Resume Next
With CheckBox1
If .Value = True Then
.Caption = "Bir [1]; asal ise!"
Else
.Caption = "Bir [1]; asal değilse!"
End If
End With
End Sub
Private Sub TextBox1_AfterUpdate()
On Error Resume Next
TextBox1.Text = VBA.Format(TextBox1.Text, "#,##0")
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
TextBox1.Text = VBA.Format(TextBox1.Text, "##0")
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
TextBox3.Value = VBA.Format(TextBox2.Value - TextBox1.Value + 1, "#,##0")
If TextBox1.Value = 1 Then
ComboBox1.Enabled = True
Else
ComboBox1.Enabled = False
End If
End Sub
Private Sub TextBox2_AfterUpdate()
On Error Resume Next
TextBox2.Text = VBA.Format(TextBox2.Text, "#,##0")
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
TextBox2.Text = VBA.Format(TextBox2.Text, "##0")
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
TextBox3.Value = VBA.Format(TextBox2.Value - TextBox1.Value + 1, "#,##0")
End Sub
Sub CommandButton1_Click()
On Error Resume Next
Durum = False
Bas = TextBox1.Value
Son = TextBox2.Value
Adet = TextBox3.Value
ListBox1.Clear
ComboBox1.Clear
Label7.Caption = ""
DoEvents
If TextBox1.Value = 1 Then
ComboBox1.Enabled = True
Else
ComboBox1.Enabled = False
End If
If Adet > 0 Then Call Asal_Sayi_Uret
Durum = True
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
If Durum = False Then Exit Sub
Label7.Caption = ""
With ListBox1
.MultiSelect = fmMultiSelectSingle
.MultiSelect = fmMultiSelectMulti
Call Goldbach_Kestirimi_Testi(ComboBox1.Value)
.Height = 258
.Width = 450
End With
Me.Repaint
DoEvents
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 358
.Width = 467.25
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
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 = 420
.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 = 420
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With CheckBox1
.Width = 104
.Left = Me.InsideWidth - .Width - 6
.Top = 6
.Height = 24
.Caption = "Bir [1]; asal ise!"
.Value = True
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbRed
End With
With ListBox1
.Left = 6
.Top = 36
.Height = 272
.Width = 450
.SpecialEffect = fmSpecialEffectEtched
.ColumnHeads = False
.TextAlign = fmTextAlignRight
.BackColor = VBA.RGB(230, 230, 230)
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.ControlTipText = "1. Kolon: Dizin, 2. Kolon: Asal Sayılar, Diğer Kolonlar: Dizindeki sayıları bölen doğal sayıları gösterir"
End With
With Label3
.Left = 6
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Başı"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With Label4
.Left = 66
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Sonu"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With Label5
.Left = 126
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Sayısı"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With TextBox1
.Left = 6
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in alt limiti..."
.ForeColor = vbBlue
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = False
.TextAlign = fmTextAlignRight
End With
With TextBox2
.Left = 66
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in üst limiti..."
.ForeColor = vbBlue
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = False
.TextAlign = fmTextAlignRight
End With
With TextBox3
.Left = 126
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in üst limiti..."
.ForeColor = vbBlack
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = True
.TextAlign = fmTextAlignRight
End With
With CommandButton1
.Left = 192
.Top = 300
.Height = 30
.Width = 48
.Caption = "Hesapla"
End With
With Label6
.Left = 246
.Top = 300
.Height = 12
.Width = 210
.Caption = "Goldbrach Kestirimi Testi"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With ComboBox1
.Left = 246
.Top = 312
.Height = 18
.Width = 72
.BackStyle = fmBackStyleTransparent
.ColumnWidths = 60
.ListWidth = 72
.AutoSize = False
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft
.Font.Bold = True
.ForeColor = vbBlue
.ControlTipText = "Goldbrach kestirimi testinin yapılabilmesi için dizin başı değeri mutlaka 1 olmalıdır."
End With
With Label7
.Left = 318
.Top = 312
.Height = 18
.Width = 138
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
End With
End Sub
Sub Asal_Sayi_Uret()
On Error Resume Next
With ListBox1
.ColumnCount = 99
For i = 1 To 99
If 99 > i Then
En = En & "42;"
Else
En = En & "42"
End If
Bellek(1, i) = ""
Next i
.ColumnWidths = En
.List() = Bellek
No = 0
MKolon = 0
For i = Bas To Son Step 1
No = No + 1
If No > 1 Then
.AddItem ""
.List((No - 1), 1) = ""
.List((No - 1), 2) = ""
End If
Kolon = 1
For ii = 2 To (i - 1) Step 1
TS = i \ ii
KS = i / ii
Fark = TS - KS
If Fark = 0 Then
Kolon = Kolon + 1
If Kolon > MKolon Then MKolon = Kolon
.List((No - 1), Kolon) = ii
End If
Next ii
.List((No - 1), 0) = i
Aranan = VBA.Val(.List((No - 1), 2))
If CheckBox1.Value = True Then
If Aranan = 0 Then .List((No - 1), 1) = i
Else
If Aranan = 0 And No > 1 Then .List((No - 1), 1) = i
End If
.ListIndex = (No - 1)
DoEvents
Next i
.Selected((No - 1)) = True
.ControlTipText = "1. Kolon: Dizin, 2. Kolon: Asal Sayılar, Diğer " & (MKolon + 1 - 2) & " Kolon: Dizindeki sayıları bölen doğal sayıları gösterir" '.ColumnCount = MKolon + 2

.Selected((No - 1)) = True
.Height = 258
.Width = 450
DoEvents
For i = 1 To Adet
TS = ListBox1.List((i - 1), 0) \ 2
KS = ListBox1.List((i - 1), 0) / 2
Fark = TS - KS
If Fark = 0 Then ComboBox1.AddItem ListBox1.List((i - 1), 0)
Next i
End With
End Sub
Private Sub Goldbach_Kestirimi_Testi(TestV As Double)
On Error Resume Next
For i = 0 To (Adet - 1)
AS1 = VBA.Val(ListBox1.List(i, 1))
If AS1 > 0 Then
Kalan = TestV - AS1
For ii = 0 To (Adet - 1)
AS2 = VBA.Val(ListBox1.List(ii, 1))
If AS2 > 0 And AS1 <> AS2 And AS2 = Kalan Then GoTo Tamam
Next ii
End If
Next i
Exit Sub
Tamam:
Label7.Caption = AS1 & " - " & AS2
ListBox1.Selected((AS1 - 1)) = True
ListBox1.Selected((AS2 - 1)) = True
End Sub


'Module1
'Mustafa ULUSARAÇ 17.Mayıs.2011


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}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
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

15 Mayıs 2011 Pazar

Getting a Folder's ID


'UserForm1


'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
'2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'A. Available Tools List
'1) İmage1
'2) Label1
'3) Label2
'4) ComboBox1
'5) ComboBox2
'6) Label3
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private i As Single
Private GF As String
Private BI As BROWSEINFO
Private GFPath As String
Private GFList As Long
Private GFFolder As Long
Private GFPosition As Integer
Private pidlRootList(1 To 62, 1 To 1)
Private ulFlagsList(1 To 12, 1 To 2)
Private Sub UserForm_Initialize()
Me.Caption = "[PBİD®] Getting a Folder's ID"
Call pidlRootList_Kur
Call ulFlagsList_Kur
Call Ekran_Duzenle
End Sub
Sub ComboBox1_Click()
On Error Resume Next
GF = GetFolder("[PBİD®] Klasör Seçimi", ComboBox1.ListIndex, ComboBox2.List(ComboBox2.ListIndex, 1))
If GF = "" Then Exit Sub
Label3.Caption = GF
End Sub
Sub ComboBox2_Click()
On Error Resume Next
GF = GetFolder("[PBİD®] Klasör Seçimi", ComboBox1.ListIndex, ComboBox2.List(ComboBox2.ListIndex, 1))
If GF = "" Then Exit Sub
Label3.Caption = GF
End Sub
Function GetFolder(Optional Msg, Optional RN As Long, Optional FN As Long) As String
On Error Resume Next
BI.pidlRoot = RN&
BI.lpszTitle = Msg
BI.ulFlags = FN
GFFolder = SHBrowseForFolder(BI)
GFPath = Space$(512)
GFList = SHGetPathFromIDList(ByVal GFFolder, ByVal GFPath)
If GFList Then
GFPosition = InStr(GFPath, Chr$(0))
GetFolder = Left(GFPath, GFPosition - 1)
Else
GetFolder = ""
End If
End Function
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 250
.Width = 240
.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 ComboBox1
.ColumnCount = 1
.Left = 6
.Top = 36
.Height = 18
.Width = 222
.BackStyle = fmBackStyleOpaque
.BackColor = vbWhite
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectEtched
.List() = pidlRootList
End With
With ComboBox2
.ColumnCount = 2
.ColumnWidths = "160;42"
.Left = 6
.Top = 60
.Height = 18
.Width = 222
.BackStyle = fmBackStyleOpaque
.BackColor = vbWhite
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectEtched
.List() = ulFlagsList
End With
With Label3
.Left = 6
.Top = 84
.Height = 138
.Width = 222
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = &H404000
End With
End With
End Sub
Private Sub pidlRootList_Kur()
On Error Resume Next
pidlRootList(1, 1) = "My Computer (Desktop)"
pidlRootList(2, 1) = "IE "
pidlRootList(3, 1) = "Programs"
pidlRootList(4, 1) = "ControlPanel"
pidlRootList(5, 1) = "InstalledPrinters"
pidlRootList(6, 1) = "Personal"
pidlRootList(7, 1) = "Favorites"
pidlRootList(8, 1) = "StartupPmGroup"
pidlRootList(9, 1) = "RecentDocDir"
pidlRootList(10, 1) = "SendToItemsDir"
pidlRootList(11, 1) = "RecycleBin"
pidlRootList(12, 1) = "StartMenu"
pidlRootList(13, 1) = "DesktopDirectory"
pidlRootList(14, 1) = "MyComputer"
pidlRootList(15, 1) = "NetworkNeighborhood"
pidlRootList(16, 1) = "NetHoodFileSystemDir"
pidlRootList(17, 1) = "Fonts"
pidlRootList(18, 1) = "Templates"
pidlRootList(19, 1) = "Network"
pidlRootList(20, 1) = "Network Shortcuts"
pidlRootList(21, 1) = "Fonts"
pidlRootList(22, 1) = "Templates"
pidlRootList(23, 1) = "Start Menu"
pidlRootList(24, 1) = "Programs"
pidlRootList(25, 1) = "Start-Fancy"
pidlRootList(26, 1) = "ShareDesktop"
pidlRootList(27, 1) = "Roaming"
pidlRootList(28, 1) = "MyPictures"
pidlRootList(29, 1) = "Local"
pidlRootList(30, 1) = "Start-OneNote"
pidlRootList(31, 1) = "Start-Bluetooth"
pidlRootList(32, 1) = "NetAndDialUpConnections"
pidlRootList(33, 1) = "Temporary Internet Files"
pidlRootList(34, 1) = "Cookies"
pidlRootList(35, 1) = "History"
pidlRootList(36, 1) = "ProgramData"
pidlRootList(37, 1) = "Windows"
pidlRootList(38, 1) = "System32"
pidlRootList(39, 1) = "Program Files (x86)"
pidlRootList(40, 1) = "MyPictures"
pidlRootList(41, 1) = "Administrator"
pidlRootList(42, 1) = "Syswow64"
pidlRootList(43, 1) = "Program Files (x86)"
pidlRootList(44, 1) = "Common Files"
pidlRootList(45, 1) = "Common Files"
pidlRootList(46, 1) = "Templates"
pidlRootList(47, 1) = "Share Documents"
pidlRootList(48, 1) = "Manegment Tools"
pidlRootList(49, 1) = "Manegment Tools"
pidlRootList(50, 1) = "Network Connections"
pidlRootList(51, 1) = ""
pidlRootList(52, 1) = ""
pidlRootList(53, 1) = ""
pidlRootList(54, 1) = "Share Music"
pidlRootList(55, 1) = "Share Picture"
pidlRootList(56, 1) = "Share Video"
pidlRootList(57, 1) = "Resources"
pidlRootList(58, 1) = ""
pidlRootList(59, 1) = "OEM Links"
pidlRootList(60, 1) = "Temporary Print Folder"
pidlRootList(61, 1) = ""
pidlRootList(62, 1) = "PC"
End Sub
Private Sub ulFlagsList_Kur()
On Error Resume Next
ulFlagsList(1, 1) = "RETURNONLYFSDIRS": ulFlagsList(1, 2) = "1"
ulFlagsList(2, 1) = "DONTGOBELOWDOMAIN": ulFlagsList(2, 2) = "2"
ulFlagsList(3, 1) = "STATUSTEXT": ulFlagsList(3, 2) = "4"
ulFlagsList(4, 1) = "RETURNFSANCESTORS": ulFlagsList(4, 2) = "8"
ulFlagsList(5, 1) = "EDITBOX": ulFlagsList(5, 2) = "16"
ulFlagsList(6, 1) = "VALIDATE": ulFlagsList(6, 2) = "32"
ulFlagsList(7, 1) = "NEWDIALOGSTYLE": ulFlagsList(7, 2) = "64"
ulFlagsList(8, 1) = "BROWSEINCLUDEURLS": ulFlagsList(8, 2) = "128"
ulFlagsList(9, 1) = "BROWSEFORCOMPUTER": ulFlagsList(9, 2) = "&H1000"
ulFlagsList(10, 1) = "BROWSEFORPRINTER": ulFlagsList(10, 2) = "&H2000"
ulFlagsList(11, 1) = "BROWSEINCLUDEFILES": ulFlagsList(11, 2) = "&H4000"
ulFlagsList(12, 1) = "SHAREABLE": ulFlagsList(12, 2) = "&H8000"
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}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
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