diğer programı öne getirme

[ozgur1122334455]

merhaba arkadaşlar

benim ihtiyacım olan diger tarata çalışmakta olan örneğin winrar gibi bir programı makro yardımı ile öne getirmek istiyorum. shell ile sıfırdan açabiliyorum ancak açık olan *.exe programını öne getiremiyorum windows().activete de olmadı yardımcı olursanız çok sevinirim. Şimdiden teşekkürler...

 

[Asri]

Menu bölümündeki aşağıdaki alanı değiştirerek farklı programları aktif edebilir siniz.

Buradaki değer büyük küçük harf duyarlıdır.
* tüm harfler demek olur.
*WinRAR* program başlığı içinde WinRAR geçeni aktif et.
*WinRAR program başlığı WinRAR ile başlayanı aktif et.
WinRAR* program başlığı WinRAR ile biteni aktif et.

Test edildi.


sTitleToFind = "*WinRAR*"

Option Explicit

Public Declare Function GetDesktopWindow Lib "user32" () As Long

Public Declare Function GetWindow Lib "user32" _
 (ByVal hWnd As Long, _
  ByVal wCmd As Long) As Long

Public Declare Function GetWindowText Lib "user32" _
  Alias "GetWindowTextA" _
 (ByVal hWnd As Long, _
  ByVal lpString As String, _
  ByVal cch As Long) As Long

Public Declare Function GetClassName Lib "user32" _
  Alias "GetClassNameA" _
 (ByVal hWnd As Long, _
  ByVal lpClassName As String, _
  ByVal nMaxCount As Long) As Long

Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_OWNER = 4
Public Const GW_CHILD = 5

Private Const HWND_TOPMOST = -1
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SW_SHOW = 5
Private Const SW_RESTORE = 9

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
     ByVal lpClassName As String, _
     ByVal lpWindowName As String _
  ) As Long
 
Private Declare Function GetWindowThreadProcessId Lib "user32" ( _
     ByVal hWnd As Long, _
     lpdwProcessId As Long _
  ) As Long
 
Private Declare Function AttachThreadInput Lib "user32" ( _
     ByVal idAttach As Long, _
     ByVal idAttachTo As Long, _
     ByVal fAttach As Long _
  ) As Long
 
Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function SetForegroundWindow Lib "user32" ( _
     ByVal hWnd As Long _
  ) As Long
 
Private Declare Function IsIconic Lib "user32" ( _
     ByVal hWnd As Long _
  ) As Long
 
Private Declare Function ShowWindow Lib "user32" ( _
     ByVal hWnd As Long, _
     ByVal nCmdShow As Long _
  ) As Long
 
Declare Function SetWindowPos Lib "user32" ( _
     ByVal hWnd As Long, _
     ByVal hWndInsertAfter As Long, _
     ByVal X As Long, _
     ByVal Y As Long, _
     ByVal cx As Long, _
     ByVal cy As Long, _
     ByVal uFlags As Long _
  ) As Long


Private Sub menu()
 
 'Used to return window handles.
  Dim sTitleToFind As String, sClassToFind As String
 
   
 'Set the FindWindowLike text values from
 'the strings entered into the textboxes
  sTitleToFind = "*WinRAR*"
  sClassToFind = "*"
 
  ForceForegroundWindow FindWindowLike(0, sTitleToFind, sClassToFind)
 
 
End Sub



Private Function FindWindowLike( _
       ByVal hWndStart As Long, _
       WindowText As String, _
       Classname As String _
   ) As Long

  Dim hWnd As Long
  Dim sWindowText As String
  Dim sClassname As String
  Dim r As Long
 
  Static level As Integer
 
  If level = 0 Then
     If hWndStart = 0 Then hWndStart = GetDesktopWindow()
  End If
 
  level = level + 1
 
  hWnd = GetWindow(hWndStart, GW_CHILD)

  Do Until hWnd = 0
     
     Call FindWindowLike(hWnd, WindowText, Classname)
     
     sWindowText = Space$(255)
     r = GetWindowText(hWnd, sWindowText, 255)
     sWindowText = Left(sWindowText, r)
       
     sClassname = Space$(255)
     r = GetClassName(hWnd, sClassname, 255)
     sClassname = Left(sClassname, r)
             
     If (sWindowText Like WindowText) And _
        (sClassname Like Classname) Then
       
       ' MsgBox hWnd & vbTab & _
                      sClassname & vbTab & _
                      sWindowText
        FindWindowLike = hWnd
                   
         Exit Do
         
      End If
   
     hWnd = GetWindow(hWnd, GW_HWNDNEXT)
 
  Loop

   level = level - 1

End Function

Public Function ForceForegroundWindow( _
     ByVal hWnd As Long _
  ) As Boolean

  Dim ThreadID1 As Long
  Dim ThreadID2 As Long
  Dim Result As Long
 
   ' Don't do anything is already in forground
  If hWnd = GetForegroundWindow() Then
     ForceForegroundWindow = True
  Else
     ' Get thread IDs of current foreground window and target window
     ThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
     ThreadID2 = GetWindowThreadProcessId(hWnd, ByVal 0&)
     ' By sharing input state, threads share their concept of the active window
     If ThreadID1 <> ThreadID2 Then
        AttachThreadInput ThreadID1, ThreadID2, True
        Result = SetForegroundWindow(hWnd)
        AttachThreadInput ThreadID1, ThreadID2, False
     Else
        Result = SetForegroundWindow(hWnd)
     End If
     ' Restore and repaint
     If IsIconic(hWnd) Then
        ShowWindow hWnd, SW_RESTORE
     Else
        ShowWindow hWnd, SW_SHOW
     End If
     ' SetForegroundWindow return accurately reflects success
     ForceForegroundWindow = CBool(Result)
  End If
 
End Function

 

[Asri]

Alternatif olarak basit ama daha yorucu bir örnek.

Birer saniye ara ile programları aktif eder.
Programlar aktif olur ancak tam ekranda açılmayabilir.

Aktif edilecek programların başlık bilgilerinin tam olarak yazılmış olması gerekir.

Sub aktif_et()
    On Error Resume Next
    AppActivate "Microsoft Word"
    Application.Wait Now + TimeSerial(0, 0, 1)
    
    AppActivate "WinRAR (evaluation copy)"
    Application.Wait Now + TimeSerial(0, 0, 1)
    
    AppActivate "Mozilla Firefox"
    Application.Wait Now + TimeSerial(0, 0, 1)
    
    AppActivate ThisWorkbook.Name

End Sub

 

[ozgur1122334455]

çok teşekkürler appactivate işimi gördü. ilginize teşekkürler