Sort dynamic set of (key, string) pairs VB6 - 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

Related

VB6: Displaying an icon in a picture box

I'm essentially just trying to draw an icon image in a picture box.
I have the following subroutine. Input parameters verified and correct, however the icon does not display in the picture box when DrawIcon is called (this is part of a larger class).
Public Sub Draw_Icon(ByVal strDefaultIcon As String, ByVal lngIconNumber As Long, ByRef Picture_hDC As Long)
Dim lngIcon As Long
Dim lngError As Long
lngIcon = ExtractIcon(App.hInstance, strDefaultIcon, lngIconNumber)
If (lngIcon = 1 Or lngIcon = 0) Then
Call No_Icon(Picture_hDC)
Else
lngError = DrawIcon(Picture_hDC, 0, 0, lngIcon)
lngError = DestroyIcon(lngIcon)
End If
End Sub
Is there anything obvious I'm doing wrong? I've tried a number of solutions from StackOverflow and other sites to no avail.
Thank you very much for your answers. I fixed the issue with the following. I used a hidden, temporary image and picture box control to store the icon or image, respectively. Their contents are used to populate controls on the parent form. I hope that the code is readable. Thank you very much once again.
' Calling code
'
Public Function GetPictureOrIconAsImage(ByVal sFilename As String) As Picture
Dim strDefaultIcon As String
Dim lngIconNumber As Long
Dim Icon As New clsIcon
' Set error handler
On Error GoTo ErrorHandler
picTempPicture.Picture = LoadPicture("")
picTempIcon.Picture = LoadPicture("")
' Return picture if this is a picture file, otherwise attempt to return icon
If (modEasyQProcs.IsPictureFile(sFilename)) Then
picTempPicture.Picture = LoadPicture(sFilename)
Set GetPictureOrIconAsImage = picTempPicture.Picture
Else
If (Icon.GetDefaultIcon(sFilename, lngIconNumber, strDefaultIcon)) Then
Call Icon.Draw_Icon(strDefaultIcon, lngIconNumber, picTempIcon.hDC)
Else
Call Icon.No_Icon(picTempIcon.hDC)
End If
Set GetPictureOrIconAsImage = picTempIcon.Image
End If
Exit Function
ErrorHandler: ' Generic error handler
Call NonCriticalError(MODULE, Err, "GetPictureOrIconAsImage:ErrorHandler")
Err.Clear
' End of error handler scope
On Error GoTo 0
End Function
' Class Icon
'
Public Function GetDefaultIcon(ByRef FileName As String, ByRef lngIconNumber As Long, ByRef strDefaultIcon As String) As Boolean
'Parameters:
'FileName: The extension of the filename, with the "." e.g .doc
'Picture_hDC: The Handle to the device context of the Picture Box you want the icon
'to be displayed on.
'Example:
'Call GetDefaultIcon(".doc",Picture1.hDC)
Dim TempFileName As String
Dim lngError As Long
Dim lngRegKeyHandle As Long
Dim strProgramName As String
Dim lngStringLength As Long
Dim lngIcon As Long
Dim intN As Integer
GetDefaultIcon = False
TempFileName = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)
If (LCase(TempFileName) = ".exe") Then
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 2
GetDefaultIcon = True
Else
lngError = RegOpenKey(HKEY_CLASSES_ROOT, TempFileName, lngRegKeyHandle)
If (lngError = 0) Then
lngStringLength = 260
strProgramName = Space$(260)
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strProgramName, lngStringLength)
If (lngError = 0) Then
lngError = RegCloseKey(lngRegKeyHandle)
lngError = RegCloseKey(lngRegKeyHandle)
strProgramName = Left(strProgramName, lngStringLength - 1)
lngError = RegOpenKey(HKEY_CLASSES_ROOT, strProgramName & "\DefaultIcon", lngRegKeyHandle)
If (lngError = 0) Then
lngStringLength = 260
strDefaultIcon = Space$(260)
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strDefaultIcon, lngStringLength)
If (lngError) Then
lngError = RegCloseKey(lngRegKeyHandle)
Else
lngError = RegCloseKey(lngRegKeyHandle)
strDefaultIcon = Trim$(Left(strDefaultIcon, lngStringLength - 1))
intN = InStrRev(strDefaultIcon, ",")
If (intN >= 1) Then
lngIconNumber = Trim$(Right(strDefaultIcon, Len(strDefaultIcon) - intN))
strDefaultIcon = Trim$(Left(strDefaultIcon, intN - 1))
GetDefaultIcon = True
End If
End If
End If
End If
End If
End If
End Function
Public Sub Draw_Icon(ByVal strDefaultIcon As String, ByVal lngIconNumber As Long, ByRef Picture_hDC As Long)
Dim lngIcon As Long
Dim lngError As Long
lngIcon = ExtractIcon(App.hInstance, strDefaultIcon, lngIconNumber)
If (lngIcon = 1 Or lngIcon = 0) Then
Call No_Icon(Picture_hDC)
Else
lngError = DrawIcon(Picture_hDC, 0, 0, lngIcon)
If (lngError) Then lngError = DestroyIcon(lngIcon)
End If
End Sub
Public Sub No_Icon(ByRef Picture_hDC As Long)
Dim strDefaultIcon As String
Dim lngIconNumber As Long
Dim lngStringLength As Long
'No icon could be found so we use the normal windows icon
'This icon is held in shell32.dll in the system directory, Icon 0
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 0
Call Draw_Icon(strDefaultIcon, lngIconNumber, Picture_hDC)
End Sub

