Marshalling and converting VB6 code to .NET - vb.net

I am having trouble converting some code from VB6 to VB.NET (I don't have as much experience with .NET). When I run the 'Select function (from the WS2_32.dll library) in .NET, using the same parameters as the VB6 program, it returns a result of -1 (indicating an error). I think the error may be related to an upgrade comment I saw about marshalling, but I was not sure what I needed to do to declare the function differently. Here is the code that I believe is related to the problem (including the upgrade warnings from Visual Studios):
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure FD_SET
Dim fd_count As Integer
<VBFixedArray(FD_SETSIZE)> Dim fd_array() As Integer
Public Sub Initialize()
ReDim fd_array(FD_SETSIZE)
End Sub
End Structure
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure TIMEVAL
Dim tv_sec As Integer
Dim tv_usec As Integer
End Structure
'UPGRADE_WARNING: Structure TIMEVAL may require marshalling attributes to be passed as an argument in this Declare statement.
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement.
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement.
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement.
Private Declare Function bsd_select Lib "WS2_32.dll" Alias "select" (ByVal nfds As Integer, ByRef readfds As FD_SET, ByRef writefds As FD_SET, ByRef exceptfds As FD_SET, ByRef timeout As TIMEVAL) As Integer
nResult = bsd_select(0, fdsRead, fdsWrite, fdsExcept, tvTimeout) 'the first parameter is ignored in Windows Sockets 2
Here is the code for the entire program. Thanks in advance!
Option Strict Off
Option Explicit On
Imports System.Runtime.InteropServices
Module modTCPCommunicaiton
'Constants used with Windows Sockets
Private Const AF_INET As Integer = 2
Private Const SOCK_STREAM As Integer = 1
Private Const IPPROTO_TCP As Integer = 6
Private Const FD_SETSIZE As Integer = 64
Private Const SOCKET_ERROR As Integer = -1
Private Const INVALID_SOCKET As Integer = -1
'Constants used for clarity
Private Const WS_VERSION_1_1 As Short = 257
Private Const SOCKADDR_LEN As Integer = 16
Private Const NO_FLAGS As Integer = 0
Private Const MAX_REPLY_LEN As Integer = 3200
'Define structures used with Windows Sockets
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure WSADATA
Dim wVersion As Short
Dim wHighVersion As Short
'UPGRADE_WARNING: Fixed-length string size must fit in the buffer. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(258), System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray, SizeConst:=258)> Public szDescription() As Char
'UPGRADE_WARNING: Fixed-length string size must fit in the buffer. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(130), System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray, SizeConst:=130)> Public szSystemStatus() As Char
Dim iMaxSockets As Short
Dim iMaxUdpDg As Short
Dim lpVenderInfo As String
End Structure
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure SOCKADDR_IN
Dim sin_family As Short
Dim sin_port As Short
Dim sin_addr As Integer
<VBFixedArray(8)> Dim sin_zero() As Byte 'this is just padding to make the whole structure size to be 16 bytes.
Public Sub Initialize()
ReDim sin_zero(8)
End Sub
End Structure
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure FD_SET
Dim fd_count As Integer
<VBFixedArray(FD_SETSIZE)> Dim fd_array() As Integer
Public Sub Initialize()
ReDim fd_array(FD_SETSIZE)
End Sub
End Structure
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi)> Private Structure TIMEVAL
Dim tv_sec As Integer
Dim tv_usec As Integer
End Structure
'Declare imported Windows Sockets functions
'UPGRADE_WARNING: Structure WSADATA may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function WSAStartup Lib "WS2_32.dll" (ByVal wVersionRequested As Short, <[In](), Out()> ByRef lpWSAData As WSADATA) As Integer
Private Declare Function WSACleanup Lib "WS2_32.dll" () As Integer
Private Declare Function WSAGetLastError Lib "WS2_32.dll" () As Integer
Private Declare Function inet_addr Lib "WS2_32.dll" (ByVal szIPv4 As String) As Integer
Private Declare Function htons Lib "WS2_32.dll" (ByVal short_int As Short) As Short
Private Declare Function socket Lib "WS2_32.dll" (ByVal af As Integer, ByVal sock_type As Integer, ByVal protocol As Integer) As Integer
'UPGRADE_WARNING: Structure SOCKADDR_IN may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function connect Lib "WS2_32.dll" (ByVal s As Integer, <[In](), Out()> ByRef name As SOCKADDR_IN, ByVal namelen As Integer) As Integer
Private Declare Function send Lib "WS2_32.dll" (ByVal s As Integer, ByVal buf As String, ByVal length As Integer, ByVal flags As Integer) As Integer
'Have to rename the "select" function due to conflict with reserved word in VB
'UPGRADE_WARNING: Structure TIMEVAL may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
'UPGRADE_WARNING: Structure FD_SET may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function bsd_select Lib "WS2_32.dll" Alias "select" (ByVal nfds As Integer, <[In](), Out()> ByRef readfds As FD_SET, <[In](), Out()> ByRef writefds As FD_SET, <[In](), Out()> ByRef exceptfds As FD_SET, <[In]()> ByRef timeout As TIMEVAL) As Integer
Private Declare Function recv Lib "WS2_32.dll" (ByVal s As Integer, ByVal buf As String, ByVal length As Integer, ByVal flags As Integer) As Integer
Private Declare Function closesocket Lib "WS2_32.dll" (ByVal s As Integer) As Integer
'Variables used in this module
Dim hSock As Integer
Dim nResult As Integer
Dim fs As New Scripting.FileSystemObject 'Requires reference to "Microsoft Scripting Runtime" (system32\scrrun.dll)
Dim fileOut As Scripting.TextStream
Public Sub Main()
'This code provides a simple example of TCP communication to a SAFER DAS.
'After initializing and connecting to the DAS, several requests will be
'sent and the results logged to a text file. When finished, the notepad
'file will be opened. Users may modify this sample however they like.
'Initialize and attempt to connect to SAFER DAS
If Not SC_Init() Then
Exit Sub
End If
'We are now connected and ready to transact data with the DAS.
'The subroutine will take care of properly formatting the request string.
Call SC_SendRequest("SI 1")
'Call SC_SendRequest("SS 1")
'Call SC_SendRequest("SA 1,1")
'Call SC_SendRequest("SH 1,1")
'Call SC_SendRequest("SM 1,1")
'Call SC_SendRequest("SN 1,1")
'Call SC_SendRequest("SP 1,1")
'Call SC_SendRequest("SQ 1,1")
'We're finished, so close down the socket connection
Call SC_Close()
'Open the output text file
Call Shell("notepad.exe SAFER_com.txt", AppWinStyle.NormalFocus)
End Sub
Private Function SC_Init() As Boolean
SC_Init = False
'Prompt for IP address and port number to connect to
Dim sIPAddr As String
Dim sPort As String
sIPAddr = "151.163.221.93"
If sIPAddr = "" Then
Exit Function
End If
sPort = "3000"
If sPort = "" Then
Exit Function
End If
'Get the output file ready
On Error GoTo ErrorHandler
fileOut = fs.CreateTextFile("SAFER_com.txt", True)
'Initialize Windows Sockets 2
Dim wsAttrib As WSADATA
nResult = WSAStartup(WS_VERSION_1_1, wsAttrib)
If Not nResult = 0 Then
MsgBox("WSAStartup Error = " & nResult)
fileOut.Close()
Exit Function
End If
'Create a TCP socket
hSock = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If hSock = INVALID_SOCKET Then
MsgBox("socket() Error = " & WSAGetLastError())
nResult = WSACleanup()
fileOut.Close()
Exit Function
End If
'Prepare the address data structure
Dim saAddress As New SOCKADDR_IN
saAddress.Initialize()
saAddress.sin_family = AF_INET
saAddress.sin_port = htons(Val(sPort))
saAddress.sin_addr = inet_addr(sIPAddr)
'Try connecting to the server
nResult = connect(hSock, saAddress, SOCKADDR_LEN)
If nResult = SOCKET_ERROR Then
MsgBox("connect() Error = " & WSAGetLastError())
nResult = WSACleanup()
fileOut.Close()
Exit Function
End If
'Successfully connected to the server
SC_Init = True
Exit Function
ErrorHandler:
MsgBox("Could not create output file.")
End Function
Private Sub SC_Close()
'Send special close request to DAS (5 bytes to send)
Dim sRequest As New VB6.FixedLengthString(15)
sRequest.Value = Chr(1) & Chr(0) & Chr(0) & Chr(0) & Chr(0)
nResult = send(hSock, sRequest.Value, 5, NO_FLAGS)
'Close our socket and shutdown Windows Sockets 2
nResult = closesocket(hSock)
nResult = WSACleanup()
fileOut.Close()
End Sub
Private Sub SC_SendRequest(ByRef sReq As String)
'Test for valid request length
If (Len(RTrim(sReq)) < 4) Or (Len(RTrim(sReq)) > 9) Then
MsgBox("Request is not valid")
Exit Sub
End If
'Format the request for sending to SAFER DAS by TCP port
Dim sRequest As New VB6.FixedLengthString(15)
sRequest.Value = Chr(0) & Chr(0) & Chr(0) & RTrim(sReq) & Chr(13) & Chr(0) & Chr(0)
'Send the formatted request
Dim nLen As Integer
nLen = 6 + Len(RTrim(sReq)) 'Include the 6 extra format bytes in the length
nResult = send(hSock, sRequest.Value, nLen, NO_FLAGS)
fileOut.WriteLine((sReq))
fileOut.WriteBlankLines((1))
'NOTE: When using the recv() function in blocking mode (default), it may wait forever
'for the other side to send some data. This can be problematic for your application.
'The select() function can be used to watch for the reply data to arrive with a timeout.
'If data has still not arrived after a generous timeout expires, it probably never will.
'In that case, the whole socket connection may be suspect and you might want to close it
'and start over.
'Prepare data structures for use with select() function
Dim fdsWrite, fdsRead, fdsExcept As New FD_SET
fdsWrite.Initialize()
fdsRead.Initialize()
fdsExcept.Initialize()
Dim tvTimeout As TIMEVAL
fdsRead.fd_count = 1 'how many sockets to check for incoming data
fdsRead.fd_array(0) = hSock 'which sockets to check
fdsWrite.fd_count = 0
fdsExcept.fd_count = 0
tvTimeout.tv_sec = 5 '5-second timeout
tvTimeout.tv_usec = 0
'Wait up to timeout for data to arrive from SAFER DAS
'System.Threading.Thread.Sleep(5000)
nResult = bsd_select(0, fdsRead, fdsWrite, fdsExcept, tvTimeout) 'the first parameter is ignored in Windows Sockets 2
Dim sReply As New VB6.FixedLengthString(MAX_REPLY_LEN)
Dim sData As String
If nResult = 1 Then
'select() reports that some data has arrived for 1 socket (our only socket)
nLen = recv(hSock, sReply.Value, MAX_REPLY_LEN, NO_FLAGS)
'nLen = recv(1001, sReply.Value, MAX_REPLY_LEN, NO_FLAGS)
'Get the length of just the SAFER data by excluding the first 3 wrapper bytes,
'the <LF> end delimiter, and the last 2 wrapper bytes.
nLen = nLen - 6
'Extract the SAFER data packet from the reply string, skipping over the first 3 wrapper bytes
sData = Mid(sReply.Value, 4, nLen)
fileOut.WriteLine((sData))
fileOut.WriteBlankLines((1))
ElseIf nResult = 0 Then
'select() timed out
MsgBox("Timed out waiting for reply" & nResult)
fileOut.WriteLine(("Timed out waiting for reply" & nResult))
fileOut.WriteBlankLines((1))
Else
'Some other error occurred
MsgBox("select() Error = " & WSAGetLastError())
fileOut.WriteLine(("select() Error = " & WSAGetLastError()))
fileOut.WriteBlankLines((1))
End If
End Sub
End Module

