Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

23 Şubat 2010 Salı

LEDMeter ActiveX Control Module


'UserForm1

'A) VBProject References List

'Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL, GUID: {000204EF-0000-0000-C000-000000000046}, Major: 4, Minor: 0
'Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE, GUID: {00020813-0000-0000-C000-000000000046}, Major:1, Minor: 5
'Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\stdole2.tlb, GUID: {00020430-0000-0000-C000-000000000046}, Major:2, Minor: 0
'Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL, GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}, Major:2, Minor: 3
'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL, GUID: {0D452EE1-E08F-101A-852E-02608C4D0BB4}, Major:2, Minor: 0
'Name: SpeechLib, Description: Microsoft Speech Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\Speech\sapi.dll, GUID: {C866CA3A-32F7-11D2-9602-00C04F8EE628}, Major:5, Minor: 0
'Name: LEDMETERLib, Description: LEDMeter ActiveX Control module, FullPath: C:\Program Files\ahead\Nero\WaveEditor\LEDMeter.ocx, GUID: {7F0DC2FA-DACB-4A76-B3C3-86A36AB1228A}, Major:1, Minor: 0

'B) Addition Tools on UserForm1

'Frame1
'Frame1\Image1, Label1, Label2
'TextBox1
'Frame2
'Frame2\Label3, Label4
'CommandButton1, CommandButton2

Option Explicit
Dim i As Single, ii As Single
Dim Güç(27) As Double, Seviye As Double, Tekrar As Double
Dim Nesne(27) As Control
'Private WithEvents Seslendirme As SpVoice 'After FormAç Macro, this line will activate
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] LEDMeter ActiveX Control Module"
'Set Seslendirme = New SpVoice 'After FormAç Macro, this line will activate
Call EkranDüzenle
Call Metin

End Sub
Private Sub CommandButton1_Click() 'To Speech

On Error Resume Next
If CommandButton2.Enabled = True Then

CommandButton2.Enabled = True
Seslendirme.Speak TextBox1.Text, SVSFlagsAsync

Else

CommandButton2.Enabled = True
Seslendirme.Resume

End If

End Sub
Private Sub CommandButton2_Click() 'To Pause

On Error Resume Next
CommandButton2.Enabled = False
Seslendirme.Pause

End Sub
Private Sub Seslendirme_Word(ByVal StreamNumber As Long, ByVal StreamPosition As Variant, ByVal CharacterPosition As Long, ByVal Length As Long)

On Error Resume Next
With TextBox1

.SetFocus
.SelStart = CharacterPosition
.SelLength = Length

End With
If (Seslendirme.Status.PhonemeId * 2) > 100 Then

Güç(14) = 100

Else

Güç(14) = (Seslendirme.Status.PhonemeId * 2)

End If
DoEvents
Güç(13) = Application.WorksheetFunction.GeoMean(Güç(14), Güç(14)): Güç(15) = Güç(13)
Güç(12) = Application.WorksheetFunction.GeoMean(Güç(13), Güç(13) * 12 * 1 / 13): Güç(16) = Güç(12)
Güç(11) = Application.WorksheetFunction.GeoMean(Güç(12), Güç(12) * 11 * 1 / 13): Güç(17) = Güç(11)
Güç(10) = Application.WorksheetFunction.GeoMean(Güç(11), Güç(11) * 10 * 1 / 13): Güç(18) = Güç(10)
Güç(9) = Application.WorksheetFunction.GeoMean(Güç(10), Güç(10) * 9 * 1 / 13): Güç(19) = Güç(9)
Güç(8) = Application.WorksheetFunction.GeoMean(Güç(9), Güç(9) * 8 * 1 / 13): Güç(20) = Güç(8)
Güç(7) = Application.WorksheetFunction.GeoMean(Güç(8), Güç(8) * 7 * 1 / 13): Güç(21) = Güç(7)
Güç(6) = Application.WorksheetFunction.GeoMean(Güç(7), Güç(7) * 6 * 1 / 13): Güç(22) = Güç(6)
Güç(5) = Application.WorksheetFunction.GeoMean(Güç(6), Güç(6) * 5 * 1 / 13): Güç(23) = Güç(5)
Güç(4) = Application.WorksheetFunction.GeoMean(Güç(5), Güç(5) * 4 * 1 / 13): Güç(24) = Güç(4)
Güç(3) = Application.WorksheetFunction.GeoMean(Güç(4), Güç(4) * 3 * 1 / 13): Güç(25) = Güç(3)
Güç(2) = Application.WorksheetFunction.GeoMean(Güç(3), Güç(3) * 2 * 1 / 13): Güç(26) = Güç(2)
Güç(1) = Application.WorksheetFunction.GeoMean(Güç(2), Güç(2) * 1 * 1 / 13): Güç(27) = Güç(1)
Tekrar = 6
If Tekrar > 0 Then

