Thursday, February 4, 2010

Excel Worksheet to picture using VBA (Jpeg, Png etc)

This sample will show how to automate export of Excel sheet to image file.

You need to download and install ImageMagick library (Q16 version)

When ImageMagick is installed you could use this code to save your Excel worksheet to picture (use "view plain" option to copy code to clipboard):
Dim imObject As Object
'Create ImageMagick Object
Set imObject = CreateObject("ImageMagickObject.MagickImage.1")
'Copy selected area to clipboard as picture
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'Save clipboard to image named c:\image.jpg
imObject.Convert "clipboard:myimage", "", "-quality", "85", "c:\image.jpg"

Export last table from Word to Excel

This sample will copy last table from each of given word documents to active sheet.

Sub CopyTables()
Set appWord = CreateObject("Word.Application")
On Error GoTo emergencyexit
fileNames = Array("c:\1.doc","c:\2.doc")
For Each Filename In fileNames
    Set docWord = Nothing
    Set docWord = appWord.Documents.Open(Filename)
    If Not docWord Is Nothing Then
        docWord.tables(docWord.tables.Count).Select
        appWord.Selection.Copy
        ActiveSheet.Paste
        docWord.Close
        ActiveSheet.UsedRange.Offset(ActiveSheet.UsedRange.Rows.Count).Resize(1, 1).Select
    End If
Next
emergencyexit:
appWord.Quit

End Sub

Excel Autofill VBA emulation

This code emulates double click on bottom right  corner of selected cell.
Sub Autofill()
    On Error Resume Next
    Dim checkRange As Range
    
    If RangeState(Selection) = 2 Then: Exit Sub
    
    selMaxRow = Selection.Row + Selection.Rows.Count - 1
    selColsCount = Selection.Columns.Count
    selRowsCount = Selection.Rows.Count
    usedRows = ActiveSheet.UsedRange.Rows.Count
    maxrow = selMaxRow
    row_offset = 0
        
    checkLeft = False
    checkRight = False
    checkCenter = False
    If Selection.Column > 1 Then
        If RangeState(Selection.Offset(0, -1).Resize(selRowsCount, 1)) = 1 Then
            checkLeft = True
        End If
    End If
    If Not checkLeft Then
        If (Selection.Column + selColsCount) < ActiveSheet.Cells.Columns.Count Then
            If RangeState(Selection.Offset(0, selColsCount).Resize(selRowsCount, 1)) = 1 Then: checkRight = True
        End If
    End If

    Set checkRange = Selection.Offset(selRowsCount).Resize(1, selColsCount)
    
    If Not checkLeft And Not checkRight Then
        If RangeState(checkRange) = 1 Then: checkCenter = True
    Else
        checkCenter = True
    End If
    
    For row_offset = 0 To usedRows - Selection.Row - selRowsCount
        If (selMaxRow + row_offset) < usedRows And checkCenter Then
            tmp = RangeState(checkRange.Offset(row_offset))
            If row_offset = 0 Then: center_state = tmp
            If tmp <> center_state Then: checkCenter = False
            If center_state = 3 Then: checkCenter = False
        End If
        
        If checkLeft And center_state = 2 Then
            left_state = RangeState(checkRange.Offset(row_offset, -1).Resize(1, 1))
            If left_state = 2 Or left_state = 3 Then: Exit For
        ElseIf checkRight And center_state = 2 Then
            right_state = RangeState(checkRange.Offset(row_offset, selColsCount).Resize(1, 1))
            If right_state = 2 Or right_state = 3 Then: Exit For
        End If
                
        If checkCenter Then: maxrow = maxrow + 1
    Next
    
    If maxrow > selMaxRow Then
        Selection.Autofill Destination:=Selection.Resize(maxrow - (Selection.Row) + 1)
        Selection.Resize(maxrow - Selection.Row + 1).Select
    End If
End Sub


Function RangeState(rng As Range)
    RangeState = 0
    If IsArray(rng.Formula) Then
        For Each Formula In rng.Formula
            If Formula <> "" Then
                RangeState = RangeState Or 1
            Else
                RangeState = RangeState Or 2
            End If
        Next
    Else
        If rng.Formula <> "" Then
            RangeState = 1
        Else
            RangeState = 2
        End If
    End If
End Function

Saturday, January 23, 2010

Excel Dictionary Password Attack macro

This xla add-in uses dictionary to recover Excel workbook password. You could use this add-in as Excel password manager too. For example if you using many passwords for many files - this add-in will help you to open these files quickly.


How to use:
1. Open dictattack.xla
2. Find new Utilities option in main menu. In Excel 2007 it will be located under Add-Ins menu.
3. Use Utilities->Add password(s) to dictionary to manage your passwords list. You have few options to add new passwords: press Show Dictionary button and copy/paste a list to any place you like, Load dictionary from .txt file (one password per line) or enter password into New password field and push Add:

