Category Archives: General VBA

Scrolling Excel chart in Powerpoint


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2012/04/21/scrolling-excel-chart-in-powerpoint/

 

While answering a question in stackoverflow.com, I came across an interesting question. How do we create a scrollable Excel chart in PowerPoint. In Excel it is very easy to make a scrollable chart using ScrollBar – Form Control. But how do we do it in PowerPoint?

I will cover this in 3 parts

1) Creating the Excel File

2) Setting up your presentation

3) The code


CREATING THE EXCEL FILE


Open a new Excel File and feed in some sample data as shown in the screen shot. I have filled 200 rows with sample data. Once the Data ready, create a line chart. Your Excel File should look like this.

image

Save the file to say, C: or any other location of your choice.


SETTING UP YOUR PRESENTATION


Open MS PowerPoint and go to slide 1. Click on the tab INSERT | OBJECT

image

You will be presented with Insert Object Dialog Box. Select the “Create From File” Option and then click on the “Browse” button. Select the Excel file that we had created earlier and select an icon by clicking “Display as Icon” and click on OK.

image

Your presentation will now look like this

image

Next navigate to the DEVELOPER Tab. (See Snapshot) In the developer tab, click on additional controls button and select “Microsoft Web Browser” and insert that control in your respective slide. Ensure that it hides the Excel Object that we inserted earlier. Size it accordingly. Also place a Command Button. Name it “Show Chart” or anything else what you feel is right.

image

And you are done with setting up your presentation


THE CODE


Press ALT + F11 or Click on tab DEVELOPER | VISUAL BASIC on the right hand side to open the visual basic editor.

image

Paste the code given below in the Slide1 code area.

image

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

Dim ImageFile As String

Private Sub CommandButton1_Click()
    ExtractToTemp
    WebBrowser1.Navigate ImageFile
End Sub

Sub ExtractToTemp()
    Dim oSl As PowerPoint.Slide
    Dim oSh As PowerPoint.Shape

    Dim oXLApp As Object, oXLWB As Object, oXLSht As Object
    Dim mychart As Object

    Set oSl = ActivePresentation.Slides(1)

    Set oSh = oSl.Shapes(1)

    With oSh.OLEFormat.Object.Sheets(1)
        .Shapes(1).Copy
    End With

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oXLApp.Visible = False

    '~~> Open the relevant file
    Set oXLWB = oXLApp.Workbooks.Add
    Set oXLSht = oXLWB.Worksheets(1)

    oXLSht.Paste

    '~~> Save Picture Object
    ImageFile = TempPath & "Tester.jpg"

    If Len(Dir(ImageFile)) > 0 Then Kill ImageFile

    Set mychart = oXLSht.ChartObjects(1).Chart
    mychart.Export FileName:=ImageFile, FilterName:="jpg"

    '~~> Wait till the file is saved
    Do
        If FileExists(ImageFile) = True Then Exit Do
        DoEvents
    Loop

    oXLWB.Close SaveChanges:=False
    oXLApp.Quit
    Set oXLWb = Nothing
    Set oXLApp = Nothing 
End Sub

'~~> Get User's TempPath
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

'~~> Function tot check if file exists
Public Function FileExists(strFullPath As String) As Boolean
    On Error GoTo Whoa
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileExists = True
Whoa:
    On Error GoTo 0
End Function

And you are done. Smile

Run the presentation by pressing F5 and click on the “Show Chart Button”. You screen show now look like this.

image

If you have made this presentation then this presentation can also be distributed easily.

Hope this helps…

Check if an Excel File has a Macro


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2012/04/12/check-if-an-excel-file-has-a-macro/

 

Today while answering a question in MSDN Excel Forum, I came across an interesting question. Can we check if the Excel File has a “Macro”. When I say “Macro”, I am not referring to just any “Code”.

I started off with a small piece of code and as the discussion went on in the thread, I realized that I had not taken several scenarios into consideration. For ex. What if the user had “Require Variable Declaration” checked. My code was just counting the lines and then deciding whether there was a macro or not. I would like to thank Hans Vogelaar for suggesting different scenarios which made it possible to narrow down the code to the specifics.

So how do we check if the file has a “Macro”?

Logic: Strictly speaking Macros start with “Sub“ or “Private Sub” or “Public Sub”. So if we check for “Sub” then we can decide if the file has any macros or not.

Code:

Option Explicit

Sub Sample()
    Dim wb As Workbook
    Dim HasMacro As Boolean
    Dim StrCode As String
    Dim i As Long

    '~~> Open the file to check if it has any MACRO

    Set wb = Workbooks.Open("C:\Users\Siddharth Rout\Desktop\book2.xlsm")

    Select Case UCase(Split(wb.Name, ".")(UBound(Split(wb.Name, "."))))
        '<~~ Excel files which can have a macro.
    Case "XLS", "XLSM", "XLTM", "XLT", "XLA", "XLSB", "XLAM"
        With wb.VBProject
            '~~> Components are like sheet1, thisworkbook, module etc.
            If .VBComponents.Count > 0 Then
                For i = 1 To .VBComponents.Count
                    '~~> get the entire code in the module
                    StrCode = .VBComponents.Item(i).CodeModule.Lines(1, _
                    .VBComponents.Item(i).CodeModule.CountOfLines)

                    StrCode = " " & Replace(StrCode, vbCrLf, " ") & " "

                    If InStr(StrCode, " Sub ") > 0 Then
                        HasMacro = True
                        Exit For
                    End If
                Next
            End If
        End With
    End Select

    wb.Close SaveChanges:=False

    If HasMacro Then
        MsgBox "The workbook has macro"
    Else
        MsgBox "The workbook doesn't have a macro"
    End If