For i = 1 To Tekrar

For ii = 1 To 27

Seviye = VBA.Round(Güç(ii), 0) * i / Tekrar
With Nesne(ii)

.Reset
.SetLevel Seviye
.RedZone = Seviye - 1
.YellowZone = Seviye - 20
DoEvents

End With

Next ii

Next i
With Label3

.Left = ((324 - 12) * (CharacterPosition / TextBox1.TextLength))
.Width = 12

End With
With Label4

.Width = ((324 - 12) * (CharacterPosition / TextBox1.TextLength))

End With
DoEvents

Else

With Label3

.Left = 0

End With
With Label4

.Width = 0

End With
DoEvents

End If

End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 332
.Width = 388
.BackColor = vbWhite
With Frame1

.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Image1

.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\Örnekİkonlar\PBİD.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip

End With
With Label1

.Left = 1.5 + 24 + 3
.Top = 1.5
.Caption = "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With
With Label2

.Left = 1.5 + 24 + 3
.Top = 13.5
.Caption = "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With

End With
With TextBox1

.Left = 6
.Top = 36
.Height = 201
.Width = 372
.ForeColor = &H4000&
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.EnterKeyBehavior = True
.Enabled = True
.Locked = True
.MultiLine = True
.ScrollBars = fmScrollBarsVertical

End With
With Frame2

.Caption = ""
.Left = 6
.Top = 240
.Height = 61
.Width = 324
.SpecialEffect = fmSpecialEffectEtched
.ScrollBars = fmScrollBarsNone
.BackColor = vbBlack
For i = 1 To 27

Set Nesne(i) = .Controls.Add("LEDMETER.LEDMeterCtrl.1")
With Nesne(i)

.Left = (i - 1) * 12
.Top = 0
.Height = 50
.Width = 12
.Reset
.RedZone = .YellowZone - 1
.YellowZone = 60

End With

Next i
With Label3

.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 0
.Top = 50
.Height = 8
.Width = 0 '12
.BackColor = vbWhite
.BorderColor = &HC000&
.BorderStyle = fmBorderStyleSingle

End With
With Label4

.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 0
.Top = 50
.Height = 8
.Width = 0 '324
.BackColor = &H80FF80

End With

End With
With CommandButton1

.Caption = "Speech"
.Left = 336
.Top = 240
.Height = 30
.Width = 42
.ForeColor = vbGreen
.Font.Bold = True

End With
With CommandButton2

.Caption = "Stop"
.Left = 336
.Top = 276
.Height = 24
.Width = 42
.ForeColor = vbRed
.Font.Bold = True

End With

End With

End Sub
Sub Metin()

On Error Resume Next
TextBox1.Text = "Speech is the vocalized form of human communication."
TextBox1.Text = TextBox1.Text & " " & "It is based upon the syntactic combination of lexicals and names that are drawn from very large (usually >10,000 different words) vocabularies."
TextBox1.Text = TextBox1.Text & " " & "Each spoken word is created out of the phonetic combination of a limited set of vowel and consonant speech sound units."
TextBox1.Text = TextBox1.Text & " " & "These vocabularies, the syntax which structures them, and their set of speech sound units, differ creating the existence of many thousands of different types of mutually unintelligible human languages."
TextBox1.Text = TextBox1.Text & " " & "Human speakers (polyglots) are often able to communicate in two or more of them."
TextBox1.Text = TextBox1.Text & " " & "The vocal abilities that enable humans to produce speech also provide humans with the ability to sing."
TextBox1.Text = TextBox1.Text & " " & "A gestural form of human communication exists for the deaf in the form of sign language."
TextBox1.Text = TextBox1.Text & " " & "Speech in some cultures has become the basis of a written language, often one that differs in its vocabulary, syntax and phonetics from its associated spoken one, a situation called diglossia."
TextBox1.Text = TextBox1.Text & " " & "Speech in addition to its use in communication, it is suggested by some psychologists such as Vygotsky is internally used by mental processes to enhance and organize cognition in the form of an interior monologue."
TextBox1.Text = TextBox1.Text & " " & "Speech is researched in terms of the speech production and speech perception of the sounds used in spoken language."
TextBox1.Text = TextBox1.Text & " " & "Other research topics concern speech repetition, the ability to map heard spoken words into the vocalizations needed to recreated that plays a key role in the vocabulary expansion in children and speech errors."
TextBox1.Text = TextBox1.Text & " " & "Several academic disciplines study these including acoustics, psychology, speech pathology, linguistics, cognitive science, communication studies, otolaryngology and computer science."
TextBox1.Text = TextBox1.Text & " " & "Another area of research is how the human brain in its different areas such as the Broca's area and Wernicke's area underlies speech."
TextBox1.Text = TextBox1.Text & " " & "It is controversial how far human speech is unique in that other animals also communicate with vocalizations."
TextBox1.Text = TextBox1.Text & " " & "While none in the wild uses syntax nor compatibly large vocabularies, research upon the nonverbal abilities of language trained apes such as Washoe and Kanzi raises the possibility that they might have these capabilities."
TextBox1.Text = TextBox1.Text & " " & "By Wikipedia, Speech"

