Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Aralık 2012 Cumartesi

RGB to RYB & CMYK 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
'6) Name: MSComCtl2, Description: Microsoft Windows Common Controls-2 6.0 (SP6), FullPath: C:\Windows\SysWow64\MSCOMCT2.OCX
'7) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\Windows\SysWOW64\MSCOMCTL.OCX
'B. Available Tools List
'1) Image1, Label1, Label2
'2) Toolbar1, ScrollBar1, ScrollBar2, ScrollBar3
'3) ProgressBar1, Image2, Frame1
'C. Sample Images
'1) [RGB]= http://www.expresscards.com.au/blog/wp-content/uploads/RGB-Colour-300x298.jpg
'2) [RYB]= http://2.bp.blogspot.com/-stZz9KgjPok/T5a3T6KJSUI/AAAAAAAADFI/npL3tSz4LGM/s1600/Color_star-en_Wiki.bmp
'3) [CMYK]= http://4.bp.blogspot.com/-CO4JWNySXyM/T5a3GlGerQI/AAAAAAAADFA/wjKthAWvcbc/s1600/CMYK_farbwuerfel_Wiki.bmp
'4) [Pompeian Lady]= "http://4.bp.blogspot.com/-3N1MPaxBLqw/T7jICAMt1qI/AAAAAAAADGc/ZFMOiE8uftQ/s1600/1891+A+Pompeian+Lady+-+Classical+Beauty+-+%5BJohn+William+Godward%5D.jpg"
'5) [Mona Lisa]= "http://4.bp.blogspot.com/-NwwGFzhLslw/T8I566gT7VI/AAAAAAAADG4/0XhLrhmRgO0/s1600/Mona_Lisa.jpg"
Option Explicit
'Screen API & Dimention
Private Declare Function GetFocus Lib "user32" () 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" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hdc 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 hWnd0 As Long
Private hDC0 As Long
Private hWnd1 As Long
Private hDC1 As Long
'Fix Tamplate API & Dimention
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private LPX As Integer 'LogPixelsX
Private LPY As Integer 'LogPixelsY
Private ITP As Integer 'InchesToPoints
Private CTPX As Double 'CentimetersToPointsX
Private CTPY As Double 'CentimetersToPointsY
'Additional Tools & Common Dimention
Private i As Double
Private ii As Double
Private No As Long
Private TBB As Integer
Private hLabel(3 To 53) As New Control
'Picture Dimention
Private tFile As String
Private pFile As Variant
Private pByte As Long
Private pWidth As Long
Private pHeight As Long
Private pWidthPix As Long
Private pHeightPix As Long
Private pWidthDpi As Long
Private pHeightDpi As Long
Private pWidthCm As Long
Private pHeightCm As Long
Private pPoint As Long
'RGB Dimention
Private hColor As Long
Private RGBRed As Long
Private RGBGreen As Long
Private RGBBlue As Long
Private hRGB As Long
Private hHex As Variant
'RYB Dimention
Private RYBRed As Double
Private RYBYellow As Double
Private RYBBlue As Double
Private RYBWhite As Double
Private RYBBlack As Double
Private RYBwRed As Double
Private RYBwGreen As Double
Private RYBwBlue As Double
Private RYBPartGreen As Double
Private RYBPartYellow As Double
Private RYBHalfGreen As Double
Private RYBHalfYellow As Double
'CMYK Dimention
Private CMYKCyan As Double
Private CMYKMagenta As Double
Private CMYKYellow As Double
Private CMYKWhite As Double
Private CMYKBlack As Double
'Text File Dimention
Private Type ColorDataBase
t_No As Long
t_i As Integer
t_ii As Integer
t_hRGB As Long
t_hHex As Variant
t_RGBRed As Integer
t_RGBGreen As Integer
t_RGBBlue As Integer
t_RYBRed As Double
t_RYBYellow As Double
t_RYBBlue As Double
t_RYBWhite As Double
t_RYBBlack As Double
t_CMYKCyan As Double
t_CMYKMagenta As Double
t_CMYKYellow As Double
t_CMYKWhite As Double
t_CMYKBlack As Double
End Type
Private CDB As ColorDataBase
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] RGB to RYB & CMYK Conversion"
Call Fix_Tamplate
Call Ekran_Kur
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error Resume Next
TBB = Button.Index
Select Case TBB
Case 1: Call Get_WMF_Picture
Case 2: Call RGB_To_RYB_And_CMYK
Case 3
Case 4
Case 5
Case 6
Case 7
Case 8
End Select
End Sub
Private Sub ScrollBar1_Change()
On Error Resume Next
If ScrollBar1.Value > -1 Then
Call RGB_Calculate
Call RYB_Calculate
Call CMYK_Calculate
Else
Call Ekran_Temizle(1)
End If
End Sub
Private Sub ScrollBar2_Change()
On Error Resume Next
If ScrollBar1.Value > -1 Then
Call RGB_Calculate
Call RYB_Calculate
Call CMYK_Calculate
Else
Call Ekran_Temizle(1)
End If
End Sub
Private Sub ScrollBar3_Change()
On Error Resume Next
If ScrollBar1.Value > -1 Then
Call RGB_Calculate
Call RYB_Calculate
Call CMYK_Calculate
Else
Call Ekran_Temizle(1)
End If
End Sub
Private Sub Get_WMF_Picture() 'Menu1
On Error GoTo Hata
Call Ekran_Temizle(0)
pFile = Application.GetOpenFilename("Windows Meta Files (*.bmp; *.jpg; *.jpe; *.gif; *.tif; *.png; *.ico; *.wmf), *.bmp; *.jpg; *.jpe; *.gif; *.tif; *.png; *.ico; *.wmf", 1, "Select Media File", "Open", False)
If VBA.IsEmpty(pFile) = False Then
tFile = VBA.Left(pFile, (VBA.Len(pFile) - VBA.Len(VBA.Dir(pFile, vbNormal)))) & "RGB.txt"
Frame1.Picture = LoadPicture(pFile)
Call Picture_Information
Else
Call Ekran_Temizle(0)
End If
Exit Sub
Hata:
Call Ekran_Temizle(0)
End Sub
Private Sub Picture_Information()
On Error Resume Next
pByte = VBA.FileLen(pFile)
pWidth = Frame1.Picture.Width
pHeight = Frame1.Picture.Height
pWidthPix = pWidth / (1000 * 2.54 / CTPX)
pHeightPix = pHeight / (1000 * 2.54 / CTPY)
pWidthDpi = pWidthPix * (ITP / CTPX)
pHeightDpi = pHeightPix * (ITP / CTPY)
pWidthCm = pWidthDpi * (2.54 / ITP)
pHeightCm = pHeightDpi * (2.54 / ITP)
pPoint = pWidthPix * pHeightPix
With Frame1
.ScrollBars = fmScrollBarsBoth
.ScrollWidth = pWidthDpi
.ScrollHeight = pHeightDpi
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.SetFocus
.ScrollLeft = 1
.ScrollTop = 1
.ScrollLeft = 0
.ScrollTop = 0
End With
hLabel(34).Caption = pByte
hLabel(36).Caption = pWidthPix
hLabel(38).Caption = pHeightPix
hLabel(40).Caption = pWidthDpi
hLabel(42).Caption = pHeightDpi
hLabel(44).Caption = pWidthCm
hLabel(46).Caption = pHeightCm
hLabel(48).Caption = pPoint
hLabel(50).Caption = " " & VBA.Dir(pFile, vbNormal)
hLabel(52).Caption = " " & tFile
Me.Repaint
VBA.DoEvents
End Sub
Private Sub RGB_To_RYB_And_CMYK()'Menu2
On Error Resume Next
Dim Rs As Long
Dim Gs As Long
Dim Bs As Long
Dim hLeft As Double
Dim hTop As Double
pPoint = ((pWidthPix - 0.75) / 0.75) * ((pHeightPix - 0.75) / 0.75)
hLabel(48).Caption = pPoint
ReDim Bellek(1 To pPoint, 1 To 18)
ProgressBar1.Visible = True
hLabel(53).Visible = True
No = 1
Close #1
VBA.Kill tFile
Open tFile For Random As #1 Len = Len(CDB)
For i = 0 To (pWidthPix - 0.75) Step 0.75
For ii = 0 To (pHeightPix - 0.75) Step 0.75
Frame1.ScrollLeft = i
Frame1.ScrollTop = ii
hLeft = i - Frame1.ScrollLeft + 0.75
hTop = ii - Frame1.ScrollTop + 0.75
hColor = GetPixel(hDC1, hLeft, hTop)
Rs = VBA.Int(hColor Mod 256)
Gs = VBA.Int((hColor Mod 65536) / 256)
Bs = VBA.Int(hColor / 65536)
ScrollBar1.Value = Rs
ScrollBar2.Value = Gs
ScrollBar3.Value = Bs
With CDB
.t_No = No
.t_i = i
.t_ii = ii
.t_hRGB = hRGB
.t_hHex = hHex
.t_RGBRed = RGBRed
.t_RGBGreen = RGBGreen
.t_RGBBlue = RGBBlue
.t_RYBRed = RYBRed
.t_RYBYellow = RYBYellow
.t_RYBBlue = RYBBlue
.t_RYBWhite = RYBWhite
.t_RYBBlack = RYBBlack
.t_CMYKCyan = CMYKCyan
.t_CMYKMagenta = CMYKMagenta
.t_CMYKYellow = CMYKYellow
.t_CMYKWhite = CMYKWhite
.t_CMYKBlack = CMYKBlack
End With
Put #1, No, CDB
ProgressBar1.Value = 100 * No / pPoint
hLabel(53).Caption = VBA.Format(No / pPoint, "0.0%")
No = No + 1
VBA.DoEvents
Next ii
Next i
Close #1
Call Ekran_Temizle(1)
End Sub
Private Sub RGB_Calculate()
On Error Resume Next
RGBRed = ScrollBar1.Value
RGBGreen = ScrollBar2.Value
RGBBlue = ScrollBar3.Value
Image2.BackColor = VBA.RGB(RGBRed, RGBGreen, RGBBlue)
hRGB = RGBRed + (RGBGreen * 256) + (RGBBlue * 65536) 'VBA.RGB(RGBRed, RGBGreen, RGBBlue) 

 hHex = VBA.Hex(hRGB)