End Sub

However an Userform might also have “Sub” so how do we ignore that?

All VBComponents have a type. To check that simply run this code in an Excel file which has Sheets, Thisworkbook, Module, Userform and a Class Module.

Option Explicit

Sub Sample()
    Dim wb As Workbook
    Dim i As Long

    Set wb = ActiveWorkbook

    With wb.VBProject
        '~~> Components are like sheet1, thisworkbook, module etc.
        If .VBComponents.Count > 0 Then
            For i = 1 To .VBComponents.Count
                Debug.Print .VBComponents.Item(i).Name
                Debug.Print .VBComponents.Item(i).Type
            Next
        End If
    End With
End Sub
You will notice that these are the types
Name : ThisWorkbook Type : 100
Name : Sheet1       Type : 100
Name : Module1      Type : 1
Name : UserForm1    Type : 3
Name : Class1       Type : 2
So you can actually trap the “type” in the above code to ignore say Userforms
With wb.VBProject
    '~~> Components are like sheet1, thisworkbook, module etc.
    If .VBComponents.Count > 0 Then
        For i = 1 To .VBComponents.Count
            If .VBComponents.Item(i).Type = 3 Then
                '~~> Rest of your code
            End If
        Next
    End If
End With
You also use the Excel Constants instead of the above numbers for example, when you type
.VBComponents.Item(i).Type =
Intellisense automatically gives you the options. See picture.
image
Taking this post a step forward.
  • How to Check if an Excel File has any code

To check if there is any “Code” or not in an excel file you can use this code. This takes account of only “Option Explicit”. You can amend it to also take into considerations the following. One can also just check if the first word is “Option” to trap all the scenarios mentioned below.

Option Compare Binary
Option Compare Text
Option Private Module
Option Base 0
Option Base 1

Code:

Sub Sample()
    Dim wb As Workbook
    Dim Count_of_Lines As Long
    Dim StrCode As String

    Set wb = Workbooks.Open("C:\Users\Siddharth Rout\Desktop\book2.xlsm")

    Select Case UCase(Split(wb.Name, ".")(UBound(Split(wb.Name, "."))))

    '<~~ Excel files which can have a macro.
    Case "XLS", "XLSM", "XLTM", "XLT", "XLA", "XLSB", "XLAM"
       '~~> Taking this approach as there are very few extensions which support macros
    Case Else
        MsgBox "The workbook doesn't have any Code"
        wb.Close SaveChanges:=False
        Exit Sub
    End Select

    Count_of_Lines = 0

    With wb.VBProject
        '~~> Components are like sheet1, thisworkbook, module etc.
        If .VBComponents.Count > 0 Then
            For i = 1 To .VBComponents.Count
                '~~> Get the entire code in the module
                StrCode = Trim(.VBComponents.Item(i).CodeModule.Lines(1, _
                .VBComponents.Item(i).CodeModule.CountOfLines))
                If checkstatus(StrCode) = False Then
                    Count_of_Lines = Count_of_Lines + .VBComponents.Item(i).CodeModule.CountOfLines
                End If
             Next
         End If
    End With

    If Count_of_Lines > 0 Then
        MsgBox "The workbook has Code"
    Else
        MsgBox "The workbook doesn't have any Code"
    End If
End Sub

'~~> Checking if the code doesn't have just blank lines or "Option Explicit" only
Function checkstatus(strg As String) As Boolean
    Dim ar
    Dim strTemp As String

    strTemp = strg

    If InStr(1, strTemp, vbNewLine) Then
        Do While InStr(1, strTemp, vbNewLine) > 0
             strTemp = Replace(strTemp, vbNewLine, "")
        Loop
        strTemp = Trim(strTemp)
    Else
        strTemp = Trim(strg)
    End If

    If Trim(strTemp) = "Option Explicit" Or _
    Len(Trim(strTemp)) = 0 Or _
    Left(Trim(strTemp), 1) = "'" _
    Then checkstatus = True
 End Function
EDIT
This edit was required as Doug Glancy gave some nice suggestions.
To access the VBA components as shown in the code above, the user needs to have checked “Trust access to the VBA project object model” in Macro Security. To do this, follow these steps
Excel 2003: Click on menu Tools | Macro | Security to access the”Security” dialog Box. Under “Trusted Publisher” tab, check the box which says “Trust access to  the Visul Basic Project

Excel 2007 : Click on the “Office”  icon| Excel Options. You will get a dialog box as shown in the snapshot below. Click on “Trust Center Settings“. Under the “Macro Settings“, check the box which says “Trust access to  the VBA project object model
Excel 2010 : Click on the “File” Tab | Options. You will get a dialog box as shown in the snapshot below. Click on “Trust Center Settings“. Under the “Macro Settings“, check the box which says “Trust access to  the VBA project object model
HTH Smile

VBA – Data Validation and Enforcing it to work


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2012/03/16/vba-data-validation-and-enforcing-it-to-work/

 

While answering a question today in StackOverflow, I came across an interesting question. And that inspired me to write a blog post on it.

PROBLEM: How to enforce Data Validation to work from VBA. By default you can set a data validation condition from VBA but it doesn’t work if you manually try to set a value to the cell. For example, this piece of code adds a DataValidation to Cell A1 in Sheet1 but doesn’t throw any error message when you supply a different value to the cell.