End Sub


'Module1

Dim i As Single
Sub FormAç()

On Error Resume Next
With ThisWorkbook.VBProject

With .References

.AddFromGuid "{C866CA3A-32F7-11D2-9602-00C04F8EE628}", 5, 0 'Microsoft Speech Object Library
.AddFromGuid "{7F0DC2FA-DACB-4A76-B3C3-86A36AB1228A}", 1, 0 'LEDMeter ActiveX Control module

End With
With .VBComponents("UserForm1").CodeModule

For i = 1 To .CountOfLines

If .Lines(i, 1) = "'Private WithEvents Seslendirme As SpVoice 'After FormAç Macro, this line will activate" Then ThisWorkbook.VBProject.VBComponents("UserForm1").CodeModule.ReplaceLine i, "Private WithEvents Seslendirme As SpVoice"
If .Lines(i, 1) = "'Set Seslendirme = New SpVoice 'After FormAç Macro, this line will activate" Then ThisWorkbook.VBProject.VBComponents("UserForm1").CodeModule.ReplaceLine i, "Set Seslendirme = New SpVoice"

Next i

End With

End With
UserForm1.Show

End Sub

13 Şubat 2010 Cumartesi

File Search At UserForm




'UserForm1

'A) VBProject References List

'Visual Basic For Application
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library

'B) Addition Tools on UserForm1

'Frame1
'Frame1\Image1, Label1, Label2
'TextBox1, TextBox2, TextBox3, ListBox1

Option Explicit
Dim i As Single, No As Double
Dim Metin As String, Boy As Double
Dim Dosyalama As Object, Sürücü, Klasör, Dosya, Eleman, Bilgi, Tip
Dim Adet As Double, Toplam As Double
Dim Liste As Control
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] File Search At UserForm"
Call EkranDüzenle
Call KlasörDüzeni

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

On Error Resume Next
Adet = Liste.ListCount
Metin = VBA.UCase(TextBox1.Text)
Boy = VBA.Len(Metin)
If Boy > 0 Then

ListBox1.Clear
TextBox2.Text = ""
TextBox3.Text = ""
For i = 1 To (Adet - 1)

If VBA.UCase(VBA.Left(Liste.List(i, 0), Boy)) = Metin Then

ListBox1.AddItem Liste.List(i, 0)
Toplam = ListBox1.ListCount
ListBox1.List((Toplam - 1), 1) = Liste.List(i, 1)
ListBox1.List((Toplam - 1), 2) = Liste.List(i, 2)

End If

Next i

Else

ListBox1.Clear
TextBox2.Text = ""
TextBox3.Text = ""

End If

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

On Error Resume Next
Adet = Liste.ListCount
Metin = VBA.UCase(TextBox2.Text)
Boy = VBA.Len(Metin)
If Boy > 0 Then

ListBox1.Clear
TextBox1.Text = ""
TextBox3.Text = ""
For i = 1 To (Adet - 1)

If VBA.UCase(VBA.Left(Liste.List(i, 1), Boy)) = Metin Then

ListBox1.AddItem Liste.List(i, 0)
Toplam = ListBox1.ListCount
ListBox1.List((Toplam - 1), 1) = Liste.List(i, 1)
ListBox1.List((Toplam - 1), 2) = Liste.List(i, 2)

End If

Next i

Else

ListBox1.Clear
TextBox1.Text = ""
TextBox3.Text = ""

End If

End Sub
Private Sub ListBox1_Click()

On Error Resume Next
With ListBox1

No = .ListIndex
TextBox1.Text = .List(No, 0)
TextBox2.Text = .List(No, 1)
TextBox3.Text = .List(No, 2)

End With

End Sub
Private Sub KlasörDüzeni()

On Error Resume Next
Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
For Each Eleman In Dosyalama.Drives

Sürücü = Eleman.DriveLetter & ":\"
If Sürücü = "K:\" Then

Exit For

Else