4. Use Utilities->Open protected files to open password protected file(s). You will get a message if some files could not be opened.

Have fun!

Friday, January 22, 2010

Excel macro. Multiple range formula quick input

Sometime you need to build a formula which should refer to many sheets and many ranges. Like =SUM(Sheet1!E:K;Sheet2!A:B;Sheet3!D:C)
To do this you need to type =SUM( then select sheet, select range, type ;, select n-th sheet again, select range.... Yeah thats boring !
I wrote an Excel Add-In to automate this task partialy:



What you need to do:
1. Place rangeformula.xla somewhere in My Documents and install it with double-click. 



2. Switch between sheets and select ranges you want to include to formula. Selection will be saved per sheet.
3. In Excel 97/2k/2k3 use menu Utilities->Range Formula to open input form of add-in (look picture). In Excel 2007 Utilities submenu will be installed under Add-Ins menu.
4. Enter Function name e.g. SUM or COUNTBLANK without brackets and equal sign


5. Select ranges in list which you want to include into formula
6. Copy/Paste Result formula.

Have fun !

Thursday, January 21, 2010

Excel password crack. Recover your forgotten password for free.

There is simple way to recover forgotten Excel password using Excel itself. I wrote a small VBA addin for this purpose. You can use it for free to recover your forgotten Excel password.
But if you like it, please consider making a donation.
Source code is open so you could see how it works. Here is link for addin download:


The idea is to iterate fake passwords (up to 8 characters) where first 1-8 characters are "A" or "B" and last one have code from 32 to 255. This utility works with Excel 97/2000/2003 only.  Excel 2007 have stronger protection and this method doesn't work there.


Here is source code with comments:
Const MENUNAME = "UNPROTECT"
Sub test()
On Error Resume Next
    Dim wb As Workbook
    Const LastCharStart = 32
    Const LastCharFinish = 255
    For i = 1 To 255
        fakepassword = FakePass(i)
        For LastCharIndex = LastCharStart To LastCharFinish
            Password = fakepassword & Chr(LastCharIndex)
            Set wb = Workbooks.Open("trypass.xls", , , , Password)
            Debug.Print Password
            If Not wb Is Nothing Then: Exit For
        Next
    Next
End Sub
'Install menu shortcut
Sub Auto_Open()
    Install
End Sub

'Crack Worksheets and Workbooks passwords at once
Sub BruteForceUnprotect()
    Dim ProtectedObjects As New Collection
    Const LastCharStart = 32
    Const LastCharFinish = 255
    
    Application.DisplayAlerts = False
    
    If Workbooks.Count <= 0 Then
        MsgBox "Open some workbook first!"
        Exit Sub
    End If
    
    
    'Add protected Workbooks to collection
    If (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows) Then
        ProtectedObjects.Add ActiveWorkbook
    End If
    
    'Add protected Worksheets to collection
    On Error Resume Next
    'Dim WSheet As Worksheet
    For Each WSheet In ActiveWorkbook.Worksheets
        WSheet.Protect ("")
        If Not WSheet.Unprotect("") Then: ProtectedObjects.Add WSheet
    Next
    On Error GoTo 0
    
    If ProtectedObjects.Count <= 0 Then
        MsgBox "No protected objects or password is empty!"
        Exit Sub
    End If
    
    'Brute force with fake password. Original password could not be restored in this way.
    For i = 1 To 255
        fakepassword = FakePass(i)
        If ProtectedObjects.Count = 0 Then: Exit For
        For LastCharIndex = LastCharStart To LastCharFinish
            Password = fakepassword & Chr(LastCharIndex)
            If ProtectedObjects.Count > 0 Then
                For j = 1 To ProtectedObjects.Count
                    If UnprotectObject(ProtectedObjects(j), Password) = True Then
                        ProtectedObjects.Remove (j)
                        If ProtectedObjects.Count > 0 Then: j = j - 1
                    End If
                Next
            End If
        Next
    Next
    
    If ProtectedObjects.Count = 0 Then
        MsgBox "Workbook and Worksheets passwords was removed!"
    Else
        MsgBox "Non standard encryption detected :(. Some objects are still protected."
    End If
    Application.DisplayAlerts = True
End Sub
Function UnprotectObject(obj, pass)
  UnprotectObject = False
  On Error GoTo WrongPassword
  obj.Unprotect pass
  UnprotectObject = True
WrongPassword:
End Function
'Build password by given numeric value.
Function FakePass(Value)
    Mask = 1
    FakePass = ""
    While Mask <= Value
        If (Value And Mask) = 0 Then
            FakePass = "A" & FakePass
        Else
            FakePass = "B" & FakePass
        End If
        Mask = Mask * 2
    Wend
    If Len(FakePass) > 0 Then: FakePass = Right(FakePass, Len(FakePass) - 1)
End Function
'Install menu shortcut
Sub Install()
    Uninstall True
    AddButton MENUNAME, "Unprotect everything", "BruteForceUnprotect"
    AddButton MENUNAME, "Uninstall addon", "Uninstall"
End Sub
'Uninstall menu shortcut
Sub Uninstall(Optional silent = False)
    If Not silent Then
        If MsgBox("Do you really want to uninstall this addon ?", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(MENUNAME).Delete
    On Error GoTo 0
End Sub
'Add menu item
Sub AddButton(menu As String, submenu As String, macro As String, Optional descr As String = "")
    On Error GoTo createmenu
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu)) Then: GoTo createmenu
    On Error GoTo create
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls(submenu)) Then: GoTo create
    End