hLabel(4).Caption = RGBRed
hLabel(6).Caption = RGBGreen
hLabel(8).Caption = RGBBlue
hLabel(10).Caption = hRGB
hLabel(12).Caption = hHex
End Sub
Private Sub RYB_Calculate()
On Error Resume Next
RYBWhite = Application.WorksheetFunction.Min(RGBRed, RGBGreen, RGBBlue)
RYBwRed = RGBRed - RYBWhite
RYBwGreen = RGBGreen - RYBWhite
RYBwBlue = RGBBlue - RYBWhite
RYBPartYellow = Application.WorksheetFunction.Min(RYBwRed, RYBwGreen)
RYBPartGreen = Application.WorksheetFunction.Max(0, RYBwGreen, RYBPartYellow)
RYBHalfYellow = RYBPartYellow / 2
RYBHalfGreen = RYBPartGreen / 2
RYBRed = (RYBwRed - RYBPartYellow) / 255
RYBYellow = (RYBHalfYellow + RYBHalfGreen) / 255
RYBBlue = (RYBwBlue + RYBHalfGreen - RYBHalfYellow) / 255
RYBWhite = RYBWhite / 255
RYBBlack = (255 - (RYBWhite * 255) - Application.WorksheetFunction.Max(RYBwRed, RYBwGreen, RYBwBlue)) / 255
hLabel(14).Caption = VBA.Format(RYBRed, "0.0%")
hLabel(16).Caption = VBA.Format(RYBYellow, "0.0%")
hLabel(18).Caption = VBA.Format(RYBBlue, "0.0%")
hLabel(20).Caption = VBA.Format(RYBWhite, "0.0%")
hLabel(22).Caption = VBA.Format(RYBBlack, "0.0%")
End Sub
Private Sub CMYK_Calculate()
On Error Resume Next
CMYKBlack = Application.WorksheetFunction.Min(1 - (RGBRed / 255), 1 - (RGBGreen / 255), 1 - (RGBBlue / 255))
If (1 - CMYKBlack) = 0 Then
CMYKCyan = 0
CMYKMagenta = 0
CMYKYellow = 0
CMYKWhite = 0
Else
CMYKCyan = (1 - (RGBRed / 255) - CMYKBlack) / (1 - CMYKBlack)
CMYKMagenta = (1 - (RGBGreen / 255) - CMYKBlack) / (1 - CMYKBlack)
CMYKYellow = (1 - (RGBBlue / 255) - CMYKBlack) / (1 - CMYKBlack)
CMYKWhite = 0
End If
hLabel(24).Caption = " " & VBA.Format(CMYKCyan, "0.00%")
hLabel(26).Caption = " " & VBA.Format(CMYKMagenta, "0.00%")
hLabel(28).Caption = " " & VBA.Format(CMYKYellow, "0.00%")
hLabel(30).Caption = " " & VBA.Format(CMYKWhite, "0.00%")
hLabel(32).Caption = " " & VBA.Format(CMYKBlack, "0.00%")
End Sub
Private Sub Ekran_Temizle(ByVal Seviye As Integer)
On Error Resume Next
Select Case Seviye
Case 0
pFile = ""
tFile = ""
pByte = 0
pWidth = 0
pHeight = 0
pWidthPix = 0
pHeightPix = 0
pWidthDpi = 0
pHeightDpi = 0
pWidthCm = 0
pHeightCm = 0
pPoint = 0
With Frame1
.Picture = LoadPicture("")
.ScrollBars = fmScrollBarsBoth
.ScrollWidth = 0
.ScrollHeight = 0
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.SetFocus
.ScrollLeft = 0
.ScrollTop = 0
End With
hLabel(34).Caption = ""
hLabel(36).Caption = ""
hLabel(38).Caption = ""
hLabel(40).Caption = ""
hLabel(42).Caption = ""
hLabel(44).Caption = ""
hLabel(46).Caption = ""
hLabel(48).Caption = ""
hLabel(50).Caption = ""
hLabel(52).Caption = ""
RGBRed = -1
RGBGreen = -1
RGBBlue = -1
hRGB = -1
hHex = ""
hLabel(4).Caption = ""
hLabel(6).Caption = ""
hLabel(8).Caption = ""
hLabel(10).Caption = ""
hLabel(12).Caption = ""
RYBPartYellow = 0
RYBPartGreen = 0
RYBHalfYellow = 0
RYBHalfGreen = 0
RYBRed = 0
RYBYellow = 0
RYBBlue = 0
RYBWhite = 0
RYBBlack = 0
hLabel(14).Caption = ""
hLabel(16).Caption = ""
hLabel(18).Caption = ""
hLabel(20).Caption = ""
hLabel(22).Caption = ""
CMYKCyan = 0
CMYKMagenta = 0
CMYKYellow = 0
CMYKWhite = 0
hLabel(24).Caption = ""
hLabel(26).Caption = ""
hLabel(28).Caption = ""
hLabel(30).Caption = ""
hLabel(32).Caption = ""
ScrollBar1.Value = -1
ScrollBar2.Value = -1
ScrollBar3.Value = -1
ProgressBar1.Visible = False
ProgressBar1.Value = 0.00001
hLabel(53).Visible = False
hLabel(53).Caption = 0.00001
Case 1
RGBRed = -1
RGBGreen = -1
RGBBlue = -1
hRGB = -1
hHex = ""
hLabel(4).Caption = ""
hLabel(6).Caption = ""
hLabel(8).Caption = ""
hLabel(10).Caption = ""
hLabel(12).Caption = ""
RYBPartYellow = 0
RYBPartGreen = 0
RYBHalfYellow = 0
RYBHalfGreen = 0
RYBRed = 0
RYBYellow = 0
RYBBlue = 0
RYBWhite = 0
RYBBlack = 0
hLabel(14).Caption = ""
hLabel(16).Caption = ""
hLabel(18).Caption = ""
hLabel(20).Caption = ""
hLabel(22).Caption = ""
CMYKCyan = 0
CMYKMagenta = 0
CMYKYellow = 0
CMYKWhite = 0
hLabel(24).Caption = ""
hLabel(26).Caption = ""
hLabel(28).Caption = ""
hLabel(30).Caption = ""
hLabel(32).Caption = ""
ProgressBar1.Visible = False
ProgressBar1.Value = 0.00001
hLabel(53).Visible = False
hLabel(53).Caption = 0.00001
ScrollBar1.Value = -1
ScrollBar2.Value = -1
ScrollBar3.Value = -1
Case 2
End Select
End Sub
Private Sub Fix_Tamplate()
On Error Resume Next
Frame1.SetFocus
hWnd1 = GetFocus()
hDC1 = GetDC(hWnd1)
LPX = 88
LPY = 90
ITP = Application.InchesToPoints(1)
CTPX = PointsPerPixelX
CTPY = PointsPerPixelY
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = &HE0E0E0
.Height = 448
.Width = 822
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Image1
.Top = 396
.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 = 396
.Height = 12
.Width = 108
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 408
.Height = 12
.Width = 108
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Toolbar1
.Left = 6
.Top = 6
.Height = 19.5
.Width = Me.InsideWidth - Toolbar1.Left - 6
.Appearance = ccFlat
.BorderStyle = ccNone
.ButtonHeight = 16.5
.Style = tbrFlat
.BorderStyle = ccNone
.TextAlignment = tbrTextAlignRight
.Buttons.Add 1, "Key1", "[1] Open Picture"
With .Buttons(1)
.Style = tbrDefault
.TooltipText = "Open WMF Picture"
.Visible = True
.Enabled = True
.MixedState = False
End With
.Buttons.Add 2, "Key2", "[2] Color Conversion"
With .Buttons(2)
.Style = tbrDefault
.TooltipText = "Make RGB to RYB & CMYK Convension and Create Color DataBase of WMF Picture"
.Visible = True
.Enabled = True
.MixedState = False
End With
End With
With Frame1
.Caption = ""
.Left = 150
.Top = 30
.Width = 660
.Height = 360
.BackColor = &HC0C0C0
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.ScrollBars = fmScrollBarsNone
.Picture = LoadPicture("")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With ProgressBar1
.Left = 6
.Top = 72
.Width = 78
.Height = 12
.Appearance = ccFlat
.BorderStyle = ccNone
.Orientation = ccOrientationHorizontal
.Visible = False
End With
With ScrollBar1
.Left = 6
.Top = 30
.Width = 78
.Height = 12
.Min = -1
.Max = 255
.ForeColor = vbRed
.SmallChange = 1
.LargeChange = 5
End With
With ScrollBar2
.Left = 6
.Top = 42
.Width = 78
.Height = 12
.Min = -1
.Max = 255
.ForeColor = vbGreen
.SmallChange = 1
.LargeChange = 5
End With
With ScrollBar3
.Left = 6
.Top = 54
.Width = 78
.Height = 12
.Min = -1
.Max = 255
.ForeColor = vbBlue
.SmallChange = 1
.LargeChange = 5
End With
With Image2
.Top = 30
.Left = 84
.Height = 36
.Width = 60
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.Picture = LoadPicture("")
.SpecialEffect = fmSpecialEffectFlat
.BackColor = &H8000000F
End With
Set hLabel(3) = Me.Controls.Add("Forms.Label.1", "Label3", True)
Create_Label hLabel(3), 6, 90, 78, 12, " RGB Red", 0, 3, &H404040, 1
hLabel(3).ForeColor = vbRed
Set hLabel(4) = Me.Controls.Add("Forms.Label.1", "Label4", True)
Create_Label hLabel(4), 84, 90, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(5) = Me.Controls.Add("Forms.Label.1", "Label5", True)
Create_Label hLabel(5), 6, 102, 78, 12, " RGB Green", 0, 3, &H404040, 1
hLabel(5).ForeColor = vbGreen
Set hLabel(6) = Me.Controls.Add("Forms.Label.1", "Label6", True)
Create_Label hLabel(6), 84, 102, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(7) = Me.Controls.Add("Forms.Label.1", "Label7", True)
Create_Label hLabel(7), 6, 114, 78, 12, " RGB Blue", 0, 3, &H404040, 1
hLabel(7).ForeColor = vbBlue
Set hLabel(8) = Me.Controls.Add("Forms.Label.1", "Label8", True)
Create_Label hLabel(8), 84, 114, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(9) = Me.Controls.Add("Forms.Label.1", "Label9", True)
Create_Label hLabel(9), 6, 132, 78, 12, " RGB Long", 0, 3, &H404040, 1
Set hLabel(10) = Me.Controls.Add("Forms.Label.1", "Label10", True)
Create_Label hLabel(10), 84, 132, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(11) = Me.Controls.Add("Forms.Label.1", "Label11", True)
Create_Label hLabel(11), 6, 144, 78, 12, " RGB Hex", 0, 3, &H404040, 1
Set hLabel(12) = Me.Controls.Add("Forms.Label.1", "Label12", True)
Create_Label hLabel(12), 84, 144, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(13) = Me.Controls.Add("Forms.Label.1", "Label13", True)
Create_Label hLabel(13), 6, 162, 78, 12, " RYB Red", 0, 3, &H404040, 1
hLabel(13).ForeColor = vbRed
Set hLabel(14) = Me.Controls.Add("Forms.Label.1", "Label14", True)
Create_Label hLabel(14), 84, 162, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(15) = Me.Controls.Add("Forms.Label.1", "Label15", True)
Create_Label hLabel(15), 6, 174, 78, 12, " RYB Yellow", 0, 3, &H404040, 1
hLabel(15).ForeColor = vbYellow
Set hLabel(16) = Me.Controls.Add("Forms.Label.1", "Label16", True)
Create_Label hLabel(16), 84, 174, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(17) = Me.Controls.Add("Forms.Label.1", "Label17", True)
Create_Label hLabel(17), 6, 186, 78, 12, " RYB Blue", 0, 3, &H404040, 1
hLabel(17).ForeColor = vbBlue
Set hLabel(18) = Me.Controls.Add("Forms.Label.1", "Label18", True)
Create_Label hLabel(18), 84, 186, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(19) = Me.Controls.Add("Forms.Label.1", "Label19", True)
Create_Label hLabel(19), 6, 198, 78, 12, " RYB White", 0, 3, &H404040, 1
hLabel(19).ForeColor = vbWhite
Set hLabel(20) = Me.Controls.Add("Forms.Label.1", "Label20", True)
Create_Label hLabel(20), 84, 198, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(21) = Me.Controls.Add("Forms.Label.1", "Label21", True)
Create_Label hLabel(21), 6, 210, 78, 12, " RYB Black", 0, 3, &H404040, 1
hLabel(21).ForeColor = vbBlack
Set hLabel(22) = Me.Controls.Add("Forms.Label.1", "Label22", True)
Create_Label hLabel(22), 84, 210, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(23) = Me.Controls.Add("Forms.Label.1", "Label23", True)
Create_Label hLabel(23), 6, 228, 78, 12, " CMYK Cyan", 0, 3, &H404040, 1
hLabel(23).ForeColor = vbCyan
Set hLabel(24) = Me.Controls.Add("Forms.Label.1", "Label24", True)
Create_Label hLabel(24), 84, 228, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(25) = Me.Controls.Add("Forms.Label.1", "Label25", True)
Create_Label hLabel(25), 6, 240, 78, 12, " CMYK Magenta", 0, 3, &H404040, 1
hLabel(25).ForeColor = vbMagenta
Set hLabel(26) = Me.Controls.Add("Forms.Label.1", "Label26", True)
Create_Label hLabel(26), 84, 240, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(27) = Me.Controls.Add("Forms.Label.1", "Label27", True)
Create_Label hLabel(27), 6, 252, 78, 12, " CMYK Yellow", 0, 3, &H404040, 1
hLabel(27).ForeColor = vbYellow
Set hLabel(28) = Me.Controls.Add("Forms.Label.1", "Label28", True)
Create_Label hLabel(28), 84, 252, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(29) = Me.Controls.Add("Forms.Label.1", "Label29", True)
Create_Label hLabel(29), 6, 264, 78, 12, " CMYK White", 0, 3, &H404040, 1
hLabel(29).ForeColor = vbWhite
Set hLabel(30) = Me.Controls.Add("Forms.Label.1", "Label30", True)
Create_Label hLabel(30), 84, 264, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(31) = Me.Controls.Add("Forms.Label.1", "Label31", True)
Create_Label hLabel(31), 6, 276, 78, 12, " CMYK Black", 0, 3, &H404040, 1
hLabel(31).ForeColor = vbBlack
Set hLabel(32) = Me.Controls.Add("Forms.Label.1", "Label32", True)
Create_Label hLabel(32), 84, 276, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(33) = Me.Controls.Add("Forms.Label.1", "Label33", True)
Create_Label hLabel(33), 6, 294, 78, 12, " Picture Byte", 0, 3, &H404040, 1
Set hLabel(34) = Me.Controls.Add("Forms.Label.1", "Label34", True)
Create_Label hLabel(34), 84, 294, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(35) = Me.Controls.Add("Forms.Label.1", "Label35", True)
Create_Label hLabel(35), 6, 306, 78, 12, " Picture Width [pix]", 0, 3, &H404040, 1
Set hLabel(36) = Me.Controls.Add("Forms.Label.1", "Label36", True)
Create_Label hLabel(36), 84, 306, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(37) = Me.Controls.Add("Forms.Label.1", "Label37", True)
Create_Label hLabel(37), 6, 318, 78, 12, " Picture Height [pix]", 0, 3, &H404040, 1
Set hLabel(38) = Me.Controls.Add("Forms.Label.1", "Label38", True)
Create_Label hLabel(38), 84, 318, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(39) = Me.Controls.Add("Forms.Label.1", "Label39", True)
Create_Label hLabel(39), 6, 330, 78, 12, " Picture Width [dpi]", 0, 3, &H404040, 1
Set hLabel(40) = Me.Controls.Add("Forms.Label.1", "Label40", True)
Create_Label hLabel(40), 84, 330, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(41) = Me.Controls.Add("Forms.Label.1", "Label41", True)
Create_Label hLabel(41), 6, 342, 78, 12, " Picture Height [dpi]", 0, 3, &H404040, 1
Set hLabel(42) = Me.Controls.Add("Forms.Label.1", "Label42", True)
Create_Label hLabel(42), 84, 342, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(43) = Me.Controls.Add("Forms.Label.1", "Label43", True)
Create_Label hLabel(43), 6, 354, 78, 12, " Picture Width [cm]", 0, 3, &H404040, 1
Set hLabel(44) = Me.Controls.Add("Forms.Label.1", "Label44", True)
Create_Label hLabel(44), 84, 354, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(45) = Me.Controls.Add("Forms.Label.1", "Label45", True)
Create_Label hLabel(45), 6, 366, 78, 12, " Picture Height [cm]", 0, 3, &H404040, 1
Set hLabel(46) = Me.Controls.Add("Forms.Label.1", "Label46", True)
Create_Label hLabel(46), 84, 366, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(47) = Me.Controls.Add("Forms.Label.1", "Label47", True)
Create_Label hLabel(47), 6, 378, 78, 12, " Picture Point [pix]", 0, 3, &H404040, 1
Set hLabel(48) = Me.Controls.Add("Forms.Label.1", "Label48", True)
Create_Label hLabel(48), 84, 378, 60, 12, "", 1, 3, &H808000, 3
Set hLabel(49) = Me.Controls.Add("Forms.Label.1", "Label49", True)
Create_Label hLabel(49), 150, 396, 330, 12, " Picture File Name", 0, 3, &H404040, 2
Set hLabel(50) = Me.Controls.Add("Forms.Label.1", "Label50", True)
Create_Label hLabel(50), 150, 408, 330, 12, "", 1, 3, &H808000, 1
Set hLabel(51) = Me.Controls.Add("Forms.Label.1", "Label51", True)
Create_Label hLabel(51), 480, 396, 330, 12, " Text DataBase File Name", 0, 3, &H404040, 2
Set hLabel(52) = Me.Controls.Add("Forms.Label.1", "Label52", True)
Create_Label hLabel(52), 480, 408, 330, 12, "", 1, 3, &H808000, 1
Set hLabel(53) = Me.Controls.Add("Forms.Label.1", "Label53", True)
Create_Label hLabel(53), 84, 72, 60, 12, "", 1, 3, &H808000, 3
hLabel(53).Visible = False
End With
End Sub
Private Sub Create_Label(oObject, oLeft, oTop, oWidth, oHeight, oCaption, oBackStyle, oSpecialEffect, oForeColor, oTextAlign)
On Error Resume Next
With oObject
.Left = oLeft
.Top = oTop
.Width = oWidth
.Height = oHeight
.Caption = oCaption
.BackStyle = oBackStyle
.SpecialEffect = oSpecialEffect
.ForeColor = oForeColor
.TextAlign = oTextAlign
End With
End Sub
Private Function PointsPerPixelX() As Double
On Error Resume Next
hWnd0 = 0
hDC0 = GetDC(hWnd0)
PointsPerPixelX = GetDeviceCaps(hDC0, LPX)
'PointsPerPixelX = ITP / GetDeviceCaps(hDC0, LPX) 

 ReleaseDC hWnd0, hDC0
End Function
Private Function PointsPerPixelY() As Double
On Error Resume Next
hWnd0 = 0
hDC0 = GetDC(hWnd0)
PointsPerPixelY = GetDeviceCaps(hDC0, LPY)
'PointsPerPixelY = ITP / GetDeviceCaps(hDC0, LPY) 

 ReleaseDC hWnd0, hDC0
End Function

'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ç() 'Open UserForm
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