Call DosyaDüzeni(Sürücü)

End If

Next Eleman
Set Dosyalama = Nothing

End Sub
Private Sub DosyaDüzeni(ByVal Sürücü)

On Error Resume Next
With Application.FileSearch

.NewSearch
.LookIn = Sürücü
.SearchSubFolders = True
.filename = "*.*"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
.Execute
Adet = .FoundFiles.Count
If Adet > 0 Then

For Each Bilgi In .FoundFiles

Metin = VBA.FileSystem.Dir(Bilgi)
Boy = VBA.Len(Metin)
For i = 1 To Boy

If VBA.Left(VBA.Right(Metin, i), 1) = "." Then

Dosya = VBA.Left(Metin, Boy - i)
Tip = VBA.Right(Metin, (i - 1))
Klasör = VBA.Left(Bilgi, VBA.Len(Bilgi) - Boy)
GoTo Devam

End If

Next i
Dosya = Metin
Tip = ""
Klasör = VBA.Left(Bilgi, VBA.Len(Bilgi) - Boy)
Devam:
Liste.AddItem Dosya
Toplam = Liste.ListCount
Liste.List((Toplam - 1), 1) = Tip
Liste.List((Toplam - 1), 2) = Klasör

Next Bilgi

End If

End With

End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 365
.Width = 640.5
.BackColor = vbWhite
With Frame1

.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Image1

.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\Örnekİkonlar\PBİD.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip

End With
With Label1

.Left = 1.5 + 24 + 3
.Top = 1.5
.Caption = "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With
With Label2

.Left = 1.5 + 24 + 3
.Top = 13.5
.Caption = "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With

End With
With TextBox1

.Left = 6
.Top = 36
.Height = 18
.Width = 120
.ForeColor = vbBlue
.BackColor = vbWhite
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox2

.Left = 126
.Top = 36
.Height = 18
.Width = 42
.ForeColor = vbBlue
.BackColor = vbWhite
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox3

.Left = 168
.Top = 36
.Height = 18
.Width = 462
.ForeColor = &H404000
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched

End With
With ListBox1

.Left = 6
.Top = 54
.Height = 279.05
.Width = 623.25
.ColumnCount = 3
.ColumnWidths = "120;42;462"
.BackColor = &H80000018
.ForeColor = &H404000
.SpecialEffect = fmSpecialEffectEtched

End With
Set Liste = Me.Controls.Add("Forms.ListBox.1")
With Liste

.Name = "ListBox2"
.ColumnCount = 3
.ColumnWidths = "120;42;462"
.Visible = False

End With

End With

End Sub

8 Şubat 2010 Pazartesi

To Make Shape On The UserForm




'UserForm1

'A) VBProject References List

'Visual Basic For Application
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library

'B) Addition Tools on UserForm1

'Frame1
'Frame1\Image1, Label1, Label2, ComboBox1

Option Explicit
Private Çizim As New Class1
Dim i As Single, ii As Single
Dim Nesne As Shape
Dim EğriX(1 To 24) As Single
Dim EğriY(1 To 24) As Single
Dim DoğruX(1 To 24) As Single
Dim DoğruY(1 To 24) As Single
Dim Üstten As Double, Soldan As Double
Private Sub UserForm_Initialize()

Me.Caption = "[PBİD®] Make Shape On The UserForm"
Call EkranDüzenle
Set Çizim.FormTuvaliYap = Me
With ComboBox1

.AddItem "Dörtgen [Box]"
.AddItem "Metin [TextEffect]"
.AddItem "Yazı Sanatı [WordArt]"
.AddItem "Eğri [Curve]"
.AddItem "Elips [Oval]"
.AddItem "Çizgi [Line]"
.AddItem "Çokgen [FreeForm]"

End With

End Sub
Private Sub ComboBox1_Change()

On Error Resume Next
Select Case ComboBox1.ListIndex

Case 0: Call Dörtgen
Case 1: Call Metin
Case 2: Call YazıSanatı
Case 3: Call Eğri
Case 4: Call ElipsDaire
Case 5: Call Çizgi
Case 6: Call Çokgen

End Select

End Sub
Private Sub Dörtgen() '[Box]

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 300) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 300) / 2, 0)
Set Nesne = Çizim.DörtgenNesne(Soldan + 0, Üstten + 0, 300, 300)
If Not Nesne Is Nothing Then

With Nesne

With .Fill

.ForeColor.RGB = VBA.RGB(255, 0, 0)
.BackColor.SchemeColor = 32
.TwoColorGradient msoGradientVertical, 1

End With
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 0, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With

End If
Çizim.NesneBoya

