Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Kasım 2009 Cuma

Convert a LongDecimal or HexaDecimal to RGB


'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Forms 2.0 Object Library
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Office Web Components 11.0

'B) UserForm1 E Eklenen Araçlar (Add Tools)

'Frame1
'Frame1\Image1, Label1, Label2
'ScrollBar1, ScrollBar2, ScrollBar3
'Label3, Label4, Label5, Label6, Label7, Label8
'TextBox1, TextBox2
'CommandButton1, CommandButton2, CommandButton3

Option Explicit
Dim Red As Integer, Blue As Integer, Green As Integer
Dim Tayf(1 To 3) As Long, Renk As Variant
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] Convert a LongDecimal or HexaDecimal to RGB"
Call EkranDüzenle

End Sub
Private Sub ScrollBar1_Change()

On Error Resume Next
Label3.Caption = ScrollBar1.Value
Red = ScrollBar1.Value
Label6.BackColor = VBA.RGB(Red, Green, Blue)
TextBox1.Text = VBA.Val(TextBox1) - Tayf(1) + ScrollBar1.Value
Tayf(1) = ScrollBar1.Value
TextBox2.Text = "&H" & VBA.Hex(Label6.BackColor)

End Sub
Private Sub ScrollBar2_Change()

On Error Resume Next
Label4.Caption = ScrollBar2.Value
Green = ScrollBar2.Value
Label6.BackColor = VBA.RGB(Red, Green, Blue)
TextBox1.Text = VBA.Val(TextBox1) - (Tayf(2) * 256) + (ScrollBar2.Value * 256)
Tayf(2) = ScrollBar2.Value
TextBox2.Text = "&H" & VBA.Hex(Label6.BackColor)

End Sub
Private Sub ScrollBar3_Change()

On Error Resume Next
Label5.Caption = ScrollBar3.Value
Blue = ScrollBar3.Value
Label6.BackColor = VBA.RGB(Red, Green, Blue)
TextBox1.Text = VBA.Val(TextBox1) - (Tayf(3) * 65536) + (ScrollBar3.Value * 65536)
Tayf(3) = ScrollBar3.Value
TextBox2.Text = "&H" & VBA.Hex(Label6.BackColor)

End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error Resume Next
CommandButton2.Enabled = True
DoEvents

End Sub
Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error Resume Next
CommandButton3.Enabled = True
DoEvents

End Sub
Private Sub CommandButton1_Click() 'Red=0, Green=0, Blue=0

On Error Resume Next
Renk = 0
Call Çevirici(Renk)

End Sub
Private Sub CommandButton2_Click()

On Error Resume Next
Renk = VBA.Val(TextBox1.Text)
TextBox1 = 0
Call Çevirici(Renk)
CommandButton2.Enabled = False

End Sub
Private Sub CommandButton3_Click()

On Error Resume Next
Renk = TextBox2.Text
TextBox2 = ""
Call Çevirici(Renk)
CommandButton3.Enabled = False

End Sub
Private Function Çevirici(ByVal Prizma As Variant)

On Error Resume Next
Prizma = Renk
Red = VBA.Int(Prizma Mod 256)
Green = VBA.Int((Prizma Mod 65536) / 256)
Blue = VBA.Int(Prizma / 65536)
ScrollBar1.Value = Red
ScrollBar2.Value = Green
ScrollBar3.Value = Blue
Me.Repaint

End Function
Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 259.5
.Width = 294
.BackColor = &H8000000F
With Frame1

.Caption = ""
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1

.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")

End With
With Label1

.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Label2

.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With

End With
With ScrollBar1

.Left = 6
.Top = 36
.Height = 12
.Width = 246
.Min = 0
.Max = 255

End With
With ScrollBar2

.Left = 6
.Top = 48
.Height = 12
.Width = 246
.Min = 0
.Max = 255

End With
With ScrollBar3

.Left = 6
.Top = 60
.Height = 12
.Width = 246
.Min = 0
.Max = 255

End With
With Label3

.Caption = ""
.BackColor = &HFF&
.SpecialEffect = fmSpecialEffectEtched
.Left = 252
.Top = 36
.Height = 12
.Width = 30
.ForeColor = vbWhite

End With
With Label4

.Caption = ""
.BackColor = &HFF00&
.SpecialEffect = fmSpecialEffectEtched
.Left = 252
.Top = 48
.Height = 12
.Width = 30
.ForeColor = vbWhite

End With
With Label5

.Caption = ""
.BackColor = &HFF0000
.SpecialEffect = fmSpecialEffectEtched
.Left = 252
.Top = 60
.Height = 12
.Width = 30
.ForeColor = vbWhite

End With
With Label6

.Caption = ""
.BackColor = &H8000000F
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 72
.Height = 114
.Width = 276

End With
With Label7

.Caption = "LongDecimal Value"
.BackColor = &H8000000F
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 186
.Height = 18
.Width = 72

End With
With TextBox1

.Left = 78
.Top = 186
.Height = 18
.Width = 66

End With
With Label8

.Caption = "HexaDecimal Value"
.BackColor = &H8000000F
.SpecialEffect = fmSpecialEffectEtched
.Left = 144
.Top = 186
.Height = 18
.Width = 72

End With
With TextBox2

.Left = 216
.Top = 186
.Height = 18
.Width = 66

End With
With CommandButton1

.Caption = "0 Decimal Reset"
.Left = 6
.Top = 210
.Height = 18
.Width = 90

End With
With CommandButton2

.Caption = "ValueDecimal Reset"
.Left = 102
.Top = 210
.Height = 18
.Width = 90

End With
With CommandButton3

.Caption = "HexaDecimal Reset"
.Left = 192
.Top = 210
.Height = 18
.Width = 90

End With

End With
ScrollBar1.Value = Red
ScrollBar2.Value = Green
ScrollBar3.Value = Blue
Label6.BackColor = VBA.RGB(Red, Green, Blue)
TextBox1.Text = VBA.Val(TextBox1) - Tayf(1) + ScrollBar1.Value
Tayf(1) = ScrollBar1.Value
TextBox2.Text = "&H" & VBA.Hex(Label6.BackColor)
CommandButton2.Enabled = False
CommandButton3.Enabled = False

End Sub

'Module1

Sub FormAç()

On Error Resume Next
UserForm1.Show 0

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