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