Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2012 Çarşamba

CreateMetaFile Function



'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
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) Label3
'3) CommandButton1, Frame1
Option Explicit
Private i As Single
Private ii As Single
Private hWnd As Long
Private hDC As Long
Private hPoint1 As Long
Private hPoint2 As Long
Private hColor As Long
Private R As Double
Private G As Double
Private B As Double
Private hFile As String
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private PA As POINTAPI
Private Declare Function CreateMetaFile Lib "gdi32" Alias "CreateMetaFileA" (ByVal lpString As String) As Long
Private Declare Function CloseMetaFile Lib "gdi32" (ByVal hMF As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Drawing As Boolean
Private hMF As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Me.Caption = "[PBİD®] CreateMetaFile Function"
Call Ekran_Kur
hWnd = FindWindow("ThunderDFrame", Me.Caption)
hDC = GetDC(hWnd)
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
CloseMetaFile hMF
Application.Visible = True
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
If Button And 1 Then
Drawing = True
Else
Drawing = False
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
If Drawing Then
LineTo hDC, (x / 0.748), (y / 0.748)
LineTo hMF, (x / 0.748), (y / 0.748)
MoveToEx hMF, (x / 0.748), (y / 0.748), PA
End If
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
On Error Resume Next
Drawing = False
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
If CommandButton1.Caption = "Create WMF" Then
VBA.Kill Label3.Caption
hMF = CreateMetaFile(Label3.Caption)
If hMF = 0 Then
MsgBox Label3.Caption & " MetaFile can not created.", vbCritical, "[PBİD®] CreateMetaFile API Function"
Exit Sub
End If
Me.Picture = Me.Picture
CommandButton1.Caption = "Open WMF"
Call Create_WMF
Else
CloseMetaFile hMF
CommandButton1.Caption = "Create WMF"
Call Open_WMF(hFile)
End If
Exit Sub
End Sub
Private Sub Create_WMF()
On Error Resume Next
Dim x As Long
Dim y As Long
hWnd = FindWindow("ThunderDFrame", Me.Caption)
hPoint1 = GetDC(hWnd)
Me.Repaint
Frame1.SetFocus
hWnd = VBA.CStr(GetFocus)
hPoint2 = GetDC(hWnd)
For i = 1 To Frame1.InsideWidth / 0.748
For ii = 1 To Frame1.InsideHeight / 0.748
hColor = GetPixel(hPoint2, i, ii)
R = VBA.Int(hColor Mod 256)
G = VBA.Int((hColor Mod 65536) / 256)
B = VBA.Int(hColor / 65536)
x = i + (6 / 0.748)
y = ii + ((Label3.Top + Label3.Height) / 0.748)
SetPixel hPoint1, x, y, VBA.RGB(R, G, B)
SetPixel hMF, x, y, VBA.RGB(R, G, B)
MoveToEx hMF, i, ii, PA
DoEvents
Next ii
Next i
End Sub
Function Open_WMF(sFile)
On Error GoTo Error_Handler
Shell VBA.Chr(34) & "C:\Windows\System32\mspaint.exe" & VBA.Chr(34) & " " & VBA.Chr(34) & sFile & Chr(34), vbNormalFocus
If VBA.Err.Number = 0 Then Exit Function
Error_Handler:
VBA.Err.Clear
MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Source: Open WMF" & vbCrLf & "Error Description: " & Err.Description, vbCritical, "[PBİD®] WMF Open"
Exit Function
End Function
Private Sub Create_OLEObject()
On Error Resume Next
Dim hFrame As OLEObject
Set hFrame = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Frame.1", Link:=False, DisplayAsIcon:=False, Left:=0, Top:=0, Width:=36, Height:=36)
With hFrame
.Object.Caption = ""
.Object.Picture = Resim(URL3)
.Object.PictureAlignment = fmPictureAlignmentCenter
.Object.PictureSizeMode = fmPictureSizeModeStretch
.Object.PictureTiling = False
.Border.LineStyle = fmBorderStyleNone
.Width = .Object.Picture.Width
.Height = .Object.Picture.Height
.Object.SetFocus
hWnd = VBA.CStr(GetFocus)
hPoint2 = GetDC(hWnd)
End With
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 324
.Width = 492
'.Picture = Resim(URL1)

.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
.ForeColor = vbRed
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 Label3
.Left = 6
.Top = 36
.Height = 18
.Width = 474
hFile = ThisWorkbook.Path
If VBA.Right$(hFile, 1) <> "\" Then
hFile = hFile & "\"
hFile = hFile & "CreateWmf.wmf"
End If
.Caption = hFile
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.ForeColor = &H808000
End With
With CommandButton1
.Top = 138
.Left = 318
.Height = 24
.Width = 162
.Caption = "Create WMF"
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = &H808000
End With
With Frame1
.Caption = ""
.Top = 168
.Left = 318
.Height = 126
.Width = 162
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
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 Const URL3 As String = "http://2.bp.blogspot.com/-g5n-KmkMtW8/TmvRrcyDWwI/AAAAAAAAC1Y/ykFDewhbCSw/s1600/Baret2.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

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

1 Haziran 2012 Cuma

Enumerate Windows Styles [2]

'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) Label3, ListView1
'3) CommandButton1, CommandButton2, Label4
Option Explicit
Private No As Long
Private sWind As Long
Private Durum As Boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) 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
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Enumerate Windows Styles [2]"
Application.Visible = False
Call Ekran_Kur
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Application.Visible = True
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Label1.Caption = FindWindow(vbNullString, Me.Caption)
ListView1.ListItems.Clear
No = 1
Call Enumeration_Window(0)
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
If Durum = False Then
StartButtonState sWind, False 'Hide the enumerated window        
Durum = True
CommandButton2.Caption = "Show Window"
Else
StartButtonState sWind, True 'Show the enumerated window        
Durum = False
CommandButton2.Caption = "Hidden Window"
End If
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error Resume Next
sWind = Item.Text
Label4.Caption = " wLong; " & sWind & ", wClass; " & Item.SubItems(1) & ", wTitle; " & Item.SubItems(2)
If sWind <> 0 Then
CommandButton2.Enabled = True
Else
CommandButton2.Enabled = False
End If
End Sub
Private Sub Enumeration_Window(pWind As Long)
On Error Resume Next
Dim hWind As Long
Dim hLong As Long
Dim hText As String
hWind = FindWindowEx(pWind, 0&, vbNullString, vbNullString)
While hWind <> 0
ListView1.ListItems.Add No, , hWind 'Handle        
hText = VBA.String$(255, VBA.Chr$(0))
hLong = GetClassName(hWind, hText, 255)
hText = VBA.Left$(hText, hLong)
ListView1.ListItems(No).SubItems(1) = hText
If hLong > 0 Then
ListView1.ListItems(No).SubItems(2) = hText 'Class Name
Else
ListView1.ListItems(No).SubItems(2) = "N/A"
End If
hText = VBA.String$(255, VBA.Chr$(0))
hLong = GetWindowText(hWind, hText, 255)
hText = VBA.Left$(hText, hLong)
If hLong > 0 Then
ListView1.ListItems(No).SubItems(2) = hText 'Title
Else
ListView1.ListItems(No).SubItems(2) = "N/A"
End If
No = No + 1
hWind = FindWindowEx(pWind, hWind, vbNullString, vbNullString)
DoEvents
Wend
End Sub
Private Sub StartButtonState(sWind As Long, hDurum As Boolean)
On Error Resume Next
Select Case hDurum
Case "True": ShowWindow sWind&, 1
Case "False": ShowWindow sWind&, 2
End Select
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 340
.Width = 570
.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 Label3
.Left = 6
.Top = 36
.Height = 18
.Width = 554
.Caption = "Enumerated Windows"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With ListView1
.Left = 6
.Top = 54
.Height = 228
.Width = 554
.Appearance = ccFlat
.BackColor = &HE0E0E0
.ForeColor = &H404000
.BorderStyle = ccNone
.ColumnHeaders.Add 1, , "Window Long", 60
.ColumnHeaders.Add 2, , "Window Class Name", 240
.ColumnHeaders.Add 3, , "window Title", 240
.FlatScrollBar = False
.FullRowSelect = True
.Gridlines = True
.LabelEdit = lvwManual
.View = lvwReport
End With
With CommandButton1
.Left = 6
.Top = 288
.Height = 24
.Width = 114
.Caption = "Enumeration Window"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With CommandButton2
.Left = 126
.Top = 288
.Height = 24
.Width = 114
.Caption = "Hidden Window"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.Enabled = False
End With
With Label4
.Left = 246
.Top = 288
.Height = 24
.Width = 312
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.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

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