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
Related
I am using Common Dialog Control of VB6 to select Font by calling ShowFont method. Here I can select desired font, font size, bold, italic, strike thru etc. I also select Arabic from script combo box. The problem is not able to get the value which I selected from the Script combo box. Any one please help.
Code:
With CommonDialog1.ShowFont
FontObject.Name = .FontName
FontObject.Bold = .FontBold
FontObject.Italic = .FontItalic
FontObject.Size = .FontSize
FontObject.Strikethrough = .FontStrikethru
FontObject.Underline = .FontUnderline
End With
You have two options:
Subclass the Common Dialog Window -
Here is an example from VBForum
Use the Windows API to call the ChooseFont Common Dialog by your self
Here is a snippet using the second approach:
Option Explicit
Private FontObject As New StdFont
Const FW_REGULAR As Integer = 400
Const FW_BOLD As Integer = 700
Const CF_BOTH = &H3
Const CF_EFFECTS = &H100
Const CF_INITTOLOGFONTSTRUCT = &H40
Const LF_FACESIZE = 32
Const LOGPIXELSY As Long = 90
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ChooseFontA Lib "comdlg32.dll" (pChoosefont As CHOOSEFONT) As Long
Private Sub String2ByteArr(ByVal str As String, ByRef arr)
Dim b() As Byte, i As Long, l As Long
b = StrConv(str & Chr(0), vbFromUnicode)
l = UBound(b)
For i = 0 To l
arr(i) = b(i)
Next
End Sub
Private Function ByteArr2String(ByRef arr) As String
Dim b() As Byte
b = StrConv(arr, vbUnicode)
bytearray2string = Left$(b, InStr(b, Chr$(0)) - 1)
End Function
Private Sub FontDialog()
Dim cf As CHOOSEFONT, lf As LOGFONT, hWnd As Long, hDC As Long, ppi As Long
hWnd = GetDesktopWindow
hDC = GetDC(hWnd)
ppi = GetDeviceCaps(hDC, LOGPIXELSY)
With lf
String2ByteArr FontObject.Name, lf.lfFaceName
.lfHeight = -(FontObject.Size * ppi) / 72
.lfWeight = IIf(FontObject.Bold, FW_BOLD, FW_REGULAR)
.lfItalic = FontObject.Italic
.lfUnderline = FontObject.Underline
.lfStrikeOut = FontObject.Strikethrough
.lfCharSet = FontObject.Charset
End With
With cf
.lStructSize = Len(cf)
.hDC = hDC
.flags = CF_BOTH Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
.hwndOwner = Me.hWnd
.lpLogFont = VarPtr(lf)
.lpTemplateName = vbNullString
End With
If ChooseFontA(cf) Then
With FontObject
.Name = ByteArr2String(lf.lfFaceName)
.Size = (-72 * lf.lfHeight) / ppi
.Bold = lf.lfWeight >= FW_BOLD
.Italic = lf.lfItalic
.Underline = lf.lfUnderline
.Strikethrough = lf.lfStrikeOut
.Charset = lf.lfCharSet
End With
' If you choose Arabic charset, this will print 178
Debug.Print "CharSet:", FontObject.Charset
End If
Call ReleaseDC(hWnd, hDC)
End Sub
Please note: as this topic is quite old, you will find many other examples by googling on the net (ChooseFont: Using the ChooseFont Common Dialog API, Karl E. Peterson and so on).
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 MD5 hash user-supplied data (a file) using The Crypto functions in AdvApi32. All is well and good unless the file is very large (hundreds of MB. or larger) in which case I eventually get an OutOfMemory exception.
I figured that the solution would be to make repeated calls to CryptHashData using the same HashObject and processing only (for example) 4096 bytes at a time.
This appears to work, but the returned hash is incorrect.
Function HashFile(File As FolderItem) As String
Declare Function CryptAcquireContextW Lib "AdvApi32" (ByRef provider as Integer, container as Integer, providerName as WString, _
providerType as Integer, flags as Integer) as Boolean
Declare Sub CryptDestroyHash Lib "AdvApi32" (hashHandle as Integer )
Declare Function CryptCreateHash Lib "AdvApi32" (provider as Integer, algorithm as Integer, key as Integer, flags as Integer, _
ByRef hashHandle as Integer) as Boolean
Declare Function CryptHashData Lib "AdvApi32" (hashHandle as Integer, data as Ptr, length as Integer, flags as Integer) as Boolean
Declare Function CryptGetHashParam Lib "AdvApi32" (hashHandle as Integer, type as Integer, value as Ptr, ByRef length as Integer, _
flags as Integer) as Boolean
Const HP_HASHVAL = &h0002
Const HP_HASHSIZE = &h0004
Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Const PROV_RSA_FULL = 1
Const CRYPT_NEWKEYSET = &h00000008
Const CALG_MD5 = &h00008003
Dim provider As Integer
Dim hashHandle As Integer
If Not CryptAcquireContextW(provider, 0, MS_DEF_PROV, PROV_RSA_FULL, 0) Then
If Not CryptAcquireContextW(provider, 0, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_NEWKEYSET) Then
Raise New RuntimeException
End If
End If
If Not CryptCreateHash(provider, CALG_MD5, 0, 0, hashHandle) Then
Raise New RuntimeException
End If
Dim dataPtr As New MemoryBlock(4096)
Dim bs As BinaryStream
bs = bs.Open(File)
dataPtr.StringValue(0, 4096) = bs.Read(4096)
Do
If CryptHashData(hashHandle, dataPtr, dataPtr.Size, 0) Then
dataPtr = New MemoryBlock(4096)
dataPtr.StringValue(0, 4095) = bs.Read(4096)
End If
Loop Until bs.EOF
Dim size as Integer = 4
Dim toss As New MemoryBlock(4)
If Not CryptGetHashParam(hashHandle, HP_HASHSIZE, toss, size, 0) Then
Raise New RuntimeException
End If
size = toss.UInt32Value(0)
Dim hashValue As New MemoryBlock(size)
If Not CryptGetHashParam(hashHandle, HP_HASHVAL, hashValue, size, 0) Then
Raise New RuntimeException
End If
CryptDestroyHash(hashHandle)
//Convert binary to hex
Dim hexvalue As Integer
Dim hexedInt As String
Dim src As String = hashValue.StringValue(0, hashValue.Size)
For i As Integer = 1 To LenB(src)
hexvalue = AscB(MidB(src, i, 1))
hexedInt = hexedInt + RightB("00" + Hex(hexvalue), 2)
next
Return LeftB(hexedInt, LenB(hexedInt))
End Function
What am I doing wrong here? The output I get is consistent, but wrong.
Did you check that msdn example on C++ ?
Very similar answer to your question.
I think the problem is that since you read the data in blocks of 4096 bytes - when the data is not a multiple of 4096 you endup including unwanted trailing 0's or possibly garbage values. Try bs.Read(1) instead of bs.Read(4096) in the loop: Loop Until bs.EOF in-order to test if correct hash is being calculated now. If successful adjust your loop to tackle the remainder (%4096) bytes separately.
Using the following code to write a string to the DesktopWindow's device context works, but the background color and text color remain the same (white on blue):
Private Sub writeToScreen(txt As String)
Declare Function GetDesktopWindow Lib "user32" () As Integer
Declare Function DrawTextW Lib "user32" (hdc As Integer, lpStr As WString, nCount As Integer, _
ByRef lpRect As RECT, wFormat As Integer) As Integer
Declare Function CreateDCA Lib "gdi32" (lpDriverName As CString, lpDeviceName As Integer, _
lpOutput As Integer, lpInitData As Integer) As Integer
Declare Function DeleteDC Lib "gdi32" (hdc As Integer) As Integer
Declare Function GetTextColor Lib "gdi32" (hdc As Integer) As Color
Declare Function SetTextColor Lib "gdi32" (hdc As Integer, crColor As Color) As Color
Declare Function GetBkColor Lib "gdi32" (hdc As Integer) As Color
Declare Function SetBkColor Lib "gdi32" (hdc As Integer, crColor As Color) As Color
Const DT_MULTILINE = &H00000001
Const DT_NOCLIP = &H100
Const INVALID_COLOR = &hFFFFFFFF
Dim tFormat As Integer = DT_MULTILINE Or DT_NOCLIP
Dim hdc As Integer = CreateDCA("DISPLAY", 0, 0, 0)
Dim tRect As RECT //The RECT structure is defined elsewhere
Dim textCol, backColor As Color
tR.Left = 200
tR.Top = 250
tR.Right = 600
tR.Bottom = 350
textCol = SetTextColor(hdc, &cFF8040)
backColor = SetBkColor(hdc, &c000000)
If DrawTextW(hdc, txt, Len(txt), tR, tFormat) = 0 Then
System.DebugLog("Text Draw Error")
End If
Call SetTextColor(hdc, textCol)
Call SetBkColor(hdc, backColor)
Call DeleteDC(hdc)
End Sub
What am I doing wrong? The text gets written just fine, but the colors are ugly.
Use SetBkMode() (http://msdn.microsoft.com/en-us/library/dd162965%28v=vs.85%29.aspx) first to set the DC to not draw a background.
SetTextColor() is only used for TextOut(), not DrawText(), IIRC - MSDN is ambiguous on it. Try seleting a different HBRUSH into the DC, that may do what you want.
I'm having a hard time converting this C++ code to VB6 code. I've search the net and haven't found anything. PInvoke.net only has reference to VB.NET code. Here's the code from MSDN:
BOOL IsUserAdmin(VOID)
/*++
Routine Description: This routine returns TRUE if the caller's
process is a member of the Administrators local group. Caller is NOT
expected to be impersonating anyone and is expected to be able to
open its own process and process token.
Arguments: None.
Return Value:
TRUE - Caller has Administrators local group.
FALSE - Caller does not have Administrators local group. --
*/
{
BOOL b;
SID_IDENTIFIER_AUTHORITY NtAuthority = SECURITY_NT_AUTHORITY;
PSID AdministratorsGroup;
b = AllocateAndInitializeSid(
&NtAuthority,
2,
SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0,
&AdministratorsGroup);
if(b)
{
if (!CheckTokenMembership( NULL, AdministratorsGroup, &b))
{
b = FALSE;
}
FreeSid(AdministratorsGroup);
}
return(b);
}
It would be great if somebody can help out in converting this to VB6 code.
Thanks!
EDIT:
I was originally going to use that function but MSDN says:
This function is a wrapper for CheckTokenMembership. It is recommended to call that function directly to determine Administrator group status rather than calling IsUserAnAdmin.
Try this
Option Explicit
Private Const SECURITY_BUILTIN_DOMAIN_RID As Long = &H20
Private Const DOMAIN_ALIAS_RID_ADMINS As Long = &H220
Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" (pIdentifierAuthority As Any, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Sub FreeSid Lib "advapi32.dll" (ByVal pSid As Long)
Private Declare Function CheckTokenMembership Lib "advapi32.dll" (ByVal hToken As Long, ByVal pSidToCheck As Long, pbIsMember As Long) As Long
Private Type SID_IDENTIFIER_AUTHORITY
Value(0 To 5) As Byte
End Type
Private Function pvIsAdmin() As Boolean
Dim uAuthNt As SID_IDENTIFIER_AUTHORITY
Dim pSidAdmins As Long
Dim lResult As Long
uAuthNt.Value(5) = 5
If AllocateAndInitializeSid(uAuthNt, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, pSidAdmins) <> 0 Then
If CheckTokenMembership(0, pSidAdmins, lResult) <> 0 Then
pvIsAdmin = (lResult <> 0)
End If
Call FreeSid(pSidAdmins)
End If
End Function
You've posted the MSDN sample code for CheckTokenMembership - it uses CheckTokenMembership to determine whether the user is an administrator.
In VB6 it's easier to use IsUserAnAdmin, which is a wrapper for CheckTokenMembership. The MSDN docs do say IsUserAnAdmin is deprecated, but it's so much easier to call than CheckTokenMembership.
Private Declare Function IsUserAnAdmin Lib "Shell32" Alias "#680" () As Integer
If IsUserAnAdmin() = 0 Then
MsgBox "Not admin"
Else
MsgBox "Admin"
End If
Unless there is a reason to convert the code, use the API
Private Declare Function IsUserAdmin Lib "Shell32" Alias "#680" () As Boolean
Private Sub Form_Load()
If IsUserAdmin Then MsgBox "User is Admin"
End Sub