VB6 StrPtr Function to VB.NET - 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

Related

VBA Code using Windows API for colorising Textbox selection

Hello VBA & Windows API experts ! I have the following code which is supposed to set the color of the current selected text in a rich text Textbox, but it works only partially. For example, it puts the whole text in Blue instead of just the selection. Can anyone spot where the problem can be ? I am using VBA 7 - 64 bits - Windows 10
Form module
Private Sub cmdButton_Click() 'Selected Text in Blue
Dim lngHandle As Long
lngHandle = fhWnd(Me.txtITMrichtxt)
RTBSetTextColor lngHandle, vbBlue
End Sub
Code Module
Option explicit
Public Enum ATTDEFINI
ATTUNDEF = -3
ATTDEFAULT = -2
End Enum
Private Type CHARFORMAT2
cbSize As Long
dwMask As Long
dwEffects As Long
yHeight As Long
yOffset As Long
crTextColor As OLE_COLOR
bCharSet As Byte
bPitchAndFamily As Byte
szFaceName As String * LF_FACESIZE
wWeight As Integer
sSpacing As Integer
crBackColor As OLE_COLOR
lcid As Long
dwReserved As Long
sStyle As Integer
wKerning As Integer
bUnderLineType As Byte
bAnimation As Byte
bRevAuthor As Byte
bReserved1 As Byte
End Type
Public Enum RTBC_FLAGS 'CharFormat (SCF_) flags for EM_SETCHARFORMAT message.
RTBC_DEFAULT = 0
RTBC_SELECTION = 1
RTBC_WORD = 2 'Combine with RTBC_SELECTION!
RTBC_ALL = 4
End Enum
Private Const WM_USER As Long = &H400
Private Const EM_SETCHARFORMAT = WM_USER + 68
Private Const CFM_COLOR As Long = &H40000000 '<-> Membre de la structure CHARFORMAT2 ou Attribut de dwEffects
Private Const CFE_AUTOCOLOR = CFM_COLOR
Declare PtrSafe Function apiGetFocus Lib "user32" Alias "GetFocus" () As LongPtr
Declare PtrSafe Function SendMessageWLng Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As Any) As LongPtr
Function fhWnd(iaControl As Control) As LongPtr
On Error Resume Next
iaControl.SetFocus
If Err Then
fhWnd = 0
Else
fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function
Public Sub RTBSetTextColor(ByVal ilngHWND As LongPtr, Optional ByVal ilngTextColor As OLE_COLOR = -1, _
Optional ByVal Scope As RTBC_FLAGS = RTBC_SELECTION)
Dim cf2Colors As CHARFORMAT2
With cf2Colors
.cbSize = LenB(cf2Colors)
.dwMask = CFM_COLOR
If ilngTextColor = ATTDEFAULT Then
.dwEffects = CFE_AUTOCOLOR
Else
.dwEffects = 0
.crTextColor = ilngTextColor
End If
End With
SendMessageWLng ilngHWND, EM_SETCHARFORMAT, Scope, VarPtr(cf2Colors)
End Sub

How do I convert a VARIANT to a managed object?