Try to set attribute MarshalAs(UnmanagedType.LPStruct)> on arguments you've received warnings about. It should help.
Also, IMHO it will be better if you rewrite your code using System.Net.Socket class ASAP. It will be much more short, simple and robust.

The problem in this case is the definition of the structure WSADATA; I used the WSAData64 structure reported here as I am under a 64 bit system and it worked without changing anything.
I am reporting the 32 bit and 64 bit structures here in case the link dies over time:
Private Structure WSAData32
Public Version As UShort
Public HighestVersion As UShort
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=257)> _
Public Description As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=129)> _
Public SystemStatus As String
Public MaxSockets As UShort
Public MaxUdpDatagramSize As UShort
Public VendorInfoPointer As IntPtr
End Structure
Private Structure WSAData64
Public Version As UShort
Public HighestVersion As UShort
Public MaxSockets As UShort
Public MaxUdpDatagramSize As UShort
Public VendorInfoPointer As IntPtr
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=257)> _
Public Description As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=129)> _
Public SystemStatus As String
End Structure
BTW: cannot use any new library as I am in a legacy maintenance project where I must change as less code as possible.

Related

VBA Excel 365 64-bit Winsock implementation problem

I am struggling with an issues related to porting VBA code from 32-bit into 64-bit excel. I would like to assure that I am trying to resolve it by myself already for two weeks, trying to modify the code, reading tones of forums, documents, web pages, looking for VBA reference on Microsoft webs. I am doing small steps forward, but ultimately I stuck on one step which I am not able to deal with.
My macro was created based on code snippets found on internet. In general it was written to connect to a server from which it needs to pull data. It sends a string and receives string back.
This macro was working well on 32-bit excel with no issues, but it is not working on 64-bit excel. Of course I modified declaration of functions including 'PtrSafe' modifier and changed 'Long' data type to 'LongPtr' whenever I found it necessary. Mainly in places where I expect function is requiring a pointer or memory address. Unfortunately I was not able to access any detailed definition what is inside 'wsock32.dll' therefore my declarations are rather guesses based on information which I could grab from internet forums... I was trying to utilize 'ws2_32.dll', but was more successful with 'wsock32.dll'. I guess for my application 'older' winsock is enough (but maybe this is an issue here...).
In order to debug by problem I've re-written the macro into simplest possible code in which I am testing step by step what is going on. At this point in time I am able to initialise winsock, get address by host name (this supposed to work well, since my code gives me the same IP address in human readable way which I can get from ping in cmd window), initialise socket. Currently I am stuck on connecting to the socket. I just have no idea what is wrong with my code. Code which I am presenting here was checked on 32-bit excel 2016 and it is able to connect to the socket. When I try to run it on 64-bit excel I get an error 10049.
May I ask for support, please?
Option Explicit
Option Compare Text
'Define address families
Public Const AF_INET = 2 'internetwork: UDP, TCP, etc.
'Define socket types
Public Const SOCK_STREAM = 1 'Stream socket
'Define return codes
Public Const GENERAL_ERROR As Long = vbObjectError + 100
Public Const INVALID_SOCKET = &HFFFF
Public Const SOCKET_ERROR = -1
Public Const NO_ERROR = 0
' Define structure for the information returned from the WSAStartup() function
Public Const WSADESCRIPTION_LEN = 256
Public Const WSASYS_STATUS_LEN = 128
Public Const WSA_DescriptionSize = WSADESCRIPTION_LEN + 1
Public Const WSA_SysStatusSize = WSASYS_STATUS_LEN + 1
Type WSAData
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSA_DescriptionSize
szSystemStatus As String * WSA_SysStatusSize
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As String * 200
End Type
' Define structure for host
Public Type hostent
h_name As LongPtr
h_aliases As LongPtr
h_addrtype As Integer
h_length As Integer
h_addr_list As LongPtr
End Type
' Define structure for address
Public Type sockaddr
sin_family As Integer
sin_port As Integer
sin_addr As LongPtr
sin_zero As String * 8
End Type
'Declare Socket functions
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSAData As WSAData) As Long
Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function gethostbyname Lib "wsock32.dll" (ByVal name As String) As LongPtr
Public Declare PtrSafe Function inet_ntoa Lib "wsock32.dll" (ByVal inaddr As LongPtr) As LongPtr
Public Declare PtrSafe Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal socktype As Long, ByVal protocol As Long) As Long
Public Declare PtrSafe Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare PtrSafe Function connect Lib "wsock32.dll" (ByVal s As LongPtr, name As sockaddr, ByVal namelen As Long) As Long
Public Declare PtrSafe Function closesocket Lib "wsock32.dll" (ByVal s As LongPtr) As Long
Public Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare PtrSafe Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Sub test()
Dim lResVal As Long
lResVal = GetDataFromServer(ServHost, ServPort)
End Sub
Function GetDataFromServer(ByVal sHostName As String, ByVal iPortNumber As Integer) As Long
Dim lResult As Long ' General variable to be used when checking the status from winsock functions
' Initialise the winsock
Dim CurrentWinsockInfo As WSAData
lResult = WSAStartup(MAKEWORD(2, 2), CurrentWinsockInfo)
If lResult <> 0 Then
Err.Raise GENERAL_ERROR, "WinsockInitInterface", "Unable to initialize Winsock!"
End If
' Get information about the server to connect to.
Dim lHostInfoPointer As LongPtr ' pointer to info about the host computer
lHostInfoPointer = gethostbyname(sHostName & vbNullChar)
If lHostInfoPointer = 0 Then
Err.Raise GENERAL_ERROR, "WinsockOpenTheSocketHostName", "Unable to resolve host!"
End If
' Copy information about the server into the structure.
Dim hostinfo As hostent ' info about the host computer
CopyMemory hostinfo, ByVal lHostInfoPointer, LenB(hostinfo)
If hostinfo.h_addrtype <> AF_INET Then
Err.Raise GENERAL_ERROR, "WinsockOpenTheSocketHostName", "Couldn't get IP address of " & sHostName
End If
' Get the server's IP address out of the structure.
Dim lIPAddressPointer As LongPtr ' pointer to host's IP address
Dim lIPAddress As LongPtr ' host's IP address
CopyMemory lIPAddressPointer, ByVal hostinfo.h_addr_list, LenB(lIPAddressPointer)
CopyMemory lIPAddress, ByVal lIPAddressPointer, LenB(lIPAddress)
' Convert the IP address into a human-readable string.
Dim lIPStringPointer As LongPtr ' pointer to an IP address formatted as a string
Dim sIPString As String ' holds a human-readable IP address string
lIPStringPointer = inet_ntoa(lIPAddress)
sIPString = Space(lstrlen(lIPStringPointer))
lResult = lstrcpy(sIPString, lIPStringPointer)
Debug.Print sHostName & " IP: " & sIPString & " : " & iPortNumber
' Create a new socket
Dim lsocketID As Long
lsocketID = socket(AF_INET, SOCK_STREAM, 0)
If lsocketID = SOCKET_ERROR Then
Err.Raise GENERAL_ERROR, "WinsockOpenTheSocket", "Unable to create the socket!"
End If
' Setup IP address and Port number
Dim I_SocketAddress As sockaddr
With I_SocketAddress
.sin_family = AF_INET
.sin_port = htons(iPortNumber)
.sin_addr = lIPAddress
.sin_zero = String$(8, 0)
End With
' Connect to the socket
lResult = connect(lsocketID, I_SocketAddress, LenB(I_SocketAddress))
Debug.Print Err.LastDllError
If lResult = SOCKET_ERROR Then
Call closesocket(lsocketID)
Call WSACleanup
Err.Raise GENERAL_ERROR, "WinsockOpenTheSocket", "Unable to connect to the socket!"
End If
End Function
Public Function MAKEWORD(ByVal bLow As Byte, ByVal bHigh As Byte) As Integer
MAKEWORD = Val("&H" & Right("00" & Hex(bHigh), 2) & Right("00" & Hex(bLow), 2))
End Function