Sub Sample()
    With Sheets("Sheet1").Range("A1")
        .Validation.Delete
        .Validation.Add Type:=xlValidateList, Formula1:="TRUE,FALSE"
        .Value = "SID" '<~~ Trying to pass an invalid value
    End With
End Sub

SOLUTION:

The solution to the above problem is a “Sideways” enforcing of DataValidation from Worksheet_Change() event. The Worksheet_Change() event is a procedure of the Worksheet Object and as such, it should reside in the private module of the Worksheet Object. This event fires whenever there is a change in the worksheet. There are few changes which of course cannot be trapped from the Worksheet_Change() event. For example – Resizing of Columns. So back to the point. The logic that we have to use:

1) Check if the change is happening in the relevant cell. For this we can use Intersect() method.

2) And if the change is happening in the the relevant cell, then check if the cell has a DataValidation.

3) If the cell has DataValidation then check for the “Type” of DataValidation

4) Once the type has been ascertained, check if the current value of the cell conforms to the formula of the DataValidation

CODE

Const dvMessage = "Incorrect Value. Please ensure that the value conforms to the Data Validation set on the cell"

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa

    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Application.EnableEvents = False

        On Error Resume Next
        If Not Target.SpecialCells(xlCellTypeSameValidation).Cells.Count < 1 Then
            Dim currentValidation As Excel.Validation
            Set currentValidation = Target.Validation

            If currentValidation.Type = xlValidateList Then
                Dim MyArray() As String
                Dim boolFound As Boolean

                MyArray = Split(currentValidation.Formula1, ",")

                For i = 0 To UBound(MyArray)
                    If UCase(Target.Value) = UCase(MyArray(i)) Then
                        boolFound = True
                        Exit For
                    End If
                Next i

                If boolFound = False Then
                    MsgBox dvMessage
                    Target.ClearContents
                End If
            End If
        End If
        On Error GoTo 0
    End If
LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

With slight modification, the above code can also work very well for xlValidateWholeNumber, xlValidateCustom, xlValidateDecimal, xlValidateDate, xlValidateTime, xlValidateTextLength and xlValidateCustom

Hope this helps Smile

VBA/VB.Net/VB6–Click Open/Save/Cancel Button on IE Download window – PART II


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2012/02/02/vbavb-netvb6click-opensavecancel-button-on-ie-download-window-part-ii/

 

This is in continuation to my previous post where I showed you on how to click the “Open/Cancel Button”.

I am quite surprised by the number of hits that I am getting on that post. So I have decided to go ahead and post the code for “Save” button as well.

But before we go ahead, let me show you something interesting. If you have Spy ++ or uuSpy then you can see what I mean.

Our first impression is that once we click the “Save” button then it will be easy to populate the filename in the “Save As dialog” box. Well that is not that easy because it depends on the nesting windows. See these two examples. The first one is for IE6 and the other is for IE 8/9.

image

In the below code, I have used lot’s of Message Boxes and Wait so that you can actually step through the code or see how the code executes.

Paste this in a Module

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long

Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _
hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As _
Long, ByVal cy As Long, ByVal wFlags As Long)

Private Declare Function SetCursorPos Lib "user32" _
(ByVal X As Integer, ByVal Y As Integer) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

'~~> Constants for pressing left button of the mouse
Const MOUSEEVENTF_LEFTDOWN As Long = &H2
'~~> Constants for Releasing left button of the mouse
Const MOUSEEVENTF_LEFTUP As Long = &H4
Const WM_SETTEXT As Long = &HC
Const BM_CLICK = &HF5
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Dim Ret As Long, OpenRet As Long, FlDwndHwnd As Long
Dim ChildRet As Long
Dim strBuff As String, ButCap As String
Dim pos As RECT

'~~> Use this if you want to specify your own name in the Save As Window
Const FileSaveAsName = "C:\MyFile.xls"

