DLLCalls using VBScripts Possible

[ptrex]

DLLCalls using VBScripts

Out if the box it is not possible to do DllCalls from VBScripts. But thanks to the +20 year COM Library called DynaWrap this is still possible

Anyhow the process of calling Win API functions need some basic knowledge and understanding on how to do this. 

More specifically the input Data Types parameters used and Calling Formats are key here, as well as the Return Data Types

 

DynaWrap COM Library

Keep in mind that this COM Library is a 32Bit only library. Which means that you need to register is using the SysWOW64 regsvr32

But to overcome this annoyance I created RegFree method so you can start using it as a portable COM Library

 

DynaWrap Documentation

I created a PDF documention on what I still could find on the internet on how to use the COM Library.

 

Examples

The second post will hold some VBScript Examples and an AutoIt Example

 

Attached

You will find the PDF and the ZIP File needed to run your code in a portable way.

Thanks to the @Professor_Bernd to provide the VBScript code to get the VBScript scripting directory and the Shortcut to run the 32Bit SysWOW64 VBScript host

Just drop the VBScript on the 32Bit Shortcut to get going.

 

Source Code

Anyhow here you can find the source code of the DynaWrap 32Bit Library.

If someone has the C++ Tools to convert it to 64Bit Library that would give a new live to it...

http://www.borncity.com/web/WSHBazaar1/WSHDynaCall.htm

Interesting reading :

https://www.drdobbs.com/windows/an-automation-object-for-dynamic-dll-cal/210200078

DynaCall.zip How to use DllCalls in VBScript using DynaWrap COM Object.pdf

Edited January 16, 2021 by ptrex

[ptrex]

Examples :

MessageBox ANSI and UNICODE

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Dim obj
Set obj = oActCtx.CreateObject("DynamicWrapper")

Msgbox "You are calling RegFree Windows API's from VBScript !" 

' call MessageBoxA(), first register the API function
obj.register "USER32.DLL", "MessageBoxA", "I=HsSu", "f=s", "R=l"

' call the MessageBoxA
Dim val
val = obj.MessageBoxA (Null, "MessageBox (ANSI)", "VBS Next Level From DynaWrap Object", 3)

' call MessageBoxW
obj.Register "USER32.DLL", "MessageBoxW", "I=Hwwu", "f=S", "R=l"
val = obj.MessageBoxW(Null, "MessageBox (UNICODE)", "From DynaWrap Object", 3)


Set obj = Nothing
Set oActCtx = Nothing

Screen Dimensions : Height and Width

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Dim obj
Set obj = oActCtx.CreateObject("DynamicWrapper")

Msgbox "You are calling RegFree Windows API's from VBScript !" 

' Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
obj.register "USER32.DLL", "GetSystemMetrics", "I=l", "f=s", "R=l"

Private Const SM_CXSCREEN = 0 'Screen width
Private Const SM_CYSCREEN = 1 'Screen height

Dim ScreenWidth, ScreenHeight 

'The width of the screen, in pixels
' Public Function ScreenWidth() As Long
ScreenWidth = obj.GetSystemMetrics(SM_CXSCREEN)
msgbox "ScreenWidth : " & ScreenWidth 

'The height of the screen, in pixels
'Public Function ScreenHeight() As Long
ScreenHeight = obj.GetSystemMetrics(SM_CYSCREEN)
msgbox "ScreenHeight : " & ScreenHeight 

GetForegroundWindow

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Dim  Dw, GetForegroundWindow
Set  Dw = oActCtx.CreateObject ( "DynamicWrapper" ) 
Dw.Register "User32.Dll", "GetForegroundWindow", "F=S" , "R=H" 
GetForegroundWindow = Dw.GetForegroundWindow() 

msgbox = " & GetForegroundWindow

Capture KeyPressed

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Public Const VK_UP = &H26
Public Const VK_DOWN = &H28
Public Const VK_LEFT = &H25
Public Const VK_RIGHT = &H27
Public Const VK_DELETE = &H2E

Dim oDyn, ExcelApp
Set oDyn = oActCtx.CreateObject("DynamicWrapper")
oDyn.Register "User32.dll", "GetAsyncKeyState", "i=l", "r=t"

Set ExcelApp = WScript.CreateObject("EXCEL.application")
ExcelApp.Visible = True
ExcelApp.workbooks.Add
ExcelApp.sheets(1).Activate
ExcelApp.DataEntryMode = True

WScript.Echo "Start : Press UP / DOWN / LEFT / RIGHT or" & vbCr & "DELETE button to stop"

Dim continue
continue = True

