Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

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

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