Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Haziran 2012 Pazar

Enumerate Windows Styles [3]




'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
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) TreeView1
'3) Label3, Label4, CommandButton1, Label5, TextBox1, Label6, TextBox2, CommandButton2, CommandButton3
Option Explicit
Dim hWind As Long
Dim lParam As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Me.Caption = "[PBİD®] Enumerate Windows Styles [3]"
Call Ekran_Kur
Set hForm = Me
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Application.Visible = True
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
Dim i As Single
Dim ii As Single
TextBox1.Value = ""
Label4.Caption = TreeView1.SelectedItem.Index
hWind = VBA.Right(TreeView1.SelectedItem.Key, VBA.Len(TreeView1.SelectedItem.Key) - 3)
TextBox1.Value = hWind
hChoose = hWind
hDC = GetDC(hChoose)
wReturn = GetWindowRect(hChoose, wRect)
wWidth = wRect.Right - wRect.Left
wHeight = (wRect.Bottom - wRect.Top)
Me.Repaint
For i = 1 To wWidth Step 6
For ii = 1 To wHeight Step 6
SetPixel hDC, i, ii, VBA.RGB(120, 120, 120)
Next ii
Next i
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Dim hControl As Control
Dim hID As Long
CommandButton2.Enabled = False
hDirection = -1
Do While Bellek.Count <> 0
Bellek.Remove 1
Loop
TreeView1.Nodes.Clear
hWind = FindWindow(vbNullString, Me.Caption)
TextBox1.Value = hWind
For Each hControl In Me.Controls
hControl.Visible = True
Next hControl
Call Get_EnumThreadWindows(hWind, lParam) ' Find the Thunder Windows hDirection = 1
Call EnumChildWindows(hWind, AddressOf Get_EnumChildWindows, lParam) ' Find the Child Windows
DoEvents
Label4 = TreeView1.Nodes.Count
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
hDirection = 1
hWind = TextBox1.Value
DoEvents
Call Get_EnumWindows(hWind, lParam) ' Find the Parent Windows
DoEvents
Label4 = TreeView1.Nodes.Count
With TreeView1.Nodes(1)
.Selected = True
.Expanded = False
.Expanded = True
End With
End Sub
Private Sub CommandButton3_Click()
On Error Resume Next
Dim hID As Long
Dim i As Single
Dim ii As Single
CommandButton2.Enabled = False
hDirection = 0
Do While Bellek.Count <> 0
Bellek.Remove 1
Loop
With TreeView1
.Nodes.Clear
.Nodes.Add , , "Key0", Application.UserName & " Windows Enumeration"
End With
hID = 0
Do While hID <> TreeView1.Nodes.Count
Label4 = TreeView1.Nodes.Count
hWind = VBA.Right(TreeView1.Nodes(hID + 1).Key, VBA.Len(TreeView1.Nodes(hID + 1).Key) - 3)
TextBox1.Value = hWind
DoEvents
Call EnumChildWindows(hWind, AddressOf Get_EnumChildWindows, lParam) ' Find the Child Windows hDirection = 1
hID = hID + 1
Loop
hID = 0
Do While hID <> TreeView1.Nodes.Count
Label4 = TreeView1.Nodes.Count
With TreeView1.Nodes(hID + 1)
If .Children > 0 Then
.Bold = True
.ForeColor = &H800000
Else
.Bold = False
.ForeColor = vbBlue
End If
End With
Label4 = TreeView1.Nodes(hID).Index
DoEvents
hID = hID + 1
Loop
With TreeView1.Nodes(1)
.Selected = True
.Expanded = False
.Expanded = True
End With
hDC = GetDC(hChoose)
wReturn = GetWindowRect(hChoose, wRect)
wWidth = wRect.Right - wRect.Left
wHeight = (wRect.Bottom - wRect.Top)
For i = 1 To wWidth Step 6
For ii = 1 To wHeight Step 6
SetPixel hDC, i, ii, VBA.RGB(120, 120, 120)
Next ii
Next i
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
hWind = TextBox1.Value
If TextBox1.Value <> "" Then
CommandButton2.Enabled = True
Else
CommandButton2.Enabled = False
End If
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
lParam = TextBox2.Value
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 358
.Width = 510
.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 = 420
.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 = 420
.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
.Height = 258
.Width = 492
.Appearance = ccFlat
.BorderStyle = ccFixedSingle
.FullRowSelect = True
.LineStyle = tvwRootLines
.Scroll = True
.Style = tvwTreelinesPlusMinusPictureText
.Sorted = False
.Indentation = 28.35
End With
With Label3
.Left = 6
.Top = 300
.Height = 12
.Width = 48
.Caption = "ID"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Label4
.Left = 6
.Top = 312
.Height = 18
.Width = 48
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With CommandButton1
.Left = 60
.Top = 300
.Height = 30
.Width = 102
.Caption = "Child Window of UserForm"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
End With
With Label5
.Left = 168
.Top = 300
.Height = 12
.Width = 84
.Caption = "Window Long"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With TextBox1
.Left = 168
.Top = 312
.Height = 18
.Width = 84
.Value = 0
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = True
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
.Enabled = True
End With
With Label6
.Left = 252
.Top = 300
.Height = 12
.Width = 30
.Caption = "lParam"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With TextBox2
.Left = 252
.Top = 312
.Height = 18
.Width = 30
.Value = 0
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = True
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
.Enabled = False
End With
With CommandButton2
.Left = 288
.Top = 300
.Height = 30
.Width = 102
.Caption = "Child Window of wLong"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
End With
With CommandButton3
.Left = 396
.Top = 300
.Height = 30
.Width = 102
.Caption = "Child Window of All"
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
End With
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ç()
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
'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

