Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Temmuz 2012 Pazar

ScreenShot Report



'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) İmage1, Label1, Label2
'2) Frame1
'3) CommandButton1, Slider1
Private eFile As String
Private eRange As Range
Private eSheet As Worksheet
Private eChart As Chart
Private ePicture As Picture
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] ScreenShot Report"
Call Ekran_Kur
If Sheets(1).Range("D3").Value <> "USD" Then Call Rapor_Kur
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Application.DisplayAlerts = False
eFile = ThisWorkbook.Path & "\ScreenShotReport.jpg"
Frame1.Caption = "ScreenShotReport; " & eFile
Set eRange = Sheets(1).Range("A1:D32")
Set eSheet = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=eSheet.Name
Set eChart = ActiveChart
With ActiveSheet.Shapes("Chart 1")
.ScaleWidth 6, msoFalse, msoScaleFromBottomRight
.ScaleHeight 6, msoFalse, msoScaleFromBottomRight
.ScaleWidth 6, msoFalse, msoScaleFromTopLeft
.ScaleHeight 6, msoFalse, msoScaleFromTopLeft
End With
VBA.DoEvents
eRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
eChart.Paste
Set ePicture = Selection
With eChart
.Parent.Width = ePicture.Width + 6
.Parent.Height = ePicture.Height + 6
.Export Filename:=eFile, FilterName:="jpg"
End With
With Frame1
.Picture = LoadPicture(eFile)
.ScrollWidth = eChart.Parent.Width
.ScrollHeight = eChart.Parent.Height
.ScrollTop = 0
.ScrollLeft = 0
End With
'Kill eFile    

