Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

4 Mart 2012 Pazar

Media File Collector


'UserForm1

'A References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\Windows\SysWOW64\MSCOMCTL.OCX
'B Additional Tolls List
'1) Image1, Label1, label2
'2) CommandButton1, Label3
'3) Label4, ComboBox1, Slider1, Image2
'4) Label5, Label6, Label7, Label8, Label9, Label10
'5) Label11, Label12, Label13, Label14, Label15, Label16
Option Explicit
Private i As Long
Private No As Double
Private hWMP1 As Object
Private hFolder As String
Private hFile As String
Private lRow As Long
Private lFile As Long
Private Type mp3Info
Header As String * 3
Title As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 30
Genre As Byte
End Type
Dim hMedia As mp3Info
Private sName As String
Private hWnd As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpFT As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private BI As BrowseInfo
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private FIDL As Long 'Folder ID List
Private FT As String 'Folder Title
Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Me.Caption = "[PBİD®] Media File Collector"
Call Ekran_Kur
hWnd = FindWindow("ThunderDFrame", Me.Caption)
VBA.ChDir "c:\users\public"
hFolder = VBA.CurDir
Label3.Caption = " " & VBA.CurDir
Call Get_MP3_DataBase(hFolder)
Call Temizle
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
hFolder = Folder_Browse(hWnd, "Select your folder", Label3.Caption)
If VBA.Len(hFolder) = 0 Then Exit Sub
Label3.Caption = " " & hFolder
VBA.ChDrive VBA.Split(Label3.Caption, "\")(0)
VBA.ChDir Label3.Caption
Call Get_MP3_DataBase(hFolder)
Call Temizle
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
With hWMP1
.currentPlaylist.Clear
.Controls.stop
End With
Set hWMP1 = Nothing
With ComboBox1
No = .ListIndex
hFile = .Value
Label11.Caption = " " & .List(No, 1)
Label12.Caption = " " & .List(No, 2)
Label13.Caption = " " & .List(No, 3)
Label14.Caption = " " & .List(No, 4)
Label15.Caption = " " & .List(No, 5)
Label16.Caption = " " & .List(No, 6)
End With
Set hWMP1 = Me.Controls.Add("WMPlayer.OCX.7", "hWMP1", False)
With hWMP1
.Top = 36
.Left = 354
.Height = 180
.Width = 184
.settings.mute = False
Slider1.Value = 10
.fullScreen = False
.currentPlaylist.Clear
.currentPlaylist.appendItem .newMedia(hFile)
.Controls.Play
End With
VBA.DoEvents
Me.Repaint
End Sub
Private Sub Slider1_Change()
On Error Resume Next
hWMP1.settings.volume = Slider1.Value
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
With hWMP1
.currentPlaylist.Clear
.Controls.stop
End With
Set hWMP1 = Nothing
Application.Visible = True
End Sub
Private Function Folder_Browse(ByVal hWnd As Long, Title As String, StartDir As String) As String
On Error Resume Next
CF = StartDir & vbNullChar
FT = Title
With BI
.hWndOwner = hWnd
.lpFT = lstrcat(FT, "")
.ulFlags = 1 + 2 + &H4&
.lpfnCallback = Folder_Adress(AddressOf Browse_Procedure)
End With
FIDL = SHBrowseForFolder(BI)
If (FIDL) Then
FB = Space(260)
SHGetPathFromIDList FIDL, FB
FB = Left(FB, InStr(FB, vbNullChar) - 1)
Folder_Browse = FB
Else
Folder_Browse = ""
End If
End Function
Private Function Folder_Adress(Additional As Long) As Long
On Error Resume Next
Folder_Adress = Additional
End Function
Private Sub Get_MP3_DataBase(hFolder)
On Error Resume Next
lRow = 0
ComboBox1.Clear
With Application.FileSearch
.NewSearch
.Filename = "*.wma;*.mp2;*.pmp2;*.ac3;*.ogg;*.wav;*.aac;*.aiff;*.au;*.ram;*.ra;*.cda;*.amr;*.m4a;*.mmf;*.awb;*.flac;*.ape;*.mpc;*.mp3;*.avi;*.mp4;*.pmp4;*.pmp5;*.3gp;*.dat;*.gt;*.mov;*.mpg;*.mpeg;*.m1v;*.wmv;*.rmvb;*.rm;*.asf;*.3gp2;*.3g2;*.3gpp;*.swf;*.flv;*.fli;*.flc;*.m4v;*.dv;*.mkv;*.ogm;*.dsm;*.vob;*.gif;*.cin;*.ts"
.LookIn = hFolder
.SearchSubFolders = True
.Execute
For i = 1 To .FoundFiles.Count
lFile = VBA.FreeFile
Open .FoundFiles(i) For Binary As lFile
Get lFile, LOF(1) - 127, hMedia
Close lFile
ComboBox1.AddItem VBA.Trim(.FoundFiles(i)), lRow
With hMedia
ComboBox1.List(lRow, 1) = VBA.Trim(.Title) & " & " & hMedia.Header
ComboBox1.List(lRow, 2) = VBA.Trim(.Artist)
ComboBox1.List(lRow, 3) = VBA.Trim(.Album)
ComboBox1.List(lRow, 4) = VBA.Trim(.Year)
ComboBox1.List(lRow, 5) = VBA.Trim(.Genre)
ComboBox1.List(lRow, 6) = VBA.Trim(.Comment)
sName = ComboBox1.List(lRow, 5)
Select Case sName
Case 0: sName = "Blues"
Case 1: sName = "Classic Rock"
Case 2: sName = "Country"
Case 3: sName = "Dance"
Case 4: sName = "Disco"
Case 5: sName = "Funk"
Case 6: sName = "Grunge"
Case 7: sName = "Hip Hop"
Case 8: sName = "Jazz"
Case 9: sName = "Metal"
Case 10: sName = "New Age"
Case 11: sName = "Oldies"
Case 12: sName = "Other"
Case 13: sName = "Pop"
Case 14: sName = "R&B"
Case 15: sName = "Rap"
Case 16: sName = "Reggae"
Case 17: sName = "Rock"
Case 18: sName = "Techno"
Case 19: sName = "Industrial"
Case 20: sName = "Alternative"
Case 21: sName = "Ska"
Case 22: sName = "Death Metal"
Case 23: sName = "Pranks"
Case 24: sName = "Soundtrack"
Case 25: sName = "Euro - Techno"
Case 255: sName = "Not Defined"
Case 26: sName = "Ambient"
Case 27: sName = "Trip Hop"
Case 28: sName = "Vocal"
Case 29: sName = "Jazz - Funk"
Case 30: sName = "Fusion"
Case 31: sName = "Trance"
Case 32: sName = "Classical"
Case 33: sName = "Instrumental"
Case 34: sName = "Acid"
Case 35: sName = "House"
Case 36: sName = "Game"
Case 37: sName = "Sound Clip"
Case 38: sName = "Gospel"
Case 39: sName = "Noise"
Case 40: sName = "Alt.Rock"
Case 41: sName = "Bass"
Case 42: sName = "Soul"
Case 43: sName = "Punk"
Case 44: sName = "Space"
Case 45: sName = "Meditative"
Case 46: sName = "Instrumental Pop"
Case 47: sName = "Instrumental Rock"
Case 48: sName = "Ethnic"
Case 49: sName = "Gothic"
Case 50: sName = "Darkwave"
Case 51: sName = "Techno - Industrial"
Case 52: sName = "Electronic"
Case 53: sName = "Pop / Folk"
Case 54: sName = "Eurodance"
Case 55: sName = "Dream"
Case 56: sName = "Southern Rock"
Case 57: sName = "Comedy"
Case 58: sName = "Cult"
Case 59: sName = "Gangsta Rap"
Case 60: sName = "Top 40"
Case 61: sName = "Christian Rap"
Case 62: sName = "Pop / Funk"
Case 63: sName = "Jungle"
Case 64: sName = "Native American"
Case 65: sName = "Cabaret"
Case 66: sName = "New Wave"
Case 67: sName = "Psychedelic"
Case 68: sName = "Rave"
Case 69: sName = "Showtunes"
Case 70: sName = "Trailer"
Case 71: sName = "Lo - fi"
Case 72: sName = "Tribal"
Case 73: sName = "Acid Punk"
Case 74: sName = "Acid Jazz"
Case 75: sName = "Polka"
Case 76: sName = "Retro"
Case 77: sName = "Musical"
Case 78: sName = "Rock 'n'Roll"
Case 79: sName = "Hard Rock"
Case 80: sName = "Folk"
Case 81: sName = "Folk / Rock"
Case 82: sName = "National Folk"
Case 83: sName = "Swing"
Case 84: sName = "Fast Fusion"
Case 85: sName = "Bebob"
Case 86: sName = "Latin"
Case 87: sName = "Revival"
Case 88: sName = "Celtic"
Case 89: sName = "Blue Grass"
Case 90: sName = "Avant Garde"
Case 91: sName = "Gothic Rock"
Case 92: sName = "Progressive Rock"
Case 93: sName = "Psychedelic Rock"
Case 94: sName = "Symphonic Rock"
Case 95: sName = "Slow Rock"
Case 96: sName = "Big Band"
Case 97: sName = "Chorus"
Case 98: sName = "Easy Listening"
Case 99: sName = "Acoustic"
Case 100: sName = "Humour"
Case 101: sName = "Speech"
Case 102: sName = "Chanson"
Case 103: sName = "Opera"
Case 104: sName = "Chamber Music"
Case 105: sName = "Sonata"
Case 106: sName = "Symphony"
Case 107: sName = "Booty Bass"
Case 108: sName = "Primus"
Case 109: sName = "Pr0n Groove"
Case 110: sName = "Satire"
Case 111: sName = "Slow Jam"
Case 112: sName = "Club"
Case 113: sName = "Tango"
Case 114: sName = "Samba"
Case 115: sName = "Folklore"
Case 116: sName = "Ballad"
Case 117: sName = "Power Ballad"
Case 118: sName = "Rhythmic Soul"
Case 119: sName = "Freestyle"
Case 120: sName = "Duet"
Case 121: sName = "Punk Rock"
Case 122: sName = "Drum Solo"
Case 124: sName = "Euro - House"
Case 125: sName = "Dance Hall"
Case 126: sName = "Goa"
Case 127: sName = "Drum & Bass"
Case 128: sName = "Club - House"
Case 129: sName = "Hardcore"
Case 130: sName = "Terror"
Case 131: sName = "Indie"
Case 132: sName = "Brit Pop"
Case 133: sName = "Negerpunk"
Case 134: sName = "Polsk Punk"
Case 135: sName = "Beat"
Case 136: sName = "Christian Gangsta Rap"
Case 137: sName = "Heavy Metal"
Case 138: sName = "Black Metal"
Case 139: sName = "Crossover"
Case 140: sName = "Contemporary Christian"
Case 141: sName = "Christian Rock"
Case 142: sName = "Merengue"
Case 143: sName = "Salsa"
Case 144: sName = "Thrash Metal"
Case 145: sName = "Anime"
Case 146: sName = "JPop"
Case 147: sName = "Synth Pop"
End Select
ComboBox1.List(lRow, 5) = VBA.Trim(sName)
End With
lRow = lRow + 1
Next i
End With
End Sub
Private Sub Temizle()
On Error Resume Next
Label11.Caption = ""
Label12.Caption = ""
Label13.Caption = ""
Label14.Caption = ""
Label15.Caption = ""
Label16.Caption = ""
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 244
.Width = 544
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 318
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With CommandButton1
.Caption = "Chose Folder"
.Left = 6
.Top = 36
.Height = 24
.Width = 78
.Picture = Resim(URL3)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Font.Bold = False
End With
With Label3
.Left = 84
.Top = 36
.Height = 24
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label4
.Left = 6
.Top = 60
.Height = 18
.Width = 78
.Caption = " mp3"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With ComboBox1
.Left = 84
.Top = 60
.Height = 18
.Width = 264
.BackColor = &H80000018
.ForeColor = &H808000
.SpecialEffect = fmSpecialEffectEtched
.Text = "Chose The mp3 File"
End With
With Label5
.Left = 6
.Top = 78
.Height = 18
.Width = 78
.Caption = " Title & Header"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label11
.Left = 84
.Top = 78
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label6
.Left = 6
.Top = 96
.Height = 18
.Width = 78
.Caption = " Artist"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label12
.Left = 84
.Top = 96
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label7
.Left = 6
.Top = 114
.Height = 18
.Width = 78
.Caption = " Album"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label13
.Left = 84
.Top = 114
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label8
.Left = 6
.Top = 132
.Height = 18
.Width = 78
.Caption = " Year"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label14
.Left = 84
.Top = 132
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label9
.Left = 6
.Top = 150
.Height = 18
.Width = 78
.Caption = " Genre"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label15
.Left = 84
.Top = 150
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label10
.Left = 6
.Top = 168
.Height = 18
.Width = 78
.Caption = " Comment"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label16
.Left = 84
.Top = 168
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Slider1
.Left = 6
.Top = 192
.Height = 24
.Width = 342
.Min = 0
.Max = 100
.LargeChange = 10
.SmallChange = 1
.BorderStyle = ccNone
.Orientation = ccOrientationHorizontal
.TickStyle = sldBottomRight
.TickFrequency = 5
End With
With Image2
.Left = 354
.Top = 36
.Height = 180
.Width = 180
.Picture = Resim(URL4)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End Sub

'Module1

Option Explicit
Public CF As String 'Current Folder
Public FB As String 'Folder Buffer
Private RF As Long 'Folder Return
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public Const URL3 As String = "http://3.bp.blogspot.com/-T8LAuWdsz_U/TcXIq0lIpPI/AAAAAAAACw4/UnomGxo3OEM/s1600/Dosya_A%25C3%25A7.gif"
Public Const URL4 As String = "http://4.bp.blogspot.com/_hsHTxo_5L8E/TKHXGkuirgI/AAAAAAAAClg/qxwPnMtL07M/s1600/maple-leaves-wallpapers_10555_1024x768.jpg"
Public URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...
On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
Public Function Browse_Procedure(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Error Resume Next
Select Case uMsg
Case 1
Call SendMessage(hWnd, (&H400 + 102), 1, CF)
Case 2
FB = Space(260)
RF = SHGetPathFromIDList(lp, FB)
If RF = 1 Then Call SendMessage(hWnd, (&H400 + 100), 0, FB)
End Select
Browse_Procedure = 0
End Function
'Sub References_List()
' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'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