Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Kasım 2011 Perşembe

Clipboard Functions

'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
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) ListBox1
Option Explicit
Private i As Integer
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Veriler As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Resimler As uPicDesc
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private OC As Long
Private OCPI As Long
Private hAvail As Long
Private hPtr As Long
Private hPal As Long
Private hCopy As Long
Private lType As Long
Private IPic As IPicture
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Clipboard Functions"
Call Ekran_Duzenle
Call Shape_Create
End Sub
Private Sub Listbox1_Click()
On Error Resume Next
ActiveSheet.Shapes(ListBox1).Copy
Me.Picture = Get_Picture
End Sub
Function Get_Picture(Optional lXlPicType As Long = xlPicture) As IPicture
On Error GoTo Hata
lType = IIf(lXlPicType = xlBitmap, 2, 14)
hAvail = IsClipboardFormatAvailable(lType)
If hAvail <> 0 Then
OC = OpenClipboard(0&)
If OC > 0 Then
hPtr = GetClipboardData(lType)
If lType = 2 Then
hCopy = CopyImage(hPtr, 0, 0, 0, &H4)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
OC = CloseClipboard
If hPtr <> 0 Then Set Get_Picture = Create_Picture(hCopy, 0, lType)
End If
End If
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Function Create_Picture(ByVal hPic As Long, ByVal hPal As Long, ByVal lType) As IPicture
On Error GoTo Hata
With Veriler
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With Resimler
.Size = Len(Resimler)
.Type = IIf(lType = 2, 1, 4)
.hPic = hPic
.hPal = IIf(lType = 2, hPal, 0)
End With
OCPI = OleCreatePictureIndirect(Resimler, Veriler, True, IPic)
Set Create_Picture = IPic
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 356
.Width = 408
.Picture = Nothing
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.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 = 270
.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 = 270
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With ListBox1
.Left = 312
.Top = 6
.Height = 24
.Width = 86
.ColumnCount = 1
.ColumnWidths = "74"
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End Sub
Private Sub Shape_Create()
On Error Resume Next
ActiveSheet.DrawingObjects.Select
Selection.Delete
Range("A1").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangularCallout, 15#, 5.25, 64.5, 31.5).Select
Range("C1").Select: ActiveSheet.Shapes.AddShape(msoShapeFlowchartMultidocument, 97.5, 3#, 91.5, 41.25).Select
Range("E1").Select: ActiveSheet.Shapes.AddShape(msoShapeNoSymbol, 197.25, 3#, 42#, 43.5).Select
Range("A6").Select: ActiveSheet.Shapes.AddShape(msoShapeSun, 5.25, 50.25, 66.75, 73.5).Select
Range("C6").Select: ActiveSheet.Shapes.AddShape(msoShapeDownRibbon, 95.25, 62.25, 142.5, 60#).Select
Range("A12").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0.75, 140.25, 84.75, 12.75).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
Range("C14").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 96.75, 167.25, 95.25, 10.5).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 85.5, 147#, 60.75, 20).Select
Range("A16").Select: ActiveSheet.Shapes.AddShape(msoShapeStripedRightArrow, 6#, 192.75, 235.5, 26.25).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 65
.OneColorGradient msoGradientVertical, 1, 0.23
End With
End With
For i = 1 To ActiveSheet.Shapes.Count
ListBox1.AddItem ActiveSheet.Shapes(i).Name
Next i
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 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(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

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