End Sub
Private Sub Metin() '[TextEffect]

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 300) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 300) / 2, 0)
Set Nesne = Çizim.DörtgenNesne(Soldan + 0, Üstten + 0, 300, 300)
If Not Nesne Is Nothing Then

With Nesne

With .Fill

.ForeColor.RGB = VBA.RGB(255, 0, 0)
.BackColor.SchemeColor = 5
.Transparency = 0.1
.Patterned msoPatternDiagonalBrick

End With
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 0, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With
With .TextFrame

With .Characters

.Text = "PBİD®"
.Font.Bold = True
.Font.Color = VBA.RGB(255, 0, 0)
.Font.Size = 72

End With
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter

End With

End With

End If
Çizim.NesneBoya

End Sub
Private Sub YazıSanatı() '[WordArt]

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 150) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 250) / 2, 0)
Set Nesne = Çizim.MetinNesne(Soldan + 0, Üstten + 0, msoTextEffect22, "PBİD ®", "Veranda", 72)
Çizim.NesneBoya

End Sub
Private Sub Eğri() '[Curve]

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 300) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 250) / 2, 0)
EğriX(1) = 40 + Soldan: EğriY(1) = 240 + Üstten
EğriX(2) = 80 + Soldan: EğriY(2) = 20 + Üstten
EğriX(3) = 120 + Soldan: EğriY(3) = 240 + Üstten
EğriX(4) = 160 + Soldan: EğriY(4) = 20 + Üstten
EğriX(5) = 200 + Soldan: EğriY(5) = 240 + Üstten
EğriX(6) = 40 + Soldan: EğriY(6) = 240 + Üstten
Set Nesne = Çizim.EğriNesne(EğriX, EğriY)
With Nesne

With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 0, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With
Çizim.NesneBoya

End Sub
Private Sub ElipsDaire() '[EllipseCircle]

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 300) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 300) / 2, 0)
Set Nesne = Çizim.DaireNesne(Soldan + 170, Üstten + 120, 70)
With Nesne

.Fill.ForeColor.RGB = RGB(255, 0, 0)
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 0, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With
Set Nesne = Çizim.OvalNesne(Soldan + 220, Üstten + 120, 45, 70)
With Nesne

.Fill.ForeColor.RGB = RGB(255, 255, 0)
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 255, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With
Set Nesne = Çizim.OvalNesne(Soldan + 95, Üstten + 120, 75, 35)
With Nesne

.Fill.ForeColor.RGB = RGB(0, 255, 255)
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(0, 255, 255)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With
Çizim.NesneBoya

End Sub
Private Sub Çizgi() '[Line]

On Error Resume Next
Çizim.TuvalSil
Set Nesne = Çizim.DörtgenNesne(60, 120, 100, 30) 'Sol - Üst - Genişlik - Yükseklik
With Nesne.Fill

.ForeColor.SchemeColor = 5
.BackColor.SchemeColor = 6
.Transparency = 0.1
.Patterned msoPattern50Percent

End With
Set Nesne = Çizim.ÇizgiNesne(160, 135, 200, 135):
With Nesne.Line

.Weight = 2
.ForeColor.SchemeColor = 4
.BeginArrowheadStyle = msoArrowheadOval

End With
Set Nesne = Çizim.ÇizgiNesne(200, 135, 200, 195): Nesne.Line.Weight = 1
With Nesne.Line

.Weight = 2
.ForeColor.SchemeColor = 4

End With
Set Nesne = Çizim.ÇizgiNesne(200, 195, 240, 195): Nesne.Line.Weight = 1
With Nesne.Line

.Weight = 2
.ForeColor.SchemeColor = 4
.EndArrowheadStyle = msoArrowheadStealth

End With
Set Nesne = Çizim.DörtgenNesne(240, 180, 100, 30)
With Nesne.Fill

.ForeColor.SchemeColor = 5
.BackColor.SchemeColor = 6
.Transparency = 0.1
.Patterned msoPattern50Percent

End With
Set Nesne = Çizim.DörtgenNesne(240, 240, 100, 30)
With Nesne.Fill

.ForeColor.SchemeColor = 5
.BackColor.SchemeColor = 6
.Transparency = 0.1
.Patterned msoPattern50Percent

End With
Set Nesne = Çizim.ÇizgiNesne(180, 135, 180, 255): Nesne.Line.Weight = 1
With Nesne.Line

.Weight = 2
.ForeColor.SchemeColor = 4

End With
Set Nesne = Çizim.ÇizgiNesne(180, 255, 240, 255): Nesne.Line.Weight = 1
With Nesne.Line

.Weight = 2
.ForeColor.SchemeColor = 4
.EndArrowheadStyle = msoArrowheadStealth

