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

10 Mayıs 2007 Perşembe

Create Short Cut Path On Start Button



'Module1

Option Explicit
Dim Yol As String '
Path
Dim Simge As Object
'Icon
Dim SimgeYol As Object
'IconPath
Dim KısaYol As String
'ShortCutPath
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Sub KısaYolYarat()
'ShortCutPath Create

On Error Resume Next
Set Simge = VBA.CreateObject("Wscript.Shell")
Yol = Simge.SpecialFolders("Programs")
VBA.MkDir Yol & "\Pbid"
KısaYol = Yol & "\Pbid" & "\" & "Pbid.lnk"
Set SimgeYol = Simge.CreateShortcut(KısaYol)
With SimgeYol
.TargetPath = "C:\Documents and Settings\PC\Desktop\BLOGSPOT\KısaYolYarat.xls"
.Description = "Pbid ® ShortCut Path of KısaYolYarat.xls"
.IconLocation = "C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico"
.RelativePath = "C:\Pbid"
.WorkingDirectory = "C:\Documents and Settings\PC\Desktop\BLOGSPOT"
.Hotkey = "Ctrl+Alt+p"
.Save
End With
Set Simge = Nothing
Call BaşlatAç
End Sub
Sub BaşlatAç()
'Open Start Bar

On Error Resume Next
Call keybd_event(&H11, 0, 0, 0)
Call keybd_event(&H1B, 0, 0, 0)
Call keybd_event(&H1B, 0, &H2, 0)
Call keybd_event(&H11, 0, &H2, 0)
End Sub 

1 Mayıs 2007 Salı

Log File Creation



'Sheet(Sayfa1)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Set Alan = Application.Selection
For Each Hücre In Alan.Cells
Call LogDosyaYaz(Hücre.Address & ":" & Hücre.FormulaR1C1)
Next Hücre
End Sub
Sub LogDosyaYaz(HücreVeri)
'Write Log File

On Error Resume Next
FL = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name & ".LOG"
TS = VBA.Format(Date, "d mmm yy") & " at " & VBA.Format(Time, "hh:mm am/pm")
If (VBA.Len(TS) = 21) Then
TS=""
Else
TS = Application.Rept(" ", 21 - VBA.Len(TS)) & TS'TarihKontrol
End if
FN = VBA.FreeFile()
If VBA.Dir(FL) = "" Then
Open FL For Append As #FN
Print #FN, "Opened: " & TS
Close #FN
End If
Open FL For Append As #FN
Print #FN, TS & ": " & HücreVeri
Close #FN
End Sub

'Module1

Option Explicit
Public RV As Double
'KayıtPublic Alan As Range, Hücre As Range
Public FN
'File Number
Public FL
'Log File
Public TS
'Time Serial

Sub LogDosyaAç() 'OpenLogFile
On Error Resume Next
FL = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name & ".LOG"
If VBA.Dir(FL) = "" Then
MsgBox "Geçerli bir dosya bulunamadı!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ" & vbCrLf & "01ulusarac@superonline.com", vbOKOnly, "[PBİD®] Log File "
Else
RV = VBA.Shell("NOTEPAD.EXE" & " " & FL, 3)
End If
End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi