vbAccelerator - Contents of code file: SampleKioskApp_mMain.bas

This file is part of the download VB6 New Desktop Sample, which is described in the article Creating New Desktops and Running Applications.

Attribute VB_Name = "mMain"
Option Explicit

Private Declare Function OpenInputDesktop Lib "user32" ( _
      ByVal dwFlags As Long, _
      ByVal fInherit As Boolean, _
      ByVal dwDesiredAccess As Long _
   ) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
 Long
Private Declare Function GetUserObjectInformation Lib "user32" Alias
 "GetUserObjectInformationW" ( _
   ByVal hObj As Long, _
   ByVal nIndex As Long, _
   pvInfo As Any, _
   ByVal nLength As Long, _
   lpnLengthNeeded As Long) As Long
Private Const UOI_FLAGS = 1
Private Const UOI_NAME = 2
Private Const UOI_TYPE = 3
Private Const UOI_USER_SID = 4

Private Const DESKTOP_READOBJECTS = &H1&

Private Const DESKTOP_NAME As String = "vbAccelerator"

Public Sub Main()
   
   ' Check we are running in the correct desktop
   If (GetDesktopName() = DESKTOP_NAME) Then
      
      ' Ok, let's run
      Dim fK As New frmKioskApp
      fK.Show
      
   Else
   
      MsgBox "This application cannot be run directly.  Launch NewDesktop.exe
       to start.", vbCritical
   
   End If
   
End Sub

Public Function GetDesktopName() As String
Dim hDesktop As Long
Dim lR As Long
Dim lSize As Long
Dim sBuff As String
Dim iPos As Long
   
   hDesktop = OpenInputDesktop(0, False, DESKTOP_READOBJECTS)
   If Not (hDesktop = 0) Then
      lSize = (Len(DESKTOP_NAME) + 1) * 2
      ReDim bBuff(0 To lSize - 1) As Byte
      lR = GetUserObjectInformation(hDesktop, UOI_NAME, bBuff(0), lSize, lSize)
      sBuff = bBuff
      iPos = InStr(sBuff, vbNullChar)
      If (iPos > 1) Then
         sBuff = Left(sBuff, iPos - 1)
      End If
      GetDesktopName = sBuff
      CloseHandle hDesktop
   End If
End Function