End With
Çizim.NesneBoya

End Sub
Private Sub Çokgen() 'FreeForm

On Error Resume Next
Çizim.TuvalSil
Üstten = VBA.Round(((Me.Height - 30 - 6 - 24 - 300) / 2) + (30 + 6), 0)
Soldan = VBA.Round((Me.Width - 300) / 2, 0)
DoğruX(1) = (60 + Soldan): DoğruY(1) = (300 + Üstten)
DoğruX(2) = (152 + Soldan): DoğruY(2) = (232 + Üstten)
DoğruX(3) = (243 + Soldan): DoğruY(3) = (300 + Üstten)
DoğruX(4) = (208 + Soldan): DoğruY(4) = (187 + Üstten)
DoğruX(5) = (301 + Soldan): DoğruY(5) = (116 + Üstten)
DoğruX(6) = (187 + Soldan): DoğruY(6) = (116 + Üstten)
DoğruX(7) = (151 + Soldan): DoğruY(7) = (3 + Üstten)
DoğruX(8) = (116 + Soldan): DoğruY(8) = (116 + Üstten)
DoğruX(9) = (1 + Soldan): DoğruY(9) = (116 + Üstten)
DoğruX(10) = (95 + Soldan): DoğruY(10) = (187 + Üstten)
DoğruX(11) = (60 + Soldan): DoğruY(11) = (300 + Üstten)
Set Nesne = Çizim.ÇokgenNesne(DoğruX, DoğruY, False)
If Not Nesne Is Nothing Then

With Nesne

With .Fill

.PresetTextured msoTextureWovenMat

End With
With .Line

.Visible = msoTrue
.Weight = 6
.ForeColor.SchemeColor = 12
.BackColor.RGB = VBA.RGB(255, 0, 0)
.DashStyle = msoLineSolid
.Pattern = msoPattern50Percent
.Transparency = 50 / 100
.Weight = 24

End With

End With

End If
Çizim.NesneBoya

End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 432
.Width = 432
.BackColor = vbWhite
With Frame1

.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Image1

.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\Örnekİkonlar\PBİD.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip

End With
With Label1

.Left = 1.5 + 24 + 3
.Top = 1.5
.Caption = "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With
With Label2

.Left = 1.5 + 24 + 3
.Top = 13.5
.Caption = "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With
With ComboBox1

.Top = 6
.Height = 18
.Width = 120
.Left = Me.Width - 12 - .Width
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Style = fmStyleDropDownCombo
.ForeColor = vbBlue
.Font.Bold = True
.BackColor = vbWhite

End With

End With

End With

End Sub

'Module1

Option Explicit
Public Sub FormAç()

On Error Resume Next
UserForm1.Show 0

End Sub

'Class1

Option Explicit
Option Compare Text
Private Type KILAVUZ

Veri1 As Long
Veri2 As Integer
Veri3 As Integer
Veri4(0 To 7) As Byte

End Type
Private Type ResimTarifi

Boyut As Long
Tip As Long
Resim As Long
Eldeki As Long

End Type
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
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 ResimTarifi, RefIID As KILAVUZ, ByVal fPictureOwnsHandle As Long, ResimNo 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 i As Integer
Private NesneÇerçeve As Shape
Private Tayf As Long
Private Sol As Single
Private Üst As Single
Private En As Single
Private Boy As Single
Private NoktaX1 As Single
Private NoktaY1 As Single
Private NoktaX2 As Single
Private NoktaY2 As Single
Private FormTuval As MSForms.UserForm
Private NesneTuval As Object
Private SayfaTuval As Worksheet, Sayfa As Worksheet
Private Durum As Boolean
Private Kontrol As Long, GeçerliResim As Long, EldekiResim As Long, Eldeki As Long, EldekiResimTipi As Long, Kopyalanan As Long
Private Okunan As Long, ResimBilgi As ResimTarifi, Yamalamak As KILAVUZ, ResimNo As IPicture
Private Sub Class_Initialize()

For Each Sayfa In ThisWorkbook.Worksheets

If Sayfa.Name = "Tuval" Then GoTo Devam

Next Sayfa
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
ThisWorkbook.ActiveSheet.Name = "Tuval"
Devam:
Set SayfaTuval = ThisWorkbook.Worksheets("Tuval")
Call TuvalSil 'MevcuduSil

End Sub
Private Sub Class_Terminate()

On Error Resume Next
Call TuvalSil 'MevcuduSil
ThisWorkbook.Saved = True
Set SayfaTuval = Nothing
Set FormTuval = Nothing
Set NesneTuval = Nothing

