Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2012 Çarşamba

CreateMetaFile Function



'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) Label3
'3) CommandButton1, Frame1
Option Explicit
Private i As Single
Private ii As Single
Private hWnd As Long
Private hDC As Long
Private hPoint1 As Long
Private hPoint2 As Long
Private hColor As Long
Private R As Double
Private G As Double
Private B As Double
Private hFile As String
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private PA As POINTAPI
Private Declare Function CreateMetaFile Lib "gdi32" Alias "CreateMetaFileA" (ByVal lpString As String) As Long
Private Declare Function CloseMetaFile Lib "gdi32" (ByVal hMF As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Drawing As Boolean
Private hMF As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Me.Caption = "[PBİD®] CreateMetaFile Function"
Call Ekran_Kur
hWnd = FindWindow("ThunderDFrame", Me.Caption)
hDC = GetDC(hWnd)
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
CloseMetaFile hMF
Application.Visible = True
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
If Button And 1 Then
Drawing = True
Else
Drawing = False
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
If Drawing Then
LineTo hDC, (x / 0.748), (y / 0.748)
LineTo hMF, (x / 0.748), (y / 0.748)
MoveToEx hMF, (x / 0.748), (y / 0.748), PA
End If
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
Drawing = False
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
If CommandButton1.Caption = "Create WMF" Then
VBA.Kill Label3.Caption
hMF = CreateMetaFile(Label3.Caption)
If hMF = 0 Then
MsgBox Label3.Caption & " MetaFile can not created.", vbCritical, "[PBİD®] CreateMetaFile API Function"
Exit Sub
End If
Me.Picture = Me.Picture
CommandButton1.Caption = "Open WMF"
Call Create_WMF
Else
CloseMetaFile hMF
CommandButton1.Caption = "Create WMF"
Call Open_WMF(hFile)
End If
Exit Sub
End Sub
Private Sub Create_WMF()
On Error Resume Next
Dim x As Long
Dim y As Long
hWnd = FindWindow("ThunderDFrame", Me.Caption)
hPoint1 = GetDC(hWnd)
Me.Repaint
Frame1.SetFocus
hWnd = VBA.CStr(GetFocus)
hPoint2 = GetDC(hWnd)
For i = 1 To Frame1.InsideWidth / 0.748
For ii = 1 To Frame1.InsideHeight / 0.748
hColor = GetPixel(hPoint2, i, ii)
R = VBA.Int(hColor Mod 256)
G = VBA.Int((hColor Mod 65536) / 256)
B = VBA.Int(hColor / 65536)
x = i + (6 / 0.748)
y = ii + ((Label3.Top + Label3.Height) / 0.748)
SetPixel hPoint1, x, y, VBA.RGB(R, G, B)
SetPixel hMF, x, y, VBA.RGB(R, G, B)
MoveToEx hMF, i, ii, PA
DoEvents
Next ii
Next i
End Sub
Function Open_WMF(sFile)
On Error GoTo Error_Handler
Shell VBA.Chr(34) & "C:\Windows\System32\mspaint.exe" & VBA.Chr(34) & " " & VBA.Chr(34) & sFile & Chr(34), vbNormalFocus
If VBA.Err.Number = 0 Then Exit Function
Error_Handler:
VBA.Err.Clear
MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Source: Open WMF" & vbCrLf & "Error Description: " & Err.Description, vbCritical, "[PBİD®] WMF Open"
Exit Function
End Function
Private Sub Create_OLEObject()
On Error Resume Next
Dim hFrame As OLEObject
Set hFrame = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Frame.1", Link:=False, DisplayAsIcon:=False, Left:=0, Top:=0, Width:=36, Height:=36)
With hFrame
.Object.Caption = ""
.Object.Picture = Resim(URL3)
.Object.PictureAlignment = fmPictureAlignmentCenter
.Object.PictureSizeMode = fmPictureSizeModeStretch
.Object.PictureTiling = False
.Border.LineStyle = fmBorderStyleNone
.Width = .Object.Picture.Width
.Height = .Object.Picture.Height
.Object.SetFocus
hWnd = VBA.CStr(GetFocus)
hPoint2 = GetDC(hWnd)
End With
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 324
.Width = 492
'.Picture = Resim(URL1)

.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
.ForeColor = vbRed
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 Label3
.Left = 6
.Top = 36
.Height = 18
.Width = 474
hFile = ThisWorkbook.Path
If VBA.Right$(hFile, 1) <> "\" Then
hFile = hFile & "\"
hFile = hFile & "CreateWmf.wmf"
End If
.Caption = hFile
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
End With
With CommandButton1
.Top = 138
.Left = 318
.Height = 24
.Width = 162
.Caption = "Create WMF"
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = &H808000
End With
With Frame1
.Caption = ""
.Top = 168
.Left = 318
.Height = 126
.Width = 162
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
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://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(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