Can I PrintToFIle in Access, or possibly spoof the fax driver to create Tifs?

I built calculator in Access using a user form. The goal of the calculator is to document the steps taken by the user in solving a problem. It's similar to a high-school student being told to 'show their work'. I need to record a visual representation of the form. A PDF would be perfected, but I can't use PDFs.
I'm limited to file formats that are supported by our imaging server.
I know that the imaging server supports: tif, jpg, bmp and rtf. It might support other formats.
I know that these formats don't work: pdf, gif and png.
I'm an inexperienced coder (less than 6 mos), and I came up with a solution which I suspect is subpar. Occasionally, it seems to just stop working.
Essentially, I copy the form using keybd_event, and paste it into a word document, and save it as a tif file.
Is there a more conventional way of accomplishing this?
Here's my code:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Public Sub sendToFaf()
Dim appWord As New Word.Application
Dim docWord As New Word.Document
Dim imgWord As InlineShape
Dim thisForm As Form
Dim oldPrinter As String
Dim rnd As Integer
Dim strRnd As String
Dim oldWidth As Integer
Dim oldHeight As Integer
On Error GoTo ProcessError
DoCmd.Echo (False)
DoCmd.Hourglass (True)
Set appWord = CreateObject("word.application")
Set docWord = appWord.Documents.Add
Set thisForm = Screen.ActiveForm
appWord.Visible = False
appWord.DisplayAlerts = wdAlertsNone
oldWidth = thisForm.InsideWidth
oldHeight = thisForm.InsideHeight
thisForm.InsideWidth = 10800
thisForm.InsideHeight = 11925
keybd_event VK_MENU, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
DoEvents
thisForm.InsideWidth = oldWidth
thisForm.InsideHeight = oldHeight
rnd = Int((10000 - 0 + 1) * Math.rnd + 0)
strRnd = Format(rnd, "0000")
With docWord.PageSetup
.TopMargin = 0
.BottomMargin = 0
.LeftMargin = 0
.RightMargin = 0
.VerticalAlignment = wdAlignVerticalCenter
End With
docWord.Paragraphs.Alignment = wdAlignParagraphCenter
appWord.Selection.Paste
Set imgWord = docWord.InlineShapes(docWord.InlineShapes.Count)
imgWord.Width = InchesToPoints(8.5)
oldPrinter = appWord.ActivePrinter
appWord.ActivePrinter = "FAX"
appWord.PrintOut _
Background:=False, _
outputfilename:="c:\a faf\" & thisForm.Name & strRnd & ".tif", _
PrintToFile:=True
MsgBox ("File created: 'c:\a faf\" & thisForm.Name & strRnd & ".tif'")
appWord.ActivePrinter = oldPrinter
ProcessExit:
Set imgWord = Nothing
docWord.Close savechanges:=wdDoNotSaveChanges
appWord.Quit savechanges:=wdDoNotSaveChanges
Set docWord = Nothing
Set appWord = Nothing
Set thisForm = Nothing
DoCmd.Echo (True)
DoCmd.Hourglass (False)
Exit Sub
ProcessError:
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & "Sub SendToFaf"
GoTo ProcessExit
End Sub

VBA : Find function code

I am trying to do vlookup through the find function in vba. I have a list of numbers in loan sheet and property sheet and If the number is found in the loan sheet then it copies the entire row and pastes it in another sheet called query. This is the code I have currently but the code just hangs as I have too many cells to find around 100,000. Any guidance in any errors in the code would be really helpful.
Option Explicit
Sub FindCopy_lall()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of Property SheetColumn
LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row
' Set range to look in
Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on IT_Asset
' With Worksheets("Loan")
' Allow not found error
On Error Resume Next
Set rFound = Worksheets("Loan").Range("D2:D" & LastRow2).Find(What:=CelValue, _
LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Reset
On Error GoTo endo
' Not found, go next
If rFound Is Nothing Then
GoTo nextCel
Else
Worksheets("Loan").Range("rFound:rFound").Select
Selection.Copy
Worksheets("Query").Range("Cel:Cel").Select
ActiveSheet.Paste
End If
'End With
nextCel:
Next Cel
'Reset
endo:
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
Running Find() many times in a loop can be very slow - I usually create a lookup using a Dictionary: typically thus is much faster and makes the loop easier to code.
Sub FindCopy_lall()
Dim calc As Long
Dim Cel As Range, LookRange As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim CelValue As Variant
Dim dict As Object
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row
Set dict = RowMap(Worksheets("Loan").Range("D2:D" & LastRow2))
Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)
For Each Cel In LookRange
CelValue = Cel.Value
If dict.exists(CelValue) Then
'just copy values (5 cols, resize to suit)
Cel.Offset(0, 1).Resize(1, 5).Value = _
dict(CelValue).Offset(0, 1).Resize(1, 5).Value
'...or copy the range
'dict(CelValue).Offset(0, 1).Resize(1, 5).Copy Cel.Offset(0, 1)
End If
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
'map a range's values to their respective cells
Function RowMap(rng As Range) As Object
Dim rv As Object, c As Range, v
Set rv = CreateObject("scripting.dictionary")
For Each c In rng.Cells
v = c.Value
If Not rv.exists(v) Then
rv.Add v, c
Else
MsgBox "Duplicate value detected!"
Exit For
End If
Next c
Set RowMap = rv
End Function
There are many things that needs to be re-written
A) Variables inside the quotes become a string. For example "rFound:rFound" Also you do not need to specify Worksheets("Loan"). before it. It is understood.
You can simply write it as rFound.Select
B) Avoid the Use of .Select It slows down the code. You might want to see this LINK. For example
Worksheets("Loan").Range("rFound:rFound").Select
Selection.Copy
Worksheets("Query").Range("Cel:Cel").Select
ActiveSheet.Paste
The above can be written as
rFound.Copy Cel
Work with Variables/Objects. Try and ignore the use of On Error Resume Next and unnecessary GO TOs if possible.
Try this (UNTESTED)
Option Explicit
Sub FindCopy_lall()
Dim calc As Long, LrowWsI As Long, LrowWsO As Long
Dim Cel As Range, rFound As Range, LookRange As Range
Dim wsI As Worksheet, wsO As Worksheet
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set wsI = ThisWorkbook.Sheets("Property")
Set wsO = ThisWorkbook.Sheets("Loan")
LrowWsI = wsI.Range("E" & wsI.Rows.Count).End(xlUp).Row
LrowWsO = wsO.Range("D" & wsI.Rows.Count).End(xlUp).Row
Set LookRange = wsI.Range("E2:E" & LrowWsI)
For Each Cel In LookRange
Set rFound = wsO.Range("D2:D" & LrowWsO).Find(What:=Cel.Value, _
LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not rFound Is Nothing Then
'~~> You original code was overwriting the cel
'~~> I am writing next to it. Chnage as applicable
rFound.Copy Cel.Offset(, 1)
End If
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
Besides the possible bugs the two big performance issues are
doing an Excel .Find.. inside your loop over all your source rows, which as has already been noted, is very slow. And
actually cutting and pasting a lot of rows is also pretty slow. If you only care about the values, then you can use range-array data copies instead which are very fast.
This is how I would do it, which should be very fast:
Option Explicit
Option Compare Text
Sub FindCopy_lall()
Dim calc As Long, CelValue As Variant
Dim LastRow As Long, LastRow2 As Long, r As Long, sr As Long
Dim LookRange As Range, FindRange As Range, rng As Range
Dim LastLoanCell As Range, LastLoanCol As Long
Dim rowVals() As Variant
' Speed
calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'capture the worksheet objects
Dim wsProp As Worksheet: Set wsProp = Worksheets("Property")
Dim wsLoan As Worksheet: Set wsLoan = Worksheets("Loan")
Dim wsQury As Worksheet: Set wsQury = Worksheets("Query")
'Get Last row of Property SheetColumn
LastRow = wsProp.Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = wsLoan.Cells(Rows.Count, "D").End(xlUp).Row
Set LastLoanCell = wsLoan.Cells.SpecialCells(xlCellTypeLastCell)
LastLoanCol = LastLoanCell.Column
' Set range to look in; And get it's data
Set LookRange = wsProp.Range("E2:E" & LastRow)
Dim Look() As Variant: ReDim Look(2 To LastRow, 1 To 1)
Look = LookRange
' Index the source values
Dim colIndex As New Collection
For r = 2 To UBound(Look, 1)
' ignore duplicate key errors
On Error Resume Next
colIndex.Add r, CStr(CelValue)
On Error GoTo endo
Next
'Set the range to search; and get its data
Set FindRange = wsLoan.Range("D2:D" & LastRow2)
Dim Find() As Variant: ReDim Find(2 To LastRow2, 1 To 1)
Find = FindRange
' Loop on each value (cell) in the Find range
For r = 2 To UBound(Find, 1)
'Try to find it in the Look index
On Error Resume Next
sr = colIndex(CStr(CelValue))
If Err.Number = 0 Then
'was found in index, so copy the row
On Error GoTo endo
' pull the source row values into an array
Set rng = wsLoan.Range(wsLoan.Cells(r, 1), wsLoan.Cells(r, LastLoanCol))
ReDim rowVals(1 To rng.Rows.Count, 1 To rng.Columns.Count)
rowVals = rng
' push the values out to the target row
Set rng = wsQury.Range(wsQury.Cells(sr, 1), wsQury.Cells(sr, LastLoanCol))
rng = rowVals
End If
On Error GoTo endo
Next r
endo:
'Reset
Application.Calculation = calc
Application.ScreenUpdating = True
End Sub
As others have noted, we cannot tell from your code where the output rows are actually supposed to go on the Query sheet, so I made a guess, but you made need to change that.

Convert from \Device\HarddiskVolume1 to C: in vb6

Is there any way to convert from \Device\HarddiskVolume1\programfile\explorer.exe to C:\programfile\explorer.exe in visual basic 6?
thanks
Try this
Option Explicit
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Sub Command1_Click()
Debug.Print pvReplaceDevice("\Device\HarddiskVolume1\aaa.txt")
End Sub
Private Function pvReplaceDevice(sPath As String) As String
Dim sDrive As String
Dim sDevice As String
Dim lIdx As Long
For lIdx = 0 To 25
sDrive = Chr$(65 + lIdx) & ":"
sDevice = Space(1000)
If QueryDosDevice(sDrive, sDevice, Len(sDevice)) <> 0 Then
sDevice = Left$(sDevice, InStr(sDevice, Chr$(0)) - 1)
' Debug.Print sDrive; "="; sDevice
If LCase$(Left$(sPath, Len(sDevice))) = LCase$(sDevice) Then
pvReplaceDevice = sDrive & Mid$(sPath, Len(sDevice) + 1)
Exit Function
End If
End If
Next
pvReplaceDevice = sPath
End Function
If you want an efficient use of API functions, create a class - "DiskDevice"
Option Explicit
Private Declare Function GetLogicalDriveStrings Lib "Kernel32" Alias "GetLogicalDriveStringsW" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As Long _
) As Long
Private Declare Function QueryDosDevice Lib "Kernel32.dll" Alias "QueryDosDeviceW" ( _
ByVal lpDeviceName As Long, _
ByVal lpTargetPath As Long, _
ByVal ucchMax As Long _
) As Long
Private m_colDrivesKeyedByDevice As VBA.Collection
Private Sub Class_Initialize()
Dim sDriveStrings As String
Dim vasDriveStrings As Variant
Dim nIndex As Long
Dim sDrive As String
' Allocate max size buffer [A-Z]:\\\0 and retrieve all drives on the system.
sDriveStrings = Space$(105)
GetLogicalDriveStrings 1000, StrPtr(sDriveStrings)
' Split over the null chars between each substring.
vasDriveStrings = Split(sDriveStrings, vbNullChar)
Set m_colDrivesKeyedByDevice = New VBA.Collection
' Iterate through each drive string (escaping later if any item is null string).
For nIndex = 0 To UBound(vasDriveStrings)
sDrive = Left$(vasDriveStrings(nIndex), 2) ' Ignore the backslash.
If Len(sDrive) = 0 Then
Exit For
End If
' Create mapping from Drive => Device
m_colDrivesKeyedByDevice.Add sDrive, GetDeviceForDrive(sDrive)
Next nIndex
End Sub
' Retrieve the device string \device\XXXXXX for the drive X:
Private Function GetDeviceForDrive(ByRef the_sDrive As String)
Const knBufferLen As Long = 1000
Dim sBuffer As String
Dim nRet As Long
sBuffer = Space$(knBufferLen)
nRet = QueryDosDevice(StrPtr(the_sDrive), StrPtr(sBuffer), knBufferLen)
GetDeviceForDrive = Left$(sBuffer, nRet - 2) ' Ignore 2 terminating null chars.
End Function
Public Function GetFilePathFromDevicePath(ByRef the_sDevicePath As String) As String
Dim nPosSecondBackslash As Long
Dim nPosThirdBackslash As Long
Dim sDevice As String
Dim sDisk As String
' Path is always \Device\<device>\path1\path2\etc. Just get everything before the third backslash.
nPosSecondBackslash = InStr(2, the_sDevicePath, "\")
nPosThirdBackslash = InStr(nPosSecondBackslash + 1, the_sDevicePath, "\")
sDevice = Left(the_sDevicePath, nPosThirdBackslash - 1)
sDisk = m_colDrivesKeyedByDevice.Item(sDevice) ' Lookup
' Reassemble, this time with disk.
GetFilePathFromDevicePath = sDisk & Mid$(the_sDevicePath, nPosThirdBackslash)
End Function
Now, you use code like:
Set m_oDiskDevice = New DiskDevice
...
sMyPath = m_oDiskDevice.GetFilePathFromDevicePath("\Device\HarddiskVolume1\programfile\explorer.exe")
That way you don't have to call the API functions multiple times - you just do a collection lookup.

Write text file in appending (utf-8 encoded) in VB6

I have to write a textfile in VB6. I need to do it in appending and utf-8 encoded.
I tried two solutions, one with "TextStream" and another one with "ADODB.Stream".
The first one:
Set fsoFile = fso.OpenTextFile(FileIn(fi), ForAppending, True)
fsoFile.WriteLine "<tag>kkkjòòkkkkjlòlk</tag>"
fsoFile.Close
Works good in appending but how can I write it utf-8 encoded?
The second one:
Dim ST As ADODB.Stream
Set ST = New ADODB.Stream
ST.Mode = adModeReadWrite
ST.Type = adTypeText
ST.Charset = "UTF-8"
ST.Open
ST.LoadFromFile FileIn(fi)
ST.Position = ST.Size
ST.WriteText "<tag>kkkjòòkkkkjlòlk</tag>"
ST.SaveToFile FileIn(fi)
ST.Close
Write correctly in utf-8 but I can't write the file in appending but only with "adSaveCreateOverWrite".
How can I do that? Is there another way?
Thank you very much.
You could combine binary I/O with an API call to perform the conversion to UTF-8:
Option Explicit
Private Const CP_UTF8 As Long = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Function OpenAppendUTF8(ByVal FileName As String) As Integer
OpenAppendUTF8 = FreeFile(0)
Open FileName For Binary Access Write As #OpenAppendUTF8
Seek #OpenAppendUTF8, LOF(OpenAppendUTF8) + 1
End Function
Private Sub WriteUTF8( _
ByVal FNum As Integer, _
ByVal Text As String, _
Optional ByVal NL As Boolean)
Dim lngResult As Long
Dim UTF8() As Byte
If NL Then Text = Text & vbNewLine
lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(Text), Len(Text), _
0, 0, 0, 0)
If lngResult > 0 Then
ReDim UTF8(lngResult - 1)
WideCharToMultiByte CP_UTF8, 0, StrPtr(Text), Len(Text), _
VarPtr(UTF8(0)), lngResult, 0, 0
Put #FNum, , UTF8
End If
End Sub
Private Sub Main()
Dim F As Integer
F = OpenAppendUTF8("test.txt")
WriteUTF8 F, "Hello"
WriteUTF8 F, ChrW$(&H2026&)
WriteUTF8 F, "World", True
Close #F
MsgBox "Done"
End Sub
I prefer to save it ANSI as it does by default. Open it with a notepad and overwrite it selecting UTF8 encoding. I found it's the fastest way by far.
And I use some other code to append, for example for a database convertion:
Dim fs As Object, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(filename, True) 'example (myfile.xml, True)
a.writeline var1
a.writeline var2
a.Close
Actually no need for API call.
Option Explicit
Sub testAppend()
Dim fileName
fileName = "C:\Test\test.txt"
Dim f As Integer
f = FreeFile(0)
Open fileName For Binary Access Write As #f
Seek #f, LOF(f) + 1
Dim t
t = "<tag>" & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(106) & ChrW(242) & ChrW(242) & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(106) & ChrW(108) & ChrW(242) & ChrW(108) & ChrW(107) & "</tag>"
Put #f, , textToBinary(t, "utf-8")
Close #f
End Sub
Function textToBinary(text, charset) As Byte()
With CreateObject("ADODB.Stream")
.Open
.Type = 2 ' adTypeText
.charset = charset
.WriteText text
.Position = 0
.Type = 1 ' adTypeBinary
textToBinary = .Read
.Close
End With
End Function```

Resources