End Sub
Public Sub TuvalSil()

On Error Resume Next
Call MevcuduSil
Call TuvaliSilmek

End Sub
Public Sub TuvaliSilmek()

On Error Resume Next
If Durum Then

FormTuval.Picture = LoadPicture("")

Else

NesneTuval.Picture = LoadPicture("")

End If

End Sub
Private Sub MevcuduSil()

On Error GoTo Hata
Do While SayfaTuval.Shapes.Count > 0

SayfaTuval.Shapes(1).Delete

Loop
Hata:
Exit Sub

End Sub

Public Function DörtgenNesne(Sol As Single, Üst As Single, En As Single, Boy As Single) As Shape

On Error GoTo Hata
Set DörtgenNesne = SayfaTuval.Shapes.AddShape(msoShapeRectangle, Sol, Üst, En, Boy)
Exit Function
Hata:
Set DörtgenNesne = Nothing
Exit Function

End Function
Public Function MetinNesne(Sol As Single, Üst As Single, Effect As MsoPresetTextEffect, Text As String, Optional FontName As String = "Arial", Optional FontSize As Single = 10, Optional FontBold As MsoTriState = msoFalse, Optional FontItalic As MsoTriState = msoFalse) As Shape

On Error GoTo Hata
Set MetinNesne = SayfaTuval.Shapes.AddTextEffect(Effect, Text, FontName, FontSize, FontBold, FontItalic, Sol, Üst)
Exit Function
Hata:
Set MetinNesne = Nothing
Exit Function

End Function
Public Function EğriNesne(Xs() As Single, Ys() As Single) As Shape

On Error GoTo Hata
With SayfaTuval.Shapes.BuildFreeform(msoEditingAuto, Xs(LBound(Xs)), Ys(LBound(Ys)))

For i = LBound(Xs) + 1 To UBound(Xs)

.AddNodes msoSegmentCurve, msoEditingAuto, Xs(i), Ys(i)

Next
Set EğriNesne = .ConvertToShape

End With
Exit Function
Hata:
Set EğriNesne = Nothing
Exit Function

End Function
Public Function ÇokgenNesne(Xs() As Single, Ys() As Single, Closed As Boolean) As Shape

On Error GoTo Hata
With SayfaTuval.Shapes.BuildFreeform(msoEditingAuto, Xs(LBound(Xs)), Ys(LBound(Ys)))

For i = LBound(Xs) + 1 To UBound(Xs)

.AddNodes msoSegmentLine, msoEditingAuto, Xs(i), Ys(i)

Next
If Closed Then

.AddNodes msoSegmentLine, msoEditingAuto, Xs(LBound(Xs)), Ys(LBound(Ys))

End If
Set ÇokgenNesne = .ConvertToShape

End With
Exit Function
Hata:
Set ÇokgenNesne = Nothing
Exit Function

End Function
Public Function OvalNesne(XOrta As Single, YOrta As Single, XÇap As Single, YÇap As Single) As Shape

On Error GoTo Hata
Sol = XOrta - XÇap
Üst = YOrta - YÇap
En = XÇap * 2
Boy = YÇap * 2
Set OvalNesne = SayfaTuval.Shapes.AddShape(msoShapeOval, Sol, Üst, En, Boy)
Exit Function
Hata:
Set OvalNesne = Nothing
Exit Function

End Function
Public Function DaireNesne(XOrta As Single, YOrta As Single, Çap As Single) As Shape

On Error GoTo Hata
Sol = XOrta - Çap
Üst = YOrta - Çap
En = Çap * 2
Boy = Çap * 2
Set DaireNesne = SayfaTuval.Shapes.AddShape(msoShapeOval, Sol, Üst, En, Boy)
Exit Function
Hata:
Set DaireNesne = Nothing
Exit Function

End Function
Public Function ÇizgiNesne(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single) As Shape

On Error GoTo Hata
NoktaX1 = X1
If X2 >= NoktaX1 Then

NoktaX2 = X2

Else

NoktaX1 = X2
NoktaX2 = X1

End If
NoktaY1 = Y1
If Y2 >= NoktaY1 Then

NoktaY2 = Y2

Else

NoktaY1 = Y2
NoktaY2 = Y1

End If
Set ÇizgiNesne = SayfaTuval.Shapes.AddLine(X1, Y1, X2, Y2)
Exit Function
Hata:
Set ÇizgiNesne = Nothing
Exit Function

End Function
Public Property Set NesneTuvaliYap(Tuval As Object)

On Error GoTo Hata
Durum = False
Set NesneTuval = Tuval
NesneTuval.PictureSizeMode = fmPictureSizeModeClip
NesneTuval.PictureAlignment = fmPictureAlignmentTopLeft
Exit Property
Hata:
Set NesneTuval = Nothing
Exit Property

