I'm re-visiting a tool that I wrote in VB.Net for my helpdesk team a while back and want to add a couple of checkboxes to replicate the same function that Windows uses to show hidden files and folders / re-hide, as well as protected operating system files.
I know I can do this by editing a registry entry and restarting explorer.exe, but that closes all open Explorer Windows and I don't want that.
Does anyone know how Windows is able to do this by a simple click of a checkbox and how I may be able to code it in VB.net?
Any input on this is greatly appreciated in advance.
EDIT: So it looks like I have found a refresh method that works to refresh Windows Explorer / File Explorer which can be applied to Drarig's answer below but I am having trouble converting it to VB.net as the original example is in C#.
'Original at http://stackoverflow.com/questions/2488727/refresh-windows-explorer-in-win7
Private Sub refreshExplorer(ByVal explorerType As String)
Dim CLSID_ShellApplication As Guid = Guid.Parse("13709620-C279-11CE-A49E-444553540000")
Dim shellApplicationType As Type = Type.GetTypeFromCLSID(CLSID_ShellApplication, True)
Dim shellApplication As Object = Activator.CreateInstance(shellApplicationType)
Dim windows As Object = shellApplicationType.InvokeMember("Windows", Reflection.BindingFlags.InvokeMethod, Nothing, shellApplication, New Object() {})
Dim windowsType As Type = windows.GetType()
Dim count As Object = windowsType.InvokeMember("Count", Reflection.BindingFlags.GetProperty, Nothing, windows, Nothing)
For i As Integer = 0 To CType(count, Integer)
Dim item As Object = windowsType.InvokeMember("Item", Reflection.BindingFlags.InvokeMethod, Nothing, windows, New Object() {i})
Dim itemType As Type = item.GetType()
'Only fresh Windows explorer Windows
Dim itemName As String = CType(itemType.InvokeMember("Name", Reflection.BindingFlags.GetProperty, Nothing, item, Nothing), String)
If itemName = explorerType Then
itemType.InvokeMember("Refresh", Reflection.BindingFlags.InvokeMethod, Nothing, item, Nothing)
End If
Next
End Sub
I am getting an exception Object reference not set to an instance of an object when I set itemType as Type = item.GetType() above. I can't figure out which object isn't being created. When I step through the code it looks like windowsType contains an object for windows. Does anyone have any idea on this? Once this is worked out I can then apply it to Drarig's solution below.
Alright I wish I could have got this to you sooner, but busy lately at work. I took a little time today to figure this out as I love digging into something I have not done before. This is the whole class from a new project; didn't have time to wrap it up in a separate class. I am sure this will get you what you need. It was a little harder than I thought as getting the correct handle and then send the command, but I got it. I hope you find it useful.
P.S. Some of the things you can leave out, specifically the boolean used for loading, this was so I can pull the current value back on load and either check/uncheck the CheckBox.
Note: This is tried and tested on Windows 7, 8 and 10
Imports Microsoft.Win32
Imports System.Reflection
Imports System.Runtime.InteropServices
Public Class Form1
<Flags()> _
Public Enum KeyboardFlag As UInteger
KEYBOARDF_5 = &H74
End Enum
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function GetWindow(ByVal hl As Long, ByVal vm As Long) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function PostMessage(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function FindWindow(ByVal lpClassName As String, ByVal lpWindowName As String) As IntPtr
End Function
Private blnLoading As Boolean = False
Private Sub CheckBox1_CheckedChanged(sender As Object, e As EventArgs) Handles CheckBox1.CheckedChanged
Form1.HideFilesExtension(Me.CheckBox1.Checked)
If Not blnLoading Then NotifyFileAssociationChanged()
RefreshExplorer()
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim name As String = "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Dim key As RegistryKey = Registry.CurrentUser.OpenSubKey(name, False)
blnLoading = True
Me.CheckBox1.Checked = CBool(key.GetValue("Hidden"))
key.Close()
blnLoading = False
End Sub
Private Shared Sub HideFilesExtension(ByVal Hide As Boolean)
Dim name As String = "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Dim key As RegistryKey = Registry.CurrentUser.OpenSubKey(name, True)
key.SetValue("Hidden", If(Hide, 1, 0))
key.Close()
End Sub
Public Shared Sub RefreshExplorer()
Dim clsid As New Guid("13709620-C279-11CE-A49E-444553540000")
Dim typeFromCLSID As Type = Type.GetTypeFromCLSID(clsid, True)
Dim objectValue As Object = Activator.CreateInstance(typeFromCLSID)
Dim obj4 As Object = typeFromCLSID.InvokeMember("Windows", BindingFlags.InvokeMethod, Nothing, objectValue, New Object(0 - 1) {})
Dim type1 As Type = obj4.GetType
Dim obj2 As Object = type1.InvokeMember("Count", BindingFlags.GetProperty, Nothing, obj4, Nothing)
If (CInt(obj2) <> 0) Then
Dim num2 As Integer = (CInt(obj2) - 1)
Dim i As Integer = 0
Do While (i <= num2)
Dim obj5 As Object = type1.InvokeMember("Item", BindingFlags.InvokeMethod, Nothing, obj4, New Object() {i})
Dim type3 As Type = obj5.GetType
Dim str As String = CStr(type3.InvokeMember("Name", BindingFlags.GetProperty, Nothing, obj5, Nothing))
If (str = "File Explorer") Then
type3.InvokeMember("Refresh", BindingFlags.InvokeMethod, Nothing, obj5, Nothing)
End If
i += 1
Loop
End If
End Sub
Public Shared Sub NotifyFileAssociationChanged()
'Find the actual window...
Dim hwnd As IntPtr = FindWindow("Progman", "Program Manager")
'Get the window handle and refresh option...
Dim j = GetWindow(hwnd, 3)
'Finally post the message...
PostMessage(j, 256, KeyboardFlag.KEYBOARDF_5, 3)
End Sub
End Class
Here's a solution for everything excepting the refreshing of the explorer.
I've translated the code, but I'm unable to find how to refresh the explorer/desktop without restarting it.
Const keyName As String = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Const Hidden As String = "Hidden"
Const SHidden As String = "ShowSuperHidden"
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim St As Integer = GetRegValue(Hidden)
If St = 2 Then
SetRegValue(Hidden, 1)
SetRegValue(SHidden, 1)
Else
SetRegValue(Hidden, 2)
SetRegValue(SHidden, 0)
End If
End Sub
Private Function GetRegValue(valueName As String) As Integer
Return CInt(My.Computer.Registry.GetValue(keyName, valueName, 0))
End Function
Private Sub SetRegValue(valueName As String, value As Integer)
My.Computer.Registry.SetValue(keyName, valueName, value, Microsoft.Win32.RegistryValueKind.DWord)
End Sub
I have a few ideas to refresh the desktop :
Send a key to a running process. I tried this (source) :
Dim pp As Process() = Process.GetProcessesByName("explorer")
If pp.Length > 0 Then
For Each p In pp
AppActivate(p.Id)
SendKeys.SendWait("{F5}")
Next
End If
Refresh using SHChangeNotify (source),
Refresh broadcasting a WM_SETTINGCHANGE message (source),
etc.
I think you'll be forced to manually refresh or restart the explorer.
Related
Being a self-taught VBA programmer I usually search the internet until I find a satisfactory solution for the problems (and the limitations of VBA) I stumble upon. I do not simply copy code of others, I really try to understand it as well, so I can learn from it. Long story short: I used code I found for dragging data from one listbox to another. Originally, the code (for 2 listboxes) was simply put in the form's code module but I wanted to use it in a class module so I don't have to copy/paste the same code for each and every d&d listbox I use on a form. The code I use:
(Code module of the form; just the listbox part)
Option Explicit
Private collection_ListBox As New collection
Private collection_ComboBox As New collection
Private collection_Textbox As New collection
Private Sub UserForm_Initialize()
Dim frm_control As Control
Set collection_ListBox = New collection
Set collection_ComboBox = New collection
Set collection_Textbox = New collection
For Each frm_control In Me.Controls
Select Case TypeName(frm_control)
Case "ListBox"
Dim obj As CfrwxDragDropList: Set obj = New CfrwxDragDropList
Set obj.FRWX_Control = frm_control: obj.Initialize
collection_ListBox.Add obj
Case "ComboBox"
Case "TextBox"
End Select
Next frm_control
'***TEMP for testing purposes***
ListBox1.List = Array("Item1", "Item2", "Item3", "Item4", "Item5", "Item6", "Item7")
End Sub
(Code module of the class)
Option Explicit
Private WithEvents FRWX_DragDrop As msforms.ListBox
Private Item_Source As msforms.ListBox
Public Property Get FRWX_Control() As msforms.ListBox
Set FRWX_Control = FRWX_DragDrop
End Property
Public Property Set FRWX_Control(reg_Control As msforms.ListBox)
Set FRWX_DragDrop = reg_Control
End Property
Public Sub Initialize()
'Nothing here yet!
End Sub
Private Sub FRWX_DragDrop_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If FRWX_Control.ListIndex < 0 Then Exit Sub
If Button = 1 Then
Call SetDraggedItem(FRWX_Control)
End If
End Sub
Private Sub FRWX_DragDrop_BeforeDragOver(ByVal Cancel As msforms.ReturnBoolean, _
ByVal Data As msforms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal DragState As Long, ByVal Effect As msforms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
Private Sub FRWX_DragDrop_BeforeDropOrPaste(ByVal Cancel As msforms.ReturnBoolean, _
ByVal Action As msforms.fmAction, _
ByVal Data As msforms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal Effect As msforms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Call AddDroppedItem(FRWX_Control, Data, Y)
Call DeleteDraggedItem(Item_Source)
End Sub
Private Sub SetDraggedItem(lb As msforms.ListBox)
Set Item_Source = lb
Dim dataObj As New DataObject
dataObj.SetText lb.Text
Call dataObj.StartDrag(fmDropEffectMove)
End Sub
Private Sub AddDroppedItem(lb As msforms.ListBox, dataObj As DataObject, Y As Single)
lb.AddItem dataObj.GetText, FixDropIndex(lb, Y)
End Sub
Private Sub DeleteDraggedItem(lb As msforms.ListBox)
Dim selIndex As Long
With lb
selIndex = .ListIndex
.Selected(selIndex) = False
.RemoveItem selIndex
End With
Set Item_Source = Nothing
End Sub
Private Function FixDropIndex(lb As msforms.ListBox, Y As Single) As Long
Dim toIndex As Long
With lb
toIndex = .TopIndex + Int(Y * 0.85 / .Font.Size)
If toIndex < 0 Then toIndex = 0
If toIndex >= .ListCount Then toIndex = .ListCount
End With
FixDropIndex = toIndex
End Function
So far so good; everything works fine except for one tiny little thing: I get an error on
Call DeleteDraggedItem(Item_Source)
in the sub FRWX_DragDrop_BeforeDropOrPaste. I know WHY I get this error: when I drop the DataObject in ListBox2, Item_Source in the corresponding instance of the class will be empty for it was filled in the ListBox1 instance of the class. So I need a way to let ListBox2 know the source of the dropped text. I can think of 2 ways of fixing this.
The first one sends shivers down my spine only thinking of it, for it feels almost like blasphemy: I could send it with the DataObject along with the text itself by 'expanding' lb.Text with "|" followed by lb.Name and split the string in the receiving instance. It will work, but I don't like this kind of solutions.
I could pass the name of the source ListBox to the parent (being the form itself) from instance 1, so instance 2 can ask for it there. I haven't tried that solution yet, but I'm sure I'll get it to work.
So now for my questions:
1. is solution 2 a/the right way to go?
2. are there other/better solutions I haven't thought of yet?
Any help will be highly appreciated!
***** UPDATE *****
As mentioned below, I found another (I think better) fix myself. The events are still triggered from the class instances for each listbox, but I used a separate, single instance of a class that performs the actual actions attached to them. Here's the updated code:
(Code module of the form; just the listbox part)
Option Explicit
Private collection_ListBox As New collection
Private collection_ComboBox As New collection
Private collection_Textbox As New collection
Private Sub UserForm_Initialize()
Dim frm_control As Control
Set collection_ListBox = New collection
Set collection_ComboBox = New collection
Set collection_Textbox = New collection
Dim handler As CfrwxDragDropList_EventHandler: Set handler = New CfrwxDragDropList_EventHandler
For Each frm_control In Me.Controls
Select Case TypeName(frm_control)
Case "ListBox"
Dim obj As CfrwxDragDropList: Set obj = New CfrwxDragDropList
Set obj.FRWX_Control = frm_control: obj.Initialize
Set obj.FRWX_EventHandler = handler
collection_ListBox.Add obj
Case "ComboBox"
Case "TextBox"
End Select
Next frm_control
'***TEMP for testing purposes***
ListBox1.List = Array("Item1", "Item2", "Item3", "Item4", "Item5", "Item6", "Item7")
End Sub
(Code module of the listbox class "CfrwxDragDropList"
Option Explicit
Private WithEvents FRWX_DragDrop As MSForms.ListBox
Private FRWX_DragDrop_Handler As CfrwxDragDropList_EventHandler
Private Item_Source As MSForms.ListBox
Public Property Get FRWX_Control() As MSForms.ListBox
Set FRWX_Control = FRWX_DragDrop
End Property
Public Property Set FRWX_Control(reg_Control As MSForms.ListBox)
Set FRWX_DragDrop = reg_Control
End Property
Public Property Get FRWX_EventHandler() As CfrwxDragDropList_EventHandler
Set FRWX_EventHandler = FRWX_DragDrop_Handler
End Property
Public Property Set FRWX_EventHandler(handler As CfrwxDragDropList_EventHandler)
Set FRWX_DragDrop_Handler = handler
End Property
Public Sub Initialize()
'Nothing here yet!
End Sub
Private Sub FRWX_DragDrop_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If FRWX_Control.ListIndex < 0 Then Exit Sub
If Button = 1 Then
Call FRWX_DragDrop_Handler.SetDraggedItem(FRWX_Control)
End If
End Sub
Private Sub FRWX_DragDrop_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal DragState As Long, ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
End Sub
Private Sub FRWX_DragDrop_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = fmDropEffectMove
Call FRWX_DragDrop_Handler.AddDroppedItem(FRWX_Control, Data, Y)
Call FRWX_DragDrop_Handler.DeleteDraggedItem
End Sub
(Code module of the eventhandler class "CfrwxDragDropList_EventHandler"
Option Explicit
Private Item_Source As MSForms.ListBox
Public Sub SetDraggedItem(lb As MSForms.ListBox)
Set Item_Source = lb
Dim dataObj As New DataObject
dataObj.SetText lb.Text
Call dataObj.StartDrag(fmDropEffectMove)
End Sub
Public Sub AddDroppedItem(lb As MSForms.ListBox, dataObj As DataObject, Y As Single)
lb.AddItem dataObj.GetText, FixDropIndex(lb, Y)
End Sub
Public Sub DeleteDraggedItem()
Dim selIndex As Long
With Item_Source
selIndex = .ListIndex
.Selected(selIndex) = False
.RemoveItem selIndex
End With
Set Item_Source = Nothing
End Sub
Private Function FixDropIndex(lb As MSForms.ListBox, Y As Single) As Long
Dim toIndex As Long
With lb
toIndex = .TopIndex + Int(Y * 0.85 / .Font.Size)
If toIndex < 0 Then toIndex = 0
If toIndex >= .ListCount Then toIndex = .ListCount
End With
FixDropIndex = toIndex
End Function
That's it! It works between 2 listboxes, but if you want to use more it'll work as well. You can move items between listboxes, but also change the order of items within a listbox.
I'm trying to set the icon from a generated Windows Form Application, here's my code.
Private Sub CompileSourceCode()
Dim cProvider As CodeDomProvider = New VBCodeProvider
Dim cParams As New CompilerParameters
Dim cResult As CompilerResults
Dim sourceCode As String = generate_exe.final_winform
With cParams
.GenerateInMemory = False
.GenerateExecutable = True
.OutputAssembly = "test.exe"
.CompilerOptions = "/target:winexe /win32icon:eye.ico"
.ReferencedAssemblies.AddRange({"System.dll", "System.Windows.Forms.dll", "Microsoft.VisualBasic.dll"})
.MainClass = "MyNamespace.form1"
End With
cResult = cProvider.CompileAssemblyFromSource(cParams, sourceCode)
cProvider.Dispose()
If cResult.Errors.HasErrors Then
MsgBox(cResult.Errors(0).Line.ToString & ", " & cResult.Errors(0).ErrorText)
End If
End Sub
The problem:
The first time i run it, it creates the EXE with the icon i chose.
The second time, if i just change the icon i want to use but leave it as the same OutputAssembly name (test.exe) it creates the EXE but with the old icon, doesn't update.
Edit: Found a very good solution, Although It's been a long time since my question, I think it could help someone else with the same problem using SHChangeNotify. Add that to the top of the code:
Const SHCNE_ASSOCCHANGED As Integer = &H8000000
Const SHCNF_IDLIST As Integer = 0
Private Class NativeMethods
<DllImport("shell32")>
Public Shared Sub SHChangeNotify(ByVal wEventId As Integer, ByVal flags As Integer, ByVal item1 As IntPtr, ByVal item2 As IntPtr)
End Sub
End Class
Usage: (before or after your compile command)
NativeMethods.SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, Nothing, Nothing)
The following is the code i m using to convert doc file to image.this works well for a file that contains only one page but if there are more than one page in doc file then it converts only first page of file to image.Can some one suggest me how to convert all pages of doc file to seperate images.
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim objWord As New Microsoft.Office.Interop.Word.Application
Dim objDoc As Microsoft.Office.Interop.Word.Document
Const CF_ENHMETAFILE As Integer = 14
objDoc = objWord.Documents.Open("F:\Study\Constructor.docx")
objWord.Activedocument.Select()
objWord.Selection.CopyAsPicture()
Dim ip As IntPtr
Dim metaFile As System.Drawing.Imaging.Metafile
Dim bRet As Boolean
bRet = ClipboardAPI.OpenClipboard(Me.Handle)
If bRet = True Then
'Verify the clipboard contains data available
'as an enhanced metafile.
bRet = ClipboardAPI.IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0
End If
If bRet = True Then
'Store the clipboard's contents in the IntPtr.
ip = ClipboardAPI.GetClipboardData(CF_ENHMETAFILE)
End If
'Verify the IntPrt contains data before proceeding. Passing
'an empty IntPtr to System.Drawing.Imaging.Metafile results
'in an exception.
If Not IntPtr.Zero.Equals(ip) Then
metaFile = New System.Drawing.Imaging.Metafile(ip, True)
ClipboardAPI.CloseClipboard()
Dim image As System.Drawing.Image = metaFile
'Me.PictureBox1.Image = metaFile
Dim objImageWriter As Image = New Bitmap(image.Width, image.Height)
Dim objGraphics As Graphics = Graphics.FromImage(objImageWriter)
objGraphics.Clear(Color.White)
'objGraphics.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
objGraphics.DrawImage(image, 0, 0, image.Width, image.Height)
image.Dispose()
objGraphics.Dispose()
Dim ep As Imaging.EncoderParameters = New Imaging.EncoderParameters
ep.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.Quality, 100)
Dim codecs() As Imaging.ImageCodecInfo = Imaging.ImageCodecInfo.GetImageEncoders()
Dim iciInfo As Imaging.ImageCodecInfo
Dim item As Imaging.ImageCodecInfo
For Each item In codecs
If (item.MimeType = "image/jpeg") Then iciInfo = item
Next
objImageWriter.Save("F:\Study\test1.jpg", iciInfo, ep)
objImageWriter.Dispose()
End If
Public Class ClipboardAPI
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="OpenClipboard", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function OpenClipboard(ByVal hWnd As IntPtr) As Boolean
End Function
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="EmptyClipboard", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function EmptyClipboard() As Boolean
End Function
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="SetClipboardData", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function SetClipboardData(ByVal uFormat As Integer, ByVal ByValhWnd As IntPtr) As IntPtr
End Function
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="CloseClipboard", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function CloseClipboard() As Boolean
End Function
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="GetClipboardData", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function GetClipboardData(ByVal uFormat As Integer) As IntPtr
End Function
<Runtime.InteropServices.DllImport("user32.dll", EntryPoint:="IsClipboardFormatAvailable", SetLastError:=True, ExactSpelling:=True, CallingConvention:=System.Runtime.InteropServices.CallingConvention.StdCall)> _
Public Shared Function IsClipboardFormatAvailable(ByVal uFormat As Integer) As Short
End Function
End Class
The problem is that the line "objWord.Activedocument.Select()" references the entire document rather than the document's individual pages. I've added a bit to your code to snap an image of each page's contents:
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim objWord As New Microsoft.Office.Interop.Word.Application
Dim objDoc As Microsoft.Office.Interop.Word.Document
Const CF_ENHMETAFILE As Integer = 14
objDoc = objWord.Documents.Open("F:\Study\Constructor.docx")
objDoc.Repaginate()
For i As Integer = 1 To objDoc.ActiveWindow.Panes(1).Pages.Count
If i = 1 Then
With objWord.ActiveDocument
.GoTo(WdGoToItem.wdGoToPage, WdGoToDirection.wdGoToAbsolute, 1)
.Bookmarks("\Page").Range.Select()
End With
Else
With objWord.Selection
.GoTo(What:=WdGoToItem.wdGoToPage, Which:=WdGoToDirection.wdGoToNext)
.Bookmarks("\Page").Range.Select()
End With
End If
objWord.Selection.CopyAsPicture()
Dim ip As IntPtr
Dim metaFile As System.Drawing.Imaging.Metafile
Dim bRet As Boolean
bRet = ClipboardAPI.OpenClipboard(Me.Handle)
If bRet = True Then
'Verify the clipboard contains data available
'as an enhanced metafile.
bRet = ClipboardAPI.IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0
End If
If bRet = True Then
'Store the clipboard's contents in the IntPtr.
ip = ClipboardAPI.GetClipboardData(CF_ENHMETAFILE)
End If
'Verify the IntPrt contains data before proceeding. Passing
'an empty IntPtr to System.Drawing.Imaging.Metafile results
'in an exception.
If Not IntPtr.Zero.Equals(ip) Then
metaFile = New System.Drawing.Imaging.Metafile(ip, True)
ClipboardAPI.CloseClipboard()
Dim image As System.Drawing.Image = metaFile
'Me.PictureBox1.Image = metaFile
Dim objImageWriter As Image = New Bitmap(image.Width, image.Height)
Dim objGraphics As Graphics = Graphics.FromImage(objImageWriter)
objGraphics.Clear(Color.White)
'objGraphics.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
objGraphics.DrawImage(image, 0, 0, image.Width, image.Height)
image.Dispose()
objGraphics.Dispose()
Dim ep As Imaging.EncoderParameters = New Imaging.EncoderParameters
ep.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.Quality, 100)
Dim codecs() As Imaging.ImageCodecInfo = Imaging.ImageCodecInfo.GetImageEncoders()
Dim iciInfo As Imaging.ImageCodecInfo
Dim item As Imaging.ImageCodecInfo
For Each item In codecs
If (item.MimeType = "image/jpeg") Then iciInfo = item
Next
objImageWriter.Save("F:\Study\test" & i.ToString & ".jpg", iciInfo, ep)
objImageWriter.Dispose()
End If
Next
End Sub
Summary of the additional code changes:
I added "objDoc.Repaginate()" to get accurate page references. Word does not really make use of pages ordinarily, it is constantly querying the system's print driver to decide where it needs to break text up into pages. This ensures that we have an accurate page count in accordance with the current machine.
I enclosed your image logic in this for-loop: "For i As Integer = 1 To objDoc.ActiveWindow.Panes(1).Pages.Count". The if-else directly following that line will select the first page in the first iteration, and then any subsequent additional pages thereafter. Everything else that follows is unchanged except for the save-filename.
Lastly, I just concatenated the page number into the image's save-path for obvious reasons...
I tested this on my own computer and it worked as intended, I hope this helps!
...Just an off-topic sidenote, I don't know if the code disposing of the Word handles just wasn't included in your question or if it's actually missing, but you may want to make sure you add that; Interop class loves to leave running office processes in the background even after the program has closed if they aren't disposed of properly, this example was leaving them open on my computer.
I have this program that shows files with its icons using a ListView and it works a little bit fine but there's a problem, some files(.exe, .docx etc...) don't show their right icon like this. how do I fix that?
This is how I call the Shell:
' declare the Win32 API function SHGetFileInfo'
Public Declare Auto Function SHGetFileInfo Lib "shell32.dll" (ByVal pszPath As String, ByVal dwFileAttributes As Integer, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Integer, ByVal uFlags As Integer) As IntPtr
' declare some constants that SHGetFileInfo requires'
Public Const SHGFI_ICON As Integer = &H100
Public Const SHGFI_SMALLICON As Integer = &H1
' define the SHFILEINFO structure'
Structure SHFILEINFO
Public hIcon As IntPtr
Public iIcon As Integer
Public dwAttributes As Integer
<Runtime.InteropServices.MarshalAs(Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=260)> _
Public szDisplayName As String
<Runtime.InteropServices.MarshalAs(Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=80)> _
Public szTypeName As String
End Structure
Function RetrieveShellIcon(ByVal argPath As String) As Image
Dim mShellFileInfo As SHFILEINFO
Dim mSmallImage As IntPtr
Dim mIcon As System.Drawing.Icon
Dim mCompositeImage As Image
mShellFileInfo = New SHFILEINFO
mShellFileInfo.szDisplayName = New String(Chr(0), 260)
mShellFileInfo.szTypeName = New String(Chr(0), 80)
mSmallImage = SHGetFileInfo(argPath, 0, mShellFileInfo, System.Runtime.InteropServices.Marshal.SizeOf(mShellFileInfo), SHGFI_ICON Or SHGFI_SMALLICON)
' create the icon from the icon handle'
Try
mIcon = System.Drawing.Icon.FromHandle(mShellFileInfo.hIcon)
mCompositeImage = mIcon.ToBitmap
Catch ex As Exception
' create a blank black bitmap to return'
mCompositeImage = New Bitmap(16, 16)
End Try
' return the composited image'
Return mCompositeImage
End Function
Function GetIcon(ByVal argFilePath As String) As Image
Dim mFileExtension As String = System.IO.Path.GetExtension(argFilePath)
' add the image if it doesn't exist'
If cIcons.ContainsKey(mFileExtension) = False Then
cIcons.Add(mFileExtension, RetrieveShellIcon(argFilePath))
End If
' return the image'
Return cIcons(mFileExtension)
End Function
and this is how I show file icons in my `ListView.
Sub lv1items()
Dim lvi As ListViewItem
Dim di As New DirectoryInfo(Form2.TextBox1.Text)
Dim exts As New List(Of String)
ImageList1.Images.Clear()
If di.Exists = False Then
MessageBox.Show("Source path is not found", "Directory Not Found", MessageBoxButtons.OK, MessageBoxIcon.Error)
Else
For Each fi As FileInfo In di.EnumerateFiles("*.*")
lvi = New ListViewItem
lvi.Text = fi.Name
lvi.SubItems.Add(((fi.Length / 1024)).ToString("0.00"))
lvi.SubItems.Add(fi.CreationTime.ToShortDateString)
If exts.Contains(fi.Extension) = False Then
Dim mShellIconManager As New Form1
For Each mFilePath As String In My.Computer.FileSystem.GetFiles(Form2.TextBox1.Text)
ImageList1.Images.Add(fi.Extension, GetIcon(mFilePath))
exts.Add(fi.Extension)
Next
End If
lvi.ImageKey = fi.Extension
ListView1.Items.Add(lvi)
Next
End If
End Sub
That appears to be a weird limitation of the .net implication
its really just making a call to shell32.dll
You should call the function in shell32 directly
something like this should work
<DllImport("shell32.dll")>
Private Shared Function ExtractAssociatedIcon(hInst As IntPtr, lpIconPath As StringBuilder, ByRef lpiIcon As UShort) As IntPtr
End Function
_
Dim handle As IntPtr = SafeNativeMethods.ExtractAssociatedIcon(New HandleRef(Nothing, IntPtr.Zero), iconPath, index)
If handle <> IntPtr.Zero Then
Return Icon.FromHandle(handle)
End If
The syntax might not be exactly correct, also there is a good blog post about how to pull that information from the registry (which won't always give you the correct answer, but its faster)
Building a Better ExtractIcon (he uses the SHGetFileInfo API in shell32.dll if that blog ever dies it will give people a place to start looking)
I am wanting to retrieve all the files in some directories. Here is my original code:
Private Function Search(path As String, Recursive As Boolean) As Boolean
Dim dirInfo As New IO.DirectoryInfo(path)
Dim fileObject As FileSystemInfo
If Recursive = True Then
For Each fileObject In dirInfo.GetFileSystemInfos()
If fileObject.Attributes = FileAttributes.Directory Then
Search(fileObject.FullName, Recursive)
Else
lstFiles.Items.Add(fileObject.FullName)
End If
Next
Else
For Each fileObject In dirInfo.GetFileSystemInfos()
lstFiles.Items.Add(fileObject.FullName)
Next
End If
Return True
End Function
This code works well, yet it returns some directories and I am wanting to only return files.
I tried this code:
Private Sub Search(ByVal path As String, ByVal Recursive As Boolean)
if not Directory.Exists(path) then Exit Sub
Dim initDirInfo As New DirectoryInfo(path)
For Each oFileInfo In initDirInfo.GetFiles
lstfiles.items.add(oFileInfo.Name)
Next
If Recursive Then
For Each oDirInfo In initDirInfo.GetDirectories
Search(oDirInfo.FullName, True)
Next
End If
End Sub
However, i get the following error:
Access to the path 'C:\Users\Simon\AppData\Local\Application Data\' is denied.
Can someone help me with my original code, or help me access these directories with my new code?
thanks
EDIT:
I have added this module to get it working:
Imports System.Security.Principal
Module VistaSecurity
'Declare API
Private Declare Ansi Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Integer
Private Const BCM_FIRST As Int32 = &H1600
Private Const BCM_SETSHIELD As Int32 = (BCM_FIRST + &HC)
Public Function IsVistaOrHigher() As Boolean
Return Environment.OSVersion.Version.Major < 6
End Function
' Checks if the process is elevated
Public Function IsAdmin() As Boolean
Dim id As WindowsIdentity = WindowsIdentity.GetCurrent()
Dim p As WindowsPrincipal = New WindowsPrincipal(id)
Return p.IsInRole(WindowsBuiltInRole.Administrator)
End Function
' Add a shield icon to a button
Public Sub AddShieldToButton(ByRef b As Button)
b.FlatStyle = FlatStyle.System
SendMessage(b.Handle, BCM_SETSHIELD, 0, &HFFFFFFFF)
End Sub
' Restart the current process with administrator credentials
Public Sub RestartElevated()
Dim startInfo As ProcessStartInfo = New ProcessStartInfo()
startInfo.UseShellExecute = True
startInfo.WorkingDirectory = Environment.CurrentDirectory
startInfo.FileName = Application.ExecutablePath
startInfo.Verb = "runas"
Try
Dim p As Process = Process.Start(startInfo)
Catch ex As Exception
Return 'If cancelled, do nothing
End Try
Application.Exit()
End Sub
End Module
The access denied errors are occurring at Windows Libraries I think. I don't think there is any way to list the file in these libraries as they aren't actually folders.