DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const WM_SYSCOMMAND = &H112
Private Const EXPLORER_CLASSNAME As String = "CabinetWClass"
'Private Const EXPLORER_CLASSNAME As String = "ExploreWClass"
Sub Test()
Dim Sleep_Time As Long, Find_Data As Variant, Find_Folder_Path As String
#If VBA7 Then
Dim hWnd As LongPtr
Dim Folder_hWnd As LongPtr
#Else
Dim hWnd As Long
Dim Folder_hWnd As Long
#End If
Find_Data = Sheet1.Range("A1").Value
Find_Folder_Path = "C:\Users\Haluk\Desktop\TestFolder\"
Call Shell("explorer ""search-ms://query=" & Find_Data & "&crumb=location:" & Find_Folder_Path & """", vbNormalFocus)
Sleep_Time = Timer
Do
DoEvents
Loop Until Timer - Sleep_Time >= 3
Folder_hWnd = FindWindow(EXPLORER_CLASSNAME, vbNullString)
If Get_Count_of_Contents(Folder_hWnd) = 0 Then
SendMessage Folder_hWnd, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&
End If
End Sub
Function Get_Count_of_Contents(hWnd As Variant) As Variant
' Haluk - 24/08/2022
' sa4truss@gmail.com
Dim objShell As Object, myWindow As Object, RetVal As Variant
Set objShell = CreateObject("Shell.Application")
For Each myWindow In objShell.Windows
On Error Resume Next
If myWindow.hWnd = hWnd Then
If Err = 0 Then
RetVal = myWindow.Document.Folder.Items.Count
End If
Exit For
End If
On Error GoTo 0
Next
Get_Count_of_Contents = RetVal
End Function
hocam bende yine çalışmadı kodun son hali ama...
#If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const WM_SYSCOMMAND = &H112
Private Const EXPLORER_CLASSNAME As String = "CabinetWClass"
'Private Const EXPLORER_CLASSNAME As String = "ExploreWClass"
'
Sub Main()
Dim Find_Data As Variant, Find_Folder_Path As String, NoA As Integer, i As Integer
NoA = Range("A" & Rows.Count).End(xlUp).Row
Find_Folder_Path = "C:\Users\Haluk\Desktop\TestFolder\"
For i = 2 To NoA
Find_Data = Range("A" & i)
Call searchFolder(Find_Data, Find_Folder_Path)
Next
End Sub
'
Sub searchFolder(varData As Variant, strFolder As String)
Dim Sleep_Time As Long
#If VBA7 Then
Dim hWnd As LongPtr
Dim Folder_hWnd As LongPtr
#Else
Dim hWnd As Long
Dim Folder_hWnd As Long
#End If
Call Shell("explorer ""search-ms://query=" & varData & "&crumb=location:" & strFolder & """", vbNormalFocus)
Sleep_Time = Timer
Do
DoEvents
Loop Until Timer - Sleep_Time >= 3
Folder_hWnd = FindWindow(EXPLORER_CLASSNAME, vbNullString)
If Get_Count_of_Contents(Folder_hWnd) = 0 Then
SendMessage Folder_hWnd, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&
End If
End Sub
'
Function Get_Count_of_Contents(hWnd As Variant) As Variant
' Haluk - 24/08/2022
' sa4truss@gmail.com
Dim objShell As Object, myWindow As Object, RetVal As Variant
Set objShell = CreateObject("Shell.Application")
For Each myWindow In objShell.Windows
On Error Resume Next
If myWindow.hWnd = hWnd Then
If Err = 0 Then
RetVal = myWindow.Document.Folder.Items.Count
End If
Exit For
End If
On Error GoTo 0
Next
Get_Count_of_Contents = RetVal
End Functionhaluk hocam çok çok teşekkürler çok sağolun...
çok sağolun hocam deneyince sonucu yazacağım buraya..
www.extendoffice.com
Sub Main()
Dim Find_Data As Variant, Find_Folder_Path As String, NoA As Integer, i As Integer
Call ShowXLOnTop(True)
NoA = Range("A" & Rows.Count).End(xlUp).Row
Find_Folder_Path = "C:\Users\Haluk\Desktop\TestFolder\"
For i = 2 To NoA
Find_Data = Range("A" & i)
Call searchFolder(Find_Data, Find_Folder_Path)
Next
Call ShowXLOnTop(False)
End Submerhaba hocam denedim ama, excel önde, arkada ise dosya aç kapa aç kapa oldu..Bunu yapmak için, dosyanıza yeni bir modül ilave ettikten sonra aşağıdaki linkte yer alan kodları oraya yapıştırın ve daha sonra 30 No'lu mesajdaki "Main" isimli prosedürde aşağıdaki kırmızı renkli satırları ilave edin;
How to keep excel window always on top?
Learn how to keep an Excel window always on top using VBA code. Follow our step-by-step guide to improve your workflow and multitasking efficiency.
Rich (BB code):Sub Main() Dim Find_Data As Variant, Find_Folder_Path As String, NoA As Integer, i As Integer Call ShowXLOnTop(True) NoA = Range("A" & Rows.Count).End(xlUp).Row Find_Folder_Path = "C:\Users\Haluk\Desktop\TestFolder\" For i = 2 To NoA Find_Data = Range("A" & i) Call searchFolder(Find_Data, Find_Folder_Path) Next Call ShowXLOnTop(False) End Sub
Söz konusu "Main" isimli prosedürü sayfa üzerine yerleştireceğiniz bir buton veya şekile atayıp, çalıştırın....
.
hocam 1000 satırlık ifadede bilgisayar belli bir süre sonra dondu...acaba işlemci ya da ram düşük mü geldi bilemedim...
hocam sizin programda 100 satır denedim, 13 tane boş klasörü kapatmadan kaldı...kendim kapattım...
Benim eski bilgisayarda bahsettiğiniz 1000 satırlık işlemden sonra herhalde ekrandan dumanlar çıkardı.
öyle birşey de mükemmel olur hocam....dediğiniz gibi sadece farklı olanları görürüm...