(Share) Mendapatkan Direktory Aktif - Windows Vista & 7

[Devran Code]

saya masih bingung mas

[Galang Kuatir]

Windows 7 Ultimate 32 bit, Nggak bisa  

[ZeroNawazaki]

ini ada source buat mendapatkan direktory aktif di windows vista atau windows 7, source ini berguna sekali bagi agan yang lagi mengembangkan antivirus buat kebutuhan RTP nya, dari thread" sebelumnya banyak menanyakan gimana cara bikin RTP dan cara mendapatkan direktory yg aktif di Windows 7, dari source yang bisa dipake di Windows XP rupanya tidak berfungsi di Windows 7, karena di Windows 7 classname" di Windows Explorer berbeda dengan yang ada di Windows XP, untuk itu kita harus menyesuaikan classnamenya yg ada di Windows 7 agar bisa mendapatkan lokasi directory aktif yang sedang dibuka melalui Windows Explorer.

  Kode ini udah aq test sendiri di Windows 7 SP1 x64 bit - bisa berfungsi dengan baik 

berikut kodenya :

Kode: [Pilih]

'HH        HH                                AA                    kk                    RRRRRRRRRR
'HH        HH                              AA  AA                  kk                    RR        RR
'HH        HH    aaaaaa    pp  pppp        AA  AA        cccccc    kk    kk    eeeeee    RR        RR
'HHHHHHHHHHHH  aa      aa  pppp    pp      AA  AA      cc      cc  kk  kk    ee      ee  RRRRRRRRRR
'HH        HH    aaaaaaaa  pp      pp    AA      AA    cc          kkkk      eeeeeeeeee  RR    RR
'HH        HH  aa      aa  pp      pp    AAAAAAAAAA    cc          kk  kk    ee          RR      RR
'HH        HH  aa    aaaa  pppp    pp  AA          AA  cc      cc  kk  kk    ee      ee  RR      RR
'HH        HH    aaaa  aa  pp  pppp    AA          AA    cccccc    kk    kk    eeeeee    RR        RR
'                          pp
'                          pp       [ Smadaver Community ]
'
Private Declare Function SendMessage Lib "user32.dll" 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.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function SendMessageTimeoutString Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As String, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Const WM_GETTEXT = &HD

Private Function GetText(ByVal hwnd As Long) As String
    Dim sText As String
    sText = Space$(1024)
    If SendMessageTimeoutString(hwnd, WM_GETTEXT, 1024, sText, SMTO_ABORTIFHUNG, 1000, 0) <> 0 Then
        GetText = Left$(sText, InStr(sText, vbNullChar) - 1)
    End If
End Function

Private Function DapatkanDirektoryAktif()
    On Error Resume Next
    Dim hand1 As Long
    Dim hand2 As Long
    Dim hand3 As Long
    Dim hand4 As Long
    Dim hand5 As Long
    Dim hand6 As Long
    Dim hand7 As Long
    Dim hand8 As Long
    Dim LokasiPath As String

    hand1 = FindWindow("ExploreWClass", vbNullString)
    hand2 = FindWindow("CabinetWClass", vbNullString)
    If hand1 = GetForegroundWindow Then
        hand3 = FindWindowEx(hand1, 0&, "WorkerW", vbNullString)
    ElseIf hand2 = GetForegroundWindow Then
        hand3 = FindWindowEx(hand2, 0&, "WorkerW", vbNullString)
    End If
    hand4 = FindWindowEx(hand3, 0&, "ReBarWindow32", vbNullString)
    hand5 = FindWindowEx(hand4, 0&, "Address Band Root", vbNullString)
    hand6 = FindWindowEx(hand5, 0&, "msctls_progress32", vbNullString)
    hand7 = FindWindowEx(hand6, 0&, "Breadcrumb Parent", vbNullString)
    hand8 = FindWindowEx(hand7, 0&, "ToolbarWindow32", vbNullString)
   
    LokasiPath = Replace(GetText(hand8), Chr(65) + Chr(100) + Chr(100) + Chr(114) + Chr(101) + Chr(115) + Chr(115) + Chr(58) + Chr(32), "")
   
    If PathFileExists(LokasiPath) = 1 Then
        DapatkanDirektoryAktif = LokasiPath
    Else
        DapatkanDirektoryAktif = ""
    End If
   
End Function

Cara makenya tinggal kita taruh hasilnya, misalkan di komponent text atau di variabel, klo disini aq simpen hasilnya di komponent text + Timer

Kode: [Pilih]

Text1.Text = DapatkanDirektoryAktif


Tambahan :

Source ini digunakan untuk mendapatkan direktori aktif saat dialog browse open dan save file muncul, lumayan buat RTP 