eSheet.Delete
Application.DisplayAlerts = True
End Sub
Private Sub Slider1_Click()
On Error Resume Next
Frame1.Zoom = Slider1.Value * 100
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 386
.Width = 496
.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 Frame1
.Left = 6
.Top = 36
.Height = 294
.Width = 480
.Caption = "ScreenShot Report"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Font.Bold = True
.ForeColor = &H808000
.ScrollBars = fmScrollBarsBoth
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With CommandButton1
.Left = 6
.Top = 336
.Height = 24
.Width = 114
.Caption = "Create ScreenShot Report"
.ForeColor = &H808000
End With
With Slider1
.Left = 126
.Top = 336
.Height = 24
.Width = 360
.Min = 1
.Max = 4
.BorderStyle = ccNone
.LargeChange = 1
.SmallChange = 1
.TextPosition = sldBelowRight
End With
End With
End Sub
Private Sub Rapor_Kur()
On Error Resume Next
Dim hOLE_OBJECT As Object
Sheets(1).Select
ActiveSheet.Unprotect
ActiveSheet.DrawingObjects.Select
Selection.Delete
Cells.Select
Selection.Delete Shift:=xlUp
Range("A6:C32").NumberFormat = "@"
Range("B1").FormulaR1C1 = "ÖRNEK A.Ş."
Range("B2").FormulaR1C1 = "ÖRNEK İNŞAAT PROJESİ"
Range("B3").FormulaR1C1 = "GELİR DURUMU"
Range("A5").FormulaR1C1 = "İşlem tanımı"
Range("A6").FormulaR1C1 = "1"
Range("A7").FormulaR1C1 = "1.1"
Range("A8").FormulaR1C1 = "1.2"
Range("A9").FormulaR1C1 = "2"
Range("A10").FormulaR1C1 = "2.1"
Range("A11").FormulaR1C1 = "'2.1.1"
Range("A12").FormulaR1C1 = "2.1.1.1"
Range("A13").FormulaR1C1 = "2.1.1.2"
Range("A14").FormulaR1C1 = "2.1.1.3"
Range("A15").FormulaR1C1 = "2.1.1.4"
Range("A16").FormulaR1C1 = "2.1.1.5"
Range("A17").FormulaR1C1 = "'2.1.2"
Range("A18").FormulaR1C1 = "2.1.2.1"
Range("A19").FormulaR1C1 = "2.1.2.2"
Range("A20").FormulaR1C1 = "2.1.2.3"
Range("A21").FormulaR1C1 = "2.1.2.4"
Range("A22").FormulaR1C1 = "2.1.2.5"
Range("A23").FormulaR1C1 = "'2.1.3"
Range("A24").FormulaR1C1 = "'2.2"
Range("A25").FormulaR1C1 = "'2.2.1"
Range("A26").FormulaR1C1 = "'2.2.2"
Range("A27").FormulaR1C1 = "3"
Range("A28").FormulaR1C1 = "4"
Range("A29").FormulaR1C1 = "'4.1"
Range("A30").FormulaR1C1 = "'4.2"
Range("A31").FormulaR1C1 = "'4.3"
Range("A32").FormulaR1C1 = "5"
Range("B6").FormulaR1C1 = "'GELİRLER"
Range("B7").FormulaR1C1 = " Hakediş Gelirleri"
Range("B8").FormulaR1C1 = " Diğer Satış Gelirleri"
Range("B9").FormulaR1C1 = "'TOPLAM MALiYET"
Range("B10").FormulaR1C1 = " ÜRETİM MALİYETLERİ"
Range("B11").FormulaR1C1 = " Değişken Üretim Maliyetleri"
Range("B12").FormulaR1C1 = " Direkt İlk Madde ve Malzeme Gideri"
Range("B13").FormulaR1C1 = " Malzemeli Uzman Ekip Gideri"
Range("B14").FormulaR1C1 = " Malzemesiz Uzman Ekip Gideri"
Range("B15").FormulaR1C1 = " Direkt İşçilik Gideri"
Range("B16").FormulaR1C1 = " Dışardan Sağlanan Fayda ve Hizmetler"
Range("B17").FormulaR1C1 = " Sabit Üretim Maliyetleri"
Range("B18").FormulaR1C1 = " Endirekt İşçilik Gideri"
Range("B19").FormulaR1C1 = " Memur Ücret ve Giderleri"
Range("B20").FormulaR1C1 = " Çeşitli Giderler"
Range("B21").FormulaR1C1 = " Vergi Resim ve harçlar"
Range("B22").FormulaR1C1 = " Amortisman ve Tükenme Payları"
Range("B23").FormulaR1C1 = " Finansman Giderleri"
Range("B24").FormulaR1C1 = " ÜRETİM DIŞI GİDERLER"
Range("B25").FormulaR1C1 = " ÖRNEK A.Ş. Merkez Masraf Paylari"
Range("B26").FormulaR1C1 = " Proje Komisyon Giderleri"
Range("B27").FormulaR1C1 = "'FAALiYET K/Z [1-2]"
Range("B28").FormulaR1C1 = "'FAALiYET DIŞI K/Z"
Range("B29").FormulaR1C1 = " Faaliyet Dışı Gelir ve Karlar"
Range("B30").FormulaR1C1 = " Faaliyet Dışı Gider ve Zararlar"
Range("B31").FormulaR1C1 = " Agio ( +/- )"
Range("B32").FormulaR1C1 = "PROJE K/Z [3+4]"
Range("C5").FormulaR1C1 = "Description"
Range("C6").FormulaR1C1 = "INCOME"
Range("C7").FormulaR1C1 = " Progress Income"
Range("C8").FormulaR1C1 = " Other Sales"
Range("C9").FormulaR1C1 = "'TOTAL COST'"
Range("C10").FormulaR1C1 = " PRODUCTION COSTS"
Range("C11").FormulaR1C1 = " Variable Production Costs"
Range("C12").FormulaR1C1 = " Direct Raw Materials and Supplies Expense"
Range("C13").FormulaR1C1 = " Expert Team with material expense"
Range("C14").FormulaR1C1 = " Without equipment Expert Team Expense"
Range("C15").FormulaR1C1 = " Direct Labor Expense"
Range("C16").FormulaR1C1 = " Externally Provided Benefits and Services"
Range("C17").FormulaR1C1 = " Fixed Production Costs"
Range("C18").FormulaR1C1 = " Indirect Labor Expense"
Range("C19").FormulaR1C1 = " Officer Fees and Expenses"
Range("C20").FormulaR1C1 = " Miscellaneous Expenses"
Range("C21").FormulaR1C1 = " Taxes and Fees"
Range("C22").FormulaR1C1 = " Depreciation and amortization"
Range("C23").FormulaR1C1 = " Financial Expenses"
Range("C24").FormulaR1C1 = " NON-PRODUCTION EXPENSES"
Range("C25").FormulaR1C1 = " SAMPLE Inc. Central Cost Shares"
Range("C26").FormulaR1C1 = " Project Commission Expenses"
Range("C27").FormulaR1C1 = "'OPERATING PROFIT / LOSS [1-2]"
Range("C28").FormulaR1C1 = "ACTIVITY OF NON PROFIT / LOSS"
Range("C29").FormulaR1C1 = " Non-Operating Income and Profits"
Range("C30").FormulaR1C1 = " Non-Operating Expenses and Losses"
Range("C31").FormulaR1C1 = " Agio (/ -)"
Range("C32").FormulaR1C1 = "PROJECT PROFIT / LOSS [3 4]"
Range("D6").FormulaR1C1 = "=R[1]C+R[2]C"
Range("D9").FormulaR1C1 = "=R[1]C+R[15]C"
Range("D10").FormulaR1C1 = "=R[1]C+R[7]C+R[13]C"
Range("D11").FormulaR1C1 = "=R[1]C+R[2]C+R[3]C+R[4]C+R[5]C"
Range("D17").FormulaR1C1 = "=R[1]C+R[2]C+R[3]C+R[4]C+R[5]C"
Range("D24").FormulaR1C1 = "=R[1]C+R[2]C"
Range("D27").FormulaR1C1 = "=R[-21]C-R[-18]C"
Range("D28").FormulaR1C1 = "=R[1]C-R[2]C+R[3]C"
Range("D32").FormulaR1C1 = "=R[-5]C+R[-4]C"
Range("D7").FormulaR1C1 = 35531747.34
Range("D8").FormulaR1C1 = 0
Range("D12").FormulaR1C1 = 24063822.5
Range("D13").FormulaR1C1 = 1393158.36
Range("D14").FormulaR1C1 = 6250376.39
Range("D15").FormulaR1C1 = 1956506.77
Range("D16").FormulaR1C1 = 5593582.31
Range("D18").FormulaR1C1 = 773736
Range("D19").FormulaR1C1 = 3104892.7
Range("D20").FormulaR1C1 = 684840
Range("D21").FormulaR1C1 = 0
Range("D22").FormulaR1C1 = 0
Range("D23").FormulaR1C1 = 2465800
Range("D25").FormulaR1C1 = 1091434.7
Range("D26").FormulaR1C1 = 0
Range("D29").FormulaR1C1 = 0
Range("D30").FormulaR1C1 = 0
Range("D31").FormulaR1C1 = -1475685
Range("A5:D6, A9:D10, A24:D24, A27:D28, A32:D32, B1:B3, D2:D3").Font.FontStyle = "Bold"
Rows("4:4").RowHeight = 6
With Range("D7:D8, D12:D16, D18:D23, D25:D26, D29:D31")
.Font.ColorIndex = 32
.Locked = False
.FormulaHidden = False
End With
Range("D5").FormulaR1C1 = "Toplam"
Range("D5:D32").NumberFormat = "#,##0.00"
With Range("A5:D32")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range("D5:D32")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range("A5:D5")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Font.Bold = True
End With
With Range("D2:D3")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range("D2")
.FormulaR1C1 = "=NOW()"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Font.Bold = True
End With
With Range("D3")
.FormulaR1C1 = "USD"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Font.Bold = True
End With
With Range("A5:D5")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.HorizontalAlignment = xlCenter
End With
Range("A5:B5").Merge
Set hOLE_OBJECT = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=48, Height:=40)
With hOLE_OBJECT.Object
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
End With
Columns("A:A").ColumnWidth = 8.43
Columns("B:C").ColumnWidth = 60
Columns("D:D").ColumnWidth = 16
Range("A5:D32").Font.Size = 10
ActiveSheet.Protect
Range("D3").Select
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://2.bp.blogspot.com/-g5n-KmkMtW8/TmvRrcyDWwI/AAAAAAAAC1Y/ykFDewhbCSw/s1600/Baret2.jpg"
Public URL As String
Sub Form_Aç()
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(3).Cells(No, 1) = No & ") Name: "
' Sheets(3).Cells(No, 2) = Eleman.Name
' Sheets(3).Cells(No, 3) = ", Description: "
' Sheets(3).Cells(No, 4) = Eleman.Description
' Sheets(3).Cells(No, 5) = ", FullPath: "
' Sheets(3).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