I have a block of code that opens and closes a registry key to find a piece of information that determines the user's location so that it can select the appropriate filepath when openeing a data file. It works fine in Windows XP with Office 2002 and 2007, but doesn't work in 32 or 64 bit versions of Windows 7 with Excel 2010.
Can anyone tell me what I need to change to get this working?
'\* Module Level Constant Declarations follow...
Private Const cvarRegistrySize = 1
Private Const cvarHkeyLocalMachine = &H80000002
Private Const cvarKeyQueryValue = &H2
'\* Private API Function Declarations follow...
Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As LongPtr) As Long
Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
'\* Dimension variables at module level...
Private strSearchKey As String
Private strRegion As String
Private intCharLen As Integer
Private intSubChar As Integer
Private lngRegKey As Long
Private lngSizeVar As Long
Private lngReturnCode As Long
'****************************************************************************
'* Function to extract the current region from the registry *
'****************************************************************************
Function GETREGION() As String
'\* registry key for user's location...
strSearchKey = "SOFTWARE\CompanyName\LogonProcess"
'\* open registry key...
lngReturnCode = RegOpenKeyEx(cvarHkeyLocalMachine, strSearchKey, 0, cvarKeyQueryValue, lngRegKey) 'returns 2
'\* return value from specified key...
strSearchKey = "CurrentLocation"
'\* return section of string from specified key...
strRegion = String(20, 32)
'\* returns the length of the string...
lngSizeVar = Len(strRegion) - 1
'\* query the registry key...
lngReturnCode = RegQueryValueEx(lngRegKey, strSearchKey, 0, cvarRegistrySize, ByVal strRegion, lngSizeVar) 'returns 6
'\* close the registry key...
Call RegCloseKey(lngRegKey)
'\* select the location from the string...
lngReturnCode = GETSTR(GETREGION, strRegion, 1, vbNullChar)
'\* return result to function as uppercase...
GETREGION = StrConv(GETREGION, vbUpperCase)
End Function
'****************************************************************************
'* Function to extract a section from a string from a given start position *
'* up to a specified character. *
'****************************************************************************
Function GETSTR(strX As String, strY As String, intStartPos As Integer, intSearchChar As String) As Integer
'\* initialisation of variables follows...
GETSTR = intStartPos
strX = ""
intCharLen = Len(strY)
intSubChar = intStartPos
'\* if comparison character at start position then leave function with empty extracted string... *
If Mid(strY, intStartPos, 1) = intSearchChar Then Exit Function
'\* begin loop...
Do
'\* create integer value based on character positions...
strX = strX + Mid(strY, intSubChar, 1)
'\* increment counter...
intSubChar = intSubChar + 1
'\* if counter exceeds string length, exit loop...
If intSubChar > intCharLen Then Exit Do
'\* define loop conditions...
Loop Until Mid(strY, intSubChar, 1) = intSearchChar
'\* return character position to function...
GETSTR = intSubChar
End Function
It is becoming critical that I resolve this as it may hold back the roll-out of our new desktop image as this code is used in a function which is part of an Excel add-in which is deployed to all the machines and used by a large number of associates.
The return codes from RegOpenKeyEx and RegQueryValueEx of 2 and 6 respectively are what are throwing me.
Thanks in advance
Martin
The error codes indicate
(0x000002) The system cannot find the file specified.
(0x000006) The handle is invalid
You pass cvarKeyQueryValue = &H2 as the samDesired rights request which is KEY_SET_VALUE (0x0002) - on windows 7 without elevation this write request to HKLM will be denied.
Try opening the key with KEY_READ (0x20019) instead as you only need to read the value.
Related
Public Declare Function FindMimeFromData Lib "urlmon.dll" ( _
ByVal pbc As Long, _
ByVal pwzUrl As String, _
pBuffer As Any, _
cbSize As Long, _
ByVal pwzMimeProposed As String, _
dwMimeFlags As Long, _
ppwzMimeOut As Long, _
dwReserved As Long) As Long
In VB6, I can't seem to figure out how to pass the pBuffer parameter of the first 256 characters of a file. When I try to use a Dim buffer() As Byte and populate that, and pass it as the parameter, it throws the error of wrong param even those of the definition is Any.
I've tried to use this example, but passing the entire file name from a file system doesn't seem to work. so I have to try sending it like the C# example with the first 256 bytes of the file.
Can anyone help?
I played around with the following Declare, and built up some code around it. There are two wrappers, GetMimeTypeFromUrl() and GetMimeTypeFromData(). I found the former only worked when you used simple URLs such as http://host.com/file.xtn. You may have to play around with the other flags.
However, the other wrapper function sounds like what you need.
Note that all the string pointers are declared As Long, and I pass the underlying UTF-16 VB string as a pointer using StrPtr().
Also note that you have to use CoTaskMemFree() to free the output ppwzMimeOut string pointer, otherwise you will leak memory.
Option Explicit
Private Declare Function FindMimeFromData Lib "Urlmon.dll" ( _
ByVal pBC As Long, _
ByVal pwzUrl As Long, _
ByVal pBuffer As Long, _
ByVal cbSize As Long, _
ByVal pwzMimeProposed As Long, _
ByVal dwMimeFlags As Long, _
ByRef ppwzMimeOut As Long, _
ByVal dwReserved As Long _
) As Long
'
' Flags:
'
' Default
Private Const FMFD_DEFAULT As Long = &H0
' Treat the specified pwzUrl as a file name.
Private Const FMFD_URLASFILENAME As Long = &H1
' Internet Explorer 6 for Windows XP SP2 and later. Use MIME-type detection even if FEATURE_MIME_SNIFFING is detected. Usually, this feature control key would disable MIME-type detection.
Private Const FMFD_ENABLEMIMESNIFFING As Long = &H2
' Internet Explorer 6 for Windows XP SP2 and later. Perform MIME-type detection if "text/plain" is proposed, even if data sniffing is otherwise disabled. Plain text may be converted to text/html if HTML tags are detected.
Private Const FMFD_IGNOREMIMETEXTPLAIN As Long = &H4
' Internet Explorer 8. Use the authoritative MIME type specified in pwzMimeProposed. Unless FMFD_IGNOREMIMETEXTPLAIN is specified, no data sniffing is performed.
Private Const FMFD_SERVERMIME As Long = &H8
' Internet Explorer 9. Do not perform detection if "text/plain" is specified in pwzMimeProposed.
Private Const FMFD_RESPECTTEXTPLAIN As Long = &H10
' Internet Explorer 9. Returns image/png and image/jpeg instead of image/x-png and image/pjpeg.
Private Const FMFD_RETURNUPDATEDIMGMIMES As Long = &H20
'
' Return values:
'
' The operation completed successfully.
Private Const S_OK As Long = 0&
' The operation failed.
Private Const E_FAIL As Long = &H80000008
' One or more arguments are invalid.
Private Const E_INVALIDARG As Long = &H80000003
' There is insufficient memory to complete the operation.
Private Const E_OUTOFMEMORY As Long = &H80000002
'
' String routines
'
Private Declare Function lstrlen Lib "Kernel32.dll" Alias "lstrlenW" ( _
ByVal lpString As Long _
) As Long
Private Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal nCount As Long)
Private Declare Sub CoTaskMemFree Lib "Ole32.dll" ( _
ByVal pv As Long _
)
Private Function CopyPointerToString(ByVal in_pString As Long) As String
Dim nLen As Long
' Need to copy the data at the string pointer to a VB string buffer.
' Get the length of the string, allocate space, and copy to that buffer.
nLen = lstrlen(in_pString)
CopyPointerToString = Space$(nLen)
CopyMemory StrPtr(CopyPointerToString), in_pString, nLen * 2
End Function
Private Function GetMimeTypeFromUrl(ByRef in_sUrl As String, ByRef in_sProposedMimeType As String) As String
Dim pMimeTypeOut As Long
Dim nRet As Long
nRet = FindMimeFromData(0&, StrPtr(in_sUrl), 0&, 0&, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromUrl = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Function GetMimeTypeFromData(ByRef in_abytData() As Byte, ByRef in_sProposedMimeType As String) As String
Dim nLBound As Long
Dim nUBound As Long
Dim pMimeTypeOut As Long
Dim nRet As Long
nLBound = LBound(in_abytData)
nUBound = UBound(in_abytData)
nRet = FindMimeFromData(0&, 0&, VarPtr(in_abytData(nLBound)), nUBound - nLBound + 1, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromData = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Sub Command1_Click()
Dim sRet As String
Dim abytData() As Byte
sRet = GetMimeTypeFromUrl("http://msdn.microsoft.com/en-us/library/ms775107%28v=vs.85%29.aspx", vbNullString)
Debug.Print sRet
abytData() = StrConv("<HTML><HEAD><TITLE>Stuff</TITLE></HEAD><BODY>Test me</BODY></HTML>", vbFromUnicode)
sRet = GetMimeTypeFromData(abytData(), vbNullString)
Debug.Print sRet
End Sub
how can i get the remote computer name based on a given IP Address in vb6? Is there any way that i can list out a list of computers linked to current computer?
If reverse DNS lookup does what you want this might help. This example simplifies the processing of the DNS results, but should get you started and may be enough:
Option Explicit
Private Const DNS_TYPE_PTR = &HC
Private Const DNS_QUERY_STANDARD = &H0
Private Const DnsFreeRecordListDeep = 1&
Private Enum DNS_STATUS
ERROR_BAD_IP_FORMAT = -3&
ERROR_NO_PTR_RETURNED = -2&
ERROR_NO_RR_RETURNED = -1&
DNS_STATUS_SUCCESS = 0&
End Enum
Private Type VBDnsRecord
pNext As Long
pName As Long
wType As Integer
wDataLength As Integer
Flags As Long
dwTTL As Long
dwReserved As Long
prt As Long
others(9) As Long
End Type
Private Declare Function DnsQuery Lib "Dnsapi" Alias "DnsQuery_A" ( _
ByVal Name As String, _
ByVal wType As Integer, _
ByVal Options As Long, _
ByRef aipServers As Any, _
ByRef ppQueryResultsSet As Long, _
ByVal pReserved As Long) As Long
Private Declare Function DnsRecordListFree Lib "Dnsapi" ( _
ByVal pDnsRecord As Long, _
ByVal DnsFreeRecordListDeep As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef pTo As Any, _
ByRef uFrom As Any, _
ByVal lSize As Long)
Private Declare Function StrCopyA Lib "kernel32" Alias "lstrcpyA" ( _
ByVal retval As String, _
ByVal PTR As Long) As Long
Private Declare Function StrLenA Lib "kernel32" Alias "lstrlenA" ( _
ByVal PTR As Long) As Long
Public Function IP2HostName(ByVal IP As String, ByRef HostName As String) As Long
Dim Octets() As String
Dim OctX As Long
Dim NumPart As Long
Dim BadIP As Boolean
Dim lngDNSRec As Long
Dim Record As VBDnsRecord
Dim Length As Long
'Returns DNS_STATUS Enum values, otherwise a DNS system error code.
IP = Trim$(IP)
If Len(IP) = 0 Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
Octets = Split(IP, ".")
If UBound(Octets) <> 3 Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
For OctX = 0 To 3
If IsNumeric(Octets(OctX)) Then
NumPart = CInt(Octets(OctX))
If 0 <= NumPart And NumPart <= 255 Then
Octets(OctX) = CStr(NumPart)
Else
BadIP = True
Exit For
End If
Else
BadIP = True
Exit For
End If
Next
If BadIP Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
IP = Octets(3) & "." & Octets(2) & "." & Octets(1) & "." & Octets(0) & ".IN-ADDR.ARPA"
IP2HostName = DnsQuery(IP, DNS_TYPE_PTR, DNS_QUERY_STANDARD, ByVal 0, lngDNSRec, 0)
If IP2HostName = DNS_STATUS_SUCCESS Then
If lngDNSRec <> 0 Then
CopyMemory Record, ByVal lngDNSRec, LenB(Record)
With Record
If .wType = DNS_TYPE_PTR Then
Length = StrLenA(.prt)
HostName = String$(Length, 0)
StrCopyA HostName, .prt
Else
IP2HostName = ERROR_NO_PTR_RETURNED
End If
End With
DnsRecordListFree lngDNSRec, DnsFreeRecordListDeep
Else
IP2HostName = ERROR_NO_RR_RETURNED
End If
'Else
'Return with DNS error code.
End If
End Function
Note however it does not handle NetBIOS names.
According to this Microsoft support article, the standard GetHostByAddr() functions should do it. Unfortunately, I can't find any examples of how to do a GetHostByAddr call in VB6, but perhaps someone else can help with that part. Alternately, you could run a commandline tool like nslookup:
bensonk#hunter ~/Desktop/cont $ nslookup 64.34.119.12
Server: 208.67.222.222
Address: 208.67.222.222#53
Non-authoritative answer:
12.119.34.64.in-addr.arpa name = stackoverflow.com.
That example was run on a linux machine, but the same command will work fine on windows.
MOST SIMPLE TECHNIQUE EVER
To send computer name ,
Do this:
Create a textbox,
Change its multiline property to true.
After that, in the text property of that textbox, write this:
echo %computername% >> C:\temp.txt
then, using Fileinput, input the textfile and input the textfile C:\temp.txt.
If you want to use this for sending over winsock or LAN, Send the text box text using winsock1.sendata
Done
Other than looping from 1 to 32 and trying open each of them, is there a reliable way to get COM ports on the system?
I believe under modern windows environments you can find them in the registry under the following key HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM. I'm not sure of the correct way to specify registry keys. However I have only ever tested this on Windows XP.
Check out this article from Randy Birch's site: CreateFile: Determine Available COM Ports
There's also the approach of using an MSCOMM control: ConfigurePort: Determine Available COM Ports with the MSCOMM Control
The code's a bit too long for me to post here but the links have everything you need.
It's 1 to 255. Fastest you can do it is using QueryDosDevice like this
Option Explicit
'--- for CreateFile
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = 3
Private Const INVALID_HANDLE_VALUE As Long = -1
'--- error codes
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_GEN_FAILURE As Long = 31&
Private Const ERROR_SHARING_VIOLATION As Long = 32&
Private Const ERROR_SEM_TIMEOUT As Long = 121&
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As Long, ByVal lpTargetPath As String, ByVal ucchMax As Long) 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 Function PrintError(sFunc As String)
Debug.Print sFunc; ": "; Error
End Function
Public Function IsNT() As Boolean
IsNT = True
End Function
Public Function EnumSerialPorts() As Variant
Const FUNC_NAME As String = "EnumSerialPorts"
Dim sBuffer As String
Dim lIdx As Long
Dim hFile As Long
Dim vRet As Variant
Dim lCount As Long
On Error GoTo EH
ReDim vRet(0 To 255) As Variant
If IsNT Then
sBuffer = String$(100000, 1)
Call QueryDosDevice(0, sBuffer, Len(sBuffer))
sBuffer = Chr$(0) & sBuffer
For lIdx = 1 To 255
If InStr(1, sBuffer, Chr$(0) & "COM" & lIdx & Chr$(0), vbTextCompare) > 0 Then
vRet(lCount) = "COM" & lIdx
lCount = lCount + 1
End If
Next
Else
For lIdx = 1 To 255
hFile = CreateFile("COM" & lIdx, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
If hFile = INVALID_HANDLE_VALUE Then
Select Case Err.LastDllError
Case ERROR_ACCESS_DENIED, ERROR_GEN_FAILURE, ERROR_SHARING_VIOLATION, ERROR_SEM_TIMEOUT
hFile = 0
End Select
Else
Call CloseHandle(hFile)
hFile = 0
End If
If hFile = 0 Then
vRet(lCount) = "COM" & lIdx
lCount = lCount + 1
End If
Next
End If
If lCount = 0 Then
EnumSerialPorts = Split(vbNullString)
Else
ReDim Preserve vRet(0 To lCount - 1) As Variant
EnumSerialPorts = vRet
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume Next
End Function
The snippet falls back to CreateFile on 9x. IsNT function is stubbed for brevity.
Using VB6 or VBScript to enumerate available COM ports can be as simple as using VB.NET, and this can be done by enumerating values from registry path HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM. It's better than calling QueryDosDevice() and doing string comparison to filter out devices which's name is leading by COM since you will get something like CompositeBattery (or other stuff which have full upper case name leading by COM) that isn't a COM port. Another benefit of doing this is that the registry values also containing USB to COM devices, which could not be detected by using the codes such as WMIService.ExecQuery("Select * from Win32_SerialPort"). If you try to plug the USB to COM devices in or out of the computer, you can see the registry values also appear or disappear immediately, since it's keeping updated.
Option Explicit
Sub ListComPorts()
List1.Clear
Dim Registry As Object, Names As Variant, Types As Variant
Set Registry = GetObject("winmgmts:\\.\root\default:StdRegProv")
If Registry.EnumValues(&H80000002, "HARDWARE\DEVICEMAP\SERIALCOMM", Names, Types) <> 0 Then Exit Sub
Dim I As Long
If IsArray(Names) Then
For I = 0 To UBound(Names)
Dim PortName As Variant
Registry.GetStringValue &H80000002, "HARDWARE\DEVICEMAP\SERIALCOMM", Names(I), PortName
List1.AddItem PortName & " - " & Names(I)
Next
End If
End Sub
Private Sub Form_Load()
ListComPorts
End Sub
The code above is using StdRegProv class to enumerate the values of a registry key. I've tested the code in XP, Windows 7, Windows 10, and it works without any complainant. The items which were added to the Listbox looks like below:
COM1 - \Device\Serial0
COM3 - \Device\ProlificSerial0
The downside of this code is that it could not detect which port is already opened by other programs since every port could only be opened once. The way to detect a COM port is opened by another program or not can be done by calling the API CreateFile. Here is an example.
I am trying to set a custom paper size by doing:
Printer.Height = 2160
Printer.Width = 11900
But it doesn't seen to have any effect. After setting this up, i ask for that values and it returns the default ones. And this:
Printer.PaperSize = 256
Returns an error...
Any ideas??
Either your printer doesn't allow these properties to be set, or you're exceeding their maximum allowed values. From the Visual Basic Reference
If you set the Height and Width
properties for a printer driver that
doesn't allow these properties to be
set, no error occurs and the size of
the paper remains as it was. If you
set Height and Width for a printer
driver that allows only certain values
to be specified, no error occurs and
the property is set to whatever the
driver allows. For example, you could
set Height to 150 and the driver would
set it to 144.
I don't know why you're getting an error when you set the Papersize property to 256. It works for me. Also, the documentation states, "Setting a printer's Height or Width property automatically sets PaperSize to vbPRPSUser.", which equals 256.
I was actually involved with the same problem but I just happen to find a breakthrough.
First you need to create a custom form that defines you custom paper size. Then, you need to
refer to Windows API to check the form name you've just created. You'll get the for name
from an array returned from a function and use the array index where the form name was found.
Finally use it as the value for printer.papersize
Example below:
Public Type PRINTER_DEFAULTS
pDatatype As Long
pDevMode As Long
DesiredAccess As Long
End Type
Public Type FORM_INFO_1
Flags As Long
pName As Long ' String
Size As SIZEL
ImageableArea As RECTL
End Type
Public Declare Function EnumForms Lib "winspool.drv" Alias "EnumFormsA" _
(ByVal hPrinter As Long, ByVal Level As Long, ByRef pForm As Any, _
ByVal cbBuf As Long, ByRef pcbNeeded As Long, _
ByRef pcReturned As Long) As Long
Public Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
Public Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Public Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" _
(ByVal lpString1 As String, ByRef lpString2 As Long) As Long
'UDF
Public Function PtrCtoVbString(ByVal Add As Long) As String
Dim sTemp As String * 512, x As Long
x = lstrcpy(sTemp, ByVal Add)
If (InStr(1, sTemp, Chr(0)) = 0) Then
PtrCtoVbString = ""
Else
PtrCtoVbString = Left(sTemp, InStr(1, sTemp, Chr(0)) - 1)
End If
End Function
Public Function IsFormExist(ByVal DeviceName As String, ByVal isFormName As String, ByVal PrinterHandle As Long) As Long
Dim NumForms As Long, i As Long
Dim FI1 As FORM_INFO_1
Dim pd As PRINTER_DEFAULTS
Dim aFI1() As FORM_INFO_1 ' Working FI1 array
Dim Temp() As Byte ' Temp FI1 array
Dim FormIndex As Integer
Dim BytesNeeded As Long
Dim RetVal As Long
On Error GoTo cleanup
FormIndex = 0
ReDim aFI1(1)
' First call retrieves the BytesNeeded.
RetVal = OpenPrinter(DeviceName, PrinterHandle, pd)
If (RetVal = 0) Or (PrinterHandle = 0) Then
'Can't access current printer. Bail out doing nothing
Exit Function
End If
RetVal = EnumForms(PrinterHandle, 1, aFI1(0), 0&, BytesNeeded, NumForms)
ReDim Temp(BytesNeeded)
ReDim aFI1(BytesNeeded / Len(FI1))
' Second call actually enumerates the supported forms.
RetVal = EnumForms(PrinterHandle, 1, Temp(0), BytesNeeded, BytesNeeded, _
NumForms)
Call CopyMemory(aFI1(0), Temp(0), BytesNeeded)
For i = 0 To NumForms - 1
With aFI1(i)
If isFormName = PtrCtoVbString(.pName) Then
' Found the desired form
FormIndex = i + 1
Exit For
End If
End With
Next i
IsFormExist = FormIndex ' Returns the number when form is found.
cleanup:
'Release the printer handle
If (PrinterHandle <> 0) Then Call ClosePrinter(PrinterHandle)
End Function
'Here We Go
dim papercode as long, printername as string, formname as string
printername=printer.Devicename
formname = "myform"
papercode=IsFormExist(printername, formname, Printer.hdc)
if papercode<>0 then
printer.papersize=papercode
end if
Give it a try, good luck
Are you sure the error isn't related to the maximum print width of the printer itself? Many printers have a max print width of 8.25" (11880) to allow 1/4" margins on either side of a 8.5" wide paper.
Quickest way to check would be to simply set the print wide to 11880 or lower and see if it works.
Another possibility would be permissions to the printer. If it's a shared network resource it may be locked down.
The solution is to use windows 98. It does not work with win2k, neither winXP. The same code, the same printer.
Regards.
I'm testing this code, but I can not see the custom form I created using printers and scanners in the Control Panel Windows XP Professional SP3.
Note: I could check in regedit that this form exists and its ID is 512 in a string value and it contains the name of the form created in the printers control panel.
Why this function does not return my custom form, I am using an HP Laserjet 1020.
I am using GetTokenInformation as a part of the code that determines if the current thread is running as an Administrator.
Anyway, I have a structure for TOKEN INFORMATION that looks like this:
Private Type TOKEN_GROUPS
GroupCount As Long
Groups(500) As SID_AND_ATTRIBUTES
End Type
Then, I invoke GetTokenInformation like so:
res = GetTokenInformation(<Process Handle>, 2, <TOKEN_GROUPS>, _
<Token Info Length>, <Buffer Length)
The first invocation is to get the Buffer Length, then I invoke it again to get the token information.
Anyway, the application will suddenly crash when the account that run the application is connected to a domain. Apparently, the size of the,
Groups(500) As SID.AND.ATTRIBUTES
is not enough and is causing a buffer overrun. I don't know why that is (MSDN says that I should provide an ANYSIZE_ARRAY or 1). Increasing the size of the Groups to 1000 fixes the problem.
As a quick fix and since I don't have an idea on how to get the appropriate size of Groups, I am planning to just ReDim the Groups until the call succeeds.
Here's my question:
I have an On Error clause, but when the buffer overrun occurs, the On Error can't catch it and my app suddenly crashes. Why is that?
Given the code below
Private Type TOKEN_GROUPS
GroupCount As Long
Groups() As SID_AND_ATTRIBUTES 'FAILING
'Groups(1000) As SID_AND_ATTRIBUTES DOES NOT FAIL
End Type
Dim X as TOKEN_GROUPS
ReDim Preserve X.Groups(1000) As SID_AND_ATTRIBUTES 'FAILING
res = GetTokenInformation(<Process Handle>, 2, <TOKEN_GROUPS>, <Token Info Length>, <Buffer Length)
res = GetTokenInformation(<Process Handle>, 2, <TOKEN_GROUPS>, <Token Info Length>, <Buffer Length)
Why is that when I declared Groups as 1000, the GetTokenInformation call is not failing but when I declared an "empty" Groups() and ReDim'd it to 1000, it is failing?
If you want to use dynamicly sized array for Groups you'll need "custom API call marshaling" code. Basicly couple of CopyMemory's and an array resize
Option Explicit
'--- for OpenProcessToken
Private Const TOKEN_READ As Long = &H20008
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
Private Type SID_AND_ATTRIBUTES
Sid As Long
Attributes As Long
End Type
Private Type VB_TOKEN_GROUPS
GroupCount As Long
Groups() As SID_AND_ATTRIBUTES
End Type
Private Sub Command1_Click()
Dim hProcessID As Long
Dim hToken As Long
Dim lNeeded As Long
Dim baBuffer() As Byte
Dim uGroups As VB_TOKEN_GROUPS
hProcessID = GetCurrentProcess()
If hProcessID <> 0 Then
If OpenProcessToken(hProcessID, TOKEN_READ, hToken) = 1 Then
Call GetTokenInformation(hToken, 2, ByVal 0, 0, lNeeded)
ReDim baBuffer(0 To lNeeded)
'--- enum TokenInformationClass { TokenUser = 1, TokenGroups = 2, ... }
If GetTokenInformation(hToken, 2, baBuffer(0), UBound(baBuffer), lNeeded) = 1 Then
Call CopyMemory(uGroups.GroupCount, baBuffer(0), 4)
ReDim uGroups.Groups(0 To uGroups.GroupCount - 1)
Call CopyMemory(uGroups.Groups(0), baBuffer(4), uGroups.GroupCount * Len(uGroups.Groups(0)))
End If
Call CloseHandle(hToken)
End If
Call CloseHandle(hProcessID)
End If
End Sub
There is another question here that seems to have solved the GetTokenInformation call.
Copied from the accepted answer:
Call GetTokenInformation(hToken, 1, ByVal 0, 0, lNeeded)
ReDim baBuffer(0 To lNeeded)
...