I am writing a VB6 program and need some help with the syntax of the PlaySound function declaration. I have written the attached snippet and it succeeds in playing Tada.wav but does not reflect all the flags.
Can I have more than one dwFlag, or am I limited to just one ?
I would like dwFlags to include SND_ASYNC, SND_FILENAME and SND_LOOP.
Here is the code I have tried so far:
Dim RetVal As Variant
Private Const SND_ASYNC As Long = &H80
Private Const SND_FILENAME As Long = &H20000
Private Const SND_LOOP As Long = &H8
Private Declare Function PlaySound Lib "winmm.dll" Alias _
"PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, _
ByVal dwFlags As Long) As Long
Private Sub Command3_Click()
RetVal = PlaySound("C:\Program Files\#VickEdu\Vocab!\Tada.wav",_
0&,_
SND_FILENAME Or SND_ASYNC Or SND_LOOP)
End Sub
Private Sub Command4_Click()
RetVal = PlaySound("C:\Program Files\#VickEdu\Vocab!\Tada.wav",_
0&, _
SND_FILENAME & SND_ASYNC & SND_LOOP)
End Sub
The way you've done it in your Command3 handler is correct (using Or).
Your issue is that you've defined the wrong value for SND_ASYNC. Change:
Private Const SND_ASYNC As Long = &H80
to:
Private Const SND_ASYNC As Long = &H1
Many thanks for your generosity in responding. After reading your remarks I encountered some additional information on my question at the following link http://www.vb6.us/tutorials/playsound-api.
It stated: "The only "gotcha" with Playsound is the creation of dwFlag. It is possible to add too many flags, which will result in an overflow error."
It then went on to give a useful discussion of the meaning of the available flags.
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
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 want to send Close Messge To Other Running Process
For that i have the name of that process
Not Process ID
Assuming you're using VB 6 (because you didn't specify .NET), you could the following code:
''#Module-level WinAPI Declarations
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * 260
End Type
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32.dll" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32.dll" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32.dll" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
''#Public function to actually kill a process, given its name
Public Sub KillProcess(ByVal ProcessName As String)
Dim uProcess As PROCESSENTRY32
Dim RProcessFound As Long
Dim hSnapshot As Long
Dim SzExeName As String
Dim ExitCode As Long
Dim MyProcess As Long
Dim AppKill As Boolean
Dim AppCount As Integer
Dim i As Integer
If LenB(ProcessName) <> 0 Then
AppCount = 0
uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
RProcessFound = ProcessFirst(hSnapshot, uProcess)
Do
i = InStr(1, uProcess.szexeFile, Chr(0))
SzExeName = LCase$(Left$(uProcess.szexeFile, i - 1))
If Right$(SzExeName, Len(ProcessName)) = LCase$(ProcessName) Then
AppCount = AppCount + 1
MyProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
AppKill = TerminateProcess(MyProcess, ExitCode)
Call CloseHandle(MyProcess)
End If
RProcessFound = ProcessNext(hSnapshot, uProcess)
Loop While RProcessFound
Call CloseHandle(hSnapshot)
End If
End Sub
Basically what this code does is enumerate all currently running processes in order to find the one you want to kill. The CreateToolHelpSnapshot API function returns a snapshot of the processes, and then we loop through this snapshot with the Process32First and Process32Next functions. When it finds a match to the name you specified, it uses the TerminateProcess function to terminate that process and all of its threads. Note that this is untested on post-XP versions of Windows.
If you speak Win32 fluently, see the following MSDN article: Taking a Snapshot and Viewing Processes
Lots of the examples you find on the Internet (i.e., option one, option two) use EnumWindows to send a WM_CLOSE message to the windows associated with a particular process. The advantage of this is that it asks nicely—sending the WM_CLOSE message gives the process a chance to save any data and exit gracefully. TerminateProcess, as used in the above example, is not so nice—it's an instant buzz-kill. But it will allow you to end processes that don't own any windows. You didn't mention if this was a requirement in the question.
(Honestly, there isn't enough detail in the question for me to have any business trying to answer this question, but I'm procrastinating. If you need anything else, please edit your question to include more details and add a comment to let me know...)
I know how to look up a hostname from an IPv4 in VB using the GetHostByAddr Windows API call (this works great). However, that function does not allow one to specify the DNS server to use. Sometimes the default company DNS servers are fine, but other times I need to specify an external DNS server for lookups, and I don't think doing a shell nslookup and parsing the output is the best method, here.
Note: this is actually going to be used as VBA code in an Excel workbook to help someone else do his job, and it's not worth writing a big application when some simple functionality is all he needs.
I thought I had possibly found an answer in the API call getnameinfo but careful reading seems to indicate it does not offer a servername parameter.
After some intense searching, I found reference to the pExtra parameter to the DNSQuery function. But I don't even know how to begin to use that in VB6.
Could anyone help me out in any way with doing a DNS lookup from VB6, specifying the servername to use?
A full working solution would of course be nice, but I'm willing to work: just point me in the right direction.
UPDATE: For some odd reason it didn't click that DNSQuery was a Windows API call. It just didn't sound like one. I certainly would have been able to make more headway on the problem if I'd gathered that one tiny detail.
Try this:
Option Explicit
Private Declare Function DnsQuery Lib "dnsapi" Alias "DnsQuery_A" (ByVal strname As String, ByVal wType As Integer, ByVal fOptions As Long, ByVal pServers As Long, ppQueryResultsSet As Long, ByVal pReserved As Long) As Long
Private Declare Function DnsRecordListFree Lib "dnsapi" (ByVal pDnsRecord As Long, ByVal FreeType As Long) As Long
Private Declare Function lstrlen Lib "kernel32" (ByVal straddress As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal pIP As Long) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal sAddr As String) As Long
Private Const DnsFreeRecordList As Long = 1
Private Const DNS_TYPE_A As Long = &H1
Private Const DNS_QUERY_BYPASS_CACHE As Long = &H8
Private Type VBDnsRecord
pNext As Long
pName As Long
wType As Integer
wDataLength As Integer
flags As Long
dwTel As Long
dwReserved As Long
prt As Long
others(35) As Byte
End Type
Private Sub Command1_Click()
MsgBox Resolve("google.com", "208.67.222.222")
End Sub
Private Function Resolve(sAddr As String, Optional sDnsServers As String) As String
Dim pRecord As Long
Dim pNext As Long
Dim uRecord As VBDnsRecord
Dim lPtr As Long
Dim vSplit As Variant
Dim laServers() As Long
Dim pServers As Long
Dim sName As String
If LenB(sDnsServers) <> 0 Then
vSplit = Split(sDnsServers)
ReDim laServers(0 To UBound(vSplit) + 1)
laServers(0) = UBound(laServers)
For lPtr = 0 To UBound(vSplit)
laServers(lPtr + 1) = inet_addr(vSplit(lPtr))
Next
pServers = VarPtr(laServers(0))
End If
If DnsQuery(sAddr, DNS_TYPE_A, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then
pNext = pRecord
Do While pNext <> 0
Call CopyMemory(uRecord, pNext, Len(uRecord))
If uRecord.wType = DNS_TYPE_A Then
lPtr = inet_ntoa(uRecord.prt)
sName = String(lstrlen(lPtr), 0)
Call CopyMemory(ByVal sName, lPtr, Len(sName))
If LenB(Resolve) <> 0 Then
Resolve = Resolve & " "
End If
Resolve = Resolve & sName
End If
pNext = uRecord.pNext
Loop
Call DnsRecordListFree(pRecord, DnsFreeRecordList)
End If
End Function
It is not an answer, but very important note to wqw post:
Security Warning on lstrlen function (lines 5 & 55):
Using this function incorrectly can compromise the security of your
application. lstrlen assumes that lpString is a null-terminated
string, or NULL. If it is not, this could lead to a buffer overrun or
a denial of service attack against your application.
Consider using one of the following alternatives: StringCbLength or
StringCchLength.
You can use the DNS WMI provider to set the DNS of the system then use GetHostByAddr
I am displaying Japanese characters in a VB6 application with the system locale set to Japan and the language for non Unicode programs as Japanese. A call to GetACP() correctly returns 932 for Japanese. When I insert the Japanese strings into my controls they display as “ƒAƒtƒŠƒJ‚Ì—‰¤” rather than “アフリカの女王”. If I manually set the Font.Charset to 128 then they display correctly.
What is the best way to determine the correct Charset for a given LCID in VB6?
Expanding Bob's answer, here's some code to get the current default charset.
Private Const LOCALE_SYSTEM_DEFAULT As Long = &H800
Private Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004
Private Const TCI_SRCCODEPAGE = 2
Private Type FONTSIGNATURE
fsUsb(4) As Long
fsCsb(2) As Long
End Type
Private Type CHARSETINFO
ciCharset As Long
ciACP As Long
fs As FONTSIGNATURE
End Type
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" ( _
ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long _
) As Long
Private Declare Function TranslateCharsetInfo Lib "GDI32" ( _
lpSrc As Long, _
lpcs As CHARSETINFO, _
ByVal dwFlags As Long _
) As Long
Public Function GetCharset() As Long
On Error GoTo ErrorHandler
Dim outlen As Long
Dim lCodepage As Long
Dim outBuffer As String
Dim cs As CHARSETINFO
outBuffer = String$(10, vbNullChar)
outlen = GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_IDEFAULTANSICODEPAGE, outBuffer, Len(outBuffer))
If outlen > 0 Then
lCodepage = val(Left$(outBuffer, outlen - 1))
If TranslateCharsetInfo(ByVal lCodepage, cs, TCI_SRCCODEPAGE) Then
GetCharset = cs.ciCharset
End If
End If
Exit Function
ErrorHandler:
GetCharset = 0
End Function
See http://www.microsoft.com/globaldev/drintl/columns/014/default.mspx#E5B
The second best way is to use a database of fonts, font.charsets, and heuristics, such as is done here:
http://www.example-code.com/vb/vb6-display-unicode.asp
(The best way is to get off the sinking ship that is VB6)