Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Aralık 2012 Pazartesi

RGB to Gray Color Model Conversion


'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) Image1, Label1, Label2, CommandButton1
'2) Label3, Label4, label5, Label6
'3) Frame1, Frame2, Frame3, Frame4
Option Explicit
Private i As Long
Private ii As Long
Private hRed As Long
Private hGreen As Long
Private hBlue As Long
Private hGray As Long
Private hBlackWhite As Long
Private hPoint As Long
Private hWidth As Long
Private hHeight As Long
Private Const Rp1 As Double = 0.25
Private Const Gp1 As Double = 0.654508
Private Const Bp1 As Double = 0.095492
Private Const Rp2 As Double = 0.299
Private Const Gp2 As Double = 0.587
Private Const Bp2 As Double = 0.114
Private Const Rp3 As Double = 0.2126
Private Const Gp3 As Double = 0.7152
Private Const Bp3 As Double = 0.0722
Private hWnd1 As Long
Private hDC1 As Long
Private hWnd2 As Long
Private hDC2 As Long
Private hWnd3 As Long
Private hDC3 As Long
Private hWnd4 As Long
Private hDC4 As Long
Private Declare Function GetFocus Lib "user32.dll" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®]RGB to Gray Color Model Conversion"
Call hDC_Kur
Call Ekran_Kur
Application.Visible = False
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
DestroyWindow hWnd1
DestroyWindow hWnd2
DestroyWindow hWnd3
DestroyWindow hWnd4
DeleteDC hDC1
DeleteDC hDC2
DeleteDC hDC3
DeleteDC hDC4
Application.Visible = True
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
hWidth = Frame1.Width / 0.75
hHeight = Frame1.Height / 0.75
For i = 1 To hWidth
For ii = 1 To hHeight
hPoint = GetPixel(hDC1, i, ii)
hRed = VBA.Int(hPoint Mod 256)
hGreen = VBA.Int((hPoint Mod 65536) / 256)
hBlue = VBA.Int(hPoint / 65536)
hGray = (Rp1 * hRed + Gp1 * hGreen + Bp1 * hBlue)
hBlackWhite = VBA.RGB(hGray, hGray, hGray)
SetPixel hDC2, i, ii, hBlackWhite
hRed = VBA.Int(hPoint Mod 256)
hGreen = VBA.Int((hPoint Mod 65536) / 256)
hBlue = VBA.Int(hPoint / 65536)
hGray = (Rp2 * hRed + Gp2 * hGreen + Bp2 * hBlue)
hBlackWhite = VBA.RGB(hGray, hGray, hGray)
SetPixel hDC3, i, ii, hBlackWhite
hRed = VBA.Int(hPoint Mod 256)
hGreen = VBA.Int((hPoint Mod 65536) / 256)
hBlue = VBA.Int(hPoint / 65536)
hGray = (Rp3 * hRed + Gp3 * hGreen + Bp3 * hBlue)
hBlackWhite = VBA.RGB(hGray, hGray, hGray)
SetPixel hDC4, i, ii, hBlackWhite
VBA.DoEvents
Next ii
Next i
End Sub
Private Sub hDC_Kur()
On Error Resume Next
Frame1.SetFocus
hWnd1 = GetFocus()
hDC1 = GetDC(hWnd1)
Frame2.SetFocus
hWnd2 = GetFocus()
hDC2 = GetDC(hWnd2)
Frame3.SetFocus
hWnd3 = GetFocus()
hDC3 = GetDC(hWnd3)
Frame4.SetFocus
hWnd4 = GetFocus()
hDC4 = GetDC(hWnd4)
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 298
.Width = 684
.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 CommandButton1
.Left = 510
.Top = 6
.Height = 24
.Width = 162
.Caption = "Make Gray Picture"
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = &H808000
End With
With Label3
.Left = 6
.Top = 36
.Height = 18
.Width = 162
.Caption = "R * %100 + G %100 + B * %100"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Label4
.Left = 174
.Top = 36
.Height = 18
.Width = 162
.Caption = "R * %25 + G * %65,4508 + B * %9,5492"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Label5
.Left = 342
.Top = 36
.Height = 18
.Width = 162
.Caption = "R * %29,9 + G * %58,7 + B * %11,4"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Label6
.Left = 510
.Top = 36
.Height = 18
.Width = 162
.Caption = "R * %21,26 + G * %71,52 + B * %7,22"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Frame1
.Left = 6
.Top = 54
.Height = 216
.Width = 162
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
.Picture = Resim(URL3)
End With
With Frame2
.Left = 174
.Top = 54
.Height = 216
.Width = 162
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
.Picture = LoadPicture("")
End With
With Frame3
.Left = 342
.Top = 54
.Height = 216
.Width = 162
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
.Picture = LoadPicture("")
End With
With Frame4
.Left = 510
.Top = 54
.Height = 216
.Width = 162
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
.Picture = LoadPicture("")
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://4.bp.blogspot.com/-3N1MPaxBLqw/T7jICAMt1qI/AAAAAAAADGc/ZFMOiE8uftQ/s1600/1891+A+Pompeian+Lady+-+Classical+Beauty+-+%5BJohn+William+Godward%5D.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

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