Modern day, unicode-friendly ".ini file" to store config data in VB6 - vb6

I'd like to store the contents of a data structure, a few arrays, and a dozen or so variables in a file that can be saved and reloaded by my software as well as optionally edited in a text editor by a user reloaded. For the text editing, I need the data to be clearly labeled, like in a good ole .ini file:
AbsMaxVoltage = 17.5
There's a GUI, and one could argue that the user should just load and save and modify from the GUI, but the customer wants to be able to read and modify the data as text.
It's easy enough to write code to save it and reload it (assuming all the labels are in the same place and only the data has changed). With more work (or using some of the INI R/W code that's already out there I could pay attention to the label so if a line gets deleted or moved around the variables still get stuffed correctly, but both of these approaches seem pretty old-school. So I'm interested in how the brightest minds in programming would approach this today (using decade-old VB6 which I have to admit I still love).
Disclaimer: I'm an electrical engineer, not a programmer. This isn't my day job. Well maybe it's a few % of my day job.
Cheers!

Lots of people will recommend XML to you. The problem is XML is still so trendy, some people use it everywhere without really thinking about it.
Like Jeff Atwood said, it's hard for non-programmers to read XML and particularly to edit it. There are too many rules, like escaping special characters and closing the tags in the correct order. Some experts recommend you treat XML as a binary format, not a text format at all.
I recommend using INI files, provided the maximum size limit of 32K is not a problem. I've never reached that limit in many similar situations in my own VB6. INI files are easy for ordinary folk to edit, and it's easy to read and write them from VB6. Just use some of the excellent drop-in code freely available on the web.
I'm sure the class Jay Riggs
provided in his answer is excellent, because
it's from VBAccelerator.
I would also recommend this class,
because anything by Karl Peterson
will be excellent too.
A couple of other points to think about:
Have you considered which directory to put the files into?
You mentioned "Unicode-friendly" in the question. INI files aren't Unicode, but that doesn't matter in practise. Unless you want to store characters that aren't supported on the current code page - like Chinese on an English computer - an unusual requirement, and one that will cause you other problems in a VB6 program anyway.
Legendary Windows guru Raymond Chen described the advantages of XML configuration files over INI files. Many of them rely on the XML file being read-only. The one legitimate advantage is if the data is highly structured - class heirarchies or the like. From your description that doesn't apply.

Consider using XML. It's completely standard, many text editors will highlight/manage it properly, every programming language and script language on Earth has good support for reading it, and it handles Unicode perfectly.
For simple name/value pairs as you suggest, it's quite readable. But you have the added advantage that if someday you need something more complex -- e.g. multi-lined values or a list of distinct values -- XML provides natural, easy ways of representing that.
P.S. Here's how to read XML in VB6.

