Related
I have been working on an Access Database where the user can click a button and the code will access the "webcam" present on the computer and then proceed to take a picture. The code works fine on regular laptops but I tried running it on a Laptop/Tablet hybrid (Latitude 5290 2-in-1 Laptop) and for whatever reason, the code does not access the camera at all.
I downloaded a third party app called Dorgem and tried to access the camera but got an error saying "Failed to connect to device." To me, it sounds like a permission issue but I made sure that camera permission is enabled in settings (https://www.tenforums.com/tutorials/71414-allow-deny-os-apps-access-camera-windows-10-a.html). I strongly believe that it is still a permission issue but I cannot find a way around it. I would really appreciate if I can get some input on how to solve this issue.
Here is the code I have been using in access.
Option Compare Database
Option Explicit
Public ImageLocation As String
Public AttachmentIndicator As String
Const WS_CHILD As Long = &H40000000
Const WS_VISIBLE As Long = &H10000000
Const WM_USER As Long = &H400
Const WM_CAP_START As Long = WM_USER
Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Private Declare PtrSafe Function capCreateCaptureWindow _
Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _
(ByVal lpszWindowName As String, ByVal dwStyle As Long _
, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long _
, ByVal nHeight As Long, ByVal hwndParent As LongPtr _
, ByVal nID As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
, ByVal wParam As Long, ByRef lParam As Any) As Long
Dim hCap As LongPtr
Private Sub TakePictureButton_Click()
Dim sFileName As String
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
sFileName = "C:\Users\212764307\Documents\" & Forms!IRForm.IRNO & ".jpg"
ImageLocation = sFileName
Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End Sub
Private Sub Cmd3_Click()
Dim Temp As Long
Temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
DoCmd.Close
End Sub
Private Sub StartCameraButton_Click()
hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0)
If hCap <> 0 Then
Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End If
End Sub
Private Sub Cmd2_Click()
Dim Temp As Long
Temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub
Private Sub Form_Load()
StartCameraButton.Caption = "Start Camera"
cmd2.Caption = "&Format Cam"`enter code here`
cmd3.Caption = "&Close Cam"
TakePictureButton.Caption = "&Take Picture"
End Sub'
Use newest version of avicap32.dll (copy to windows\system32 and windows\sysWOW64 directories,also check camera drivers, there is always problem on them with avicap.
newly signed up desperate user here.
I left the programming business quite a while ago but now and then get asked to make some enhancements etc.
I want to use the registry to store some file locations so the user doesn't have to specify them all the time. I want to store them under HKEY_LOCAL_MACHINE because there are multiple users.
I have got the key created using RegCreateKeyEx, and a value has been entered into the key, with RegSetValueExString, so there is a key under HKEY_LOCAL_MACHINE called SUPPLIERFILE and it has the value "C:\Documents and Settings.." etc.
However when I use RegQueryValueExString it doesn't work: the lpValue string is empty, although the cbdata does contain the length of the string I was expecting to find there. The error retured is 234, ERROR_MORE_DATA.
I have tried using RegGetValue, because I thought maybe a non-null terminated string was the problem, but I haven't got RegGetValue in the api dll.
Any suggestions would be gratefully received, even along the lines of how to terminate a string with a null.
Thanks,
Steve
Your error indicates you have not initialized a large enough string buffer for the API function to use, but without your code, ??? I pulled the code below from a registry utility class I use. I think I have included all the API declarations, and constants used, as well as a method to translate returned errors to something helpful.
Public Enum RegRootKey
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
'the following declare is used to return windows error descriptions
Private Declare Function FormatMessage Lib "Kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
'key constants
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS = 0&
Private Const SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const READ_WRITE = 2
Private Const READAPI = 0
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7 ' Multiple Unicode strings
Private Const REG_NONE = 0 ' No value type
Private Const KEY_WOW64_64KEY As Long = &H100& '32 bit app to access 64 bit hive
Private Const KEY_WOW64_32KEY As Long = &H200& '64 bit app to access 32 bit hive
'API declarations
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RootKeyName Lib "advapi32.dll" Alias "RootKeyNameA" (ByVal lphKey As RegRootKey) As String
Public Function GetStringValue(ByVal hKeyRoot As RegRootKey, ByVal hKeySubKey As String, ByVal ValueName As String, Optional ByVal Default As String) As String
Dim strReturn As String
Dim strBuffer As String
Dim lngType As Long
Dim lngBufLen As Long
Dim lngRst As Long
Dim hKeyHandle As Long
On Error GoTo errGetStringValue
'just to avoid any errors in calling functions using a ubound to check the contents
strBuffer = String(255, vbNullChar)
lngBufLen = Len(strBuffer)
lngRst = RegOpenKeyEx(hKeyRoot, hKeySubKey, 0, KEY_READ Or KEY_WOW64_64KEY, hKeyHandle)
If hKeyHandle <> 0 Then
If StrComp(ValueName, "default", vbTextCompare) = 0 Then
lngRst = RegQueryValueEx(hKeyHandle, "", ByVal 0&, lngType, ByVal strBuffer, lngBufLen)
Else
lngRst = RegQueryValueEx(hKeyHandle, ValueName, ByVal 0&, lngType, ByVal strBuffer, lngBufLen)
End If
End If
If lngRst = 0 Then
If lngType = REG_SZ Then
If lngBufLen > 0 Then
strReturn = Left$(strBuffer, lngBufLen - 1)
Else
strReturn = Default
End If
Else
Err.Raise 1, App.EXEName, FormatClassError(1)
End If
ElseIf lngRst = 2 Then 'the key does not exists so return the default
strReturn = Default
Else 'if the return is non-zero there was an error
Err.Raise lngRst, App.EXEName, "There was an error reading the " & RootKeyName(hKeyRoot) & "\" & _
hKeySubKey & " registry key, " & LCase$(FormatClassError(lngRst))
End If
If hKeyHandle <> 0 Then
lngRst = RegCloseKey(hKeyHandle)
hKeyHandle = 0
End If
GetStringValue = strReturn
Exit Function
errGetStringValue:
If hKeyHandle <> 0 Then
lngRst = RegCloseKey(hKeyHandle)
hKeyHandle = 0
End If
Err.Raise Err.Number, Err.Source & ":GetStringValue", Err.Description
End Function
Private Function FormatClassError(ByVal ErrorNumber As Long) As String
Dim strReturn As String
Dim strBuffer As String
Dim lngBufLen As Long
Dim lngRst As Long
On Error Resume Next
'initialize the buffer to to API function
strBuffer = String(1024, vbNullChar)
lngBufLen = Len(strBuffer)
'make the call to the API function
lngRst = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, ErrorNumber, ByVal 0&, strBuffer, lngBufLen, ByVal 0&)
'if the return value is <> 0 then we have a valid message
If lngRst <> 0 Then
strReturn = Left$(strBuffer, lngRst)
Else
'make another call to the API function with the last dll error
lngRst = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, Err.LastDllError, ByVal 0&, strBuffer, lngBufLen, ByVal 0&)
If lngRst <> 0 Then
strReturn = Left$(strBuffer, lngRst)
Else
strReturn = "Unable to retrieve error description."
End If
End If
'return the result
FormatClassError = strReturn
End Function
Quick answer: try the GetRegStringValue$ code here
In case you (or others) want to know more
When you call that API, as with many windows APIs you are supposed to provide a buffer (string) to hold the registry value, and you are supposed to pass in the maximum size of your buffer.
MSDN explains
If the buffer specified by lpData parameter is not large enough to hold the data, the function returns ERROR_MORE_DATA and stores the required buffer size in the variable pointed to by lpcbData. In this case, the contents of the lpData buffer are undefined.
You need to allocate a buffer (probably fill your string with spaces) and pass in the size in lpData.
you should check first, if the Registry is really do exist or not. By error handling, we can check for the Registry key Entry.
Private Function RegOSInfo(RegPath As String, RegKey As String) As String
On Error GoTo ErrHandler
Dim osName As String
Dim Reg As Object
Set Reg = CreateObject("WScript.Shell")
RegOSInfo = Reg.RegRead(RegPath & "\" & RegKey)
ErrHandler:
RegOSInfo = "-555" 'custom Error Code, Registry key doesn't exist
End Function
you can handle the Custom error code according to your need.
Help I am making a word processor and have a custom file extension to save it with but when I save that file and use open with select my program's exe then open it, the program opens with blank text how would I get it to open my text from double click in windows explorer
Inside your code use the following (no way to make it pretty but it works fine, copy and paste)
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_BADDB = 1&
Private Const ERROR_BADKEY = 2&
Private Const ERROR_CANTOPEN = 3&
Private Const ERROR_CANTREAD = 4&
Private Const ERROR_CANTWRITE = 5&
Private Const ERROR_OUTOFMEMORY = 6&
Private Const ERROR_INVALID_PARAMETER = 7&
Private Const ERROR_ACCESS_DENIED = 8&
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_CREATE_SUB_KEY = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const KEY_SET_VALUE = &H2&
Private Const MAX_PATH = 260&
Private Const REG_DWORD As Long = 4
Private Const REG_SZ = 1
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Sub MakeFileAssociation(Extension As String, PathToApplication As String, ApplicationName As String, Description As String, Optional FullIconPath As String)
Dim ret&
If Left(PathToApplication, 1) <> "\" Then PathToApplication = PathToApplication & "\"
'Create a Root entry called .XXX associated with application name
sKeyName = "." & Extension
sKeyValue = ApplicationName
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
'Set application key and file description
sKeyName = ApplicationName
sKeyValue = Description
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
'This sets the default icon for XXX_auto_file
If FullIconPath <> "" Then
sKeyName = ApplicationName & "\DefaultIcon"
sKeyValue = FullIconPath & ",0"
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
End If
'This sets the command line for XXX_auto_file
sKeyName = ApplicationName & "\shell\open\command"
sKeyValue = Chr(34) & PathToApplication & ApplicationName & ".exe" & Chr(34) & " %1"
ret& = WriteKey(HKEY_CLASSES_ROOT, sKeyName, "", sKeyValue)
End Sub
Public Sub DeleteFileAssociation(Extension As String)
Dim Application As String
Dim ret&
'check if filetype is registred
Application = ReadKey(HKEY_CLASSES_ROOT, "." & Extension, "", "")
If Application <> "" Then
'delete file extension
ret& = DeleteKey(HKEY_CLASSES_ROOT, "." & Extension)
'delete command lines
ret& = DeleteKey(HKEY_CLASSES_ROOT, Application)
End If
End Sub
Public Function CheckFileAssociation(ByVal Extension As String) As String
Extension = "." & Extension
'read in the program name associated with this filetype
CheckFileAssociation = ReadKey(HKEY_CLASSES_ROOT, Extension, "", "")
End Function
Public Function ReadKey(ByVal KeyName As String, ByVal SubKeyName As String, ByVal ValueName As String, ByVal DefaultValue As String) As String
Dim sBuffer As String
Dim lBufferSize As Long
Dim ret&
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
ret& = RegOpenKey(KeyName, SubKeyName, 0, KEY_READ, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegQueryValue(lphKey&, ValueName, 0, REG_SZ, sBuffer, lBufferSize)
ret& = RegCloseKey(lphKey&)
Else
ret& = RegCloseKey(lphKey&)
End If
sBuffer = Trim(sBuffer)
If sBuffer <> "" Then
sBuffer = Left(sBuffer, Len(sBuffer) - 1)
Else
sBuffer = DefaultValue
End If
ReadKey = sBuffer
End Function
Public Function WriteKey(ByVal KeyName As String, ByVal SubKeyName As String, ByVal ValueName As String, ByVal KeyValue As String) As Long
Dim ret&
ret& = RegCreateKey&(KeyName, SubKeyName, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegSetValue&(lphKey&, ValueName, REG_SZ, KeyValue, 0&)
Else
ret& = RegCloseKey(lphKey&)
End If
WriteKey = ret&
End Function
Public Function DeleteKey(ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim ret&
ret& = RegOpenKey(KeyName, SubKeyName, 0, KEY_WRITE, lphKey&)
If ret& = ERROR_SUCCESS Then
ret& = RegDeleteKey(lphKey&, "") 'delete the key
ret& = RegCloseKey(lphKey&)
End If
DeleteKey = ret&
End Function
Then you can call them and provide the parameter and it will create it for you, delete it and check it. As for handing it via your application when you open the file using the extension, you need to make sure you have a command line parser and feed it with a %1 and use that file name to open the document within your program. That's it.
You can create a main() and set your program startup to use that instead of the usual form1 and inside that put:
Public Sub main()
'Store command line arguments in this array
Dim sArgs() As String
Dim iLoop As Integer
'Assuming that the arguments passed from
'command line will have space in between,
'you can also use comma or other things...
sArgs = Split(Command$, " ")
For iLoop = 0 To UBound(sArgs)
'this will print the command line
'arguments that are passed from the command line
Debug.Print sArgs(iLoop)
Next
End Sub
Depending on what arguments you are passing to the command of your program, you would replace the debug line with the path to the file you just opened with your program and do what you do with it in your application.
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
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.