While (continue)
    If (oDyn.GetAsyncKeyState(VK_UP) <> 0) Then
        WScript.Echo "UP"
    End If
    If (oDyn.GetAsyncKeyState(VK_DOWN) <> 0) Then
        WScript.Echo "DOWN"
    End If
    If (oDyn.GetAsyncKeyState(VK_LEFT) <> 0) Then
        WScript.Echo "LEFT"
    End If
    If (oDyn.GetAsyncKeyState(VK_RIGHT) <> 0) Then
        WScript.Echo "RIGHT"
    End If
    If (oDyn.GetAsyncKeyState(VK_DELETE) <> 0) Then
        continue = False
    End If
    WScript.Sleep(50)
Wend

ExcelApp.DisplayAlerts = False
ExcelApp.Quit
ExcelApp.DisplayAlerts = True

Set ExcelApp = Nothing

Set oActCtx = Nothing
Set oDyn = Nothing

Clipboard Example

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Dim a, b, c, data
Set a = oActCtx.CreateObject("DynamicWrapper")

data = "Data that was placed in your clipboard !!"

a.register "kernel32.dll", "GlobalAlloc", "i=uu", "f=s", "r=l"
a.register "kernel32.dll", "GlobalLock", "i=l", "f=s", "r=l"
a.register "kernel32.dll", "lstrcpy", "i=hs", "f=s", "r=h"
a.register "user32.dll", "OpenClipboard", "i=h", "f=s", "r=l"
a.register "user32.dll", "EmptyClipboard", "f=s", "r=l"
a.register "user32.dll", "SetClipboardData", "i=uh", "f=s", "r=l"
a.register "user32.dll", "CloseClipboard", "f=s", "r=l"
b = a.lstrcpy(a.GlobalLock(a.GlobalAlloc(0, cint(len(data)+1))), cstr(data))

c = a.OpenClipboard(0)
c = a.EmptyClipboard()
c = a.SetClipboardData(1, b)
c = a.CloseClipboard()

Msgbox "Data that is placed in your clipboard !!"

set a = nothing
set b = nothing
set c = nothing

UpTime Example

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Dim Dw, iTicks

Set  Dw = oActCtx.CreateObject ( "DynamicWrapper" ) 
Dw.Register "kernel32.dll", "GetTickCount", "f=s" , "r=l" 

iTicks = Dw.GetTickCount

msgbox "GetTickCount : " & iTicks

Dim iDays, iHours, iMins, iSecs

iTicks = iTicks / 1000
iDays  = CInt(iTicks / 86400)
iHours = CInt(iTicks / 3600)
iTicks = iTicks Mod 3600
iMins = CInt(iTicks / 60)
iSecs = iTicks Mod 60

Msgbox "PC UpTime : " & vbCrLf & vbCrLf & _
       "Days " & iDays & " Hours " & iHours & " Min. " & iMins & " Sec. " & iSecs

 

Get Window Title

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

' demo script to illustrate using "GetActiveWindowText", jw 07Mar01
' https://microsoft.public.scripting.vbscript.narkive.com/OseMULX0/dynamicwrapper-string-by-reference

' instante ActX components here (to assure DynaWrap is available)...
Dim oDW : Set oDW = oActCtx.CreateObject ("DynamicWrapper")  ' no events
Dim oSH : Set oSH = WScript.CreateObject("WScript.Shell")
'
Dim hActWin, nRtn ' as long
Dim sWinCaption ' as string
Const MAX_PATH = 260

' --- end of declarations and constants ----------

' ================================================
' === MAIN LINE SCRIPT LOGIC =====================
' ================================================

' allocate space for the return string...
sWinCaption = String(MAX_PATH, vbNullChar)

oSH.Run "notepad.exe"

' wait for notepad to load...
' (using AppActivate's undocumented feature, re: returns t/f)...
Do : WScript.Sleep 100
Loop Until oSH.AppActivate("Notepad")

hActWin = GetActiveWindow()
BugAssert (hActWin <> 0), "no window activated at this time, sorry."

nRtn = GetWindowText(hActWin, sWinCaption, MAX_PATH)
MsgBox(sWinCaption)

oSH.SendKeys "%{F4}" ' alt-F4 (to close window)

Set oDW = nothing ' clean up
Set oSH = nothing
WScript.Quit