Private Sub CommandButton1_Click()
    On Error GoTo Whoa

    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Main Window Found"

        '~~> Get the handle of the Button's "Window"
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        If ChildRet = 0 Then
            MsgBox "Child Window Not Found"
            Exit Sub
        End If

        '~~> Get the caption of the child window
        strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
        GetWindowText ChildRet, strBuff, Len(strBuff)
        ButCap = strBuff

        '~~> Loop through all child windows
        Do While ChildRet <> 0
            '~~> Check if the caption has the word "Save"
            If InStr(1, ButCap, "Save") Then
                '~~> If this is the button we are looking for then exit
                OpenRet = ChildRet
                Exit Do
            End If

            '~~> Get the handle of the next child window
            ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
            '~~> Get the caption of the child window
            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
            GetWindowText ChildRet, strBuff, Len(strBuff)
            ButCap = strBuff
        Loop

        '~~> Check if we found it or not
        If OpenRet = 0 Then
            MsgBox "The Handle of Save Button was not found"
            Exit Sub
        End If

        '~~> Retrieve the dimensions of the bounding rectangle of the
        '~~> specified window. The dimensions are given in screen
        '~~> coordinates that are relative to the upper-left corner of the screen.
        GetWindowRect OpenRet, pos

        '~~> Move the cursor to the specified screen coordinates.
        SetCursorPos (pos.Left - 10), (pos.Top - 10)
        '~~> Suspends the execution of the current thread for a specified interval.
        '~~> This give ample amount time for the API to position the cursor
        Sleep 100
        SetCursorPos pos.Left, pos.Top
        Sleep 100
        SetCursorPos (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2

        '~~> Set the size, position, and Z order of "File Download" Window
        SetWindowPos Ret, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
        Sleep 100

        '~~> Simulate mouse motion and click the button
        '~~> Simulate LEFT CLICK
        mouse_event MOUSEEVENTF_LEFTDOWN, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0
        Sleep 700
        '~~> Simulate Release of LEFT CLICK
        mouse_event MOUSEEVENTF_LEFTUP, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0

        Wait 10

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' START OF SAVEAS ROUTINE '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Ret = FindWindow(vbNullString, "Save As")

        If Ret = 0 Then
            MsgBox "Save As Window Not Found"
            Exit Sub
        End If

        '~~> UNCOMMENT this if using IE6 and COMMENT the code for "DUIViewWndClassName"
        '~~> "DirectUIHWND" and "FloatNotifySink"

' '~~> Get the handle of the Main ComboBox
' ChildRet = FindWindowEx(Ret, ByVal 0&, "ComboBoxEx32", "")
'
' If ChildRet = 0 Then
' MsgBox "ComboBoxEx32 Window Not Found"
' Exit Sub
' End If

        ChildRet = FindWindowEx(Ret, ByVal 0&, "DUIViewWndClassName", "")
        If ChildRet = 0 Then
            MsgBox "DUIViewWndClassName Not Found"
            Exit Sub
        End If

        ChildRet = FindWindowEx(ChildRet, ByVal 0&, "DirectUIHWND", "")
        If ChildRet = 0 Then
            MsgBox "DirectUIHWND Not Found"
            Exit Sub
        End If

        ChildRet = FindWindowEx(ChildRet, ByVal 0&, "FloatNotifySink", "")
        If ChildRet = 0 Then
            MsgBox "FloatNotifySink Not Found"
            Exit Sub
        End If

        '~~> Get the handle of the Main ComboBox
        ChildRet = FindWindowEx(ChildRet, ByVal 0&, "ComboBox", "")

        If ChildRet = 0 Then
            MsgBox "ComboBox Window Not Found"
            Exit Sub
        End If

        '~~> Get the handle of the Edit
        ChildRet = FindWindowEx(ChildRet, ByVal 0&, "Edit", "")

        If ChildRet = 0 Then
            MsgBox "Edit Window Not Found"
            Exit Sub
        End If

        '~~> COMMENT the below 3 lines if you do not want to specify a filename
        Wait 10
        SendMess FileSaveAsName, ChildRet
        Wait 10

        '~~> Get the handle of the Save Button in the Save As Dialog Box
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        '~~> Check if we found it or not
        If ChildRet = 0 Then
            MsgBox "Save Button in Save As Window Not Found"
            Exit Sub
        End If

        '~~> Get the caption of the child window
        strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
        GetWindowText ChildRet, strBuff, Len(strBuff)
        ButCap = strBuff

        '~~> Loop through all child windows
        Do While ChildRet <> 0
            '~~> Check if the caption has the word "Save"
            If InStr(1, ButCap, "Save") Then
                '~~> If this is the button we are looking for then exit
                OpenRet = ChildRet
                Exit Do
            End If

            '~~> Get the handle of the next child window
            ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
            '~~> Get the caption of the child window
            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
            GetWindowText ChildRet, strBuff, Len(strBuff)
            ButCap = strBuff
        Loop

        '~~> Check if we found it or not
        If OpenRet = 0 Then
            MsgBox "The Handle of Save Button in Save As Window was not found"
            Exit Sub
        End If

        '~~> Save the file
        SendMessage OpenRet, BM_CLICK, 0, ByVal 0&

        Wait 10
    Else
        MsgBox "File Download Window Not found"
    End If
    Exit Sub
Whoa:
    MsgBox Err.Description
End Sub

Sub Wait(nSec As Double)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

Sub SendMess(Message As String, hwnd As Long)
    Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub

To convert the above code to VB6 or VB.Net, refer to my previous post where I have already given an example.

If you understand the basic structure on how to get the handle of a window then the above task will look like a piece of cake.

UPDATE: 25/7/2012

NOTE: For people using IE9, depending on the link that you pass to the browser, you may or may not see the Info Security Bar. If you see the Info security bar then I suggest seeing this link where I have attached an exe file which you can use to bypass the IE9 Info Security Bar.


Color Print your code with Editor Format colors


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2011/10/31/color-print-your-code-with-editor-format-colors/

 

Here is one link which I found today and I feel that I should share it. Though this application has been discontinued but it still works on Vista and Win 7.

You can use this application to color print your VB6/VB.Net/VBA code.

Name of Application: PrettyCode.Print

Link: http://submain.com/products/prettycode.print.aspx

Hope this helps Smile

VBA/VB.Net/VB6–Click Open/Save/Cancel Button on IE Download window – PART I


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2011/10/23/vbavb-netvb6click-opensavecancel-button-on-ie-download-window/

Recently, while answering a question in msdn forum, I came across a question when the asker had a query on how to interact with download window which pops up.

Consider this.

Open Internet explorer and navigate to this link

http://spreadsheetpage.com/index.php/file/king_james_bible/

If your IE settings allow then you will get a pop up window like this.

image

So how do we click on “Open“, “Save” or “Cancel” button?

Initially I thought that using API FindWindow, FindWindowEx and Sendmessage would be enough but soon I realized that like normal windows the download window remains unresponsive to SendMessage API. So finally I had to use a workaround and then I was able to click on the Open/Save/Cancel button.

Like you and me, we both have names, similarly windows have “handles” (hWnd), Class etc. Once you know what that hWnd is, it is easier to interact with that window.

Findwindow API finds the hWnd of a particular window by using the class name and the caption of the window (“File Download”) in this case. To test it, here is a sample code

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Dim Ret As Long

Sub Sample()
    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Window Found"
    Else
        MsgBox "Window Not Found"
    End If
End Sub

The “Open“, “Save” and “Cancel” buttons are windows in itself but they are child windows of the main window which is “File Download“. That means each one of those will also have a hWnd 🙂 To find the child windows, we don’t use FindWindow but use FindWindowEx. All the three buttons “Open“, “Save” and “Cancel” have the same class which is “ Button”. To test it, here is a sample code.

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Dim Ret As Long, ChildRet As Long

Sub Sample()
    '~~> Get the handle of the "File Download" Window
    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Main Window Found"

        '~~> Get the handle of the Button's "Window"
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        '~~> Check if we found it or not
        If ChildRet <> 0 Then
            MsgBox "Child Window Also Found"
        Else
             MsgBox "Child Window Not Found"
        End If
    Else
        MsgBox "Window Not Found"
    End If
End Sub

Now, how do we get the hWnd of “Open” only? To get the handle of a specified button we need to first get it’s caption so that we can then compare and see if it is the right button. For this we need to use two more API’s GetWindowText and GetWindowTextLength. See the code below.

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String

Sub Sample()
    '~~> Get the handle of the "File Download" Window
    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Main Window Found"

        '~~> Get the handle of the Button's "Window"
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        '~~> Check if we found it or not
        If ChildRet <> 0 Then
            MsgBox "Child Window Found"

            '~~> Get the caption of the child window
            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
            GetWindowText ChildRet, strBuff, Len(strBuff)
            ButCap = strBuff

            '~~> Loop through all child windows
            Do While ChildRet <> 0
                '~~> Check if the caption has the word "Open"
                '~~> For "Save" or "Cancel", replace "Open" with
                '~~> "Save" or "Cancel"
                If InStr(1, ButCap, "Open") Then
                    '~~> If this is the button we are looking for then exit
                    OpenRet = ChildRet
                    Exit Do
                End If

                '~~> Get the handle of the next child window
                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff
            Loop

            '~~> Check if we found it or not
            If OpenRet <> 0 Then
                MsgBox "The Handle of Open Button is : " & OpenRet
            Else
                MsgBox "The Handle of Open Button was not found"
            End If
        Else
             MsgBox "Child Window Not Found"
        End If
    Else
        MsgBox "Window Not Found"
    End If
End Sub

Now we have the handle of the Button that we need. So how do we click it? Under normal circumstances, the following code would have worked but like I mentioned earlier, the IE window remains unresponsive to the SendMessage API and hence the below code will not work as desired.

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const BM_CLICK = &HF5&

Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String

Sub Sample()
    '~~> Get the handle of the "File Download" Window
    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Main Window Found"

        '~~> Get the handle of the Button's "Window"
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        '~~> Check if we found it or not
        If ChildRet <> 0 Then
            MsgBox "Child Window Found"

            '~~> Get the caption of the child window
            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
            GetWindowText ChildRet, strBuff, Len(strBuff)
            ButCap = strBuff

            '~~> Loop through all child windows
            Do While ChildRet <> 0
                '~~> Check if the caption has the word "Open"
                '~~> For "Save" or "Cancel", replace "Open" with
                '~~> "Save" or "Cancel"
                If InStr(1, ButCap, "Open") Then
                    '~~> If this is the button we are looking for then exit
                    OpenRet = ChildRet
                    Exit Do
                End If

                '~~> Get the handle of the next child window
                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff
            Loop

            '~~> Check if we found it or not
            If OpenRet <> 0 Then
                MsgBox "The Handle of Open Button is : " & OpenRet
                '~~> Click the button using Send Message
                SendMessage OpenRet, BM_CLICK, 0, 0
            Else
                MsgBox "The Handle of Open Button was not found"
            End If
        Else
             MsgBox "Child Window Not Found"
        End If
    Else
        MsgBox "Window Not Found"
    End If
End Sub

Since SendMessage refuses to work, we have to find an alternative. The alternative is to programmatically position your mouse cursor over that button and then click it.

To do this we need few more APIs. They are SetWindowPos, SetCursorPos, GetWindowRect, Sleep and mouse_event.

Now when you use this code, it works perfectly. I have commented the code so that you will not have any problem understanding it.

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _
hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As _
Long, ByVal cy As Long, ByVal wFlags As Long)

