I have been trying to find out why in the following code, the third time through the loop I am getting a Error type 13 Mismatch when the line "For lCount = 0 To maxCount" is being evaluated. I had originally thought the problem was in getting the value from the vArray, but testing shows it to be triggered by the "For" line. I haven't a clue as to how the type would be changing during the processing of the loop. Thanks!
Public Function FindCodeIndex(vArray As Variant, MatchValue As String) As Integer
''This function locates a value in a combo box returning the index or -1 if not found
Dim lCount As Long
Dim maxCount As Long
Dim arrayStr As String
On Error GoTo ErrorHandler
maxCount = UBound(vArray)
For lCount = 0 To maxCount
arrayStr = vArray(1, lCount)
If UCase$(arrayStr) = UCase$(MatchValue) Then
FindCodeIndex = Int(lCount)
Exit Function
End If
Next lCount
FindCodeIndex = -1
Exit Function
ErrorHandler:
MsgBox "Unexpected error in frmComment::FindCodeIndex()" & vbCrLf & _
"Error Code: " & CStr(Err.Number) & " Error Desc: " & Err.Description
Public Function FindCodeIndex(Array() As String, ByVal MatchValue As String) As Long
Dim index As Long
Dim upper_bound As Long
upper_bound= UBound(Array)
MatchValue = UCase(MatchValue)
For index = 0 To upper_bound
If UCase(Array(index)) = MatchValue Then
FindCodeIndex = index
Exit Function
End If
Next index
FindCodeIndex = -1
End Function
The function mentions that the code is being written for a ComboBox (are you actually copying each item in the List() method into an array and sending this to your function?). This seems a little over-complicated if you are using the standard VB ComboBox. Just use the following code:
Private Declare Function SendMessage Lib "User32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal uMsg As Long, ByRef wParam As Any, ByRef lParam As Any) As Long
Private Const CB_FINDSTRINGEXACT As Long = &H158
Public Function FindCodeIndex(ByRef cmb As ComboBox, ByRef sMatchValue As String) As Long
'This function locates a value in a combo box returning the index or -1 if not found
FindCodeIndex = SendMessage(cmb.hWnd, CB_FINDSTRINGEXACT, ByVal -1, ByVal sMatchValue
End Function
It is a lot quicker and smaller to use the Windows API in this case.
Related
I want to decode a string (which I got via readAsDataUrl()) to bytes.
At first, I remove the data:*/*;base64, then I call the following:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
'within the following call, VB6 crashes:
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Now I call this:
Dim s$
'code to get base64 string
'code to strip for example "data:image/jpeg;base64,"
Dim nBytes() As Byte
nBytes = DecodeBase64(s) 'Here VB6 crashes
Edit:
I am using the following alternative version now, and it works, but I wonder what the error is:
Public Function DecodeBase64(ByVal sBase64Buf As String) As Byte()
Const CRYPT_STRING_BASE64 As Long = 1
Const CRYPT_STRING_NOCRLF As Long = &H40000000
Dim bTmp() As Byte
Dim lLen As Long
Dim dwActualUsed As Long
'Get output buffer length
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
'RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
End If
'Convert Base64 to binary.
ReDim bTmp(lLen - 1)
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
'RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
Else
'm_bData = bTmp
End If
ReleaseHandles:
DecodeBase64 = bTmp
End Function
Edit:
In version 1, dwBinaryBytes is 156080 in this line:
dwBinaryBytes = LenB(strData)
and in version 2, lLen is 58528 in this line:
ReDim bTmp(lLen - 1)
Why the discrepancy, and why didn't the author notice that?
The "CryptStringToBinaryW" requires the number of characters in the string as a parameter. That is returned by the "Len" function. You used the "LenB" function which returns the number of bytes in the string which is larger than the number of characters in the string so the function attempted to access memory past the end of the string which caused the crash.
I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function
I have a listbox with a few thousand items. The code below given by #AngryHacker in this threat work perfect if i want to get the 1st match. But sometimes i have multiple items with the same data. So, i'd like to get all the match, how to do it?
oh, actually, its something like this:
aa4
sds
aa5
aa6
fdf
dsf
From the list, i want to get the index of the items starting with "aa"
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As _
Integer, ByVal lParam As Any) As Long
'constants for searching the ListBox
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_FINDSTRING = &H18F
'function to get find an item in the Listbox
Public Function GetListBoxIndex(hWnd As Long, SearchKey As String, Optional FindExactMatch As Boolean = True) As Long
If FindExactMatch Then
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRINGEXACT, -1, ByVal SearchKey)
Else
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRING, -1, ByVal SearchKey)
End If
End Function
You can utilize the fact that wParam for LB_FINDSTRING and LB_FINDSTRINGEXACT messages lets the caller to specify the first item to be searched:
wParam
The zero-based index of the item before the first item to be searched. When the search reaches the bottom of the list box, it continues searching from the top of the list box back to the item specified by the wParam parameter. If wParam is – 1, the entire list box is searched from the beginning.
So your GetListBoxIndex takes the following form (note StartIndex argument instead of hardcoded -1):
'LB_ constants
Private Const LB_ERR = -1
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "USER32" _
Alias "SendMessageA" (ByVal hWnd As Long _
, ByVal wMsg As Long _
, ByVal wParam As Integer _
, ByVal lParam As Any) As Long
Public Function GetListBoxIndex(hWnd As Long _
, SearchKey As String _
, StartIndex As Long _
, Optional FindExactMatch As Boolean = True) As Long
If FindExactMatch Then
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRINGEXACT, StartIndex, SearchKey)
Else
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRING, StartIndex, SearchKey)
End If
End Function
The rest depends on what you intend to do with the results afterwards. Below is simple test that merely prints results to Immediate window:
Private Sub Command1_Click()
PrintAllMatches List1.hWnd, Text1.Text
End Sub
Private Sub Form_Load()
List1.AddItem "aa1"
List1.AddItem "bbb"
List1.AddItem "aa2"
End Sub
Private Sub PrintAllMatches(hWnd As Long, SearchKey As String)
Dim firstMatch As Long, nextMatch As Long
nextMatch = GetListBoxIndex(hWnd, SearchKey, -1, False)
If nextMatch = LB_ERR Then
Debug.Print "Not found"
Exit Sub
End If
firstMatch = nextMatch
Do
Debug.Print "Match is at index " & nextMatch
nextMatch = GetListBoxIndex(hWnd, SearchKey, nextMatch, False)
Loop While nextMatch <> firstMatch
End Sub
I have similar case like this how to solve the following code,
Adodc1.Recordset.MoveFirst Adodc1.Recordset.Find "DEBTOR_CODE = '" & Text11.Text & "'" If Adodc1.Recordset.EOF = True Or Adodc1.Recordset.BOF = True Then MsgBox "Record Not Found!", vbApplicationModal Adodc1.Recordset.MoveFirst Me.Combo1.SetFocus Me.Combo1.ListIndex = Me.Text11.Text End If
i have to search debtor_code and each debtor has multiple addresses, i need to get the multiple answers in a combo box
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
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.