Function GetActiveWindow()
Set oDW = nothing ' clear any previous instance
Set oDW = oActCtx.CreateObject ("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
' (note: no parameters, so LEAVE OUT "i=" argument)...
oDW.Register "USER32.DLL", "GetActiveWindow", "f=s", "r=h"
GetActiveWindow = oDW.GetActiveWindow()
End Function

Function GetWindowText(hWnd, lpString, cch)
Set oDW = nothing ' clear any previous instance
Set oDW = oActCtx.CreateObject ("DynamicWrapper") ' start over...
' register (declare) this flavor of api call...
' (note: string passed byref to allow for proper return address)...
oDW.Register "USER32.DLL", "GetWindowTextA", "i=lrl", "f=s", "r=h"
GetWindowText = oDW.GetWindowTextA(hWnd, lpString, cch)
End Function


' --- BUGASSERT (yes, it's for debugging) --------
Sub BugAssert (bTest, sErrMsg)

' BugAssert is a Bruce McKinney creation.
' It is used to test for intermediate results...
if bTest then Exit Sub
MsgBox "Error Detected by BugAssert: " & vbCr & vbCr & sErrMsg, _
vbCritical, " << BugAssert FAILED >> "
WScript.Quit

End Sub

 

 

Edited January 26, 2021 by ptrex

[ptrex]

Examples :

Compare AutoIt DLLCall to DynaWrap : Sinus

#AutoIt3Wrapper_UseX64=N

Local $iVal = 1/2

; AutoIT DllCall Example
Local $ret = DllCall("msvcrt.dll", "double:cdecl", "sin", "double", $iVal)
MsgBox(0, "AutoIT DllCall", "Sinus : " &$ret[0] & @CRLF)

Calling DynaWrap from AutoIt using the VBScript Object give the same result 🙂

expandcollapse popup

#AutoIt3Wrapper_UseX64=N

; Initialize COM error handler
$oMyError = ObjEvent("AutoIt.Error","MyErrFunc")

Local $iVal = 1/2

; DynWrap Example (RegFree)
Local $oActCtx = ObjCreate("Microsoft.Windows.ActCtx")
$oActCtx.manifest = @ScriptDir & "\dynwrap.sxs.manifest"

$UserWrap = $oActCtx.CreateObject("DynamicWrapper")

Local $oActCtx = ObjCreate("Microsoft.Windows.ActCtx")
$oActCtx.manifest = @ScriptDir & "\dynwrap.sxs.manifest"

$UserWrap.Register("MSVCRT.DLL", "sin", "f=mc8", "i=d", "r=d")
$ret = $UserWrap.sin($iVal)
MsgBox(0, "DynWrap (RegFree)", "Sinus : " &$ret & @CRLF)

; VbScript Example (RegFree)
Local $Code = 'Option Explicit'
$code=$code & @CRLF & ''
$code=$code & @CRLF & 'Dim oActCtx'
$code=$code & @CRLF & 'Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")'
$code=$code & @CRLF & 'oActCtx.manifest = "dynwrap.sxs.manifest"'
$code=$code & @CRLF & ''
$code=$code & @CRLF & 'Dim UserWrap'
$code=$code & @CRLF & 'Set UserWrap = oActCtx.CreateObject("DynamicWrapper")'
$code=$code & @CRLF & ''
$code=$code & @CRLF & 'Dim ret, val'
$code=$code & @CRLF & 'val = 1/2'
$code=$code & @CRLF & ''
$code=$code & @CRLF & 'UserWrap.Register "MSVCRT.DLL", "sin", "f=mc8", "i=d", "r=d"'
$code=$code & @CRLF & 'ret = UserWrap.sin(val)'
$code=$code & @CRLF & 'msgbox "VBScript sin : " & ret'
$code=$code & @CRLF & 'UserWrap.Register "MSVCRT.DLL", "cos", "f=mc8", "i=d", "r=d"'
$code=$code & @CRLF & 'ret = UserWrap.cos(val)'
$code=$code & @CRLF & 'msgbox "VBScript cos : " & ret'
$code=$code & @CRLF & 'UserWrap.Register "MSVCRT.DLL", "sinh", "f=mc8", "i=d", "r=d"'
$code=$code & @CRLF & 'ret = UserWrap.sinh(val)'
$code=$code & @CRLF & 'msgbox "VBScript sinh : " & ret'
$code=$code & @CRLF & 'UserWrap.Register "MSVCRT.DLL", "cosh", "f=mc8", "i=d", "r=d"'
$code=$code & @CRLF & 'ret = UserWrap.cosh(val)'
$code=$code & @CRLF & 'msgbox "VBScript cosh : " & ret'

Local $vbs = ObjCreate("ScriptControl")
$vbs.language="vbscript"
$vbs.addcode($code)