Kode: [Pilih]

Private Function GetDirektoryAktifBrowse()
    On Error Resume Next
    Dim hand1 As Long
    Dim hand2 As Long
    Dim hand3 As Long
    Dim hand4 As Long
    Dim hand5 As Long
    Dim hand6 As Long
    Dim hand7 As Long
    Dim hand8 As Long
    Dim LokasiPath As String
    Dim Teks As String * 255
    GetWindowText GetForegroundWindow, Teks, 255

    hand1 = FindWindow("#32770", Teks)
    If hand1 = GetForegroundWindow Then
        hand2 = FindWindowEx(hand1, 0&, "WorkerW", vbNullString)
        hand3 = FindWindowEx(hand2, 0&, "ReBarWindow32", vbNullString)
        hand4 = FindWindowEx(hand3, 0&, "Address Band Root", vbNullString)
        hand5 = FindWindowEx(hand4, 0&, "msctls_progress32", vbNullString)
        hand6 = FindWindowEx(hand5, 0&, "Breadcrumb Parent", vbNullString)
        hand7 = FindWindowEx(hand6, 0&, "ToolbarWindow32", vbNullString)

        LokasiPath = Replace(GetText(hand7), Chr(65) + Chr(100) + Chr(100) + Chr(114) + Chr(101) + Chr(115) + Chr(115) + Chr(58) + Chr(32), vbNullString)

        If PathFileExists(LokasiPath) = 1 Then
            GetDirektoryAktifBrowse = LokasiPath
        Else
            GetDirektoryAktifBrowse = ""
        End If

    End If

End Function


  Jangan lupa creditnya buat anak" Smadaver, Maju terus programmer indonesia 

masih pake Timer ya?

[derit]

bagian sini eror
If SendMessageTimeoutString(hwnd, WM_GETTEXT, 1024, sText, SMTO_ABORTIFHUNG, 1000, 0) 

[Maulana_id]

Kalo error di bagian SMTO_ABORTIFHUNG tambahkan aja code ini

Public Const SMTO_ABORTIFHUNG = &H2  

saran dari saya pakai yg di bawah ini aja
masukan 1 textbox, 1 timer dengan interval =100
tambahkan referensi Microsoft Internet Controls

Kode: [Pilih]

'*********************************************************************
'*  Author : Maulana Yusuf [Maulana Technology Software]
'*  Facebook : facebook.com/maulanalways / facebook.com/MysoftId
'*  Twitter : @maulanayusuf_id
'*  Site : http://mysoft-id.blogspot.com
'*  Copyright (c) 2013 Maltech Soft. All rights reserved
'***********************************************************************
Private Declare Function GetForegroundWindow Lib "user32" () As Long

Public DirToScan As String
Public TmpPath As String

Private IExplorer As InternetExplorer
Private CurWnd As New ShellWindows

Private Sub Timer1_Timer()
    On Error Resume Next
    
    For Each IExplorer In CurWnd

        If IExplorer.Busy Then GoTo IEBusy
        
        If IExplorer.hWnd = GetForegroundWindow Then
            DirToScan = vbNullString
            DirToScan = ValidatePath(IExplorer.LocationURL)
            Text1.Text = DirToScan
        Else
            GoTo IEBusy
        End If
        
        If DirToScan = TmpPath Then
            GoTo IEBusy
        ElseIf DirToScan <> vbNullString Or DirToScan <> TmpPath Then
            'disini isi dengan code scan
        End If
        
IEBusy:

    Next

    TmpPath = vbNullString
    TmpPath = DirToScan

    On Error GoTo 0
End Sub
'untuk membetulkan path yg gak karuan!!
Private Function ValidatePath(ByRef sPath As String) As String
    On Error Resume Next
    Dim i As Long

    sPath = Replace(sPath, "file:///", "")
    sPath = Replace(sPath, "/", ChrW$(92))

    For i = 32 To 255
        If InStr(sPath, "%") <> 0 Then
            sPath = Replace(sPath, "%" & Hex$(i), ChrW$(i), , , vbBinaryCompare)
        End If
    Next i

    ValidatePath = sPath
End Function


[hamaboi789]

Yup bener sekali, klo mau make kode diatas buat RTP antivirus, jangan lupa check dulu Windows yang digunakan, klo windowsnya Vista atw 7 silahkan pake kode diatas, nah klo windowsnya XP bisa pke kode di thread sebelah.. 

ohh iya , kalau Ingin Check dulu Windows yang digunakan Misalnya Menggunakan punya TS , maka akan ke scan
jika memakai Windows XP berarti source berbeda dengan ts dong , nah jika Ingin di bedakan dengan Source code Windows 7 sama XP gimana yah penerapannya ?