createmenu:
    Set mnu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=10)
    mnu.Caption = "&" & menu
    mnu.Visible = True
    
create:
    Set Button = Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls.Add(Type:=1, ID:=2950)
    With Button
        .DescriptionText = descr
        .TooltipText = descr
        .Caption = "&" & submenu
        .Style = 3
        .OnAction = macro
    End With
End Sub


Wednesday, January 20, 2010

Crack Microsoft Word password

It is possible to remove read-only password protection of Word document using MS Word itself. You don't need any software excepting Word to do this.

Follow these steps to unprotect your document:
1. Open document
2. Press Alt+Shift+F11. Microsoft Script Editor will be opened.
3. Press Ctrl+F and type "pass" (without quotes) in the Find what field.

4. Press Find Next. You will find the line like: <w:UnprotectPassword>1234F8E7</w:UnprotectPassword>

5. Select whole line and delete it
6. Press Ctrl+S to save document
7. Close Microsoft Script Editor
8. Go to Tools->Unprotect document. This will reset read-only password protection.

Excel VBA speed up

1. Speed up Excel cells reading/writing using Range.Resize()
There two ways to read Excel cells programatically. First method is to use loops. This method is simple and ... slow.
Here is sample code:
For i = 1 To 10
  destination.Cells(i,1).value = source.Cells(i,1).value 
Next
As you see there was 10 reads and 10 writes in loop.

You can use Resize() method of Range class to speed up cells reading and writing.. Resize method allows to read range of cells at once.

Sample code:
Dim arSales as Variant
arSales = source.Cells.Resize(10,1)

This method reads specified range to array almost instantly. In Excel 2003 you can get entire sheet (65536x256 cells) in seconds.
You can write data to Excel sheet in same way using prepared array.

Sample code:
destination.Cells.Resize(10,1) = arSales

In some cases you don't need to use Resize to get array of cells. Use Value property of Range if you want to get all Cells of range.

An example:
Set rng = Range("DATA")
arSales = rng.Value

2. Disable automatic calculation, screen update and events
Each change of worksheet invokes automatic calculation of entire workbook. This behavior is useful when you do some manual input but unacceptable for VBA methods.
You can use Application properties to disable unnecessary updates.

Sample code:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

And to return settings back :

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

3. Conditional formatting

Sometime we need to format Excel sheet using VBA. MS Excel provides few ways to do this with VBA.
First one is to use Color and Font properties of Range class.

Sample code:
Set rng = Range("HEADER")
    With rng.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
    With rng.Font
        .Font.Italic = True
        .Font.Bold = True
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With

This code works well but it have few disadvantages. It is slow when complex formatting required and incredibly hard to tune it later.

Second method is Conditional formatting usage. The idea is to format cells automatically if they contain some data.
1. Create Excel file with header and other static information;
2. Apply Conditional formatting to first row of range where data will be placed. Select font/colors and use condition like if A2<>"";
3. Place data into A2 cell using VBA. This will fire automatic formatting.

Benefits of this method is speed and flexibility. Color and font picker simplifies formatting and code.

Sample code:
rowscount = 20000 ' Rows number to format
colscount= 5   ' Columns number to format
onepass = 1024 ' Rows number to format at once
src_row = 1    ' Row number where conditional format is set
For i = src_row+1 To rowscount Step onepass
  Rows(src_row).Resize(1, colscount).Copy ' Copy row format
  If i + onepass > rowscount Then: onepass = rowscount - i
  ' Paste format
  Rows(i).Resize(onepass, colscount).PasteSpecial _  
    Paste:=xlPasteFormats, _
    Operation:=xlNone, _
    SkipBlanks:=False, _ 
    Transpose:=False
Next

Tuesday, January 19, 2010

Last cell in range

To get last cell in ActiveSheet you can use this code:

Set LastCell = ActiveSheet.SpecialCells(xlLastCell)

This code works in most cases. But you could face a problem when data was inserted and deleted at the end of sheet. As an example if you clear 5 of 10 filled rows on the sheet, SpecialCells(xlLastCell) will not be changed. It will point to 10th row instead of 5th.
To get last cell of non-empty row you need to use this code:

Sample:
Set LastCell = ActiveSheet.UsedRange.SpecialCells(xlLastCell)

Worksheet.UsedRange is object of Range class which contains filled cells only.