'Module2

Option Explicit
Public hDirection As Double
Public hDC As Long
Public hForm As Object
Public hChoose As Long
Public wReturn As Long
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public wRect As RECT
Public wWidth As Long
Public wHeight As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Bellek As New Collection
Function Get_EnumWindows(ByVal hWind As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim wID As Long
Dim tID As Long
Dim wCBuffer As String * 255
Dim wTBuffer As String * 255
Dim wClass As String
Dim wTitle As String
Dim nText As String
Dim nKey As String
Dim rKey As String
wReturn = GetClassName(hWind, wCBuffer, 255)
wClass = Get_Null_String(wCBuffer)
wReturn = GetWindowText(hWind, wTBuffer, 255)
wTitle = Get_Null_String(wTBuffer)
nKey = "Key" & hWind
nText = "Long: " & hWind & ", Class: " & wClass & ", Title: " & wTitle
Call EnumChildWindows(hWind, AddressOf Get_EnumChildWindows, lParam)
tID = GetWindowThreadProcessId(hWind, wID)
Call EnumThreadWindows(tID, AddressOf Get_EnumThreadWindows, lParam)
Get_EnumWindows = True
End Function
Function Get_EnumThreadWindows(ByVal hWind As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim wCBuffer As String * 255
Dim wTBuffer As String * 255
Dim wClass As String
Dim wTitle As String
Dim nText As String
Dim nKey As String
Dim rKey As String
wReturn = GetClassName(hWind, wCBuffer, 255)
wClass = Get_Null_String(wCBuffer)
wReturn = GetWindowText(hWind, wTBuffer, 255)
wTitle = Get_Null_String(wTBuffer)
With hForm.TreeView1
nKey = "Key" & hWind
nText = "Long: " & hWind & ", Class: " & wClass & ", Title: " & wTitle
If hDirection = -1 Then
.Nodes.Add , , nKey, nText
ElseIf hDirection = 0 Then
rKey = "Key0"
.Nodes.Add rKey, 4, nKey, nText
Else
rKey = "Key" & hForm.TextBox1.Value
.Nodes.Add rKey, 4, nKey, nText
VBA.DoEvents
End If
.Nodes("Key" & hWind).Expanded = True
.Nodes("Key" & hWind).EnsureVisible
End With
Get_EnumThreadWindows = True
End Function
Function Get_EnumChildWindows(ByVal hWind As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim wCBuffer As String * 255
Dim wTBuffer As String * 255
Dim wClass As String
Dim wTitle As String
Dim nText As String
Dim nKey As String
Dim rKey As String
Bellek.Add hWind, "Key" & hWind
If VBA.Err.Number = 0 Then
wReturn = GetClassName(hWind, wCBuffer, 255)
wClass = Get_Null_String(wCBuffer)
wReturn = GetWindowText(hWind, wTBuffer, 255)
wTitle = Get_Null_String(wTBuffer)
With hForm.TreeView1
nKey = "Key" & hWind
nText = "Long: " & hWind & ", Class: " & wClass & ", Title: " & wTitle
If hDirection = -1 Then
.Nodes.Add , , nKey, nText
ElseIf hDirection = 0 Then
rKey = "Key0"
.Nodes.Add rKey, 4, nKey, nText
Else
rKey = "Key" & hForm.TextBox1.Value
.Nodes.Add rKey, 4, nKey, nText
VBA.DoEvents
End If
.Nodes("Key" & hWind).Expanded = True
.Nodes("Key" & hWind).EnsureVisible
End With
If wClass = "TreeView20WndClass" Then
hChoose = hWind
'Get_EnumChildWindows = False
Get_EnumChildWindows = True
Else
Get_EnumChildWindows = True
End If
Else
VBA.Err.Clear
End If
End Function
Public Function Get_Null_String(wString As String) As String
On Error Resume Next
If VBA.InStr(wString, VBA.Chr(0)) > 0 Then
wString = VBA.Left(wString, VBA.InStr(wString, VBA.Chr(0)) - 1)
End If
If wString = "" Then
Get_Null_String = "N/A"
Else
Get_Null_String = wString
End If
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