Func MyErrFunc()
  $HexNumber=hex($oMyError.number,8)
  Msgbox(0,"COM Test","We intercepted a COM Error !"       & @CRLF  & @CRLF & _
             "err.description is: "    & @TAB & $oMyError.description    & @CRLF & _
             "err.windescription:"     & @TAB & $oMyError.windescription & @CRLF & _
             "err.number is: "         & @TAB & $HexNumber              & @CRLF & _
             "err.lastdllerror is: "   & @TAB & $oMyError.lastdllerror   & @CRLF & _
             "err.scriptline is: "     & @TAB & $oMyError.scriptline     & @CRLF & _
             "err.source is: "         & @TAB & $oMyError.source         & @CRLF & _
             "err.helpfile is: "       & @TAB & $oMyError.helpfile       & @CRLF & _
             "err.helpcontext is: "    & @TAB & $oMyError.helpcontext _
            )
  SetError(1)   ; to check for after this function returns
Endfunc

 

Edited January 16, 2021 by ptrex

[Professor_Bernd]

54 minutes ago, ptrex said:

; VbScript Example (Refgree)

Could you please be so kind as to format the VBScript examples in the second post as code? (There is a VBScript highlighter.) That would make it easier to read. 

-----------------------------------------

Hello ptrex.

I think it's amazing what you can do with a little brain power! What you share with us is impressive! Great work! 👍

I want to finish my current sub-project first before I delve deeper into the topic here. That should work out by next month, hopefully I'll have more time then.

Thanks for your work, the examples, and the documentation! 👍 (I skimmed through it all briefly).

[ptrex]

Thanks !

Not sure how to use the VBScript highlighter ?

[Nine]

When you open code tag, look at bottom right, there a drop down ...

[Professor_Bernd]

 

 

Edit: Nine was faster!

Edited January 16, 2021 by Professor_Bernd

[ptrex]

Changed it to vbscript code tags ... don't see much difference though ... anyhow if this make you happy ...

[Professor_Bernd]

5 minutes ago, ptrex said:

Changed it to vbscript code tags ... don't see much difference though

That's weird! For me it looks like this:

This is a test!

Capture KeyPressed

Option Explicit

' USE 32Bit SysWOW64 script host !!!

Dim fso, objShell, ScriptPath, ScriptDir

ScriptPath = WScript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptDir = fso.GetParentFolderName(ScriptPath)

Set objShell = CreateObject("Wscript.Shell")
' Msgbox objShell.CurrentDirectory      ' show WorkingDirectory
objShell.CurrentDirectory = ScriptDir ' set WorkingDirectory

Dim oActCtx
Set oActCtx = CreateObject("Microsoft.Windows.ActCtx")
oActCtx.manifest = "dynwrap.sxs.manifest"

Public Const VK_UP = &H26
Public Const VK_DOWN = &H28
Public Const VK_LEFT = &H25
Public Const VK_RIGHT = &H27
Public Const VK_DELETE = &H2E

Dim oDyn, ExcelApp
Set oDyn = oActCtx.CreateObject("DynamicWrapper")
oDyn.Register "User32.dll", "GetAsyncKeyState", "i=l", "r=t"

Set ExcelApp = WScript.CreateObject("EXCEL.application")
ExcelApp.Visible = True
ExcelApp.workbooks.Add
ExcelApp.sheets(1).Activate
ExcelApp.DataEntryMode = True

WScript.Echo "Start : Press UP / DOWN / LEFT / RIGHT or" & vbCr & "DELETE button to stop"

Dim continue
continue = True

While (continue)
    If (oDyn.GetAsyncKeyState(VK_UP) <> 0) Then
        WScript.Echo "UP"
    End If
    If (oDyn.GetAsyncKeyState(VK_DOWN) <> 0) Then
        WScript.Echo "DOWN"
    End If
    If (oDyn.GetAsyncKeyState(VK_LEFT) <> 0) Then
        WScript.Echo "LEFT"
    End If
    If (oDyn.GetAsyncKeyState(VK_RIGHT) <> 0) Then
        WScript.Echo "RIGHT"
    End If
    If (oDyn.GetAsyncKeyState(VK_DELETE) <> 0) Then
        continue = False
    End If
    WScript.Sleep(50)
Wend

ExcelApp.DisplayAlerts = False
ExcelApp.Quit
ExcelApp.DisplayAlerts = True

Set ExcelApp = Nothing

Set oActCtx = Nothing
Set oDyn = Nothing

 

[Professor_Bernd]

That's doubly weird!  First it was with colored highlighting, then I refreshed the page and the color was gone!  And I can't expand the code window.

 

[ptrex]

updated first post with a "Get Window Title"  Example

Found on the internet and reworked into a RegFree version.

Enjoy !