Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Ocak 2012 Salı

Create Wscript.Shell For Your Favorite Folder


'UserForm1

'A. Available 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
'7) Name: SHDocVw, Description: Microsoft Internet Controls, FullPath: C:\Windows\SysWOW64\ieframe.dll
'B. Available Tools List
'1) Image1, Label1, Label2, Image2, ImageList1
'2) TreeView1
'3) WebBrowser1
Option Explicit
Private i As Integer
Private CB As CommandBar
Private CBB As CommandBarButton
Private nFaceID As Variant
Private hPicture As IPictureDisp
Private hImage As ListImage
Private FSO As Object
Private hFile As Object
Private hFolder As Object
Private hShell As Object
Private hFavorite As String
Private fFavorite As Object
Private hNode As INode
Private nNode1 As Node
Private nNode2 As Node
Private hURL As Object
Private Ekran As New Class1
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Create Wscript.Shell For Your Favorite Folder"
Call FaceID_List
Call Ekran_Kur
Set Ekran.Ekran1 = Me
Call TreeView_Kur
End Sub
Private Sub UserForm_Resize()
On Error Resume Next
TreeView1.Height = Me.InsideHeight - TreeView1.Top
With WebBrowser1
.Height = TreeView1.Height
.Width = Me.InsideWidth - .Left - 6
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
End Sub
Private Sub TreeView1_Click()
On Error Resume Next
Set hNode = TreeView1.SelectedItem
Set hURL = hShell.CreateShortcut(hFavorite & "\" & VBA.Replace(hNode.FullPath, "Your Favourite websites", "") & ".url")
If hURL.TargetPath <> "" Then
WebBrowser1.Navigate "" & hURL.TargetPath
End If
End Sub
Private Sub TreeView_Kur()
On Error Resume Next
Set nNode1 = TreeView1.Nodes.Add(, , , "Your Favourite websites", 1)
With nNode1
.Expanded = True
Set hShell = CreateObject("Wscript.Shell")
hFavorite = hShell.specialfolders("Favorites")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fFavorite = FSO.GetFolder(hFavorite)
Call Favorite_List(.Index, fFavorite)
For Each hFile In fFavorite.Files
If VBA.LCase(VBA.Right(hFile.Name, 4)) = ".url" Then
TreeView1.Nodes.Add .Index, tvwChild, , VBA.LCase(VBA.Left(hFile.Name, VBA.Len(hFile.Name) - 4)), 4, 5
End If
Next hFile
End With
End Sub
Sub Favorite_List(hID, nFolder)
On Error Resume Next
For Each hFolder In nFolder.subfolders
Set nNode2 = TreeView1.Nodes.Add(hID, tvwChild, , hFolder.Name, 2, 3)
For Each hFile In hFolder.Files
If LCase(Right(hFile.Name, 4)) = ".url" Then
TreeView1.Nodes.Add nNode2.Index, tvwChild, , LCase(Left(hFile.Name, Len(hFile.Name) - 4)), 4, 5
End If
Next hFile
Call Favorite_List(nNode2.Index, hFolder)
Next hFolder
End Sub
Sub FaceID_List()
On Error Resume Next
nFaceID = Array(1016, 137, 138, 168, 169)
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
Set CB = Application.CommandBars.Add(Name:="FaceIds", Temporary:=True)
With CB
.Visible = False
For i = 0 To 4
Set CBB = .Controls.Add(Type:=msoControlButton, ID:=2950)
With CBB
.FaceId = nFaceID(i)
Set hPicture = Nothing
Set hPicture = .Picture
Set hImage = ImageList1.ListImages.Add(i + 1, "Key" & i + 1, hPicture)
If i = 0 Then Image2.Picture = hPicture
.Delete
End With
Next
End With
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
TreeView1.ImageList = ImageList1
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 402
.Width = 582
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
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 = 240
.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 = 240
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With TreeView1
.Left = 6
.Top = 36
.Width = 196
.Height = Me.InsideHeight - .Top
.Appearance = ccFlat
.BorderStyle = ccNone
.LineStyle = tvwRootLines
.Scroll = True
.Style = tvwTreelinesPlusMinusPictureText
End With
With WebBrowser1
.Left = TreeView1.Left + TreeView1.Width
.Top = TreeView1.Top
.Height = TreeView1.Height
.Width = Me.InsideWidth - .Left - 6
End With
Image2.Top = -6000
End With
End Sub

'Module1

Option Explicit
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 URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
Load UserForm1
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
'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

'Class1

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Pencere_Düzeni As Long, ByVal Mesaj As Long, ByVal Değişken1 As Long, Değişken2 As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Pencere As Long, ByVal Koordinat As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal Pencere As Long, ByVal Eylem As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal Pencere As Long) As Long
Private hWindow As Long
Private hImage As Long
Public Property Set Ekran1(Ekran As Object)
On Error Resume Next
hWindow = FindWindow(vbNullString, Ekran.Caption)
hImage = Ekran.Image2.Picture.Handle
Call Simge_Yarat(hWindow, hImage)
SetWindowLong hWindow, (-16), GetWindowLong(hWindow, (-16)) Or &H80000 Or &H20000 Or &H10000
ShowWindow hWindow, 3
DrawMenuBar hWindow
End Property
Private Function Simge_Yarat(hWindow, hImage)
On Error Resume Next
Call SendMessage(hWindow, &H80, 0&, ByVal hImage)
Call SendMessage(hWindow, &H80, 1&, ByVal hImage)
End Function

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