Private Declare Function SetCursorPos Lib "user32" _
(ByVal X As Integer, ByVal Y As Integer) As Long

Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

'~~> Constants for pressing left button of the mouse
Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
'~~> Constants for Releasing left button of the mouse
Private Const MOUSEEVENTF_LEFTUP As Long = &H4

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40

Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim pos As RECT

Sub Sample()
    '~~> Get the handle of the "File Download" Window
    Ret = FindWindow(vbNullString, "File Download")

    If Ret <> 0 Then
        MsgBox "Main Window Found"

        '~~> Get the handle of the Button's "Window"
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

        '~~> Check if we found it or not
        If ChildRet <> 0 Then
            MsgBox "Child Window Found"

            '~~> Get the caption of the child window
            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
            GetWindowText ChildRet, strBuff, Len(strBuff)
            ButCap = strBuff

            '~~> Loop through all child windows
            Do While ChildRet <> 0
                '~~> Check if the caption has the word "Open"
                '~~> For "Save" or "Cancel", replace "Open" with
                '~~> "Save" or "Cancel"
                If InStr(1, ButCap, "Open") Then
                    '~~> If this is the button we are looking for then exit
                    OpenRet = ChildRet
                    Exit Do
                End If

                '~~> Get the handle of the next child window
                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff
            Loop

            '~~> Check if we found it or not
            If OpenRet <> 0 Then
                MsgBox "The Handle of Open Button is : " & OpenRet

                '~~> Retrieve the dimensions of the bounding rectangle of the
                '~~> specified window. The dimensions are given in screen
                '~~> coordinates that are relative to the upper-left corner of the screen.
                GetWindowRect OpenRet, pos

                '~~> Move the cursor to the specified screen coordinates.
                SetCursorPos (pos.Left - 10), (pos.Top - 10)
                '~~> Suspends the execution of the current thread for a specified interval.
                '~~> This give ample amount time for the API to position the cursor
                Sleep 100
                SetCursorPos pos.Left, pos.Top
                Sleep 100
                SetCursorPos (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2

                '~~> Set the size, position, and Z order of "File Download" Window
                SetWindowPos Ret, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
                Sleep 100

                '~~> Simulate mouse motion and click the button
                '~~> Simulate LEFT CLICK
                mouse_event MOUSEEVENTF_LEFTDOWN, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0
                Sleep 700
                '~~> Simulate Release of LEFT CLICK
                mouse_event MOUSEEVENTF_LEFTUP, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0
            Else
                MsgBox "The Handle of Open Button was not found"
            End If
        Else
             MsgBox "Child Window Not Found"
        End If
    Else
        MsgBox "Window Not Found"
    End If
End Sub

Similarly, you can click on “Save” button and save the file to a location of your choice. This mean, you have to repeat the process of FindWindow, FindWindowEx with “Save As” window.

If it is just a matter of saving a file to a desired location then there is a different API altogether which is URLDownloadToFile. I would recommend using this as it is not painful as above Smile

Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Dim Ret As Long

Sub Sample()
    Dim strURL As String
    Dim strPath As String

    '~~> URL of the Path
    strURL = "http://spreadsheetpage.com/downloads/xl/king-james-bible.zip"
    '~~> Destination for the file
    strPath = "E:\Users\Siddharth Rout\Desktop\king-james-bible.zip"

    Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)

    If Ret = 0 Then
        MsgBox "File successfully downloaded"
    Else
        MsgBox "Unable to download the file"
    End If
