Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mayıs 2007 Pazar

Create The Filter For WindowsMediaPlayer1 Files



'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
'Microsoft Windows Common Control 6.0 (SP6)
'Windows Media Player
'B) Addition Tools on UserForm1
'Frame1
'Frame1\Image1, Label1, Label2
'TreeView1, WindowsMediaPlayer1, Label3
Option Explicit
Dim Dosyalama As Object, oDosya As Object, sDosya As Object
Dim Klasör As Object, oKlasör As Object, sKlasör As Object, dKlasör As Object
Dim No, Bilgi, Klasörlenen
Dim Dal, DalAnahtarı, DalAdı, OkunanDosya, EklenenDosya, DosyaBilgisi() As String
Dim ÖzelMenü, ÖzelKomut
Dim Resimlik As New ImageList
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Creat The Filter For WindowsMediaPlayer1 Files"
Call EkranDüzenle
Call KlasörDüzeniKur
End Sub
Private Sub TreeView1_DblClick()

On Error Resume Next
Dim Yol As String
Yol = TreeView1.SelectedItem.Key
Label3.Caption = Yol
WindowsMediaPlayer1.URL = Yol
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)

If Node.Image = 1 Then
Call AğaçKur(Node.Key)
End If
End Sub
Sub KlasörDüzeniKur()

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
For Each Klasör In Dosyalama.Drives
Bilgi = Klasör.DriveLetter & ":\"
If Bilgi = "K:\" Then
Exit For
Else
Set Dal = TreeView1.Nodes.Add(, , Bilgi, Bilgi, 1)
AğaçKur (Bilgi)
End If
Next
End Sub
Sub AğaçKur(rKlasör As String)

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
On Error GoTo Mevcut
Set oKlasör = Dosyalama.GetFolder(rKlasör)
Set sKlasör = oKlasör.SubFolders
For Each dKlasör In sKlasör
Klasörlenen = dKlasör.ParentFolder
DalAnahtarı = dKlasör.Path
DalAdı = dKlasör.Name
Set Dal = TreeView1.Nodes.Add(Klasörlenen, 4, DalAnahtarı, DalAdı, 1)
Next
OkunanDosya = DosyaBilgisiGetir(rKlasör)
For EklenenDosya = 1 To UBound(OkunanDosya)
If OkunanDosya(EklenenDosya, 1) = "" Then
Else
Set Dal = TreeView1.Nodes.Add(OkunanDosya(EklenenDosya, 3), 4, OkunanDosya(EklenenDosya, 2), OkunanDosya(EklenenDosya, 1), 2)
End If
Next EklenenDosya
Mevcut:
End Sub
Function DosyaBilgisiGetir(rFolder As String)

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
Set oKlasör = Dosyalama.GetFolder(rFolder)
Set oDosya = oKlasör.Files
ReDim DosyaBilgisi(oDosya.Count, 3)
No = 0
For Each sDosya In oDosya
No = No + 1
If sDosya.ParentFolder = rFolder And sDosya.Type = "MP3 Format Sound" Or sDosya.Type = "Windows Media Audio file" Or sDosya.Type = "Wave Sound" Or sDosya.Type = "M3U Biçimli Ses" Then
DosyaBilgisi(No, 1) = sDosya.Name
DosyaBilgisi(No, 2) = sDosya.Path
DosyaBilgisi(No, 3) = sDosya.ParentFolder

End If
Next
DosyaBilgisiGetir = DosyaBilgisi
End Function
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 372
.Width = 680
With Frame1
.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
If .Picture Is Nothing Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
With Image1
.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
If .Picture Is Nothing Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\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 Resimlik
Set ÖzelMenü = Application.CommandBars.Add("", msoBarPopup, , True)
Set ÖzelKomut = ÖzelMenü.Controls.Add(1, , , , True)
ÖzelKomut.FaceId = 6496
.ListImages.Add 1, "K1", ÖzelKomut.Picture
ÖzelKomut.FaceId = 7166
.ListImages.Add 2, "K2", ÖzelKomut.Picture
End With
With TreeView1
.ImageList = Resimlik
.Appearance = ccFlat
.BorderStyle = ccNone
.Indentation = 14
.LineStyle = tvwRootLines
.Top = 30
.Left = 0
.Height = Me.Height - .Top - 24
.Width = 240
End With
With Label3
.Top = TreeView1.Top
.Left = TreeView1.Left + TreeView1.Width
.Height = 12
.Width = Me.Width - .Left
.BackColor = vbWhite
.Caption = ""
.ForeColor = vbBlue
End With
With WindowsMediaPlayer1
.Top = TreeView1.Top + Label1.Height
.Left = TreeView1.Left + TreeView1.Width
.Height = TreeView1.Height - Label1.Height
.Width = Me.Width - .Left
End With
End With
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