VBA with WinSock2: send() sends wrong data

I'm trying to use WinSock2 in VBA to send (and later on, receive) data from a localhost TCP Stream.
For now, I've mostly been trying to replicate the client sample from here,https://msdn.microsoft.com/en-us/library/windows/desktop/ms738630(v=vs.85).aspx
My code "almost" works; I can create a socket & establish a connection to my server.
Sending data (e.g. invoking the send() function of ws2_32.dll) is odd, though..
In the example below, the server would indeed receive a byte array of length 10, but its contents are odd. The first 4 bytes of the array are set (but vary with each call), the last 6 bytes are always 0.
I'm not really sure what's going on; given I run this in 32bit Excel = pointers would be 4 bytes long, it almost seems a bit like only the address of some variable is being sent.
When I try to call this function passing an explicit address of the data (the SendWithPtr() call that is commented out), same issue occurs, so that doesn't help either.
Does anyone know what's going on there? Do I need to call the send() function different in any way?!
Thanks
VBA Code:
Option Explicit
' Constants ----------------------------------------------------------
Const INVALID_SOCKET = -1
Const WSADESCRIPTION_LEN = 256
Const SOCKET_ERROR = -1
' Typ definitions ----------------------------------------------------
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To WSADESCRIPTION_LEN) As Byte
szSystemStatus(0 To WSADESCRIPTION_LEN) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type ADDRINFO
ai_flags As Long
ai_family As Long
ai_socktype As Long
ai_protocol As Long
ai_addrlen As Long
ai_canonName As LongPtr 'strptr
ai_addr As LongPtr 'p sockaddr
ai_next As LongPtr 'p addrinfo
End Type
' Enums ---------------------------------------------------------------
Enum AF
AF_UNSPEC = 0
AF_INET = 2
AF_IPX = 6
AF_APPLETALK = 16
AF_NETBIOS = 17
AF_INET6 = 23
AF_IRDA = 26
AF_BTH = 32
End Enum
Enum sock_type
SOCK_STREAM = 1
SOCK_DGRAM = 2
SOCK_RAW = 3
SOCK_RDM = 4
SOCK_SEQPACKET = 5
End Enum
' External functions --------------------------------------------------
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef data As WSADATA) As Long
Public Declare Function connect Lib "ws2_32.dll" (ByVal socket As Long, ByVal SOCKADDR As Long, ByVal namelen As Long) As Long
Public Declare Sub WSACleanup Lib "ws2_32.dll" ()
Private Declare PtrSafe Function GetAddrInfo Lib "ws2_32.dll" Alias "getaddrinfo" (ByVal NodeName As String, ByVal ServName As String, ByVal lpHints As LongPtr, lpResult As LongPtr) As Long
Public Declare Function ws_socket Lib "ws2_32.dll" Alias "socket" (ByVal AF As Long, ByVal stype As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal socket As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Public Declare Function Send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf() As Byte, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function SendWithPtr Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByVal bufPtr As Long, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
Private Declare Function VarPtrArray Lib "VBE7" Alias "VarPtr" (var() As Any) As Long
Sub TestWinsock()
Dim m_wsaData As WSADATA
Dim m_RetVal As Integer
Dim m_Hints As ADDRINFO
Dim m_ConnSocket As Long: m_ConnSocket = INVALID_SOCKET
Dim Server As String
Dim port As String
Dim pAddrInfo As LongPtr
Dim RetVal As Long
Dim lastError As Long
RetVal = WSAStartup(MAKEWORD(2, 2), m_wsaData)
If (RetVal <> 0) Then
LogError "WSAStartup failed with error " & RetVal, WSAGetLastError()
Call WSACleanup
Exit Sub
End If
m_Hints.ai_family = AF.AF_UNSPEC
m_Hints.ai_socktype = sock_type.SOCK_STREAM
Server = "localhost"
port = "5001"
RetVal = GetAddrInfo(Server, port, VarPtr(m_Hints), pAddrInfo)
If (RetVal <> 0) Then
LogError "Cannot resolve address " & Server & " and port " & port & ", error " & RetVal, WSAGetLastError()
Call WSACleanup
Exit Sub
End If
m_Hints.ai_next = pAddrInfo
Dim connected As Boolean: connected = False
Do While m_Hints.ai_next > 0
CopyMemory m_Hints, ByVal m_Hints.ai_next, LenB(m_Hints)
m_ConnSocket = ws_socket(m_Hints.ai_family, m_Hints.ai_socktype, m_Hints.ai_protocol)
If (m_ConnSocket = INVALID_SOCKET) Then
LogError "Error opening socket, error " & RetVal
Else
Dim connectionResult As Long
connectionResult = connect(m_ConnSocket, m_Hints.ai_addr, m_Hints.ai_addrlen)
If connectionResult <> SOCKET_ERROR Then
connected = True
Exit Do
End If
LogError "connect() to socket failed"
closesocket (m_ConnSocket)
End If
Loop
If Not connected Then
LogError "Fatal error: unable to connect to the server", WSAGetLastError()
Call WSACleanup
Exit Sub
End If
Dim SendBuf() As Byte
SendBuf = StrConv("Message #1", vbFromUnicode)
Dim buflen As Integer
buflen = UBound(SendBuf) - LBound(SendBuf) + 1
' !!!!!!!!!!!
' !! Send() does not seem to send the right bytes !!
' !!!!!!!!!!!
RetVal = Send(m_ConnSocket, SendBuf, buflen, 0)
' The following does not work either:
' RetVal = SendWithPtr(m_ConnSocket, VarPtrArray(SendBuf), buflen, 0)
If RetVal = SOCKET_ERROR Then
LogError "send() failed", WSAGetLastError()
Call WSACleanup
Exit Sub
Else
Debug.Print "sent " & RetVal & " bytes"
End If
RetVal = closesocket(m_ConnSocket)
If RetVal <> 0 Then
LogError "closesocket() failed", WSAGetLastError()
Call WSACleanup
Else
Debug.Print "closed socket"
End If
End Sub
Public Function MAKEWORD(Lo As Byte, Hi As Byte) As Integer
MAKEWORD = Lo + Hi * 256& Or 32768 * (Hi > 127)
End Function
Private Sub LogError(msg As String, Optional ErrorCode As Long = -1)
If ErrorCode > -1 Then
msg = msg & " (error code " & ErrorCode & ")"
End If
Debug.Print msg
End Sub
Server code, just for reference:
using System;
using System.Net;
using System.Net.Sockets;
using System.Text;
using System.Threading;
namespace Server
{
class Program
{
static void Main(string[] args)
{
var address = Dns.GetHostEntry("localhost").AddressList[0];
var addressBytes = address.GetAddressBytes();
var port = 5001;
var ipEndpoint = new IPEndPoint(address, port);
var listener = new TcpListener(ipEndpoint);
listener.Start();
bool done = false;
TcpClient tcpClient = null;
try
{
while (!done)
{
Thread.Sleep(10);
Console.WriteLine("Waiting for broadcast");
tcpClient = listener.AcceptTcpClient();
byte[] bytes = new byte[10];
NetworkStream stream = tcpClient.GetStream();
var bytesRead = stream.Read(bytes, 0, bytes.Length);
// when called via the VBA sample, "bytes" will contain odd values.
// when called through Microsoft's C++ sample, everything works fine
}
}
finally {
tcpClient?.Close();
}
}
}
}
You need to pass the address of the data within the array - i.e. the address of the first element (because the address of the variable itself is the address of the enclosing SAFEARRAY)
Change the send argument to ByRef buf As Any
Pass in the address of the first array element:
RetVal = Send(m_ConnSocket, SendBuf(0), buflen, 0)
Const MAX_BUFFER_LENGTH As Long = 8192
Dim arrBuffers(1 To MAX_BUFFER_LENGTH) As Byte
Dim lngBytesReceived As Long
Dim strTempBuffer As String
lngBytesReceived = recv(s1, arrBuffers(1), MAX_BUFFER_LENGTH, 0&)
strTempBuffer = StrConv(arrBuffers, vbUnicode)
strBuffer = Left$(strTempBuffer, lngBytesReceived)
Dim arrBuffers(1 To MAX_BUFFER_LENGTH) As Byte
Dim lngBytesReceived As Long
Dim strTempBuffer As String
lngBytesReceived = recv(s1, arrBuffers(1), MAX_BUFFER_LENGTH, 0&)
If lngBytesReceived > 0 Then
'
' If we have received some data, convert it to the Unicode
' string that is suitable for the Visual Basic String data type
'
strTempBuffer = StrConv(arrBuffers, vbUnicode)
'
' Remove unused bytes
'
strBuffer = Left$(strTempBuffer, lngBytesReceived)

Unable to look up IP address in 64-bit VBA

My base problem is that I have a spreadsheet with 10's of thousands of FQDN (fully qualified domain name) entries that I need to check if the FQDN is a valid DNS entry on the public internet. I am doing a DNS lookup of each FQDN and would like to specify a public DNS server. If the call to the DNS returns an IP address, I will assume the FQDN is valid. I am working in excel 64-bit, but need a solution that will also compile and work in 32-bit, so I want the same source code to be able to be compiled in both. Since there are so many rows in the spreadsheet, I don't want to use a function that creates a temporary file for each lookup. (I am OCD about unneeded temporary files when a system call is available).
I believe that the function "getaddrinfoex" provides the ability to specify what name server is queried, but I have not been able to find any VBA snippets that use getaddrinfoex or the lesser version of getaddrinfo (which does not allow specifying the DNS server). I have found several examples of calls to gethostbyname, but all are for 32-bit Excel. Also, Microsoft has published that gethostbyname has been deprecated (https://msdn.microsoft.com/en-us/library/windows/desktop/ms738524(v=vs.85).aspx), so I was trying to use the recommended replacement getaddrinfo
How can I make a network connection with Visual Basic from Microsoft Access?
The snippet posted in the answer by #david in the question I linked above looks to have the proper syntax to be both 32-bit and 64-bit compatible. But the example did not include the call to gethostbyname, it only provided the declaration of the function.
Is getaddrinfoex available in VBA? Does someone have an example of using getaddrinfoex which will work in both 32-bit and 64-bit?
I would appreciate any help. I have not coded in MANY years, so my skills are very dated. Thus I am doing a lot of searches to find what I need.
Here is the code I have created from combining various searches on-line.
Private Type HOSTENT
hName As LongPtr
hAliases As LongPtr
hAddrType As Integer
hLen As Integer
hAddrList As LongPtr
End Type
#if Not VBA7 then
' used by 32-bit compiler
Private Declare Function gethostbyname Lib "wsock32.dll" _
(ByVal HostName As String) As LongPtr
Private Declare Function getaddrinfo Lib "wsock32.dll" _
(ByVal HostName As String) As LongPtr
Public Declare Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As LongPtr
#else
' used by 64-bit compiler
Private Declare PtrSafe Function gethostbyname Lib "wsock32.dll" _
(ByVal HostName As String) As LongPtr
Private Declare PtrSafe Function getaddrinfo Lib "wsock32.dll" _
(ByVal HostName As String) As LongPtr
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As LongPtr
#endif
Public Function GetIPAddressFromHostName(ByVal HostName As String) _
As LongPtr
Dim HostEntry As HOSTENT
Dim HostEntry2 as HOSTENT
Dim HostEntryPtr As LongPtr
Dim HostEntryPtr2 As LongPtr
Dim IPAddressesPtr As LongPtr
Dim Result As Long
If InitializeSockets Then
' I added the call do getaddrinfo as an example
' I have been able to get it to work at all
HostEntryPtr2 = getaddrinfo(HostName & vbNullChar)
HostEntryPtr = gethostbyname(HostName & vbNullChar)
If HostEntryPtr > 0 Then
CopyMemory HostEntry, ByVal HostEntryPtr, Len(HostEntryPtr)
CopyMemory IPAddressesPtr, ByVal HostEntry.hAddrList, _
Len(IPAddressesPtr)
CopyMemory Result, ByVal IPAddressesPtr, Len(Result)
GetIPAddressFromHostName = Result
End If
End If
End Function
Public Function InitializeSockets() As Boolean
' Initialize Windows sockets.
Dim WinSockData As WSADATA
InitializeSockets = WSAStartup(WS_VERSION_REQD, WinSockData) = 0
End Function
I have it working now as long as it is not moved to an add-in (.xlam). If I move it to an add-in this exact same code crashes on the call to getaddrinfo. I will continue to work on that.
The procedure requires one argument (hostname passed as a string). The second argument is the maximum number of IP addresses to return (passed as an integer), but is optional. If the second argument is blank, all IP address are returned. When set to a value other than zero, that value will be the maximum number of ip addresses for the host.
Private Const AF_UNSPEC As Long = 0
Private Const AF_INET As Long = 2
Private Const AF_INET6 As Long = 23
Private Const SOCK_STREAM As Long = 1
Private Const INADDR_ANY As Long = 0
Private Const IPPROTO_TCP As Long = 6
' Getaddrinfo return status codes
Private Const WAS_NOT_ENOUGH_MEMORY = 8 ' Insufficient memory available.
Private Const WASEINVAL = 10022 ' Invalid argument.
Private Const WASESOCKTNOSUPPORT = 10044 ' Socket type not supported.
Private Const WASEAFNOSUPPORT = 10047 ' Address family not supported by protocol family.
Private Const WASNOTINITIALISED = 10093 ' Successful WSAStartup not yet performed.
Private Const WASTYPE_NOT_FOUND = 10109 ' Class type not found.
Private Const WASHOST_NOT_FOUND = 11001 ' Host not found.
Private Const WASTRY_AGAIN = 11002 ' Nonauthoritative host not found.
Private Const WASNO_RECOVERY = 11003 ' This is a nonrecoverable error.
Private Const WASNO_DATA = 11004 ' Valid name, no data record of requested type.
'AI_flags
Private Const AI_PASSIVE As Long = &H1
Private Const ai_canonName As Long = &H2
Private Const AI_NUMERICHOST As Long = &H4
Private Const AI_ALL As Long = &H100
Private Const AI_ADDRCONFIG As Long = &H400
Private Const AI_V4MAPPED As Long = &H800
Private Const AI_NON_AUTHORITATIVE As Long = &H4000
Private Const AI_SECURE As Integer = &H8000
Private Const AI_RETURN_PREFERRED_NAMES As Long = &H10000
Private Const AI_FQDN As Long = &H20000
Private Const AI_FILESERVER As Long = &H40000
Dim hSocket As Long
Dim sServer As String
' To initialize Winsock.
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(256 + 1) As Byte
szSystemstatus(128 + 1) As Byte
iMaxSockets As Integer
iMaxUpdDg As Integer
lpVendorInfo As Long
End Type
Private Type in_addr
s_addr As LongPtr
End Type
Private Type sockaddr_in
sin_family As Integer '2 bytes
sin_port As Integer '2 bytes
sin_addr As in_addr '4 bytes or 8 bytes
sin_zero(7) As Byte '8 bytes
End Type 'Total 16 bytes or 24 bytes
Private Type sockaddr
sa_family As Integer '2 bytes
sa_data(25) As Byte '26 bytes
End Type 'Total 28 bytes
Private Type addrinfo
ai_flags As Long
ai_family As Long
ai_socktype As Long
ai_protocol As Long
ai_addrlen As Long
ai_canonName As LongPtr 'strptr
ai_addr As LongPtr 'p sockaddr
ai_next As LongPtr 'p addrinfo
End Type
Private Declare PtrSafe Function API_Socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal stype As Long, ByVal Protocol As Long) As Long
Private Declare PtrSafe Function API_GetAddrInfo Lib "ws2_32.dll" Alias "getaddrinfo" (ByVal NodeName As String, ByVal ServName As String, ByVal lpHints As LongPtr, lpResult As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare PtrSafe Function ntohs Lib "ws2_32.dll" (ByVal netshort As Long) As Integer
Public Function NameToIPaddress(hostname As String, Optional MaxReturn As Integer = 0) As String
Dim sa_local As sockaddr_in
Dim sa_dest As sockaddr
Dim lRet As Long
Dim Hints As addrinfo
Dim ptrResult As LongPtr
Dim IPaddress As String
Dim AddressList As String
Dim AddressType As Long
Dim Cnt As Integer
AddressType = AF_INET
If hostname = "" Then
NameToIPaddress = ""
Exit Function
End If
'Create TCP socket
hSocket = API_Socket(AddressType, SOCK_STREAM, IPPROTO_TCP)
If hSocket = 0 Then
MsgBox ("Failed to create socket!")
Exit Function
End If
'Populate the local sockaddr
sa_local.sin_family = AddressType
sa_local.sin_port = ntohs(0&)
sa_local.sin_addr.s_addr = INADDR_ANY
'Recover info about the destination.
'Hints.ai_flags = AI_NON_AUTHORITATIVE
Hints.ai_flags = 0
Hints.ai_family = AddressType
sServer = hostname & vbNullChar 'Null terminated string
sServer = hostname
lRet = API_GetAddrInfo(sServer, 0, VarPtr(Hints), ptrResult)
If lRet <> 0 Then
If lRet = WASHOST_NOT_FOUND Then
NameToIPaddress = "not found"
Exit Function
End If
Dim errorText As String
Select Case lRet
Case WAS_NOT_ENOUGH_MEMORY
errorText = "Insufficient memory available"
Case WASEINVAL
errorText = "Invalid argument"
Case WASESOCKTNOSUPPORT
errorText = "Socket type not supported"
Case WASEAFNOSUPPOR
errorText = "Address family not supported by protocol family"
Case WASNOTINITIALISED
errorText = "Successful WSAStartup not yet performed"
Case WASTYPE_NOT_FOUND
errorText = "Class type not found"
Case WASHOST_NOT_FOUND
errorText = "Host not found"
Case WASTRY_AGAIN
errorText = "Nonauthoritative host not found"
Case WASNO_RECOVERY
errorText = "This is a nonrecoverable error"
Case WASNO_DATA
errorText = "Valid name, no data record of requested type"
Case Else
errorText = "unknown error condition"
End Select
'MsgBox ("Error in GetAddrInfo: " & lRet & " - " & errorText)
NameToIPaddress = "#Error in lookup"
Exit Function
End If
Cnt = 0
Hints.ai_next = ptrResult 'Pointer to first structure in linked list
Do While Hints.ai_next > 0 And (Cnt < MaxReturn Or MaxReturn = 0)
CopyMemory Hints, ByVal Hints.ai_next, LenB(Hints) 'Copy next address info to Hints
CopyMemory sa_dest, ByVal Hints.ai_addr, LenB(sa_dest) 'Save sockaddr portion
Select Case sa_dest.sa_family
Case AF_INET
IPaddress = sa_dest.sa_data(2) & "." & sa_dest.sa_data(3) & "." & sa_dest.sa_data(4) & "." & sa_dest.sa_data(5)
Case AF_INET6
IPaddress = sa_dest.sa_data(0) & ":" & sa_dest.sa_data(1) & ":" & sa_dest.sa_data(2) & "::" & sa_dest.sa_data(3) & ":" & sa_dest.sa_data(4)
Case Else
IPaddress = ""
End Select
Cnt = Cnt + 1
If AddressList = "" Then
AddressList = IPaddress
Else
AddressList = AddressList & "," & IPaddress
End If
Loop
NameToIPaddress = AddressList
End Function

VB6 StrPtr Function to VB.NET

Trying to convert VB6 line of code to VB.net. Code will serve as identification if printer is OFF or ON
Thanks
"PRINTERFOUND = OpenPrinterW(StrPtr(PrinterName), hPrinter)" Particular StrPtr function...
Can't get OpenPrinter to work - Tries to print I simply want to to know if printer is OFF or ON
changing line to
PRINTERFOUND = OpenPrinterW(PrinterName.Normalize(), hPrinter, Nothing)
does not work, thanks
Tried to convert VB6 declaration to VB.net per previous suggestions but it still a same error cant convert String to Integer please see below
'Private Declare Function GetPrinterApi Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, ByRef BUFFER As Long, ByVal pbSize As Long, ByRef pbSizeNeeded As Long) As Long
<DllImport("winspool.Drv", EntryPoint:="GetPrinterA", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function GetPrinterApi(<MarshalAs(UnmanagedType.LPStr)> ByVal hPrinter As String, ByVal Level As IntPtr, ByVal BUFFER As IntPtr, ByVal pbSize As IntPtr, ByRef pbSizeNeeded As IntPtr) As Boolean
End Function
'Private Declare Function OpenPrinterW Lib "winspool.drv" (ByVal pPrinterName As Long, ByRef phPrinter As Long, Optional ByVal pDefault As Long = 0) As Long
<DllImport("winspool.Drv", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function OpenPrinterW(ByVal pPrinterName As IntPtr, ByVal phPrinter As Int32, <[In](), MarshalAs(UnmanagedType.LPStruct)> ByVal pDefault As IntPtr) As Boolean
End Function
'Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
<DllImport("winspool.Drv", EntryPoint:="ClosePrinter", SetLastError:=True, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function ClosePrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Long, ByRef Source As Long, ByVal Length As Long)
<DllImport("kernel32.dll", SetLastError:=True, EntryPoint:="RtlMoveMemory")> _
Public Function CopyMemory(ByRef Destination As Long, ByVal Source As IntPtr, ByVal Length As String) As IntPtr
End Function
Full code Below
'Acknowledgements : This program has been written making extensive use of the
'Merrion article http://www.merrioncomputing.com/Programming/PrintStatus.htm
'It has also benefited from the contributors to VBForums thread # 733849
'http://www.vbforums.com/showthread.php?t=733849&goto=newpost - especially the code
'suggested by "Bonnie West"
'Program written 14 Sept. 2013 by C.A. Moore
Option Explicit
Dim PRINTERFOUND As Long
Dim GETPRINTER As Long
Dim BUFFER() As Long
Dim pbSizeNeeded As Long
Dim PRINTERINFO As PRINTER_INFO_2
Dim N As Integer
Dim M As Integer
Dim CHAR As String
Dim prnPrinter As Printer
Dim BUF13BINARY As String
' Note : PRINTERREADY as an Integer variable is Dim'd
'"Public PRINTERREADY As Integer" at Form1 Option Explicit
Private Type PRINTER_INFO_2
pServerName As String
pPrinterName As String
pShareName As String
pPortName As String
pDriverName As String
pComment As String
pLocation As String
pDevMode As Long
pSepFile As String
pPrintProcessor As String
pDatatype As String
pParameters As String
pSecurityDescriptor As Long
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
JobsCount As Long
AveragePPM As Long
End Type
Private Declare Function GetPrinterApi Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, BUFFER As Long, ByVal pbSize As Long, pbSizeNeeded As Long) As Long
Private Declare Function OpenPrinterW Lib "winspool.drv" (ByVal pPrinterName As Long, ByRef phPrinter As Long, Optional ByVal pDefault As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function StringFromPointer(lpString As Long, lMaxLength As Long) As String
'this service function extracts a string (sRet) when fed with a pointer (lpstring)
'from a buffer
Dim sRet As String
Dim lret As Long
If lpString = 0 Then
StringFromPointer = ""
Exit Function
End If
'\\ Pre-initialise the return string...
sRet = Space$(lMaxLength)
CopyMemory ByVal sRet, ByVal lpString, ByVal Len(sRet)
If Err.LastDllError = 0 Then
If InStr(sRet, Chr$(0)) > 0 Then
sRet = Left$(sRet, InStr(sRet, Chr$(0)) - 1)
End If
End If
StringFromPointer = sRet
End Function
Public Function IsPrinterReady(ByRef PrinterName As String)
Form1.PRINTERREADY = 0
'first select the named printer and check if it is installed
For Each prnPrinter In Printers
CHAR = prnPrinter.DeviceName
If CHAR = PrinterName Then
Set Printer = prnPrinter 'sets this as printer
Form1.PRINTERREADY = 1
End If
Next
If Form1.PRINTERREADY = 0 Then GoTo Line1000 'exit. printer not installed
Dim hPrinter As Long
Dim PI6 As PRINTER_INFO_2
PRINTERFOUND = 0
Form1.PRINTERREADY = 0
PRINTERFOUND = OpenPrinterW(StrPtr(PrinterName), hPrinter)
'(OpenPrinterW(ByVal pPrinterName As Long, ByRef phPrinter As Long) As Long)
If PRINTERFOUND = 0 Then 'ie. printer not found
Form1.PRINTERREADY = 0
Debug.Assert ClosePrinter(hPrinter)
GoTo Line100
End If
'If we get here named printer was found and accessed and its hPrinter handle is
'known
'Dim BUFFER() As Long
'Dim pbSizeNeeded As Long
ReDim Preserve BUFFER(0 To 1) As Long
GETPRINTER = GetPrinterApi(hPrinter, 2&, BUFFER(0), UBound(BUFFER), pbSizeNeeded)
ReDim Preserve BUFFER(0 To (pbSizeNeeded / 4) + 3) As Long
GETPRINTER = GetPrinterApi(hPrinter, 2&, BUFFER(0), UBound(BUFFER) * 4, pbSizeNeeded)
If GETPRINTER = 0 Then 'ie. some problem with printer access
Form1.PRINTERREADY = 0
GoTo Line100
End If
'If we get here then GETPRINTER = 1, ie. printer found and accessed OK
With PRINTERINFO '\\ This variable is of type PRINTER_INFO_2
'These quantities are defined here because the Merrion article
'so specifies. However they are not used by this program, and most
'have been found to be void
.pServerName = StringFromPointer(BUFFER(0), 1024)
.pPrinterName = StringFromPointer(BUFFER(1), 1024)
.pShareName = StringFromPointer(BUFFER(2), 1024)
.pPortName = StringFromPointer(BUFFER(3), 1024)
.pDriverName = StringFromPointer(BUFFER(4), 1024)
.pComment = StringFromPointer(BUFFER(5), 1024)
.pLocation = StringFromPointer(BUFFER(6), 1024)
.pDevMode = BUFFER(7)
.pSepFile = StringFromPointer(BUFFER(8), 1024)
.pPrintProcessor = StringFromPointer(BUFFER(9), 1024)
.pDatatype = StringFromPointer(BUFFER(10), 1024)
.pParameters = StringFromPointer(BUFFER(11), 1024)
.pSecurityDescriptor = BUFFER(12)
.Attributes = BUFFER(13)
.Priority = BUFFER(14)
.DefaultPriority = BUFFER(15)
.StartTime = BUFFER(16)
.UntilTime = BUFFER(17)
.Status = BUFFER(18)
.JobsCount = BUFFER(19)
.AveragePPM = BUFFER(20)
End With
'This next code is for interest and program development only.
'It writes into List1 the value of each buffer 1 - 20
'To by-pass it, add a "Go To Line15" statement at this point.
Form1.List1.Clear
N = 0
Line5:
On Error GoTo Line15
Form1.List1.AddItem "Buffer No. " & N & " Buffer Value " & BUFFER(N)
N = (N + 1)
If N = 21 Then GoTo Line15
GoTo Line5
'Now to convert the decimal value of Buffer(13) into a binary
'bit pattern and store this in BUF13BINARY
Line15: 'and to show Buffer(13) as a binary bit pattern at Form1.Label1
N = BUFFER(13)
BUF13BINARY = ""
M = 4196
Line16:
If N < M Then
BUF13BINARY = BUF13BINARY & "0"
GoTo Line20
End If
BUF13BINARY = BUF13BINARY & "1"
N = (N - M)
Line20:
If M = 1 Then GoTo Line10
M = M / 2
GoTo Line16
Line10: 'BUF13BINARY is now the 13 bit binary value of Buffer(13)
'eg. 0011000100010
Form1.Label1.Caption = BUF13BINARY 'display this binary value at form 1
'we now examine the value of the third binary bit in BUF13BINARY
If Mid$(BUF13BINARY, 3, 1) = "0" Then Form1.PRINTERREADY = 1
If Mid$(BUF13BINARY, 3, 1) = "1" Then Form1.PRINTERREADY = 0
Line100:
ClosePrinter (hPrinter)
Line1000:
End Function
and
Option Explicit
Public PRINTERREADY As Integer
Private Sub Command1_Click()
IsPrinterReady ("Brother QL-500")
'IsPrinterReady ("EPSON Stylus CX5400")
MsgBox PRINTERREADY '0 = Not Ready 1 = Ready
End Sub
You cannot convert VarPtr, StrPtr, or ObjPtr, because in .NET you do not directly control memory. These functions were used to extract a pointer from an instance, a variable, or a Unicode string. But in .NET, object locations in memory is managed by the garbage collector, and the GC can move objects around in memory at any time.
Consider the following code, but do not use it! I put it here only to explain why these functions do not exist in .NET.
Private Function VarPtr(ByVal obj As Object) As Integer
' Obtain a pinned handle to the object
Dim handle As GCHandle = GCHandle.Alloc(obj, GCHandleType.Pinned)
Dim pointer As Integer = handle.AddrOfPinnedObject.ToInt32
' Free the allocated handle. At this point the GC can move the object in memory, this is
' why this function does not exist in .NET. If you were to use this pointer as a destination
' for memcopy for example, you could overwrite unintended memory, which would crash the
' application or cause unexpected behavior. For this function to work you would need to
' maintain the handle until after you are finished using it.
handle.Free()
Return pointer
End Function
Edit:
The correct way to get the printer status is through the managed interface for it, in this case through WMI:
Imports System.Management
Public Class Form1
Private Enum PrinterStatus As Integer
Other = 1
Unknown = 2
Idle = 3
Printing = 4
Warmup = 5
Stopped = 6
Offline = 7
End Enum
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim mos = New ManagementObjectSearcher("SELECT * FROM Win32_Printer")
For Each p In mos.Get()
Debug.Print(p.Properties("Name").Value.ToString() & " : " & CType(CInt(p.Properties("PrinterStatus").Value), PrinterStatus).ToString())
Next
End Sub
End Class
You can get more information about the Win32_Printer class here: https://msdn.microsoft.com/en-us/library/aa394363(v=vs.85).aspx
In particular take note of this:
Note If you are retrieving PrinterStatus = 3 or PrinterState = 0, the
printer driver may not be feeding accurate information into WMI. WMI
retrieves the printer information from the spoolsv.exe process. It is
possible the printer driver does not report its status to the spooler.
In this case, Win32_Printer reports the printer as Idle.
From there you can get information about and manage just about any peripheral connected. Just figure out the appropriate WMI classes and read up on the docs.
Thanks Everyone, especially Drunken Code Monkey for all the information provided, I was able to finally achieve what I wanted after reading on https://msdn.microsoft.com/en-us/library/aa394363(v=vs.85).aspx figured need to is boolean WorkOffline; Pew... made it more simple then VB6 language even using that feels kinda hmm old. Also lucky me found codes that did the same thing as I wanted here is link to VB.NET "https://bytes.com/topic/visual-basic-net/answers/524957-detecting-if-printer-connected-pc" And my modification of this code below
Imports System.Management
Public Class Form1
Public Class CheckPrinterStatus
Public Function PrinterIsOnline(ByVal sPrinterName As String) As Boolean
'// Set management scope
Dim scope As ManagementScope = New ManagementScope("\root\cimv2")
scope.Connect()
'// Select Printers from WMI Object Collections
Dim searcher As ManagementObjectSearcher = New ManagementObjectSearcher("SELECT * FROM Win32_Printer")
Dim printerName As String = String.Empty
For Each printer As ManagementObject In searcher.Get()
printerName = printer("Name").ToString() '.ToLower()
If (printerName.Equals(sPrinterName)) Then
MsgBox(printerName)
If (printer("WorkOffline").ToString().ToLower().Equals("true")) Then
MsgBox("Offline")
' Printer is offline by user
Return False
Else
' Printer is not offline
MsgBox("Online")
Return True
End If
End If
Next
Return False
End Function ' PrinterIsOnline
End Class
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim PrinterSatus As New CheckPrinterStatus
PrinterSatus.PrinterIsOnline("Brother QL-500") 'Name of The printer HERE
End Sub
End Class

How do I get the current logged in Active Directory username from VBA?

I am new to Active Directory.
I have a VBA Excel Add-In that should run if, and only if, the computer that it is running on is currently logged into the Active Directory, whether locally or through a VPN.
Knowing the domain name, how would I retrieve the user name for the currently logged in user?
Thanks!
I know it's kinda late, but I went through hell last year to find the following code, that can return the username ("fGetUserName()") or the full name ("DragUserName()"). You don't even need to know the ad / dc address..
Hope this is helpful to anyone who consults this question.
Private Type USER_INFO_2
usri2_name As Long
usri2_password As Long ' Null, only settable
usri2_password_age As Long
usri2_priv As Long
usri2_home_dir As Long
usri2_comment As Long
usri2_flags As Long
usri2_script_path As Long
usri2_auth_flags As Long
usri2_full_name As Long
usri2_usr_comment As Long
usri2_parms As Long
usri2_workstations As Long
usri2_last_logon As Long
usri2_last_logoff As Long
usri2_acct_expires As Long
usri2_max_storage As Long
usri2_units_per_week As Long
usri2_logon_hours As Long
usri2_bad_pw_count As Long
usri2_num_logons As Long
usri2_logon_server As Long
usri2_country_code As Long
usri2_code_page As Long
End Type
Private Declare Function apiNetGetDCName Lib "Netapi32.dll" Alias "NetGetDCName" (ByVal servername As Long, ByVal DomainName As Long, bufptr As Long) As Long
Private Declare Function apiNetAPIBufferFree Lib "Netapi32.dll" Alias "NetApiBufferFree" (ByVal buffer As Long) As Long
Private Declare Function apilstrlenW Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function apiNetUserGetInfo Lib "Netapi32.dll" Alias "NetUserGetInfo" (servername As Any, UserName As Any, ByVal level As Long, bufptr As Long) As Long
Private Declare Sub sapiCopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private strUserID As String
Private strUserName As String
Private strComputerName As String
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
Public Function fGetUserName() As String
' Returns the network login name
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngRet = apiGetUserName(strUserName, lngLen)
If lngRet Then
fGetUserName = Left$(strUserName, lngLen - 1)
End If
End Function
Private Sub Class_Initialize()
On Error Resume Next
'Returns the network login name
Dim strTempUserID As String, strTempComputerName As String
'Create a buffer
strTempUserID = String(100, Chr$(0))
strTempComputerName = String(100, Chr$(0))
'Get user name
GetUserName strTempUserID, 100
'Get computer name
GetComputerName strTempComputerName, 100
'Strip the rest of the buffer
strTempUserID = Left$(strTempUserID, InStr(strTempUserID, Chr$(0)) - 1)
Let strUserID = LCase(strTempUserID)
strTempComputerName = Left$(strTempComputerName, InStr(strTempComputerName, Chr$(0)) - 1)
Let strComputerName = LCase(strTempComputerName)
Let strUserName = DragUserName(strUserID)
End Sub
Public Property Get UserID() As String
UserID = strUserID
End Property
Public Property Get UserName() As String
UserName = strUserName
End Property
Public Function DragUserName(Optional strUserName As String) As String
On Error GoTo ErrHandler
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As USER_INFO_2
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
' Unicode
abytPDCName = fGetDCName() & vbNullChar
If strUserName = "" Then strUserName = fGetUserName()
abytUserName = strUserName & vbNullChar
' Level 2
lngRet = apiNetUserGetInfo( _
abytPDCName(0), _
abytUserName(0), _
2, _
pBuf)
If (lngRet = ERROR_SUCCESS) Then
Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
DragUserName = fStrFromPtrW(pTmp.usri2_full_name)
End If
Call apiNetAPIBufferFree(pBuf)
ExitHere:
Exit Function
ErrHandler:
DragUserName = vbNullString
Resume ExitHere
End Function
Public Property Get ComputerName() As String
ComputerName = strComputerName
End Property
Private Sub Class_Terminate()
strUserName = ""
strComputerName = ""
End Sub
Public Function fGetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
lngRet = apiNetGetDCName(0, 0, pTmp)
If lngRet = NERR_SUCCESS Then
fGetDCName = fStrFromPtrW(pTmp)
End If
Call apiNetAPIBufferFree(pTmp)
End Function
Public Function fStrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
' Get the length of the string at the memory location
lngLen = apilstrlenW(pBuf) * 2
' if it's not a ZLS
If lngLen Then
ReDim abytBuf(lngLen)
' then copy the memory contents
' into a temp buffer
Call sapiCopyMem( _
abytBuf(0), _
ByVal pBuf, _
lngLen)
' return the buffer
fStrFromPtrW = abytBuf
End If
End Function
EDITED: If I understand your situation properly, then you might be going about this the wrong way.
When your app starts up, you could do a simple ping against a machine that the user would only be able to see if they were connected to your network, whether they log into the local network or if they are connected via the VPN.
If they already have access to your local network, it means they've already authenticated against whatever machanism, whether it's Active Directory or something else, and it means they are "currently logged in".
On a side note, Active Directory by itself doesn't know if someone is logged in. There's no way you can do something like:
ActiveDirectory.getIsThisUserLoggedIn("username");
Active Directory only acts as a mechanism for user metadata, security, and authentication.
Try this
MsgBox Environ("USERNAME")
This function returns full name of logged user:
Function UserNameOffice() As String
UserNameOffice = Application.UserName
End Function