I have found plenty of examples in C#, but I cannot make this work in VB no matter what I try. The only icon I can extract is the one representing a file with no association. If there is a better approach I am open to that too. Here is the code:
Declaration:
Declare Auto Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As IntPtr, ByVal lpIconPat As String, ByRef lpiIcon As Integer) As IntPtr
Other Code:
Dim handle As IntPtr
Dim li As ListViewItem
Dim modul As System.Reflection.Module()
For Each filename As FileInfo In quotesFolder.GetFiles()
If ImgLstQuotes.Images.ContainsKey(filename.Extension) Then
Else
modul = System.Reflection.Assembly.GetExecutingAssembly.GetModules()
'handle = ExtractAssociatedIcon(Marshal.GetHINSTANCE(modul(0)), filename.FullName, -1) 'doesnt work
'handle = ExtractAssociatedIcon(IntPtr.Zero(), filename.FullName, -1) 'doesn't work
handle = ExtractAssociatedIcon(Process.GetCurrentProcess().Handle, filename.FullName, -1) 'doesn't work
ImgLstQuotes.Images.Add(filename.Extension, Drawing.Icon.FromHandle(handle))
End If
li = LstVwQuotes.Items.Add(filename.Name, filename.Extension)
li.Name = UCase(filename.Name)
li.SubItems.Add(filename.LastWriteTime)
Next
Thanks in advance!
Related
I would like to automatically change the keyboard layout and I create a simple console application in Visual Basic adding the following:
InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(New CultureInfo("ru"))
But when I compile this code it doesn't change the keyboard layout, so it remains what it was before compiling. What am I doing wrong?
There three ways to change keyboard language:
Using property .CurrentInputLanguage (only if input language installed)
InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(New CultureInfo("ru-RU"))
Using property .CurrentCulture (only if input language installed)
Dim culture = System.Globalization.CultureInfo.GetCultureInfo("ru-RU")
Dim lang = InputLanguage.FromCulture(culture)
If InputLanguage.InstalledInputLanguages.IndexOf(lang) >= 0 Then
InputLanguage.CurrentInputLanguage = InputLanguage.InstalledInputLanguages(InputLanguage.InstalledInputLanguages.IndexOf(lang))
System.Threading.Thread.CurrentThread.CurrentCulture = culture
End If
Using winapi function .LoadKeyboardLayout (slowly, works even if input language not installed)
<DllImport("user32.dll")>
Private Shared Function LoadKeyboardLayout(ByVal pwszKLID As String, ByVal Flags As UInteger) As IntPtr
End Function
LoadKeyboardLayout("00000419", 1)
Additional
For check current culture:
InputLanguage.CurrentInputLanguage.Culture.Name
Check is input language installed:
InputLanguage.InstalledInputLanguages.IndexOf(InputLanguage.FromCulture(New CultureInfo("ru-RU"))
Switch to next locale identifier (keyboard layout):
Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Integer, ByVal flags As Integer) As Integer
'switch keyboard layout to next
Sub SwitchKeyboardLayout()
Dim HKL_NEXT As Integer = 1
Dim dl As Integer = ActivateKeyboardLayout(HKL_NEXT, 0)
If dl = 0 Then MsgBox("Unsuccessful!")
End Sub
Additional materials
CultureInfo
Available Language Packs for Windows
Function GetUNC(strMappedDrive As String) As String
Dim objFso As FileSystemObject
Set objFso = New FileSystemObject
Dim strDrive As String
Dim strShare As String
'Separated the mapped letter from
'any following sub-folders
strDrive = objFso.GetDriveName(strMappedDrive)
'find the UNC share name from the mapped letter
strShare = objFso.Drives(strDrive).ShareName '<<<< this is the line that the code fails on
'The Replace function allows for sub-folders
'of the mapped drive
GetUNC = Replace(strMappedDrive, strDrive, strShare)
Set objFso = Nothing 'Destroy the object
End Function
It works fine on my laptop and network, but when a colleague uses the same spreadsheet with the same code on their laptop and network the code throws a run-time error 5 exception 'invalid procedure call or argument' at the following line:
strShare = objFso.Drives(strDrive).ShareName
When I hover over the line of code I see: when I run the code to this point I see a file path.
My colleague has tried running the code on his local drive as well as a network drive with no success. We both have the same references selected as well. Does anyone know what I need to do to get this working on my colleagues machine?
Not entirely sure what the issue is, but it might be worth using an API call instead:
#If Win64 Then
Declare PtrSafe Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#Else
Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#End If
Dim lpszRemoteName As String * lBUFFER_SIZE
Dim lSize As Long
Const NO_ERROR As Long = 0&
Const lBUFFER_SIZE As Long = 255&
Function GetUNC(ByRef strDriveLetter As String) As String
strDriveLetter = UCase$(strDriveLetter) & ":"
GetUNC = IIf(WNetGetConnection32(strDriveLetter, lpszRemoteName, lBUFFER_SIZE) = NO_ERROR, lpszRemoteName, "Error")
End Function
Then simply use something like:
MsgBox GetUNC("S")
I'm using VBA in MS Access, and one of the subs takes a file path in a network, checks if the file exists or not, and write the result of a query on it.
The problem is that when I try to run the code, it gives me error 52 (Bad file name or number). But if I open the network path in windows explorer first, for example, after that the error doesn't happen anymore. Any ideas on what the problem might be?
Here is some of the code I'm running:
fpath = "\\networkpath\file.txt"
DeleteFile fpath
Sub DeleteFile(ByVal FileToDelete As String)
FileExists(FileToDelete) Then
SetAttr FileToDelete, vbNormal
FileToDelete
End If
End Sub
Function FileExists(ByVal FileToTest As String) As Boolean
FileExists = (Dir(FileToTest) <> "") 'this is where the error happens
End Function
Does the UNC path you use contain any non-Ascii characters, like accents? What is the exact path?
None of the file functions in VBA work well with Unicode anyway.
You could try to use the FileSystemObject to achieve the same a bit more reliably than the build-in VBA functions:
Public Function FileExists(filePath as string) as Boolean
Dim o As Object
Set o = CreateObject("Scripting.FileSystemObject")
FileExists = o.FileExists(filePath)
End Function
An alternative using the Win32 API tha works in 32 and 64 bit environments:
Private Const INVALID_FILE_ATTRIBUTES As Long = -1
#If VBA7 Then ' Win API Declarations for 32 and 64 bit versions of Office 2010 and later
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As LongPtr) As Long
#Else ' WIN API Declarations for Office 2007
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
#End If
Public Function FileExists(fname As Variant) As Boolean
If IsNull(fname) Or IsEmpty(fname) Then Exit Function
' Make sure that we can take care of paths longer than 260 characters
If Left$(fname, 2) = "\\" Then
FileExists = GetFileAttributes(StrPtr("\\?\UNC" & Mid$(fname, 2))) <> INVALID_FILE_ATTRIBUTES
Else
FileExists = GetFileAttributes(StrPtr("\\?\" & fname)) <> INVALID_FILE_ATTRIBUTES
End If
End Function
I'm trying to adapt the code in either here or here to open the custom colour palette in Excel 2010 64-bit but cannot get it to work. Code on both sites work fine in Excel 2003
One attempt
Option Explicit
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustomColors() As Byte
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As Long
Dim lReturn As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
This runs ok but doesn't show the dialog. I've also tried changing some LONG types to LONGPTR with no success. Does anyone know how to get this working on a 64-bit machine; or if it's even possible? Perhaps there's a new library?
Thanks
Edit: Slight rewording with offer of bounty...
How do I access and use this custom colour chooser (image below) in Excel 2010 64-bit (MUST work on 64-bit!) to set cells in Excel 2010 with the colour chosen and store the colour? The image is taken from Excel 2010 64-bit by selecting fill button>more colors>Custom
Valid XHTML http://img851.imageshack.us/img851/2057/unlednvn.png
Two things I would try. First, replace every use of Long with LongPtr.
Private Type CHOOSECOLOR
lStructSize As LongPtr
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As LongPtr
lpCustColors As String
flags As LongPtr
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As LongPtr
Second, replace the use of Len with LenB.
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As LongPtr
Dim lReturn As LongPtr
cc.lStructSize = LenB(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
More Info
LongPtr Data Type
LenB Function
AFAIK 32-bit dll's cannot be used by a 64-bit application.
Use comdlg64.dll instead (if there is such a dll).
Using google reveals that there a host of viruses floating around on the net by that name.
So if comdlg64.dll is not on your machine don't download it from the net!
(Unless you want to experience zombieness).
I am trying to register a type library programatically from VBA code, using two variants of a technique found using Google (Subs RegisterTypeLibrary and RegisterTypeLibrary2 below).
The code below crashes with an access violation on the call to LoadTypeLib / LoadTypeLibEx. What am I doing wrong? In case it's relevant, the type library is a TLB file generated from a .NET assembly using tlbexp.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As Object) As Long
Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
ByVal ptlib As Object, szFullPath As Byte, _
szHelpFile As Byte) As Long
Private Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLib(abNullTerminatedFileName(0), objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLib", "Error registering type library " & FileName
End If
lHResult = RegisterTypeLib(objTypeLib, abNullTerminatedFileName(0), 0)
If lHResult <> 0 Then
Err.Raise lHResult, "RegisterTypeLib", "Error registering type library " & FileName
End If
Exit Sub
End Sub
Private Sub RegisterTypeLibrary2(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
EDIT
I suspect it is something specific about my type library. I've found a solution which I've posted as an answer below.
I've found a solution, using the code below. Basically, the third parameter to LoadTypeLibEx (ITypeLib** in C/C++) is declared as stdole.IUnknown instead of as Object.
To do so, I needed to add a reference to stdole32.tlb to the VBA project.
I suspect there is something about my type library that means it can't be declared as a VB (late-bound) Object.
I could also have declared the third parameter as Long, but I'm not sure that wouldn't lead to problems with reference counting.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As stdole.IUnknown) As Long
Public Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As stdole.IUnknown
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
I suspect your type library (TLB) has errors because the code you provided works when I tested against a third-party TLB.
I am assuming you are going to use your .NET Assembly from VBA. Therefore, I suggest you make sure you can reference your TLB from VBA without errors.
Note, that all objects exposed by your .NET library must have public constructors that accept no arguments. This may be causing the problem.