Dapatkan Nama Host dari IP Address

Kode berikut berfungis untuk mendapatkan HostName dari IP Address, dengan fungsi yang ada di wsock32.

Berikut kodingnya :

Option Explicit

Private Const WSADescription_Len As Long = 256
Private Const WSASYS_Status_Len As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const IP_SUCCESS As Long = 0
Private Const SOCKET_ERROR As Long = -1
Private Const AF_INET As Long = 2

Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
imaxsockets As Integer
imaxudp As Integer
lpszvenderinfo As Long
End Type

Private Declare Function WSAStartup Lib "wsock32" _
(ByVal VersionReq As Long, _
WSADataReturn As WSADATA) As Long

Private Declare Function WSACleanup Lib "wsock32" () As Long

Private Declare Function inet_addr Lib "wsock32" _
(ByVal s As String) As Long

Private Declare Function gethostbyaddr Lib "wsock32" _
(haddr As Long, _
ByVal hnlen As Long, _
ByVal addrtype As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)

Private Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenA" _
(lpString As Any) As Long

Private Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

Private Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", _
vbExclamation
End If
End Sub

Private Function GetHostNameFromIP(ByVal sAddress As String) As String

Dim ptrHosent As Long
Dim hAddress As Long
Dim nbytes As Long
If SocketsInitialize() Then
hAddress = inet_addr(sAddress)
If hAddress <> SOCKET_ERROR Then
ptrHosent = gethostbyaddr(hAddress, 4, AF_INET)
If ptrHosent <> 0 Then
CopyMemory ptrHosent, ByVal ptrHosent, 4
nbytes = lstrlen(ByVal ptrHosent)
If nbytes > 0 Then
sAddress = Space$(nbytes)
CopyMemory ByVal sAddress, ByVal ptrHosent, nbytes
GetHostNameFromIP = sAddress
End If

Else
MsgBox "memanggil gethostbyaddr gagal."
End If 'If ptrHosent
SocketsCleanup
Else
MsgBox "IP Address salah."
End If 'If hAddress
Else
MsgBox "Sockets failed to initialize."
End If 'If SocketsInitialize
End Function

Private Sub Form_Load()
MsgBox "HostName: " & GetHostNameFromIP("192.168.0.1")
End Sub

Baca Selengkapnya »

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

Baca Selengkapnya »

Menukar Fungsi Tombol Pada Mouse dgn VB

Berikut ini adalah cara menukar tombol mouse antara klik kiri dan klik kanan.



Taruh kode berikut di bagian paling atas pada form :


'sebelumnya, declarasiin dulu SwapMouseButton-nya
Private Declare Function SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long
Private Const PENCETAN1 = &H0&
Private Const PENCETAN2 = &H100&


Kemudian buatlah 2 command di form tersebut. Dengan isinya sbb :

'ini coding buat di command1
Private Sub Command1_Click()
SwapMouseButton PENCETAN2

End Sub


'ini coding buat di command2
Private Sub Command2_Click()
SwapMouseButton PENCETAN1
End Sub

Baca Selengkapnya »

Fakta Tentang Paypal Wishlist

Paypal Wishlist Benar-benar membayar membernya. coba Lihat Gambar di bawah ini :

Baca Selengkapnya »