Short Question
Is there a library that is supposed to replace mswinsoc.osx used to create and maintain socket connections within VBA applications?
Background
I am trying to create socket connection(s) within a Visio 2010 Professional document. I have found a way to register mswinsoc.osx on Windows 7 here, but this seems very strange that Microsoft would get rid of a library to make socket connections without having something (better) to replace it. To add to my concern, there are little to no examples using the Winsoc library for Office 2010. I am not supporting old documents, so Winsoc is not a requirement; it's just the closet thing I know will work.
Additional Thoughts
I have found some very useful VBA stuff for Visio here that lead me to believe that there should be a new solution.
Any examples of socket connections for Office 2010 or insight to what happened to mswinsoc.osx would be of great help.
I made vba login client (ws2_32.dll) example
It may works fine (I tested.)
Tested Screen Image Here
ServerMain.c
#undef UNICODE
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <winsock2.h>
#include <ws2tcpip.h>
#include <stdlib.h>
#include <stdio.h>
// Need to link with Ws2_32.lib
#pragma comment (lib, "Ws2_32.lib")
#define DEFAULT_BUFLEN 512
#define DEFAULT_PORT "16001"
static char LoginCheck(char * recvbuf);
int main(void)
{
WSADATA wsaData;
int iResult;
SOCKET ListenSocket = INVALID_SOCKET;
SOCKET ClientSocket = INVALID_SOCKET;
struct addrinfo *result = NULL;
struct addrinfo hints;
int iSendResult;
char recvbuf[DEFAULT_BUFLEN];
int recvbuflen = DEFAULT_BUFLEN;
char sendbuf[DEFAULT_BUFLEN];
int sendbuflen = DEFAULT_BUFLEN;
printf("Excel Login Server Start..\n");
// Initialize Winsock
iResult = WSAStartup(MAKEWORD(2, 2), &wsaData);
if (iResult != 0) {
printf("WSAStartup failed with error: %d\n", iResult);
return 1;
}
ZeroMemory(&hints, sizeof(hints));
hints.ai_family = AF_INET;
hints.ai_socktype = SOCK_STREAM;
hints.ai_protocol = IPPROTO_TCP;
hints.ai_flags = AI_PASSIVE;
// Resolve the server address and port
iResult = getaddrinfo(NULL, DEFAULT_PORT, &hints, &result);
if (iResult != 0) {
printf("getaddrinfo failed with error: %d\n", iResult);
WSACleanup();
return 1;
}
// Create a SOCKET for connecting to server
ListenSocket = socket(result->ai_family, result->ai_socktype, result->ai_protocol);
if (ListenSocket == INVALID_SOCKET) {
printf("socket failed with error: %ld\n", WSAGetLastError());
freeaddrinfo(result);
WSACleanup();
return 1;
}
// Setup the TCP listening socket
iResult = bind(ListenSocket, result->ai_addr, (int)result->ai_addrlen);
if (iResult == SOCKET_ERROR) {
printf("bind failed with error: %d\n", WSAGetLastError());
freeaddrinfo(result);
closesocket(ListenSocket);
WSACleanup();
return 1;
}
freeaddrinfo(result);
iResult = listen(ListenSocket, SOMAXCONN);
if (iResult == SOCKET_ERROR) {
printf("listen failed with error: %d\n", WSAGetLastError());
closesocket(ListenSocket);
WSACleanup();
return 1;
}
printf("Server Is running at port %s\n", DEFAULT_PORT);
while(1) {
// Accept a client socket
ClientSocket = accept(ListenSocket, NULL, NULL);
if (ClientSocket == INVALID_SOCKET) {
printf("accept failed with error: %d\n", WSAGetLastError());
//closesocket(ListenSocket);
//WSACleanup();
//return 1;
}
// recieve data from client
iResult = recv(ClientSocket, recvbuf, recvbuflen, 0);
if (iResult > 0) {
printf("Bytes received: %d\n", iResult);
recvbuf[iResult] = '\0';
printf("Recieved string : %s\n", recvbuf);
// id, pw check
sendbuf[0] = LoginCheck(recvbuf); //success code
sendbuf[1] = '\0';
// Echo the buffer back to the sender
iSendResult = send(ClientSocket, sendbuf, 1, 0);
if (iSendResult == SOCKET_ERROR) {
printf("send failed with error: %d\n", WSAGetLastError());
//closesocket(ClientSocket);
//WSACleanup();
//return 1;
}
printf("Bytes sent: %d\n", iSendResult);
}
else if (iResult == 0)
printf("Connection closing...\n");
else {
printf("recv failed with error: %d\n", WSAGetLastError());
//closesocket(ClientSocket);
//WSACleanup();
//return 1;
}
Sleep(10);
}
// No longer need server socket
closesocket(ListenSocket);
// shutdown the connection since we're done
iResult = shutdown(ClientSocket, SD_SEND);
if (iResult == SOCKET_ERROR) {
printf("shutdown failed with error: %d\n", WSAGetLastError());
closesocket(ClientSocket);
WSACleanup();
return 1;
}
// cleanup
closesocket(ClientSocket);
WSACleanup();
return 0;
}
// check if login info correct (input : "id"|"pw")
static char LoginCheck(char * recvbuf)
{
char *id, *pw;
if (!recvbuf | !recvbuf[0])
return 0;
// temp id, pw info (later, may use db info)
id = strtok(recvbuf, "|");
if (!id)
return 0;
if (strcmp(id, "testid"))
return 0;
pw = strtok(NULL, "|");
if (!pw)
return 0;
if (strcmp(pw, "testpw"))
return 0;
return 's'; //success
}
Server.vb
'
' reference site https://stackoverflow.com/questions/49028281/vba-with-winsock2-send-sends-wrong-data
' edited by robotmanya (2018.10.28) (https://blog.naver.com/monkey5255/221386590654)
' Constants ----------------------------------------------------------
Const ip = "127.0.0.1"
Const port = "16001"
Const INVALID_SOCKET = -1
Const WSADESCRIPTION_LEN = 256
Const SOCKET_ERROR = -1
Const SD_SEND = 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, ByVal buf As String, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function Recv Lib "ws2_32.dll" Alias "recv" (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
Public Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how 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
'Login Button Click Event
Function Login(ID As String, pw As String)
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 pAddrInfo As LongPtr
Dim RetVal As Long
Dim lastError As Long
Dim iRC As Long
Dim MAX_BUF_SIZE As Integer: MAX_BUF_SIZE = 512
Login = 0
'Socket Settings
RetVal = WSAStartup(MAKEWORD(2, 2), m_wsaData)
If (RetVal <> 0) Then
LogError "WSAStartup failed with error " & RetVal, WSAGetLastError()
Call WSACleanup
Exit Function
End If
m_Hints.ai_family = AF.AF_UNSPEC
m_Hints.ai_socktype = sock_type.SOCK_STREAM
RetVal = GetAddrInfo(ip, port, VarPtr(m_Hints), pAddrInfo)
If (RetVal <> 0) Then
LogError "Cannot resolve address " & ip & " and port " & port & ", error " & RetVal, WSAGetLastError()
Call WSACleanup
Exit Function
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()
RetVal = closesocket(m_ConnSocket)
Call WSACleanup
Exit Function
End If
'After Socket Connected
Dim SendBuf As String
SendBuf = ID + "|" + pw
'Send Login Data
RetVal = Send(m_ConnSocket, SendBuf, Len(SendBuf), 0)
If RetVal = SOCKET_ERROR Then
LogError "send() failed", WSAGetLastError()
RetVal = closesocket(m_ConnSocket)
Call WSACleanup
Exit Function
Else
Debug.Print "sent " & RetVal & " bytes"
End If
' shutdown the connection since no more data will be sent
RetVal = shutdown(m_ConnSocket, SD_SEND)
If RetVal <> 0 Then
LogError "send socket close failed", WSAGetLastError()
RetVal = closesocket(m_ConnSocket)
Call WSACleanup
Else
Debug.Print "send socket closed"
End If
'Recieve From Server (Login Success : 1, Fail : 0)
Dim RecvBuf As Byte
RetVal = Recv(m_ConnSocket, RecvBuf, MAX_BUF_SIZE, 0)
If RetVal = SOCKET_ERROR Then
LogError "recv() failed", WSAGetLastError()
RetVal = closesocket(m_ConnSocket)
Call WSACleanup
Exit Function
Else
Debug.Print "recieved " & RetVal & " bytes"
End If
'Login Check (s : success(id,pw correspond, f : fail)
If Left(Chr(RecvBuf), 1) = "s" Then
Login = 1
Else
Login = 0
End If
RetVal = closesocket(m_ConnSocket)
If RetVal <> 0 Then
LogError "closesocket() failed", WSAGetLastError()
Call WSACleanup
Else
Debug.Print "closed socket"
End If
End Function
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
I think this code explained all you need.
but if you know more detailed process,
I also posted this to my blog
https://blog.naver.com/monkey5255/221386590654
Short Answer
wsock32.dll
Additional Information
I have found a few detailed examples in C and VB using this DLL.
Examples in C
Examples in VB
Thus far I have not had a chance to run any examples within VBA due to a shift in my projects scope. I am instead using Python to control Visio via a COM connection with great success.
You might want to take a look at Webxcel https://github.com/michaelneu/webxcel, a full REST-Backend written in Excel-Macros.
Related
Windows
With Raku/Perl6, how do I use NativeCall to read the value of
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\ "EnableLUA"]
with RegQueryValueExW?
https://learn.microsoft.com/en-us/windows/win32/api/winreg/nf-winreg-regqueryvalueexw
Many thanks,
-T
edit 12-27-2019 #1: removing bad code and inserting new code
This is how far I have gotten.
Test run string:
K:\Windows\NtUtil>perl6 -I. -e "use WinMount :GetLUA; say GetLUA();"
RegOpenKeyExW
RegOpenKeyExW RtnCode 0
RegQueryValueExW
1
2
RegQueryValueExW RtnCode 87 (87 = ERROR_INVALID_PARAMETER)
lpData pointer 0
lpcbData data length 0
RegCloseKey
RegCloseKey RtnCode 0
True
WinMount.pm6
# unit module WinMount;
# WinMount.pm6#`{
Utilities to mount and dismound drive partitions
Note: LUA must be unset (0x00000000) for mount to function prpoperly
raku -I. -c WinMount.pm6
}
use NativeCall;
use WinPopUps :WinMsg;
# Reference to types and values: http://dsource.org/projects/tango/ticket/820
constant BYTE := uint8;
constant WCHAR := uint16;
constant DWORD := int32;
constant REGSAM := int32;
constant WCHARS := CArray[WCHAR];
constant BYTES := CArray[BYTE];
constant HKEY_CURRENT_USER = 0x80000001;
constant HKEY_LOCAL_MACHINE = 0x80000002;
constant KEY_QUERY_VALUE = 1;
constant ERROR_SUCCESS = 0; # Yeah, I know. The Win-Api uses 0 for success and other values to indicate errors
constant REG_SZ = 1;
constant KEY_READ = 0x20019;
constant KEY_SET_VALUE = 0x0002;
constant REG_DWORD = 0x00000004;
sub to-c-str( Str $str ) returns CArray[WCHAR] is export( :to-c-str ) {
my #str := CArray[WCHAR].new;
for ( $str.comb ).kv -> $i, $char { #str[$i] = $char.ord; }
#str[ $str.chars ] = 0;
#str;
}
sub wstr( Str $str ) returns WCHARS is export( :wstr ) {
CArray[WCHAR].new( $str.comb.map: *.ord )
}
sub GetLUA() is export( :GetLUA ) {
#`{
Returns the LUA value in the registry to True (0x00000001) or False (0x00000000)
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System]
"EnableLUA"=dword:00000000
https://docs.perl6.org/language/nativecall
Win32 return codes:
https://learn.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-
}
my Str $SubName = &?ROUTINE.name;
my Str $OS = $*KERNEL.name;
if not $OS eq "win32" { say "Sorry, $SubName only work in Windows."; exit; }
my Bool $LUA = True;
my $RtnCode;
my Str $SubKey = Q[SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\];
my Str $Key = Q[EnableLUA];
my $lpSubKey = wstr( $SubKey );
my $lpValueName = wstr( $Key );
# my $lpSubKey = CArray[uint8].new($Key.encode.list);
# my $lpValueName = CArray[uint8].new($SubKey.encode.list);
my int32 $Handle;
my int32 $ulOptions = 0;
my int32 $lpData;
my int32 $lpcbData;
my int32 $lpReserved = 1;
#`{
Open the key:
https://learn.microsoft.com/en-us/windows/win32/api/winreg/nf-winreg-regopenkeyexw
https://learn.microsoft.com/en-us/windows/win32/sysinfo/registry-key-security-and-access-rights
C++
LSTATUS RegOpenKeyExW(
HKEY hKey, # Hive name (HKEY_LOCAL_MACHINE)
LPCWSTR lpSubKey, # path to the key(/SOFTWARE/Microsoft/Windows/CurrentVersion/Policies/System/EnableLUA)
DWORD ulOptions, # 0
REGSAM samDesired, # KEY_READ (0x20019), KEY_SET_VALUE (0x0002)
PHKEY phkResult # A pointer to a variable that receives a handle to the opened key
);
}
say "RegOpenKeyExW";
sub RegOpenKeyExW( DWORD, WCHARS, DWORD, DWORD, DWORD is rw) is native("Kernel32.dll") returns DWORD { * };
$RtnCode = RegOpenKeyExW( HKEY_LOCAL_MACHINE, $lpSubKey, $ulOptions, KEY_READ, $Handle );
say "RegOpenKeyExW RtnCode $RtnCode\n";
#`{
Read the key:
use RegQueryValueExW if you know key and value name
https://learn.microsoft.com/en-us/windows/win32/api/winreg/nf-winreg-regqueryvalueexw
C++
LSTATUS RegQueryValueExW(
HKEY hKey, # Hive name (HKEY_LOCAL_MACHINE)
LPCWSTR lpValueName, # path to the key(\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA)
LPDWORD lpReserved, # give it "int32" without the quotes to give it a NULL
LPDWORD lpType, # Registry Value Type (REG_DWORD which is 32 bit)
LPBYTE lpData, # Pointer to the return value
LPDWORD lpcbData # number of bytes in the return value
);
}
say "RegQueryValueExW";
sub RegQueryValueExW( DWORD, WCHARS, DWORD, DWORD, DWORD is rw, DWORD is rw ) is native("Kernel32.dll") returns DWORD { * };
say "1";
$RtnCode = RegQueryValueExW( $Handle, $lpValueName, $lpReserved, REG_DWORD, $lpData, $lpcbData );
say "2";
say "RegQueryValueExW RtnCode $RtnCode (87 = ERROR_INVALID_PARAMETER)\nlpData pointer $lpData\nlpcbData data length $lpcbData\n";
#`{
Close the key
https://learn.microsoft.com/en-us/windows/win32/api/winreg/nf-winreg-regclosekey
C++
LSTATUS RegCloseKey(
HKEY hKey # handle to the open key to be closed. See RegOpenKeyExW phkResult
);
}
say "RegCloseKey";
sub RegCloseKey( DWORD ) is native("Kernel32.dll") returns DWORD { * };
$RtnCode = RegCloseKey( $Handle );
say "RegCloseKey RtnCode $RtnCode\n";
return $LUA;
}
Here's what I have so far. I am able to successfully retrieve the handle for the registry key, but when I try to read the key it throws "Native call expected argument that references a native integer, but got P6int". And I don't know why yet. But I figured I post this already, maybe someone else can shed some light.
use NativeCall;
constant BYTE := uint8;
constant WCHAR := uint16;
constant DWORD := int32;
constant REGSAM := int32;
constant WCHARS := CArray[WCHAR];
constant BYTES := CArray[BYTE];
constant HKEY_CURRENT_USER = 0x80000001;
constant HKEY_LOCAL_MACHINE = 0x80000002;
constant KEY_QUERY_VALUE = 1;
constant ERROR_SUCCESS = 0; # Yeah, I know. The Win-Api uses 0 for success and other values to indicate errors
constant REG_SZ = 1;
sub RegOpenKeyExW( DWORD, WCHARS, DWORD, REGSAM, DWORD is rw) is native("Kernel32.dll") returns DWORD { * };
#DWORD RegOpenKeyExW(
# HKEY hKey,
# LPCWSTR lpSubKey,
# DWORD ulOptions,
# REGSAM samDesired,
# PHKEY phkResult
#);
sub RegQueryValueExW( DWORD, WCHARS, DWORD is rw, DWORD is rw, BYTE is rw, DWORD is rw) is native("Kernel32.dll") returns DWORD { * };
#DWORD RegQueryValueExW(
# HKEY hKey,
# LPCWSTR lpValueName,
# LPDWORD lpReserved,
# LPDWORD lpType,
# LPBYTE lpData,
# LPDWORD lpcbData
#);
my $key = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System';
my DWORD $hkey;
my $length = 1024;
if RegOpenKeyExW(HKEY_LOCAL_MACHINE, wstr($key), 0, KEY_QUERY_VALUE, $hkey) == ERROR_SUCCESS
{
say "Got handle: $hkey";
my BYTES $buffer = CArray[BYTE].new( 0 xx 1024 );
# throws "Native call expected argument that references a native integer, but got P6int"
if RegQueryValueExW( $hkey, WCHARS, DWORD, REG_SZ, $buffer, $length ) == ERROR_SUCCESS
{
say "Got data of length $length";
say gather for 0 .. $length { take $buffer[$_] };
}
}
sub wstr( Str $str ) returns WCHARS {
CArray[WCHAR].new( $str.comb.map: *.ord )
}
I am trying to get the UserAgent of the default browser using the ObtainUserAgentString API in Visual Basic 6. I found the documentation on the MSDN and tried to convert it to Visual Basic 6 but it did not work.
C++ (MSDN)
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Visual Basic 6 API
Private Declare Function ObtainUserAgentString Lib "Urlmon.dll" (ByVal dwOption As Long, ByRef pcszUAOut As String, ByRef cbSize As Long) As Long
Private Function BrowserUserAgent() As String
Dim httpUseragent As String
Dim szhttpUserAgent As Long
httpUseragent = Space(512)
szhttpUserAgent = Len(httpUseragent)
Call ObtainUserAgentString(0, httpUseragent, szhttpUserAgent)
BrowserUserAgent = httpUseragent
End Function
Private Sub Command1_Click()
MsgBox BrowserUserAgent
End Sub
Aside from the fact this is a cruddy old ANSI entrypoint, everything you need appears to be documented.
Option Explicit
Private Const NOERROR As Long = 0
Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Enum UAS_OPTIONSENUM
[_UAS_EXACTLEGACY] = &H1000&
UAS_DEFAULT = 0
UAS_7 = 7 'Compatible mode.
UAS_7_LEGACY = 7 Or [_UAS_EXACTLEGACY]
UAS_8 = 8
UAS_9 = 9
UAS_10 = 10
UAS_11 = 11
End Enum
Private Declare Function ObtainUserAgentString Lib "urlmon" ( _
ByVal dwOption As Long, _
ByVal pcszUAOut As Long, _
ByRef cbSize As Long) As Long
Private Function BrowserUserAgent( _
Optional ByVal Options As UAS_OPTIONSENUM = UAS_DEFAULT) As String
Const MAX_BUFFER As Long = 2048
Dim Size As Long
Dim Buffer() As Byte
Dim HRESULT As Long
Do
Size = Size + 128
ReDim Buffer(Size - 1)
HRESULT = ObtainUserAgentString(Options, VarPtr(Buffer(0)), Size)
Loop While HRESULT = E_OUTOFMEMORY And Size < MAX_BUFFER
If HRESULT = NOERROR Then
BrowserUserAgent = StrConv(LeftB$(Buffer, Size - 1), vbUnicode)
Else
Err.Raise &H8004D000, _
, _
"ObtainUserAgentString error &H" & Hex$(HRESULT)
End If
End Function
Private Sub Form_Load()
AutoRedraw = True
Print BrowserUserAgent()
Print BrowserUserAgent(UAS_7)
Print BrowserUserAgent(UAS_7_LEGACY)
Print BrowserUserAgent(UAS_8)
Print BrowserUserAgent(UAS_11)
End Sub
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Param 2 is LongPointerCString. You always pass C strings ByVal which in reality passes the C string part of the B String ByRef. If it was a IN param you would have to end the string with a Chr(0) which is what real C strings have.
String arguments are a special case. Passing a string by value means you are passing the address of the first data byte in the string; passing a string by reference means you are passing the memory address where another address is stored; the second address actually refers to the first data byte of the string. How you determine which approach to use is explained in the topic "Passing Strings to a DLL Procedure" later in this chapter.
From Visual Basic Concepts in Help.
I am trying to open a Registry Key using the RegOpenKeyEx function from the Windows API, and have this code:
#include <windows.h>
#include <iostream>
#include <stdio.h>
#include <stdlib.h>
using namespace std;
int wmain(int argc, wchar_t*argv [])
{
HKEY hKey = HKEY_CURRENT_USER;
LPCTSTR lpSubKey = L"Demo";
DWORD ulOptions = 0;
REGSAM samDesired = KEY_ALL_ACCESS;
HKEY phkResult;
long R = RegOpenKeyEx(hKey, lpSubKey, ulOptions, samDesired, &phkResult);
if (R == ERROR_SUCCESS)
{
cout << "The registry key has been opened." << endl;
}
else //How can I retrieve the standard error message using GetLastError() here?
{
}
}
How do I use the GetLastError() function to show a generic error message instead of valid any Error Message ID into the else?
Edit: I know there is a FormatMessage function but have the same problem, I don't know how to use it on my code.
The Registry functions do not use GetLastError(). They return the actual error codes directly:
long R = RegOpenKeyEx(hKey, lpSubKey, ulOptions, samDesired, &phkResult);
if (R == ERROR_SUCCESS)
{
cout << "The registry key has been created." << endl;
}
else
{
cout << "The registry key has not been created. Error: " << R << endl;
}
If you want to display a system error message, use FormatMessage() for that:
long R = RegOpenKeyEx(hKey, lpSubKey, ulOptions, samDesired, &phkResult);
if (R == ERROR_SUCCESS)
{
cout << "The registry key has been created." << endl;
}
else
{
char *pMsg = NULL;
FormatMessageA(
FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS | FORMAT_MESSAGE_ARGUMENT_ARRAY | FORMAT_MESSAGE_ALLOCATE_BUFFER,
NULL,
R,
0,
(LPSTR)&pMsg,
0,
NULL
);
cout << "The registry key has not been created. Error: (" << R << ") " << pMsg << endl;
LocalFree(pMsg);
}
Try this
HKEY hKey = HKEY_CURRENT_USER;
LPCTSTR lpSubKey = L"Demo";
DWORD ulOptions = 0;
REGSAM samDesired = KEY_ALL_ACCESS;
HKEY phkResult;
char *ErrorMsg= NULL;
long R = RegOpenKeyEx(hKey, lpSubKey, ulOptions, samDesired, &phkResult);
if (R == ERROR_SUCCESS)
{
printf("The registry key has been opened.");
}
else //How can I retrieve the standard error message using GetLastError() here?
{
FormatMessageA(
FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS | FORMAT_MESSAGE_ARGUMENT_ARRAY | FORMAT_MESSAGE_ALLOCATE_BUFFER,
NULL,
R,
0,
(LPSTR)&ErrorMsg,
0,
NULL
);
printf("Error while creating Reg key.");
}
first of all i'm sorry for my english.
I've one question about windows WMI and how to add a local port to shared printer. I've this script:
Set objWMIService = GetObject("winmgmts:")
Set objNewPort = objWMIService.Get _
("Win32_TCPIPPrinterPort").SpawnInstance_
objNewPort.Name = "Ricoh3300C"
objNewPort.Protocol = 2
objNewPort.HostAddress = "XXX.XXX.X.XXX"
objNewPort.PortNumber = "9100"
objNewPort.SNMPEnabled = False
objNewPort.Put_
With this i can add a printer with IP address but i want to add a printer in samba server with an address like "\\XXX.XXX.X.XXX\printerColor". I've lost a lot of time in google trying to find an script and all that i've seen is for TCPIP ports. I wan't to do it but in local port.
I've tried to use this script with prnadmin.dll and no luck.
function PortAdd(strPort, portType)
on error resume next
dim oMaster
dim oPort
dim iResult
set oMaster = CreateObject("PrintMaster.PrintMaster.1")
set oPort = CreateObject("Port.Port.1")
iResult = kErrorFailure
oPort.PortName = strPort
oPort.PortType = portType
oMaster.PortAdd oPort
if Err = 0 then
iResult = kErrorSuccess
else
wscript.echo "Error: 0x" & Hex(Err.Number) & ". " & Err.Description
end if
PortAdd = iResult
end function
I get this error:
Error: 0x1A8. Se requiere un objeto
in english is like
Error: 0x1A8. An object is required
How can i fix that error or what script can i use to add a local port?. Thanks in advance.
I forgot to say that i want to do it with normal user without admin access. The first script works fine in that users but is for TCPIP.
Consider using XcvData, e.g.
private static void AddPort(string portName)
{
var def = new PRINTER_DEFAULTS();
def.pDatatype = null;
def.pDevMode = IntPtr.Zero;
def.DesiredAccess = 1; //Server Access Administrator
IntPtr hPrinter = IntPtr.Zero;
int n = OpenPrinter(",XcvMonitor Local Port", ref hPrinter, def);
if (n == 0)
throw new Exception("Local Port monitor has not been opened.");
if (!portName.EndsWith("\0"))
portName += "\0";
// .NET strings are formed by 2-byte characters
var size = (uint) (portName.Length*2);
IntPtr portPtr = Marshal.AllocHGlobal((int) size);
Marshal.Copy(portName.ToCharArray(), 0, portPtr, portName.Length);
uint needed, xcvResult;
XcvData(hPrinter, "AddPort", portPtr, size, IntPtr.Zero, 0, out needed, out xcvResult);
ClosePrinter(hPrinter);
Marshal.FreeHGlobal(portPtr);
}
[DllImport("winspool.drv", EntryPoint = "XcvDataW", SetLastError = true)]
private static extern bool XcvData(
IntPtr hXcv,
[MarshalAs(UnmanagedType.LPWStr)] string pszDataName,
IntPtr pInputData,
uint cbInputData,
IntPtr pOutputData,
uint cbOutputData,
out uint pcbOutputNeeded,
out uint pwdStatus);
I'm trying to shutdown Windows programmatically:
Function ExitWindows() As Integer
Declare Function GetCurrentProcess Lib "Kernel32" () As Integer
Declare Function OpenProcessToken Lib "AdvApi32" (handle As Integer, access As Integer, ByRef tHandle As Integer) As Boolean
Declare Function LookupPrivilegeValueW Lib "AdvApi32" (sysName As Ptr, privName As WString, Luid As Ptr) As Boolean
Declare Function AdjustTokenPrivileges Lib "AdvApi32" (tHandle As Integer, disableAllPrivs As Boolean, newState As Ptr, buffLength As Integer, prevPrivs As Ptr, ByRef retLen As Integer) As Boolean
Declare Function ExitWindowsEx Lib "User32" (flags As Integer, reason As Integer) As Boolean
Declare Function GetLastError Lib "Kernel32" () As Integer
Const SE_PRIVILEGE_ENABLED = &h00000002
Const TOKEN_QUERY = &h00000008
Const TOKEN_ADJUST_PRIVILEGES = &h00000020
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const EWX_SHUTDOWN = &h00000001
Dim pHandle As Integer = GetCurrentProcess() //a handle to the current process
Dim tHandle As Integer //a handle to the token
If OpenProcessToken(pHandle, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, tHandle) Then
Dim mb As New MemoryBlock(8)
mb.UInt32Value(0) = 1
mb.Int32Value(4) = SE_PRIVILEGE_ENABLED
Dim pt As Ptr
If LookupPrivilegeValueW(Nil, "SeShutdownPrivilege", mb) Then
Dim z As Integer
If AdjustTokenPrivileges(tHandle, False, mb, mb.Size, pt, z) Then
If Not ExitWindowsEx(EWX_SHUTDOWN, 0) Then
Return GetLastError() //Returns 1314
End If
Else
Return GetLastError()
End If
Else
Return GetLastError()
End If
Else
Return GetLastError()
End If
End Function
Each function call succeeds except for ExitWindowsEx, which invariably will fail with error code 1314 (Privilege not held) even when running as Admin. Reboot has the same problem but Logoff works.
What am I doing wrong here?
You are calling LookupPrivilegeValueW with a wrong mb and passing a wrong mb to AdjustTokenPrivileges.
Dim luid As New MemoryBlock(8)
If LookupPrivilegeValueW(Nil, "SeShutdownPrivilege", luid) Then
Dim mb As New MemoryBlock(16)
mb.UInt32Value(0) = 1
mb.UInt32Value(4) = luid.UInt32Value(0)
mb.UInt32Value(8) = luid.UInt32Value(4)
mb.UInt32Value(12) = SE_PRIVILEGE_ENABLED
Dim z As Integer
If AdjustTokenPrivileges(tHandle, False, mb, mb.Size, pt, z) Then