End Property
Public Property Set FormTuvaliYap(Ekran As MSForms.UserForm)

On Error GoTo Hata
Durum = True
Set FormTuval = Ekran
FormTuval.PictureSizeMode = fmPictureSizeModeClip
FormTuval.PictureAlignment = fmPictureAlignmentTopLeft
Exit Property
Hata:
Set FormTuvaliYap = Nothing
Exit Property

End Property
Public Sub NesneBoya()

On Error GoTo Hata
Set NesneÇerçeve = Çerçevele
ReDim Bellek(SayfaTuval.Shapes.Count - 1) As Variant
i = 0
For Each NesneÇerçeve In SayfaTuval.Shapes

Bellek(i) = NesneÇerçeve.Name
i = i + 1

Next
SayfaTuval.Shapes.Range(Bellek).Group
Set NesneÇerçeve = SayfaTuval.Shapes(1)
NesneÇerçeve.CopyPicture xlScreen, xlBitmap
If Durum Then

Set FormTuval.Picture = ResimGönder(xlBitmap)

Else

Set NesneTuval.Picture = ResimGönder(xlBitmap)

End If
Exit Sub
Hata:
Set NesneÇerçeve = Nothing
Set FormTuval.Picture = Nothing
Set NesneTuval.Picture = Nothing
Exit Sub

End Sub
Private Function Çerçevele() As Shape

On Error GoTo Hata
If Durum Then

If FormTuval.BackColor >= 0 Then

Tayf = FormTuval.BackColor

Else

Tayf = FormTuval.BackColor And &HFF
Tayf = GetSysColor(Tayf)

End If
Set Çerçevele = SayfaTuval.Shapes.AddShape(msoShapeRectangle, 0, 0, FormTuval.InsideWidth - 1, FormTuval.InsideHeight - 1)

Else

If NesneTuval.BackColor >= 0 Then

Tayf = NesneTuval.BackColor

Else

Tayf = NesneTuval.BackColor And &HFF
Tayf = GetSysColor(Tayf)

End If
Set Çerçevele = SayfaTuval.Shapes.AddShape(msoShapeRectangle, 0, 0, NesneTuval.Width - 1, NesneTuval.Height - 1)

End If
With Çerçevele

With .Fill

.ForeColor.RGB = Tayf
.BackColor.RGB = Tayf

End With
.Line.BackColor.RGB = Tayf
.Line.ForeColor.RGB = Tayf
.ZOrder msoSendToBack

End With
Exit Function
Hata:
Set Çerçevele = Nothing
Exit Function

End Function
Function ResimGönder(Optional ResimTipi As Long = xlPicture) As IPicture

EldekiResimTipi = IIf(ResimTipi = xlBitmap, 2, 14)
GeçerliResim = IsClipboardFormatAvailable(EldekiResimTipi)
If GeçerliResim <> 0 Then

Kontrol = OpenClipboard(0&)
If Kontrol > 0 Then

EldekiResim = GetClipboardData(EldekiResimTipi)
If EldekiResimTipi = 2 Then

Kopyalanan = CopyImage(EldekiResim, 0, 0, 0, &H4)

Else

Kopyalanan = CopyEnhMetaFile(EldekiResim, vbNullString)

End If
Kontrol = CloseClipboard
If EldekiResim <> 0 Then Set ResimGönder = ResimYap(Kopyalanan, 0, EldekiResimTipi)

End If

End If

End Function
Private Function ResimYap(ByVal Resim1 As Long, ByVal Eldeki As Long, ByVal EldekiResimTipi) As IPicture

On Error GoTo Hata
With Yamalamak

.Veri1 = &H7BF80980
.Veri2 = &HBF32
.Veri3 = &H101A
.Veri4(0) = &H8B: .Veri4(1) = &HBB: .Veri4(2) = &H0: .Veri4(3) = &HAA: .Veri4(4) = &H0: .Veri4(5) = &H30: .Veri4(6) = &HC: .Veri4(7) = &HAB

End With
With ResimBilgi

.Boyut = VBA.Len(Resim1)
.Tip = VBA.IIf(EldekiResimTipi = 2, 1, 4)
.Resim = Resim1
.Eldeki = VBA.IIf(EldekiResimTipi = 2, Eldeki, 0)

End With
Okunan = OleCreatePictureIndirect(ResimBilgi, Yamalamak, True, ResimNo)
Set ResimYap = ResimNo
Exit Function
Hata:
Set ResimYap = Nothing
Exit Function

End Function

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