End Sub

The above code will work in VBA and VB6.

VB.NET CODE

a) Code to Click the Buttons

Imports System.Runtime.InteropServices
Imports System.Text

Public Class Form1
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer

    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
    (ByVal hWnd1 As Integer, ByVal hWnd2 As Integer, ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Integer

    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
    Private Shared Function GetWindowText(ByVal hwnd As IntPtr, ByVal lpString As StringBuilder, ByVal cch As Integer) As Integer
    End Function

    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
    Private Shared Function GetWindowTextLength(ByVal hwnd As IntPtr) As Integer
    End Function

    Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Integer, ByVal _
    hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As _
    Integer, ByVal cy As Integer, ByVal wFlags As Integer)

    Private Declare Function SetCursorPos Lib "user32.dll" ( _
    ByVal X As Int32, ByVal Y As Int32) As Boolean

    <DllImport("user32.dll")> _
    Private Shared Function GetWindowRect(ByVal HWND As Integer, ByRef lpRect As RECT) As Boolean
    End Function

    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Integer)

    Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Integer, _
    ByVal dx As Integer, ByVal dy As Integer, ByVal cButtons As Integer, ByVal dwExtraInfo As Integer)

    '~~> Constants for pressing left button of the mouse
    Private Const MOUSEEVENTF_LEFTDOWN As Integer = &H2
    '~~> Constants for Releasing left button of the mouse
    Private Const MOUSEEVENTF_LEFTUP As Integer = &H4

    <StructLayout(LayoutKind.Sequential)> Public Structure RECT
        Dim Left As Integer
        Dim Top As Integer
        Dim Right As Integer
        Dim Bottom As Integer
    End Structure

    Const HWND_TOPMOST = -1
    Const HWND_NOTOPMOST = -2
    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40

    Dim Ret As Integer, ChildRet As Integer, OpenRet As Integer
    Dim strBuff As String, ButCap As String
    Dim pos As RECT

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        '~~> Get the handle of the "File Download" Window
        Ret = FindWindow(vbNullString, "File Download")

        If Ret <> 0 Then
            MessageBox.Show("Main Window Found")

            '~~> Get the handle of the Button's "Window"
            ChildRet = FindWindowEx(Ret, 0, "Button", vbNullString)

            '~~> Check if we found it or not
            If ChildRet <> 0 Then
                MessageBox.Show("Child Window Found")

                '~~> Get the caption of the child window
                ButCap = GetText(ChildRet)

                '~~> Loop through all child windows
                Do While ChildRet <> 0
                    '~~> Check if the caption has the word "Open"
                    '~~> For "Save" or "Cancel", replace "Open" with
                    '~~> "Save" or "Cancel"
                    If InStr(1, ButCap, "Open") Then
                        '~~> If this is the button we are looking for then exit
                        OpenRet = ChildRet
                        Exit Do
                    End If

                    '~~> Get the handle of the next child window
                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    ButCap = GetText(ChildRet)
                Loop

                '~~> Check if we found it or not
                If OpenRet <> 0 Then
                    MessageBox.Show("The Handle of Open Button is : " & OpenRet)

                    '~~> Retrieve the dimensions of the bounding rectangle of the
                    '~~> specified window. The dimensions are given in screen
                    '~~> coordinates that are relative to the upper-left corner of the screen.
                    GetWindowRect(OpenRet, pos)

                    '~~> Move the cursor to the specified screen coordinates.
                    SetCursorPos((pos.Left - 10), (pos.Top - 10))
                    '~~> Suspends the execution of the current thread for a specified interval.
                    '~~> This give ample amount time for the API to position the cursor
                    Sleep(100)
                    SetCursorPos(pos.Left, pos.Top)
                    Sleep(100)
                    SetCursorPos((pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2)

                    '~~> Set the size, position, and Z order of "File Download" Window
                    SetWindowPos(Ret, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE)
                    Sleep(100)

                    '~~> Simulate mouse motion and click the button
                    '~~> Simulate LEFT CLICK
                    mouse_event(MOUSEEVENTF_LEFTDOWN, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0)
                    Sleep(700)
                    '~~> Simulate Release of LEFT CLICK
                    mouse_event(MOUSEEVENTF_LEFTUP, (pos.Left + pos.Right) / 2, (pos.Top + pos.Bottom) / 2, 0, 0)
                Else
                    MessageBox.Show("The Handle of Open Button was not found")
                End If
            Else
                MessageBox.Show("Child Window Not Found")
            End If
        Else
            MessageBox.Show("Window Not Found")
        End If

    End Sub
    Public Function GetText(ByVal hWnd As IntPtr) As String
        Dim length As Integer
        If hWnd.ToInt32 <= 0 Then
            Return Nothing
        End If
        length = GetWindowTextLength(hWnd)
        If length = 0 Then
            Return Nothing
        End If
        Dim sb As New System.Text.StringBuilder("", length + 1)

        GetWindowText(hWnd, sb, sb.Capacity)
        Return sb.ToString()
    End Function
End Class

b) Code to download the file

