VB6: Displaying an icon in a picture box - vb6

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

Related

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

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

Problems opening and closing the mscomm port in vb6 when interfacing microcontroller

the code is to get data from a microcontroller or any device from serial device using serial port,so i am having problem with port opening and getting data,am having this problem for last 20 days please kindly help me at the earliest :)
Private Sub Command1_Click()
MsgBox ("The port is open " & MSComm1.PortOpen)
If (MSComm1.PortOpen = False) Then
MSComm1.PortOpen = True
End If
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
If (MSComm1.PortOpen = True) Then
MSComm1.PortOpen = False
End If
Command1.Enabled = True
Command2.Enabled = False
End Sub
Private Sub Form_Load()
With MSComm1
.CommPort = 1
.RThreshold = 1
.RTSEnable = True
.Settings = "9600,N,8,1"
.InputLen = 127
.SThreshold = 1
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
If (MSComm1.PortOpen = True) Then
MSComm1.PortOpen = False
End If
End Sub
Private Sub MSComm1_OnComm()
Dim Buffer As String
Select Case MSComm1.CommEvent
Case comEvReceive
'Text1.Text = " "
Buffer = MSComm1.Input
Text1.Text = Text1.Text & Buffer
End Select
End Sub!
Below is the image of interface which contains the MScomm control ,a text box , two command buttons for connecting and disconnecting :
'****** paste this in form'*********
Option Explicit
Dim Portnumber As Integer
Private Sub cmdClose_Click()
On Error GoTo handler
MSComm1.PortOpen = False
Shape1.FillColor = vbRed
cmdOpen.Enabled = True
txtRecieve.Text = ""
Exit Sub
handler: MsgBox Err.Description
End Sub
Private Sub cmdOpen_Click()
On Error GoTo handler
' Debug.Print cboComm.ItemData(cboComm.ListIndex)
portnumber = Mid(cboComm.Text, 4, (Len(cboComm.Text) - 3))
a = Mid(cboComm.Text, 4, (Len(cboComm.Text) - 3))
' If MSComm1.PortOpen = False Then
MSComm1.CommPort = portnumber
MSComm1.PortOpen = True
Shape1.FillColor = vbGreen
cmdOpen.Enabled = False
' End If
Exit Sub
handler: MsgBox Err.Description
End Sub
Private Sub Form_Load()
cboComm.Clear '*** cbo is for combobox
MSComm1.Settings = "9600,n,8,1"
ListComPorts
End Sub
Private Sub ListComPorts()
Dim i As Integer
cboComm.Clear
Static iData As Integer
iData = -1
For i = 1 To 16
If ComAvailable(i) Then
cboComm.AddItem (("COM") & i)
iData = iData + 1
cboComm.ItemData(iData) = i
End If
Next
cboComm.ListIndex = 0
' cmdGet.Enabled = False
End Sub
Private Sub MSComm1_OnComm()
Select Case MSComm1.CommEvent
Case comEvReceive
txtRecieve.Text = MSComm1.Input
Case Else
Debug.Print "Event: " & MSComm1.CommEvent
End Select
End Sub
'**************** End of form code **************
'*********** Now API code******************
'********** Paste in Module**************
Option Explicit
'*** API Declarations
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'*** API Structures
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'***API Constants
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const OPEN_EXISTING = 3
Public Const FILE_ATTRIBUTE_NORMAL = &H80
'*** Create a Fuction to check whether COM exists or not. If exists return "true" otherwise "false"
Public Function ComAvailable(comnum As Integer) As Boolean
Dim hcom As Long
Dim ret As Long
Dim sec As SECURITY_ATTRIBUTES
hcom = CreateFile("\.\COM" & comnum & "", 0, FILE_SHARE_READ + FILE_SHARE_WRITE, sec, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If hcom = -1 Then
ComAvailable = False
Else
ComAvailable = True
'*** close the CO MPort
ret = CloseHandle(hcom)
End If
End Function
''''''''*******End of module code********
I think this will help you.....
If you get error 8002 then the port probably doesn't exist.
Are you using an rs232 connection, or are you connect via an USB port?
Have a look at the code i posted here .... when you run it, it will give a list of available ports on your system.

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.

Resources