This is the source of the original VBA code: Original VBA code
Im converting these functions to VB.Net
FilePropertyExplorer
Class_Initialize
Heres the code I have thus far (note I removed some lines for brevity)
Imports System.Runtime.InteropServices
Public Class VirtualCOMObject
Private Const OPTION_BASE As Long = 0
Private Const OPTION_FLAGS As Long = 2
Private Const OPTION_INCLUDE_REFERENCEDOCS As Long = 0
Private Const OPTION_DISABLEDCLASSES As String = ""
Private Const DECOMPRESSED_EXT As Long = 56493
Private Const SIZEOF_PTR32 As Long = &H4
Private Const SIZEOF_PTR64 As Long = &H8
Private Const PAGE_EXECUTE_RW As Long = &H40
Private Const MEM_RESERVE_AND_COMMIT As Long = &H3000
Private Const ERR_OUT_OF_MEMORY As Long = &H7
Private m_ClassFactory As Object
<DllImport("kernel32.dll", CharSet:=CharSet.None, ExactSpelling:=False, SetLastError:=True)>
Private Shared Function VirtualAlloc(
ByVal lpAddress As IntPtr,
ByVal dwSize As UIntPtr,
ByVal flAllocationType As AllocationType,
ByVal flProtect As MemoryProtection) As IntPtr
End Function
<DllImport("kernel32.dll", CharSet:=CharSet.Auto, SetLastError:=True)>
Public Shared Function GetModuleHandleA(ByVal lpModuleName As String) As IntPtr
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True)>
Public Shared Function GetProcAddress(ByVal hModule As IntPtr, ByVal procName As String) As IntPtr
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
Public Shared Sub CopyMemoryAnsi(ByVal Dest As IntPtr, ByVal Source As String, ByVal Size As IntPtr)
End Sub
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
Public Shared Sub CastToObject(ByRef Dest As Object, ByRef Source As IntPtr, ByVal Size As IntPtr)
End Sub
Declare Sub CopyMemoryByref Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Integer, ByRef source As Integer, ByVal numBytes As Integer)
<Flags>
Public Enum AllocationType As UInteger
COMMIT = 4096
RESERVE = 8192
RESET = 524288
TOP_DOWN = 1048576
WRITE_WATCH = 2097152
PHYSICAL = 4194304
LARGE_PAGES = 536870912
End Enum
<Flags>
Public Enum MemoryProtection As UInteger
NOACCESS = 1
[READONLY] = 2
READWRITE = 4
WRITECOPY = 8
EXECUTE = 16
EXECUTE_READ = 32
EXECUTE_READWRITE = 64
EXECUTE_WRITECOPY = 128
GUARD_Modifierflag = 256
NOCACHE_Modifierflag = 512
WRITECOMBINE_Modifierflag = 1024
End Enum
Public Sub Class_Initialize()
Dim NativeCode As String
Dim LoaderVTable As IDispatchVTable
Dim Ignore As Boolean
Dim ClassFactoryLoader As Object
#If VBA7 = False Then
Dim Kernel32Handle As Long
Dim GetProcAddressPtr As Long
Dim NativeCodeAddr As Long
Dim LoaderVTablePtr As Long
Dim LoaderObj As Long
#Else
Dim Kernel32Handle As LongPtr
Dim GetProcAddressPtr As LongPtr
Dim NativeCodeAddr As LongPtr
Dim LoaderVTablePtr As LongPtr
Dim LoaderObj As LongPtr
#End If
'#If Win64 = False Then
' Const SIZEOF_PTR = SIZEOF_PTR32
'#Else
Const SIZEOF_PTR = SIZEOF_PTR64
'#End If
'NativeCode string initialized here
NativeCode = NativeCode & "%EEEE%::::RPZPPPh$#$$j PPPPH+T$ t5AYAZkDTX 5j7{{L3TQ#M3LR#A)DR#Xf5##fA)AUXI3DR#ZZZZZZ?!, #RY3LDl3TA#PY,VH)DJ#XXXXXXXXXX%EEEE%::::VSPPPPj PPPPPPPP4T)D$04P)D$,4 '4 )D$($ PZ3D$#+D$ YQ3H +L$ XP3Q +T$0XPf55nf)BUR[YQ^VXP2Cf<0tF1+++
'==========================================================================
'Code removed for brevity. The full string can be found on the links above
'==========================================================================
ij DdEXXZPEdkHOqrLSKGZT;pOCUHvFst;z??qapyyZtzrUuhX_;hnJmp;n;kGQF^AF oqvSDDS\^;TufXPumRLDVQSzCbT]x]keCb?fWgTwFvTwEj0"
ClassFactoryLoader = New Object()
' Allocate the executable memory for the object
NativeCodeAddr = VirtualAlloc(0, Len(NativeCode) + DECOMPRESSED_EXT, MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
If NativeCodeAddr <> 0 Then
' Copy the x86 and x64 native code into the allocated memory
Call CopyMemoryAnsi(NativeCodeAddr, NativeCode, Len(NativeCode))
' Force the memory address into an Object variable (also triggers the shell code)
LoaderVTable.QueryInterface = NativeCodeAddr 'longptr
LoaderVTablePtr = VarPtr(LoaderVTable) 'ptr to LoaderVTable(IDispatchVTable structure)
LoaderObj = VarPtr(LoaderVTablePtr)
'==========================================================================
'ERROR: Managed Debugging Assistant 'InvalidVariant' : 'An invalid VARIANT was detected during a conversion from an unmanaged VARIANT to a managed object. Passing invalid VARIANTs to the CLR can cause unexpected exceptions, corruption or data loss.'
'==========================================================================
Call CastToObject(ClassFactoryLoader, LoaderObj, SIZEOF_PTR) 'CastToObject=RtlMoveMemory
Ignore = TypeOf ClassFactoryLoader Is VBA.Collection 'ClassFactoryLoader(object type)
m_ClassFactory = (ClassFactoryLoader) 'object
' Initialize our COM object
Kernel32Handle = GetModuleHandleA("kernel32")
GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")
'With m_ClassFactory
' Call .Init(Kernel32Handle, GetProcAddressPtr, OPTION_BASE + OPTION_FLAGS, NativeCode, New FilePropertyExplorer_Helper)
' Ignore = TypeOf .FileProperties Is FileProperties And TypeOf .FileProperty Is FileProperty
'End With
Else
Err.Raise(ERR_OUT_OF_MEMORY)
End If
End Sub
Function OpenFile(ByVal FilePath As String, Optional ByVal WriteSupport As Boolean = False) As FileProperties
OpenFile = m_ClassFactory.OpenFile(FilePath, WriteSupport)
End Function
End Class
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi, Pack:=1)>
Public Structure IDispatchVTable
Public QueryInterface As IntPtr
Public AddRef As IntPtr
Public Release As IntPtr
Public GetTypeInfoCount As IntPtr
Public GetTypeInfo As IntPtr
Public GetIDsOfNames As IntPtr
Public Invoke As IntPtr
End Structure
VarToPtr . Im unsure of this code. Found it on the internet and slightly modified it
Module VarPtrSupport
' a delegate that can point to the VarPtrCallback method
Private Delegate Function VarPtrCallbackDelegate(
ByVal address As Integer, ByVal unused1 As Integer,
ByVal unused2 As Integer, ByVal unused3 As Integer) As Integer
' two aliases for the CallWindowProcA Windows API method
' notice that 2nd argument is passed by-reference
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Short,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Integer,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
' ...add more overload to support other data types...
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IDispatchVTable,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Long,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IntPtr,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
' the method that is indirectly executed when calling CallVarPtrSupport
' notice that 1st argument is declared by-value (this is the
' argument that receives the 2nd value passed to CallVarPtrSupport)
Private Function VarPtrCallback(ByVal address As Integer,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Return address
End Function
' two overloads of VarPtr
Public Function VarPtr(ByRef var As Short) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As Integer) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As IDispatchVTable) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As Long) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As IntPtr) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
' ...add more overload to support other data types...
End Module
Now I currently get the error (I placed a comment in the code):
ERROR: Managed Debugging Assistant 'InvalidVariant' : 'An invalid VARIANT was detected during a conversion from an unmanaged VARIANT to a managed object. Passing invalid VARIANTs to the CLR can cause unexpected exceptions, corruption or data loss.'
But overall... Im actually unsure if Im even on the right track in properly converting the VBA code as Im having to do it without for example excel installed to test the VBA out on.
The code essentially creates a dynamic COM object which will then be used to fetch extended file properties.
If someone could perhaps tell me what Im doing wrong it will be appreciated. Also the code needs to be in .Net and not import any VBA/VB dll's.
In reference to #Jimi's comment, I have created a couple of vba functions for you.
Here is the vba Code which you can just paste into an excel "ThisWorkbook" object.
It will create a text file name "ExtendedProperties.txt" in the same directory as the file that is passed to it.
Sub GetExtendedProperties(strInFullFilePath)
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim strPath As String
Dim strFldr As String
Dim vntInfo As Variant
Dim intI As Integer
Dim strName As String
Dim strTemp As String
Dim fso As Object
Dim strOut As String
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strPath = fso.GetAbsolutePathName(strInFullFilePath)
strFldr = fso.GetParentFolderName(strPath)
strName = fso.GetFileName(strPath)
strOut = strFldr & "\ExtendedProperties.txt"
Set ts = fso.CreateTextFile(strOut, True)
Set objShell = CreateObject("shell.application")
If (Not (objShell Is Nothing)) Then
Set objFolder = objShell.Namespace(CStr(strFldr))
If (Not (objFolder Is Nothing)) Then
Set objFolderItem = objFolder.ParseName(CStr(strName))
If (Not (objFolderItem Is Nothing)) Then
For intI = 0 To 321
If intI <> 31 Then
vntInfo = objFolder.GetDetailsOf(Nothing, intI)
strTemp = CStr(vntInfo)
If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
If IsNull(strTemp) = False Then
ts.WriteLine "File Detail Attribute: " & CheckString(strTemp)
Else
ts.WriteLine "File Detail Attribute: NULL"
End If
vntInfo = objFolder.GetDetailsOf(objFolderItem, intI)
strTemp = CStr(vntInfo)
If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
If IsNull(strTemp) = False Then
ts.WriteLine "Value: """ & CheckString(strTemp) & """"
Else
ts.WriteLine "Value: NULL"
End If
End If
Next intI
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
End If
ts.Close
Set ts = Nothing
Set objShell = Nothing
End Sub
Private Function CheckString(strInString As String) As String
Dim strOut As String
Dim strTemp As String
Dim blnValid As Boolean
Dim intI As Integer
Dim intJ As Integer
Dim strChar As String
Dim bytChars() As Byte
'This Function is used to check the string to see if there are any problem
' characters in the string (as there are at intI=31 in the above function).
strTemp = strInString
strOut = ""
For intI = 1 To Len(strTemp)
strChar = Mid(strTemp, intI, 1)
If (AscW(strChar) = 32) Or (AscW(strChar) >= 48) And (AscW(strChar) <= 57) Or _
(AscW(strChar) >= 65) And (AscW(strChar) <= 90) Or _
(AscW(strChar) >= 97) And (AscW(strChar) <= 122) Then
strOut = strOut & strChar
End If
Next intI
CheckString = strOut
End Function

Excel VBA printer API, set colour and duplex

here's my problem.
I am trying to access the printer and change the colour and duplex settings. So far the code I have allows me to change the user preferences of the networked printer. But I have the following two problems below.
1) The codes set's the printer to either simplex or duplex as intended, however is does not set the colour preference correctly!
2) Excel is not automatically picking up the new settings, I still have to go in and manually click the reset button for the new changes to take affect.
Here is the code I am using:
Private Type PRINTER_INFO_9
pDevmode As Long ' Pointer to DEVMODE
End Type
Private Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As Any) As Long
Private Declare Function GetPrinter 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 SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal Command As Long) As Long
Private Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode 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" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Const DM_IN_BUFFER = 8
Private Const DM_OUT_BUFFER = 2
Private Sub CommandButton1_Click()
Dim sPrinterName As String
Dim my_printer_address As String
Dim hPrinter As Long
Dim Pinfo9 As PRINTER_INFO_9
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim nRet As Long
my_printer_address = Application.ActivePrinter
'slice string for printer name (minus port name)
sPrinterName = Left(my_printer_address, InStr(my_printer_address, " on ") - 1)
'Open Printer
nRet = OpenPrinter(sPrinterName, hPrinter, ByVal 0&)
'Get the size of the DEVMODE structure
nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then MsgBox "Cannot get the size of the DEVMODE structure.": Exit Sub
'Get DEVMODE Structure
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Cannot get the DEVMODE structure."
Exit Sub
End If
'Copy the DEVMODE structure
Call CopyMemory(dm, yDevModeData(0), Len(dm))
'Change DEVMODE Stucture as required
dm.dmColor = 1 ' 1 = colour, 2 = b/w
dm.dmDuplex = 2 ' 1 = simplex, 2 = duplex
'Replace the DEVMODE structure
Call CopyMemory(yDevModeData(0), dm, Len(dm))
'Verify DEVMODE Stucture
nRet = DocumentProperties(0, hPrinter, sPrinterName, VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), DM_IN_BUFFER Or DM_OUT_BUFFER)
Pinfo9.pDevmode = VarPtr(yDevModeData(0))
'Set DEVMODE Stucture with any changes made
nRet = SetPrinter(hPrinter, 9, Pinfo9, 0)
If (nRet <= 0) Then MsgBox "Cannot set the DEVMODE structure.": Exit Sub
'Close the Printer
nRet = ClosePrinter(hPrinter)
End Sub
Any help you can provide will be much appreciated!! I have been hitting my head against a wall with this for weeks now!
After some extensive research, I have found the answer I was looking for. I have posted it here, in case anyone has a similar situation.
The main issue I was having was getting excel to accept the new changes with closing the workbook or having to go into the print preferences and click reset.
The solution I came up with was to temporarily set the active printer to another printer then set it back to the printer the settings were changed on, this forces Excel to pick up the new settings.
Here are the Public Types, Functions and Constants:
Public Type PRINTER_INFO_9
pDevmode As Long '''' POINTER TO DEVMODE
End Type
Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer: dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As Any) As Long
Public Declare Function GetPrinter 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
Public Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As Long
Public Declare Function DocumentProperties Lib "winspool.drv" Alias "DocumentPropertiesA" (ByVal hWnd As Long, ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long
Public Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cbLength As Long)
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
This is the routine i am using to set the new values:
Public Sub SetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long)
Dim PrinterName, sPrinter, sDefaultPrinter As String
Dim Pinfo9 As PRINTER_INFO_9
Dim hPrinter, nRet As Long
Dim yDevModeData() As Byte
Dim dm As DEVMODE
'''' STROE THE CURRENT DEFAULT PRINTER
sDefaultPrinter = sPrinterName
'''' USE THE FULL PRINTER ADDRESS TO GET THE ADDRESS AND NAME MINUS THE PORT NAME
PrinterName = Left(sDefaultPrinter, InStr(sDefaultPrinter, " on ") - 1)
'''' OPEN THE PRINTER
nRet = OpenPrinter(PrinterName, hPrinter, ByVal 0&)
'''' GET THE SIZE OF THE CURRENT DEVMODE STRUCTURE
nRet = DocumentProperties(0, hPrinter, PrinterName, 0, 0, 0)
If (nRet < 0) Then MsgBox "Cannot get the size of the DEVMODE structure.": Exit Sub
'''' GET THE CURRENT DEVMODE STRUCTURE
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, PrinterName, VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then MsgBox "Cannot get the DEVMODE structure.": Exit Sub
'''' COPY THE CURRENT DEVMODE STRUCTURE
Call CopyMemory(dm, yDevModeData(0), Len(dm))
'''' CHANGE THE DEVMODE STRUCTURE TO REQUIRED
dm.dmDuplex = iPropertyType ' 1 = simplex, 2 = duplex
'''' REPLACE THE CURRENT DEVMODE STRUCTURE WITH THE NEWLEY EDITED
Call CopyMemory(yDevModeData(0), dm, Len(dm))
'''' VERIFY THE NEW DEVMODE STRUCTURE
nRet = DocumentProperties(0, hPrinter, PrinterName, VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), DM_IN_BUFFER Or DM_OUT_BUFFER)
Pinfo9.pDevmode = VarPtr(yDevModeData(0))
'''' SET THE DEMODE STRUCTURE WITH ANY CHANGES MADE
nRet = SetPrinter(hPrinter, 9, Pinfo9, 0)
If (nRet <= 0) Then MsgBox "Cannot set the DEVMODE structure.": Exit Sub
'''' CLOSE THE PRINTER
nRet = ClosePrinter(hPrinter)
'''' GET THE FULL PRINTER NAME FOR THE CUTE PDF WRITER
sPrinter = GetPrinterFullName("CutePDF")
'''' CHECK TO MAKE SURE THE CUTEPDF WAS FOUND
If sPrinter <> vbNullString Then
'''' THIS FORCES EXCEL TO ACCEPT THE NEW CHANGES THAT HAVE BEEN MADE TO THE PRINTER SETTINGS
'''' SET THE ACTIVE PRINTER TEMPERARILLY TO THE CUTE PDF WRITER
Application.ActivePrinter = sPrinter
'''' SET THE PRINTER BACK TO THE DEFAULY FOLLOW ME.
Application.ActivePrinter = sDefaultPrinter
End If
End Sub
I then call either of these two subs to set set preferences:
Public Sub SetDuplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, iDuplex
End Sub
Public Sub SetSimplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, iDuplex
End Sub
Awesome. Thank you for this fix. Our office recently switched to Windows 10 and Office 16 and my old duplex code no longer worked for printing out worksheets in duplex mode. Your code is incredibly complicated, but it works (for reasons beyond my understanding as a novice programmer) and saves a lot of paper from being wasted. Thank you very much. I did notice one thing about your function that needs to be addressed. There is a call to another function you did not provide.
sPrinter = GetPrinterFullName("CutePDF")
Coincidentally I happened to have the function GetPrinterFullName() in another module so it was running but not returning the full name of "CutePDF". That was because "CutePDF" does not exist on my computer. So I simply went to settings, set the default to "Microsoft Print to PDF" and then did a small test routine (below) to get the full name of the active default printer:
sub getActivePrinterFullAddress()
debug.print application.activeprinter
end sub
This returned "Microsoft Print to PDF on Ne03:" So any user could send the full name of any second printer to your function by adding a 3rd variable and avoid the call to GetPrinterFullName(), or they can hard code the name into your function like I did to avoid the call. Or they can add the following function to the module: (I've been to 30 different sites this morning to find a solution, and yours is the one that works. But the credits for the following function are inside the function below. It is not my code. I think it is credited to Frans Bus)
Public Function GetPrinterFullName(Printer As String) As String
' This function returns the full name of the first printerdevice that
matches Printer.
' Full name is like "PDFCreator on Ne01:" for a English Windows and like
' "PDFCreator sur Ne01:" for French.
' Created: Frans Bus, 2015. See http://pixcels.nl/set-activeprinter-excel
' see http://blogs.msdn.com/b/alejacma/archive/2008/04/11/how-to-read-a-
registry-key-and-its-values.aspx
' see http://www.experts-exchange.com/Software/Microsoft_Applications/Q_27566782.html
Const HKEY_CURRENT_USER = &H80000001
Dim regobj As Object
Dim aTypes As Variant
Dim aDevices As Variant
Dim vDevice As Variant
Dim sValue As String
Dim v As Variant
Dim sLocaleOn As String
' get locale "on" from current activeprinter
v = Split(Application.ActivePrinter, Space(1))
sLocaleOn = Space(1) & CStr(v(UBound(v) - 1)) & Space(1)
' connect to WMI registry provider on current machine with current user
Set regobj = GetObject("WINMGMTS:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' get the Devices from the registry
regobj.EnumValues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", aDevices, aTypes
' find Printer and create full name
For Each vDevice In aDevices
' get port of device
regobj.GetStringValue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", vDevice, sValue
' select device
If Left(vDevice, Len(Printer)) = Printer Then ' match!
' create localized printername
GetPrinterFullName = vDevice & sLocaleOn & Split(sValue, ",")(1)
Exit Function
End If
Next
' at this point no match found
GetPrinterFullName = vbNullString
End Function

How can I create product keys for VBA applications so that illegal distribution of software is prevented?

I am working on an Excel VBA application.
My company wants to make it a product. This application should be installable only on one system. Could someone please help me with this.
This is just a basic example on how to ensure that your product is installed on just one system.
Logic:
Retrieve the Hardware ID (Ex: Hard Disk Number, CPU Number etc...)
You may also ask the user Name and email address
Encrypt the above info to generate an Unique Code (This is done within the App)
User sends you the Unique Code (Be it via email / Online Activation / Telephone)
You send the user an Activation Id based on the Unique Code
CODE for retrieving HardDisk Serial Number and CPU Number
Paste this code in a class module (Not my code. Copyright info mentioned in the code)
Private Const VER_PLATFORM_WIN32S = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Enum HDINFO
HD_MODEL_NUMBER
HD_SERIAL_NUMBER
HD_FIRMWARE_REVISION
End Enum
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type IDEREGS
bFeaturesReg As Byte
bSectorCountReg As Byte
bSectorNumberReg As Byte
bCylLowReg As Byte
bCylHighReg As Byte
bDriveHeadReg As Byte
bCommandReg As Byte
bReserved As Byte
End Type
Private Type SENDCMDINPARAMS
cBufferSize As Long
irDriveRegs As IDEREGS
bDriveNumber As Byte
bReserved(1 To 3) As Byte
dwReserved(1 To 4) As Long
End Type
Private Type DRIVERSTATUS
bDriveError As Byte
bIDEStatus As Byte
bReserved(1 To 2) As Byte
dwReserved(1 To 2) As Long
End Type
Private Type SENDCMDOUTPARAMS
cBufferSize As Long
DStatus As DRIVERSTATUS
bBuffer(1 To 512) As Byte
End Type
Private Declare Function GetVersionEx _
Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function CreateFile _
Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle _
Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl _
Lib "kernel32" _
(ByVal hDevice As Long, _
ByVal dwIoControlCode As Long, _
lpInBuffer As Any, _
ByVal nInBufferSize As Long, _
lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
lpBytesReturned As Long, _
ByVal lpOverlapped As Long) As Long
Private Declare Sub ZeroMemory _
Lib "kernel32" Alias "RtlZeroMemory" _
(dest As Any, _
ByVal numBytes As Long)
Private Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GetLastError _
Lib "kernel32" () As Long
Private mvarCurrentDrive As Byte
Private mvarPlatform As String
Public Property Get Copyright() As String
Copyright = "HDSN Vrs. 1.00, (C) Antonio Giuliana, 2001-2003"
End Property
Public Function GetModelNumber() As String
GetModelNumber = CmnGetHDData(HD_MODEL_NUMBER)
End Function
Public Function GetSerialNumber() As String
GetSerialNumber = CmnGetHDData(HD_SERIAL_NUMBER)
End Function
Public Function GetFirmwareRevision() As String
GetFirmwareRevision = CmnGetHDData(HD_FIRMWARE_REVISION)
End Function
Public Property Let CurrentDrive(ByVal vData As Byte)
If vData < 0 Or vData > 3 Then
Err.Raise 10000, , "Illegal drive number" ' IDE drive 0..3
End If
mvarCurrentDrive = vData
End Property
Public Property Get CurrentDrive() As Byte
CurrentDrive = mvarCurrentDrive
End Property
Public Property Get Platform() As String
Platform = mvarPlatform
End Property
Private Sub Class_Initialize()
Dim OS As OSVERSIONINFO
OS.dwOSVersionInfoSize = Len(OS)
Call GetVersionEx(OS)
mvarPlatform = "Unk"
Select Case OS.dwPlatformId
Case Is = VER_PLATFORM_WIN32S
mvarPlatform = "32S"
Case Is = VER_PLATFORM_WIN32_WINDOWS
If OS.dwMinorVersion = 0 Then
mvarPlatform = "W95"
Else
mvarPlatform = "W98"
End If
Case Is = VER_PLATFORM_WIN32_NT
mvarPlatform = "WNT"
End Select
End Sub
Private Function CmnGetHDData(hdi As HDINFO) As String
Dim bin As SENDCMDINPARAMS
Dim bout As SENDCMDOUTPARAMS
Dim hdh As Long
Dim br As Long
Dim ix As Long
Dim hddfr As Long
Dim hddln As Long
Dim s As String
Select Case hdi
Case HD_MODEL_NUMBER
hddfr = 55
hddln = 40
Case HD_SERIAL_NUMBER
hddfr = 21
hddln = 20
Case HD_FIRMWARE_REVISION
hddfr = 47
hddln = 8
Case Else
Err.Raise 10001, "Illegal HD Data type"
End Select
Select Case mvarPlatform
Case "WNT"
hdh = CreateFile("\\.\PhysicalDrive" & mvarCurrentDrive, _
GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, _
0, OPEN_EXISTING, 0, 0)
Case "W95", "W98"
hdh = CreateFile("\\.\Smartvsd", _
0, 0, 0, CREATE_NEW, 0, 0)
Case Else
Err.Raise 10002, , "Illegal platform (only WNT, W98 or W95)"
End Select
If hdh = 0 Then
Err.Raise 10003, , "Error on CreateFile"
End If
ZeroMemory bin, Len(bin)
ZeroMemory bout, Len(bout)
With bin
.bDriveNumber = mvarCurrentDrive
.cBufferSize = 512
With .irDriveRegs
If (mvarCurrentDrive And 1) Then
.bDriveHeadReg = &HB0
Else
.bDriveHeadReg = &HA0
End If
.bCommandReg = &HEC
.bSectorCountReg = 1
.bSectorNumberReg = 1
End With
End With
DeviceIoControl hdh, DFP_RECEIVE_DRIVE_DATA, _
bin, Len(bin), bout, Len(bout), br, 0
s = ""
For ix = hddfr To hddfr + hddln - 1 Step 2
If bout.bBuffer(ix + 1) = 0 Then Exit For
s = s & Chr(bout.bBuffer(ix + 1))
If bout.bBuffer(ix) = 0 Then Exit For
s = s & Chr(bout.bBuffer(ix))
Next ix
CloseHandle hdh
CmnGetHDData = Trim(s)
End Function
You can then call it using
'~~> Get the CPU No
CPU = GetWmiDeviceSingleValue("Win32_Processor", "ProcessorID")
'~~> Get the Hard Disk No
Dim h As HDSN
Set h = New HDSN
With h
.CurrentDrive = 0
HDNo = .GetSerialNumber
End With
Set h = Nothing
Once you have this info, you can then merge it with the First Name, Last Name and the email address to create a string. For example
strg = Trim(FirstName) & Chr(1) & Trim(LastName) & Chr(1) & _
Trim(EmailAddress) & Chr(1) & Trim(CPU) & Chr(1) & Trim(HDNo)
Once you have the string, you can then encrypt it. Here is another basic example of encrypting it. You can choose any type of encryption that you would like
For i = 1 To Len(strg)
RandomNo = (Rnd * 100)
tmp = tmp & Hex((Asc(Mid(strg, i, 1)) Xor RandomNo))
Next
The tmp above holds the encrypted string.
Once you receive this string, you will have to decode it and create an Activation Id based on that. You App should be able to accept the Activation Id. You also have an option to store this info in the registry or in a Dat File.
A simple registration window might look like this.
Hope this gets you started! :)
IMP: Though you can lock your VBA project but it is definitely not hack proof. You might want to explore VSTO to create DLLs which does the above thing.

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