Public Class Form1
    Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Integer, _
    ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Integer, ByVal lpfnCB As Integer) As Integer

    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim Ret As Integer
        Dim strURL As String
        Dim strPath As String

        '~~> URL of the Path
        strURL = "http://spreadsheetpage.com/downloads/xl/king-james-bible.zip"
        '~~> Destination for the file
        strPath = "E:\Users\Siddharth Rout\Desktop\king-james-bible.zip"

        Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)

        If Ret = 0 Then
            MessageBox.Show("File suceesfully downloaded")
        Else
            MessageBox.Show("Unable to download the file")
        End If
    End Sub
End Class

Hope this helps Smile

Edit: Updated

VBA/VB.Net/VB6–Click Open/Save/Cancel Button on IE Download window – PART II

Using Save As and keeping Original File and New File open at the same time


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2011/09/02/using-save-as-and-keeping-original-file-and-new-file-open-at-the-same-time/

Today while answering one of the questions in the msdn forum, I came across an interesting question. The question was, “Can we save an excel file with a new name generated by the macro and keep the original file and the new file both open?”

We are aware that the moment you do a .SaveAs in Excel, the original file is closed and the new saved file remains open. What if we want to keep the original file and the new file open at the same time? Is it possible?

The answer is “Yes, it is possible”.

After struggling with it for a file, an interesting solution came to my mind and to my surprise it worked as expected. The trick is NOT to use the inbuilt .SaveAs command. The alternative is to save the original file first and then make a copy of it and then finally open it.

As expected, I used the FileCopy command and then realized that FileCopy doesn’t make a copy of the file if the file is open. You will get a “Permission Denied” error. Instead of FileCopy, I then used CopyFile API and it worked just fine.

Here is the code.

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long

Sub NewSaveAsRoutine()
    Dim FileExtStr As String, sPath As String, NewFileName As String
    Dim wb1 As Workbook, wb2 As Workbook
    Dim FileFormatNum As Long

    Set wb1 = ActiveWorkbook

    sPath = wb1.Path

    FileExtStr = ".xlsm": FileFormatNum = 5

    NewFileName = sPath & "\" & "NewFile" & FileExtStr

    '~~> Save the Original file before making a copy of it
    wb1.Save

    '~~> Make a copy of the original File with a new name
    CopyFile sPath & "\" & wb1.Name, NewFileName, 0

    '~~> Open the New Workbook (Copy of Original)
    Set wb2 = Workbooks.Open(NewFileName)
End Sub

Hope it helps Smile

VBA – Control Arrays


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2011/08/05/vba-control-arrays/

These are the few things that we will be covering in this post.

  • What is a Control Array?
  • Can we create Control Arrays in VBA?
  • Why do we need a Control Array?
  • Examples of Control Arrays in VBA
    a) Using existing textboxes in the UserForm and assigning a same set of event procedures
    b) Creating new textboxes at runtime and assigning them same set of event procedures

What is a Control Array?

A Control Array is a group of controls that share the same name type and the same event procedures. They are a convenient way to handle groups of controls (Same Type) that perform a similar function. All of the events available to the single control are available to the array of controls.

