Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations Chriss Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Net Send
- Thread starter jkDiener
- Start date
Hi jkDiener
I attach some code that I have modified from a program I use to help you. I can't claim all the credit for this as I found this on the web and have adapted this for my own needs.
What you will need is a form module and a standard module.
Create a new form and call it frmNetSend. On it add one combobox (name it "cboDomain"), one text box ("txtMessage"), one label ("Label_Feedback"), and two command buttons ("cmdCancel" & "cmdSend"). To this paste the following code:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim colServerNames As New Collection
Dim num As Integer
Private Sub cmdCancel_Click()
Unload Me
Set frmNetSend = Nothing
End Sub
Private Sub cmdSend_Click()
Dim lReturnCode As Long
Dim sUnicodeToName As String
Dim sUnicodeFromName As String
Dim sUnicodeMessage As String
Dim lMessageLength As Long
If cboDomain.Text = "YOURDOMAINNAME*" Then '* = YOURDOMAINNAME (entire firm)
If MsgBox("Are you sure you want to send this to the whole firm?", _
vbYesNo + vbInformation, "Send to all?") = vbNo Then
Exit Sub
End If
End If
'Get the local computer name and convert it to unicode
sUnicodeFromName = StrConv(GetLocalSystemName, vbUnicode)
' Convert the to computer name to Unicode
sUnicodeToName = StrConv(cboDomain.Text, vbUnicode)
' Convert the message text to unicode
sUnicodeMessage = StrConv(txtMessage.Text, vbUnicode)
lMessageLength = Len(sUnicodeMessage)
' Hourglass pointer
MousePointer = vbHourglass
Label_Feedback.Caption = vbNullString
' Send the message
lReturnCode = NetMessageBufferSend("", _
sUnicodeToName, _
sUnicodeFromName, _
sUnicodeMessage, _
lMessageLength)
' Prove some feedback about the send action
If lReturnCode = 0 Then
txtMessage.Text = vbNullString
Label_Feedback.Caption = "Message was successfully sent"
Else
Label_Feedback.Caption = "Error - Return code: " & CStr(lReturnCode)
End If
' Default pointer
MousePointer = vbDefault
End Sub
Private Sub Form_Load()
On Error Resume Next
Set colServerNames = GetNetworkSystemNames(SERVER_TYPE_NT)
' Set colServerNames = GetNetworkSystemNames(SERVER_TYPE_WORKSTATION)
cboDomain.AddItem GetDomainName & "*"
For num = 1 To colServerNames.Count
cboDomain.AddItem colServerNames.Item(num)
' List1.AddItem colServerNames.Item(num)
Next
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Make sure you replace YOURDOMAINNAME with the name of your domain.
Secondly name the standard module NetAPI and in it paste the following code:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Global Const SERVER_TYPE_NT = &H1000
Global Const SERVER_TYPE_NTSERVER = &H8
Global Const SERVER_TYPE_SQLSERVER = &H4
Global Const SERVER_TYPE_ALL = &HFFFF
Type SERVER_INFO_100
sv100_platform_id As Long
sv100_servername As Long
End Type
Type SERVER_INFO_101
wki101_platform_id As Long
wki101_servername As Long
wki101_langroup As Long
wki101_ver_major As Long
wki101_ver_minor As Long
wki101_lanroot As Long
End Type
Type WKSTA_INFO_100
wki100_platform_id As Long
wki100_computername As Long
wki100_langroup As Long
wki100_ver_major As Long
wki100_ver_minor As Long
End Type
Declare Function NetServerEnum Lib "Netapi32" (ByVal sServerName$, ByVal lLevel&, _
vBuffer As Any, lPreferedMaxLen&, lEntriesRead&, lTotalEntries&, _
ByVal lServerType&, ByVal sDomain$, vResume As Any) As Long
Declare Function NetWkstaGetInfo Lib "Netapi32" (ByVal sServerName$, ByVal lLevel&, _
vBuffer As Any) As Long
Declare Function NetMessageBufferSend Lib "Netapi32" (ByVal sServerName$, _
ByVal sMsgName$, ByVal sFromName$, _
ByVal sMessageText$, ByVal lBufferLength&) As Long
Declare Function NetApiBufferFree Lib "Netapi32" (ByVal lBuffer&) As Long
Declare Sub lstrcpyW Lib "Kernel32" (vDest As Any, ByVal vSrc As Any)
Declare Sub lstrcpy Lib "Kernel32" (vDest As Any, ByVal vSrc As Any)
Declare Sub lstrcpynW Lib "Kernel32" (ByVal vDest As Any, ByVal vSrc As Any, lLength As Long)
Declare Sub RtlMoveMemory Lib "Kernel32" (dest As Any, vSrc As Any, ByVal lSize&)
Function GetNetworkSystemNames(lServerType As Long) As Collection
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer, X As Integer
Dim tSeverInfo101 As SERVER_INFO_101, lSeverInfo101 As Long
Dim sComputerName As String
Dim lPreferedMaxLen As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim sDomain As String
Dim vResume As Variant
Dim lSeverInfo101StructPtr As Long
Dim serverCollection As New Collection
'Clear all of the sComputerName
sComputerName = vbNullString
'Call NetServerEnum to get a list of Servers
lReturnCode = NetServerEnum("", 101, lSeverInfo101, lPreferedMaxLen, lEntriesRead, lTotalEntries, lServerType, sDomain, vResume)
' NetServerEnum Index is 1 based
X = 1
lSeverInfo101StructPtr = lSeverInfo101
Do While X <= lTotalEntries
RtlMoveMemory tSeverInfo101, ByVal lSeverInfo101StructPtr, Len(tSeverInfo101)
lstrcpyW bBuffer(0), tSeverInfo101.wki101_servername
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sComputerName = sComputerName & Chr(bBuffer(i))
i = i + 2
Loop
serverCollection.Add Item:=sComputerName
'GetServerInfo.Add sComputerName
sComputerName = ""
X = X + 1
lSeverInfo101StructPtr = lSeverInfo101StructPtr + Len(tSeverInfo101)
Loop
lReturnCode = NetApiBufferFree(lSeverInfo101)
Set GetNetworkSystemNames = serverCollection
End Function
Public Function GetLocalSystemName()
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer
Dim twkstaInfo100 As WKSTA_INFO_100, lwkstaInfo100 As Long
Dim lwkstaInfo100StructPtr As Long
Dim sLocalName As String
lReturnCode = NetWkstaGetInfo("", 100, lwkstaInfo100)
lwkstaInfo100StructPtr = lwkstaInfo100
If lReturnCode = 0 Then
RtlMoveMemory twkstaInfo100, ByVal lwkstaInfo100StructPtr, Len(twkstaInfo100)
lstrcpyW bBuffer(0), twkstaInfo100.wki100_computername
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sLocalName = sLocalName & Chr(bBuffer(i))
i = i + 2
Loop
GetLocalSystemName = sLocalName
End If
End Function
Public Function GetDomainName() As String
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer
Dim twkstaInfo100 As WKSTA_INFO_100, lwkstaInfo100 As Long
Dim lwkstaInfo100StructPtr As Long
Dim sDomainName As String
lReturnCode = NetWkstaGetInfo("", 100, lwkstaInfo100)
lwkstaInfo100StructPtr = lwkstaInfo100
If lReturnCode = 0 Then
RtlMoveMemory twkstaInfo100, ByVal lwkstaInfo100StructPtr, Len(twkstaInfo100)
lstrcpyW bBuffer(0), twkstaInfo100.wki100_langroup
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sDomainName = sDomainName & Chr(bBuffer(i))
i = i + 2
Loop
GetDomainName = sDomainName
End If
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As I said I have pulled this out of another application so if there are any bugs in it you will have to track them down for yourself (I couldn't justify sending a netsend to the whole firm here to test this for you!), but it should be pretty much there. One bug I have noticed is that when sending it to the entire firm it seems to chop off the message at a certain point, but seems fine with individual computers. If anyone works out why this is could they let me know as I haven't really had chance to track the problem down.
Hope this helps
Asjeff
I attach some code that I have modified from a program I use to help you. I can't claim all the credit for this as I found this on the web and have adapted this for my own needs.
What you will need is a form module and a standard module.
Create a new form and call it frmNetSend. On it add one combobox (name it "cboDomain"), one text box ("txtMessage"), one label ("Label_Feedback"), and two command buttons ("cmdCancel" & "cmdSend"). To this paste the following code:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim colServerNames As New Collection
Dim num As Integer
Private Sub cmdCancel_Click()
Unload Me
Set frmNetSend = Nothing
End Sub
Private Sub cmdSend_Click()
Dim lReturnCode As Long
Dim sUnicodeToName As String
Dim sUnicodeFromName As String
Dim sUnicodeMessage As String
Dim lMessageLength As Long
If cboDomain.Text = "YOURDOMAINNAME*" Then '* = YOURDOMAINNAME (entire firm)
If MsgBox("Are you sure you want to send this to the whole firm?", _
vbYesNo + vbInformation, "Send to all?") = vbNo Then
Exit Sub
End If
End If
'Get the local computer name and convert it to unicode
sUnicodeFromName = StrConv(GetLocalSystemName, vbUnicode)
' Convert the to computer name to Unicode
sUnicodeToName = StrConv(cboDomain.Text, vbUnicode)
' Convert the message text to unicode
sUnicodeMessage = StrConv(txtMessage.Text, vbUnicode)
lMessageLength = Len(sUnicodeMessage)
' Hourglass pointer
MousePointer = vbHourglass
Label_Feedback.Caption = vbNullString
' Send the message
lReturnCode = NetMessageBufferSend("", _
sUnicodeToName, _
sUnicodeFromName, _
sUnicodeMessage, _
lMessageLength)
' Prove some feedback about the send action
If lReturnCode = 0 Then
txtMessage.Text = vbNullString
Label_Feedback.Caption = "Message was successfully sent"
Else
Label_Feedback.Caption = "Error - Return code: " & CStr(lReturnCode)
End If
' Default pointer
MousePointer = vbDefault
End Sub
Private Sub Form_Load()
On Error Resume Next
Set colServerNames = GetNetworkSystemNames(SERVER_TYPE_NT)
' Set colServerNames = GetNetworkSystemNames(SERVER_TYPE_WORKSTATION)
cboDomain.AddItem GetDomainName & "*"
For num = 1 To colServerNames.Count
cboDomain.AddItem colServerNames.Item(num)
' List1.AddItem colServerNames.Item(num)
Next
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Make sure you replace YOURDOMAINNAME with the name of your domain.
Secondly name the standard module NetAPI and in it paste the following code:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Global Const SERVER_TYPE_NT = &H1000
Global Const SERVER_TYPE_NTSERVER = &H8
Global Const SERVER_TYPE_SQLSERVER = &H4
Global Const SERVER_TYPE_ALL = &HFFFF
Type SERVER_INFO_100
sv100_platform_id As Long
sv100_servername As Long
End Type
Type SERVER_INFO_101
wki101_platform_id As Long
wki101_servername As Long
wki101_langroup As Long
wki101_ver_major As Long
wki101_ver_minor As Long
wki101_lanroot As Long
End Type
Type WKSTA_INFO_100
wki100_platform_id As Long
wki100_computername As Long
wki100_langroup As Long
wki100_ver_major As Long
wki100_ver_minor As Long
End Type
Declare Function NetServerEnum Lib "Netapi32" (ByVal sServerName$, ByVal lLevel&, _
vBuffer As Any, lPreferedMaxLen&, lEntriesRead&, lTotalEntries&, _
ByVal lServerType&, ByVal sDomain$, vResume As Any) As Long
Declare Function NetWkstaGetInfo Lib "Netapi32" (ByVal sServerName$, ByVal lLevel&, _
vBuffer As Any) As Long
Declare Function NetMessageBufferSend Lib "Netapi32" (ByVal sServerName$, _
ByVal sMsgName$, ByVal sFromName$, _
ByVal sMessageText$, ByVal lBufferLength&) As Long
Declare Function NetApiBufferFree Lib "Netapi32" (ByVal lBuffer&) As Long
Declare Sub lstrcpyW Lib "Kernel32" (vDest As Any, ByVal vSrc As Any)
Declare Sub lstrcpy Lib "Kernel32" (vDest As Any, ByVal vSrc As Any)
Declare Sub lstrcpynW Lib "Kernel32" (ByVal vDest As Any, ByVal vSrc As Any, lLength As Long)
Declare Sub RtlMoveMemory Lib "Kernel32" (dest As Any, vSrc As Any, ByVal lSize&)
Function GetNetworkSystemNames(lServerType As Long) As Collection
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer, X As Integer
Dim tSeverInfo101 As SERVER_INFO_101, lSeverInfo101 As Long
Dim sComputerName As String
Dim lPreferedMaxLen As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim sDomain As String
Dim vResume As Variant
Dim lSeverInfo101StructPtr As Long
Dim serverCollection As New Collection
'Clear all of the sComputerName
sComputerName = vbNullString
'Call NetServerEnum to get a list of Servers
lReturnCode = NetServerEnum("", 101, lSeverInfo101, lPreferedMaxLen, lEntriesRead, lTotalEntries, lServerType, sDomain, vResume)
' NetServerEnum Index is 1 based
X = 1
lSeverInfo101StructPtr = lSeverInfo101
Do While X <= lTotalEntries
RtlMoveMemory tSeverInfo101, ByVal lSeverInfo101StructPtr, Len(tSeverInfo101)
lstrcpyW bBuffer(0), tSeverInfo101.wki101_servername
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sComputerName = sComputerName & Chr(bBuffer(i))
i = i + 2
Loop
serverCollection.Add Item:=sComputerName
'GetServerInfo.Add sComputerName
sComputerName = ""
X = X + 1
lSeverInfo101StructPtr = lSeverInfo101StructPtr + Len(tSeverInfo101)
Loop
lReturnCode = NetApiBufferFree(lSeverInfo101)
Set GetNetworkSystemNames = serverCollection
End Function
Public Function GetLocalSystemName()
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer
Dim twkstaInfo100 As WKSTA_INFO_100, lwkstaInfo100 As Long
Dim lwkstaInfo100StructPtr As Long
Dim sLocalName As String
lReturnCode = NetWkstaGetInfo("", 100, lwkstaInfo100)
lwkstaInfo100StructPtr = lwkstaInfo100
If lReturnCode = 0 Then
RtlMoveMemory twkstaInfo100, ByVal lwkstaInfo100StructPtr, Len(twkstaInfo100)
lstrcpyW bBuffer(0), twkstaInfo100.wki100_computername
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sLocalName = sLocalName & Chr(bBuffer(i))
i = i + 2
Loop
GetLocalSystemName = sLocalName
End If
End Function
Public Function GetDomainName() As String
Dim lReturnCode As Long
Dim bBuffer(512) As Byte
Dim i As Integer
Dim twkstaInfo100 As WKSTA_INFO_100, lwkstaInfo100 As Long
Dim lwkstaInfo100StructPtr As Long
Dim sDomainName As String
lReturnCode = NetWkstaGetInfo("", 100, lwkstaInfo100)
lwkstaInfo100StructPtr = lwkstaInfo100
If lReturnCode = 0 Then
RtlMoveMemory twkstaInfo100, ByVal lwkstaInfo100StructPtr, Len(twkstaInfo100)
lstrcpyW bBuffer(0), twkstaInfo100.wki100_langroup
'Get every other byte from Unicode string.
i = 0
Do While bBuffer(i) <> 0
sDomainName = sDomainName & Chr(bBuffer(i))
i = i + 2
Loop
GetDomainName = sDomainName
End If
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As I said I have pulled this out of another application so if there are any bugs in it you will have to track them down for yourself (I couldn't justify sending a netsend to the whole firm here to test this for you!), but it should be pretty much there. One bug I have noticed is that when sending it to the entire firm it seems to chop off the message at a certain point, but seems fine with individual computers. If anyone works out why this is could they let me know as I haven't really had chance to track the problem down.
Hope this helps
Asjeff
macleod1021
Programmer
Great code Asjeff...but I'm not sure it does what he needs. If I'm understanding you correctly you want to be able to programatically enable and start the Messenger service on remote computers. I know this can be done because servers do it all the time. If the computer is in a domain, you will have to have an account that has computer administration rights. If it's not in a domain then you will need to know the username and password of the local adminsitrator.
I haven't actually done this using VB because the MMC in windows does it already. I would imagine checking out the API's that allow control of the AD a good place to start if it's a domain computer.
I haven't actually done this using VB because the MMC in windows does it already. I would imagine checking out the API's that allow control of the AD a good place to start if it's a domain computer.
Hmmm - thanks macleod - now you've pointed it out I think you're right. Still, if he ever figures it out at least he'll have a way to communicate with them all!
I suspect you're right about checking the API's. If I had to guess I would start by checking the OpenSCManager API or something like that, but I'm sure that someone who knows a lot more about API's than me could point him in the right direction.
Asjeff
I suspect you're right about checking the API's. If I had to guess I would start by checking the OpenSCManager API or something like that, but I'm sure that someone who knows a lot more about API's than me could point him in the right direction.
Asjeff
- Status
Similar threads