Back in the olden days this class helped me use INI files with my VB6 programs:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cInifile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' =========================================================
' Class: cIniFile
' Author: Steve McMahon
' Date : 21 Feb 1997
'
' A nice class wrapper around the INIFile functions
' Allows searching,deletion,modification and addition
' of Keys or Values.
'
' Updated 10 May 1998 for VB5.
' * Added EnumerateAllSections method
' * Added Load and Save form position methods
' =========================================================
Private m_sPath As String
Private m_sKey As String
Private m_sSection As String
Private m_sDefault As String
Private m_lLastReturnCode As Long
#If Win32 Then
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As
Long
Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias
"GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal
lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As
String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal
lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As
Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal
lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As
Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal
lpFileName As String) As Integer
#End If
Property Get LastReturnCode() As Long
LastReturnCode = m_lLastReturnCode
End Property
Property Get Success() As Boolean
Success = (m_lLastReturnCode <> 0)
End Property
Property Let Default(sDefault As String)
m_sDefault = sDefault
End Property
Property Get Default() As String
Default = m_sDefault
End Property
Property Let Path(sPath As String)
m_sPath = sPath
End Property
Property Get Path() As String
Path = m_sPath
End Property
Property Let Key(sKey As String)
m_sKey = sKey
End Property
Property Get Key() As String
Key = m_sKey
End Property
Property Let Section(sSection As String)
m_sSection = sSection
End Property
Property Get Section() As String
Section = m_sSection
End Property
Property Get Value() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(255)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf,
iSize, m_sPath)
If (iSize > 0) Then
Value = Left$(sBuf, iRetCode)
Else
Value = ""
End If
End Property
Property Let Value(sValue As String)
Dim iPos As Integer
' Strip chr$(0):
iPos = InStr(sValue, Chr$(0))
Do While iPos <> 0
sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))
iPos = InStr(sValue, Chr$(0))
Loop
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue,
m_sPath)
End Property
Public Sub DeleteKey()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&,
m_sPath)
End Sub
Public Sub DeleteSection()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)
End Sub
Property Get INISection() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize,
m_sPath)
If (iSize > 0) Then
INISection = Left$(sBuf, iRetCode)
Else
INISection = ""
End If
End Property
Property Let INISection(sSection As String)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection,
m_sPath)
End Property
Property Get Sections() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(0&, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Sections = Left$(sBuf, iRetCode)
Else
Sections = ""
End If
End Property
Public Sub EnumerateCurrentSection(ByRef sKey() As String, ByRef iCount As Long)
Dim sSection As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sKey
sSection = INISection
If (Len(sSection) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sSection, Chr$(0))
Do While iNextPos <> 0
sCur = Mid$(sSection, iPos, (iNextPos - iPos))
If (sCur <> Chr$(0)) Then
iCount = iCount + 1
ReDim Preserve sKey(1 To iCount) As String
sKey(iCount) = Mid$(sSection, iPos, (iNextPos - iPos))
iPos = iNextPos + 1
iNextPos = InStr(iPos, sSection, Chr$(0))
End If
Loop
End If
End Sub
Public Sub EnumerateAllSections(ByRef sSections() As String, ByRef iCount As
Long)
Dim sIniFile As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sSections
sIniFile = Sections
If (Len(sIniFile) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Do While iNextPos <> 0
If (iNextPos <> iPos) Then
sCur = Mid$(sIniFile, iPos, (iNextPos - iPos))
iCount = iCount + 1
ReDim Preserve sSections(1 To iCount) As String
sSections(iCount) = sCur
End If
iPos = iNextPos + 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Loop
End If
End Sub
Public Sub SaveFormPosition(ByRef frmThis As Object)
Dim sSaveKey As String
Dim sSaveDefault As String
On Error GoTo SaveError
sSaveKey = Key
If Not (frmThis.WindowState = vbMinimized) Then
Key = "Maximised"
Value = (frmThis.WindowState = vbMaximized) * -1
If (frmThis.WindowState <> vbMaximized) Then
Key = "Left"
Value = frmThis.Left
Key = "Top"
Value = frmThis.Top
Key = "Width"
Value = frmThis.Width
Key = "Height"
Value = frmThis.Height
End If
End If
Key = sSaveKey
Exit Sub
SaveError:
Key = sSaveKey
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Sub LoadFormPosition(ByRef frmThis As Object, Optional ByRef lMinWidth =
3000, Optional ByRef lMinHeight = 3000)
Dim sSaveKey As String
Dim sSaveDefault As String
Dim lLeft As Long
Dim lTOp As Long
Dim lWidth As Long
Dim lHeight As Long
On Error GoTo LoadError
sSaveKey = Key
sSaveDefault = Default
Default = "FAIL"
Key = "Left"
lLeft = CLngDefault(Value, frmThis.Left)
Key = "Top"
lTOp = CLngDefault(Value, frmThis.Top)
Key = "Width"
lWidth = CLngDefault(Value, frmThis.Width)
If (lWidth < lMinWidth) Then lWidth = lMinWidth
Key = "Height"
lHeight = CLngDefault(Value, frmThis.Height)
If (lHeight < lMinHeight) Then lHeight = lMinHeight
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 *
Screen.TwipsPerPixelX
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lLeft = Screen.Width - 4 * Screen.TwipsPerPixelX - lWidth
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 *
Screen.TwipsPerPixelX
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lWidth = Screen.Width - lLeft - 4 * Screen.TwipsPerPixelX
End If
End If
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lTOp = Screen.Height - 4 * Screen.TwipsPerPixelY - lHeight
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 *
Screen.TwipsPerPixelY
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lHeight = Screen.Height - lTOp - 4 * Screen.TwipsPerPixelY
End If
End If
If (lWidth >= lMinWidth) And (lHeight >= lMinHeight) Then
frmThis.Move lLeft, lTOp, lWidth, lHeight
End If
Key = "Maximised"
If (CLngDefault(Value, 0) <> 0) Then
frmThis.WindowState = vbMaximized
End If
Key = sSaveKey
Default = sSaveDefault
Exit Sub
LoadError:
Key = sSaveKey
Default = sSaveDefault
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Function CLngDefault(ByVal sString As String, Optional ByVal lDefault As
Long = 0) As Long
Dim lR As Long
On Error Resume Next
lR = CLng(sString)
If (Err.Number <> 0) Then
CLngDefault = lDefault
Else
CLngDefault = lR
End If
End Function

Would and XML file be acceptable:-
<config>
<someAppPart
AbsMaxVoltage="17.5"
AbsMinVoltage="5.5"
/>
<someOtherAppPart
ForegroundColor="Black"
BackgroundColor="White"
/>
</config>
Its very easy to consume in VB6, you don't need to worry about positioning etc.
The downside is its the user tweaking it can make it unparsable, however thats true if you write your own parser for a config file.

If we can assume your saved settings are simply a set of name/value pairs without a two-level hierarchy requirement (i.e. INI "Keys" within "Sections") you might just persist them as such:
AbsMaxVoltage=17.5
AbsMinVoltage=5.5
For writing the persistence format this is a case where you might consider the FSO, since the access volume is low anyway. The FSO can handle read/writing Unicode text files.
I think I'd do something like read lines and parse them using a Split() on "=" specifying just 2 parts (thus allowing "=" within values as well). For loading these I'd store them into a simple Class instance where the Class has two properties (Name and Value) and add each one to a Collection using Name as the Key. Make Value the default property if desired.
Maybe even implement some form of comment text line too using a generated sequence-numbered special Name value stored as say Name="%1" Value="comment text" with generated unique Names to avoid Collection Key collisions. Blank lines might be similarly preserved.
Then persisting as necessary means simply using a For Each on the Collection and using the FSO to write Name=Value out to disk.
To simulate a hierarchy you could simply use Names like:
%Comment: somAppPart settings
someAppPart.AbsMaxVoltage=17.5
someAppPart.AbsMinVoltage=5.5
%someOtherPart settings
someOtherAppPart.ForegroundColor=Black
someOtherAppPart.BackgroundColor=White
The parsing is cheap, so any probing of the Collection might be preceded by a full reparse (as the INI API calls do). Any changing of values in the program might do a full rewrite to disk (like the INI API calls do).
Some of this can be automated by just wrapping the Collection with some logic in another Class. The result could be syntax like:
Settings("someOtherAppPart", "ForegroundColor") = "Red"
aka
Settings.Value("someOtherAppPart", "ForegroundColor") = "Red"
This would reload the Collection, then probe the Collection for an Item keyed "someOtherAppPart.ForegroundColor" and create it or set its Value to "Red" and then flush the Collection to disk. Or you might eschew frequent rewriting and use distinct Load and Save methods.
Make it as simple or fancy as desired.
In any case, the result is a text file users can hack at with Notepad. The only reason for the FSO is to have an easy way of read/writing Unicode text. One could also screw around with Byte array I/O and explicit conversions (array to String) and line level parsing as required to avoid the FSO. If so just don't forget about the UTF-16LE BOM.

Related

What might make CryptStringToBinaryW crash?

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.

Visual Basic 6 - Argument not optional

I have this very simple code:
Private Sub Image87_Click()
PrintRTFWithMargins
End Sub
PrintRTFWithMargins is a function, which should "hopefully" print the contents of a RichTextBox. Every time I do run the code though, it gives me "Argument not optional" on PrintRTFWithMargins.
The code inside the function has already Option Explicit at the start, and I've tried to put it at the start of the Image87_Click too, but nothing.
Here's the code of PrintRTFWithMargins:
Option Explicit
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
Private Type FORMATRANGE
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CHARRANGE
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, _
ByVal wp As Long, lp As Any) As Long
Public Function PrintRTFWithMargins(RTFControl As Object, _
ByVal LeftMargin As Single, ByVal TopMargin As Single, _
ByVal RightMargin As Single, ByVal BottomMargin As Single) _
As Boolean
'********************************************************8
'PURPOSE: Prints Contents of RTF Control with Margins
'PARAMETERS:
'RTFControl: RichTextBox Control For Printing
'LeftMargin: Left Margin in Inches
'TopMargin: TopMargin in Inches
'RightMargin: RightMargin in Inches
'BottomMargin: BottomMargin in Inches
'***************************************************************
On Error GoTo ErrorHandler
'*************************************************************
'I DO THIS BECAUSE IT IS MY UNDERSTANDING THAT
'WHEN CALLING A SERVER DLL, YOU CAN RUN INTO
'PROBLEMS WHEN USING EARLY BINDING WHEN A PARAMETER
'IS A CONTROL OR A CUSTOM OBJECT. IF YOU JUST PLUG THIS INTO
'A FORM, YOU CAN DECLARE RTFCONTROL AS RICHTEXTBOX
'AND COMMENT OUT THE FOLLOWING LINE
If Not TypeOf RTFControl Is RichTextBox Then Exit Function
'**************************************************************
Dim lngLeftOffset As Long
Dim lngTopOffSet As Long
Dim lngLeftMargin As Long
Dim lngTopMargin As Long
Dim lngRightMargin As Long
Dim lngBottomMargin As Long
Dim typFr As FORMATRANGE
Dim rectPrintTarget As Rect
Dim rectPage As Rect
Dim lngTxtLen As Long
Dim lngPos As Long
Dim lngRet As Long
Dim iTempScaleMode As Integer
iTempScaleMode = Printer.ScaleMode
' needed to get a Printer.hDC
Printer.Print ""
Printer.ScaleMode = vbTwips
' Get the offsets to printable area in twips
lngLeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
lngTopOffSet = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
' Get Margins in Twips
lngLeftMargin = InchesToTwips(LeftMargin) - lngLeftOffset
lngTopMargin = InchesToTwips(TopMargin) - lngTopOffSet
lngRightMargin = (Printer.Width - _
InchesToTwips(RightMargin)) - lngLeftOffset
lngBottomMargin = (Printer.Height - _
InchesToTwips(BottomMargin)) - lngTopOffSet
' Set printable area rect
rectPage.Left = 0
rectPage.Top = 0
rectPage.Right = Printer.ScaleWidth
rectPage.Bottom = Printer.ScaleHeight
' Set rect in which to print, based on margins passed in
rectPrintTarget.Left = lngLeftMargin
rectPrintTarget.Top = lngTopMargin
rectPrintTarget.Right = lngRightMargin
rectPrintTarget.Bottom = lngBottomMargin
' Set up the printer for this print job
typFr.hdc = Printer.hdc 'for rendering
typFr.hdcTarget = Printer.hdc 'for formatting
typFr.rc = rectPrintTarget
typFr.rcPage = rectPage
typFr.chrg.cpMin = 0
typFr.chrg.cpMax = -1
' Get length of text in the RichTextBox Control
lngTxtLen = Len(Form1.RichTextBox1.Text)
' print page by page
Do
' Print the page by sending EM_FORMATRANGE message
'Allows you to range of text within a specific device
'here, the device is the printer, which must be specified
'as hdc and hdcTarget of the FORMATRANGE structure
lngPos = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
True, typFr)
If lngPos >= lngTxtLen Then Exit Do 'Done
typFr.chrg.cpMin = lngPos ' Starting position next page
Printer.NewPage ' go to next page
Printer.Print "" 'to get hDC again
typFr.hdc = Printer.hdc
typFr.hdcTarget = Printer.hdc
Loop
' Done
Printer.EndDoc
' This frees memory
lngRet = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
False, Null)
Printer.ScaleMode = iTempScaleMode
PrintRTFWithMargins = True
Exit Function
ErrorHandler:
Err.Raise Err.Number, , Err.Description
End Function
Private Function InchesToTwips(ByVal Inches As Single) As Single
InchesToTwips = 1440 * Inches
End Function
I really, really don't know what else to put. It's such a simple code, just running a function, and yet "Argument not optional". It's single-hand the most annoying Visual Basic error I've ever experienced, because it's so dumb
'''
Call your function as:
Dim retVal as Boolean
retVal = PrintRTFWithMargins(RichTextBox1, 1.1, 1, 1, 1)

Sort dynamic set of (key, string) pairs VB6

Could anybody please tell me what is the best way to sort a dynamic (key, string) set by the key using VB6.
I have tried to use VBA.collections and 2D arrays. But they seems to have a big workaround to do the sort.
I also tried with the MSComctlLib.ListView as mentioned in this stackoverflow question.
Dim lvSelectedStyles As MSComctlLib.ListView
Dim listItem As MSComctlLib.listItem
'Some code here
lvSelectedStyles.ListItems.Add Key:=CStr(lngCount) Text:=objParagraph.Key
But this item adding gives an error saying "Object or with block variable not set". If I can go through this I can sort the list view by column and move forward.
Could anybody please let me know a way to overcome this, or if you have any other way to do this, please let me know.
Thank you.
Try using a Recordset object to do the sorting like this
Option Explicit
Private Function pvSortImpl(vData As Variant, _
ByVal lKeyType As Long, _
ByVal lKeySize As Long, _
ByVal lValueType As Long, _
ByVal lValueSize As Long) As Variant
Const adFldIsNullable As Long = 32
Dim rs As Object
Dim vElem As Variant
Dim vFields As Variant
Dim vRetVal As Variant
Dim lIdx As Long
Dim oFldKey As Object
Dim oFldValue As Object
Set rs = CreateObject("ADODB.Recordset")
rs.Fields.Append "Key", lKeyType, lKeySize, adFldIsNullable
rs.Fields.Append "Value", lValueType, lValueSize, adFldIsNullable
rs.Open
vFields = Array(0, 1)
For Each vElem In vData
rs.AddNew vFields, vElem
Next
If rs.RecordCount = 0 Then
vRetVal = Array()
Else
rs.Sort = "Key"
ReDim vRetVal(0 To rs.RecordCount - 1) As Variant
Set oFldKey = rs.Fields("Key")
Set oFldValue = rs.Fields("Value")
rs.MoveFirst
Do While Not rs.EOF
vRetVal(lIdx) = Array(oFldKey.Value, oFldValue.Value)
lIdx = lIdx + 1
rs.MoveNext
Loop
End If
pvSortImpl = vRetVal
End Function
Public Function SortNumeric(vData As Variant) As Variant
Const adDouble As Long = 5
Const adVarWChar As Long = 202
SortNumeric = pvSortImpl(vData, adDouble, 0, adVarWChar, 1000)
End Function
Public Function SortStrings(vData As Variant) As Variant
Const adVarWChar As Long = 202
SortStrings = pvSortImpl(vData, adVarWChar, 202, adVarWChar, 1000)
End Function
Private Sub Form_Load()
Dim vResult As Variant
vResult = SortStrings(Array(Array("bbb", "test"), Array("aaa", Now)))
Debug.Print Join(vResult(0), "=>")
Debug.Print Join(vResult(1), "=>")
vResult = SortNumeric(Array(Array("33", "test"), Array("2.2", Now), Array("22", "Proba")))
Debug.Print Join(vResult(0), "=>")
Debug.Print Join(vResult(1), "=>")
Debug.Print Join(vResult(2), "=>")
End Sub
This prints in Immediate window
aaa=>9/21/2018 11:50:19 AM
bbb=>test
2.2=>9/21/2018 11:50:19 AM
22=>Proba
33=>test

Byte shifting / casting VB6

I'm extremely unfamiliar with VB6 so please excuse the rookie question:
I'm attempting to turn a long into it's component bytes. In C it is simple because of the automatic truncation and the bitshift operators. For the life of me I cannot figure out how to do this in VB6.
Attempts so far have all generally looked something like this
sys1 = CByte(((sys & &HFF000000) / 16777216)) ' >> 24
sys2 = CByte(((sys & &HFF0000) / 65536)) ' >> 16
sys1 and sys2 are declared as Byte and sys is declared as Long
I'm getting a type mismatch exception when I try to do this. Anybody know how to convert a Long into 4 Bytes ??
Thanks
You divide correctly, but you forgot to mask out only the least significant bits.
Supply the word you want to divide into bytes, and the index (0 is least significant, 1 is next, etc.)
Private Function getByte(word As Long, index As Integer) As Byte
Dim lTemp As Long
' shift the desired bits to the 8 least significant
lTemp = word / (2 ^ (index * 8))
' perform a bit-mask to keep only the 8 least significant
lTemp = lTemp And 255
getByte = lTemp
End Function
Found on FreeVBCode.com. Not tested, sorry.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal _
Length As Long)
Public Function LongToByteArray(ByVal lng as Long) as Byte()
'Example:
'dim bytArr() as Byte
'dim iCtr as Integer
'bytArr = LongToByteArray(90121)
'For iCtr = 0 to Ubound(bytArr)
'Debug.Print bytArr(iCtr)
'Next
'******************************************
Dim ByteArray(0 to 3)as Byte
CopyMemory ByteArray(0), Byval VarPtr(Lng),Len(Lng)
LongToByteArray = ByteArray
End Function
You can convert between simple value types and Byte arrays by combining UDTs and the LSet statement.
Option Explicit
Private Type DataBytes
Bytes(3) As Byte
End Type
Private Type DataLong
Long As Long
End Type
Private DB As DataBytes
Private DL As DataLong
Private Sub cmdBytesToLong_Click()
Dim I As Integer
For I = 0 To 3
DB.Bytes(I) = CByte("&H" & txtBytes(I).Text)
Next
LSet DL = DB
txtLong.Text = CStr(DL.Long)
txtBytes(0).SetFocus
End Sub
Private Sub cmdLongToBytes_Click()
Dim I As Integer
DL.Long = CLng(txtLong.Text)
LSet DB = DL
For I = 0 To 3
txtBytes(I).Text = Right$("0" & Hex$(DB.Bytes(I)), 2)
Next
txtLong.SetFocus
End Sub

Printer Page Size Problem

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.

Resources