Can we create Control Arrays in VBA?

Even though, VBA doesn’t allow us to to create Control Array like in vb6 and vb.net, we can still create Control Array in VBA.

Why do we need Control Arrays in VBA?

Control Arrays mainly have these advantages

  1. Controls in a Control Array share the same set of event procedures. This results in you writing less amount of code.
  2. Control Arrays uses fewer resources.
  3. You can effectively create new controls at design time, if you need to.

Examples of Control Arrays in VBA

We would be covering the following here

a) Using existing textboxes in the UserForm and assigning a same set of event procedures
b) Creating new textboxes at runtime and assigning them same set of event procedures

Using existing textboxes in the UserForm and assigning a same set of event procedures

Let’s say you have 10 textboxes in your UserForm (see image below)

image

And you want all 10 to be numeric textboxes. Numeric textboxes are those text boxes where you can only type numbers. If it was just 1 TextBox, you would have a code like this

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    '<~~ 48 to 57 is AscII code for numbers. 127 is for 'Delete' and 8 is for 'Backspace'
    Case 48 To 57, 127, 8
    Case Else
        KeyAscii = 0
    End Select
End Sub

Now imagine writing this code 10 times for each and every textbox?

This is where we will use Control Array of Textboxes and assign them the same procedure.

To start with, add a new Class. You can do that by right clicking on the “VBAProject~~>Insert~~>Class Module”. See the two images below.

image

image

Now paste this code in the code area of the Class1 Module

Public WithEvents TextBoxEvents As MSForms.TextBox

Private Sub TextBoxEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    '<~~ 48 to 57 is AscII code for numbers. 127 is for 'Delete' and 8 is for 'Backspace'
    Case 48 To 57, 127, 8
    Case Else
        KeyAscii = 0
    End Select
End Sub

image

and in the UserForm Initialize event, paste this code.

Option Explicit

Dim TextArray() As New Class1

Private Sub UserForm_Initialize()
    Dim i As Integer, TBCtl As Control

    For Each TBCtl In Me.Controls
        If TypeOf TBCtl Is MSForms.TextBox Then
            i = i + 1
            ReDim Preserve TextArray(1 To i)
            Set TextArray(i).TextBoxEvents = TBCtl
        End If
    Next TBCtl
    Set TBCtl = Nothing
End Sub

image

And you are done! Now when you run the UserForm, all the textboxes will now show the same behavior Smile

To test it, simply run your UserForm and try typing anything in the textboxes. You will notice that you will not be able to type anything other than numbers or pressing the ‘Delete’ and the ‘Backspace’ button. Similarly you can create other events for textboxes like change(), click() etc.

Creating new textboxes at runtime and assigning them same set of event procedures

Now let’s take another scenario. Instead of creating textboxes at design time and then assigning them same set of event procedures, what we want to do is to create these textboxes at run time and then assign them same set of event procedures.
Let’s say your UserForm now simply looks like this.

image

Create the Class module as I have shown above and then paste the code which I gave above for the Class module.

Paste this in the the Initialize event of the UserForm.

Option Explicit

Dim TextArray() As New Class1

Private Sub UserForm_Initialize()
    Dim ctlTBox As MSForms.TextBox
    Dim TBoxTop As Long, i As Long

    '~~> Decide on the .Top for the 1st TextBox
    TBoxTop = 30

    For i = 1 To 10
        Set ctlTBox = Me.Controls.Add("Forms.TextBox.1", "txtTest" & i)

        '~~> Define the TextBox .Top and the .Left property here
        ctlTBox.Top = TBoxTop: ctlTBox.Left = 50

        '~~> Increment the .Top for the next TextBox
        TBoxTop = TBoxTop + 20

        ReDim Preserve TextArray(1 To i)
        Set TextArray(i).TextBoxEvents = ctlTBox
    Next
End Sub

and you are done 🙂

To test it, simply run your UserForm. You will see that the TextBoxes automatically get created and you will not be able to type anything other than numbers or pressing the ‘Delete’ and the ‘Backspace’ button. This is how your UserForm will look.

image

Hope this helps Smile

Deselect Items in MultiSelect Listbox without looping


EDIT

I have stopped updating this blog. This link can also be found in my Website.

http://www.siddharthrout.com/2011/07/29/deselect-items-in-multiselect-listbox-without-looping/

Consider this Multiselect Listbox. I simply used the following code to generate it.

Private Sub UserForm_Initialize()
    For i = 1 To 100000
        ListBox1.AddItem i
    Next i
End Sub

MultiSelect Listbox

Now imagine, I have some 50 entries selected and after my work is done, I would like to deselect them. The only options that I have are either I

1) Manually unselect them OR

2) Write a code which will loop through the entries and deselect them like this?

For i = 1 To ListBox1.ListCount
    ListBox1.Selected(i - 1) = False
Next i

Right?

Wrong! There is a third way 🙂

I see two problems with the 2nd way.

1) Looping takes time if Listbox contains huge data

2) It causes a flicker if Listbox contains huge data

Here is an extraordinary way to do it. I just discovered it on my own. I quickly did a search on the web and couldn’t find a single website which suggested this.

Private Sub CommandButton1_Click()
    '~~> Reset selected items to deselected by changing it's selection behavior
    ListBox1.MultiSelect = fmMultiSelectSingle
    ListBox1.MultiSelect = fmMultiSelectMulti
End Sub

Hope this helps 🙂