Code samples

Embed and run VBscript. Convert VBScript to executable (C#)

2011-08-01T10:52:00.002+03:00

First Create empty console C# project.

Next, add your script file to project's resources.
In VS2010 you can do it with:
RMB on project name->Properties->Resources->Add Resource->Add New Text File

Now you can get script's content to save and run it.
Source code is quite simple:

To reference script content I use:

Properties.Resources.MyEmbeddedScript

where MyMbeddedScript is name of resource.

Get some random temporary file name:

string scriptFileName = Path.GetTempFileName().Replace(".tmp",".vbs");

Next save and run script:

File.WriteAllText(scriptFileName, content);
startedProcess = Process.Start(scriptFileName);

To run a script as other user you can use this method:
RunAs without password prompt

Any other script (.js, .vbs, .ahk) can be easily embedded into .exe-file in this way.

Full source code:

using System;
using System.Security;
using System.Diagnostics;
using System.IO;

namespace scriptEmbed
{
    class Program
    {
        static int Main(string[] args)
        {
            return RunScript(Properties.Resources.MyEmbeddedScript);
        }
        static int RunScript(string content)
        {
            string scriptFileName = Path.GetTempFileName().Replace(".tmp",".vbs");
            Process startedProcess;
            try
            {
                File.WriteAllText(scriptFileName, content);
                startedProcess = Process.Start(scriptFileName);
                
                while (!startedProcess.HasExited) ;

                File.Delete(scriptFileName);
                
                return startedProcess.ExitCode;
            }
            catch (Exception e)
            {
                Console.WriteLine(e.Message);
                return 1;
            }
        }
        static string GetTempFolder()
        {
            return System.Environment.GetEnvironmentVariable("TEMP");
        }
    }

}

RunAs without password prompt in C#

2011-07-31T15:58:00.005+03:00

This alternative of RunAs utility allows to specify a password in command line.

It does same as standard runas.exe does. The only difference is you can specify your user password right in command line.

It can be used by System Administrators in batch jobs to run tasks under admin account.

Download RunAs Utility with password parameter in command line

Syntax:
runasuser [-u user] [-p password] [-d domain] someprogram.exe [params]

Here is full source code:

using System;
using System.Diagnostics;
using System.Security;

namespace RunAsUser
{
    class Program
    {
        static int Main(string[] args)
        {
            string username = "", password = "", domain = "", apppath = "", arguments = "";

            for( int i=0; i<args.Length; i++)
            {
                switch (args[i].ToLower())
                {
                    case "-u":
                        username = args[++i];
                        break;
                    case "-p":
                        password = args[++i];
                        break;
                    case "-d":
                        domain = args[++i];
                        break;
                    default:
                        if (apppath == "")
                            apppath = args[i];
                        else
                            arguments += args[i] + (i<args.Length?" ":"");
                        break;
                }
            }

            if (args.Length == 0 || apppath == "" )
            {
                Console.WriteLine("\nCommand line syntax:\nrunasuser [-u user] [-p password] [-d domain] someprogram.exe [params]\n");
                return 1;
            }
            Console.WriteLine(arguments);
            return RunAs(apppath, arguments, domain, username, password);

        }
        static int RunAs(string apppath, string arguments, string domain, string username, string password)
        {
            Process userProcess;
            try
            {
                userProcess = Process.Start( apppath, arguments, username, GetSecure(password), domain);
                while (!userProcess.HasExited) ;
                return userProcess.ExitCode;
            }
            catch (Exception e)
            {
                Console.WriteLine(e.Message);
            }
            return -1;
        }

        static SecureString GetSecure(string str)
        {
            SecureString SecureStr = new SecureString();
            foreach (char c in str)
            {
                SecureStr.AppendChar(c);
            }

            return SecureStr;
        }
    }
}

Microsoft DNS live sync to MySQL (VBScript)

2011-07-26T10:48:00.001+03:00

Sometime its handy to have replica of DNS records in MySQL server. You can use this database to build some network diagrams, count computers etc.

In this example I use WMI to synchronize Microsoft DNS database with MySQL server.

This script makes complete snapshot of DNS database first. Then it set a handler for each event: Create/Modify/Delete.

Each event makes changes in MySQL database. This approach allow to have exact replica of DNS records in MySQL without visible delays.

Download dnsmonitor.vbs script

You can find source code below.
Don't forget to change NetBios name of your server and MySQL credentials on top.

'Netbios name of DNS server
Const SERVERNAME = "SERVER"

'MySQL credentials
Const host="localhost"
Const Db="system"
Const login= "user"
Const password="userpassword"

'MySQL connection options
Const MYDRIVER = "MySQL ODBC 5.1 Driver"
Const FLAG_BIG_PACKETS = 8 'Allow big results
Const FLAG_NO_PROMPT = 16 'Dont prompt anything
Const FLAG_DYNAMIC_CURSOR = 32 'Allow dynamic cursor
Const FLAG_COMPRESSED_PROTO = 2048 'Use compressed protocol
Const FLAG_NO_BIGINT = 16384 'Change bigint(8) to int(4)
Const FLAG_MULTI_STATEMENTS = 67108864 'Enable batch statements
Const FLAG_AUTO_RECONNECT = 4194304 'Auto reconnect

'ADODB connection
Dim conn

'Create global objects
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}\\" & SERVERNAME & "\root\MicrosoftDNS")
Set objSink = WScript.CreateObject("WBemScripting.SWbemSink","event_")
Set objShell = CreateObject("WScript.Shell")

'Exit if already running
Set oProcess = Nothing
If alreadyRunning() Then: WScript.Quit

If Not MySQLConnect() Then
WScript.Quit
Else
PrepareDatabase
End If

'Initialize mysql data once
MySQLExecute "DELETE FROM dns_cache"
Set dnsRecords = objWMIService.ExecQuery( "SELECT * FROM MicrosoftDNS_AType", "WQL", 48 )
For Each objRecord in dnsRecords
domain = objRecord.DomainName
name = Replace(objRecord.OwnerName,domain,"")
ip = objRecord.IPAddress 
ttl = objRecord.TTL
timestamp = objRecord.Timestamp
OnCreation domain,name,ip,timestamp,ttl
Next

'Set DNS event handler
objWMIService.ExecNotificationQueryAsync objSink, "Select * from __InstanceOperationEvent within 1 where TargetInstance ISA 'MicrosoftDNS_AType'"

'Infinite loop
Do
WScript.Sleep 1000
Loop

'Events handler
Sub event_OnObjectReady( objEvent, objContext )
With objEvent
domain = objEvent.TargetInstance.DomainName
name = Replace(objEvent.TargetInstance.OwnerName,domain,"")
ip = objEvent.TargetInstance.IPAddress 
ttl = objEvent.TargetInstance.TTL
timestamp = objEvent.TargetInstance.timestamp
if name <> "" Then
Select Case .Path_.Class
Case "__InstanceModificationEvent"
OnModify domain,name,ip,timestamp,ttl
Case "__InstanceCreationEvent"
OnCreation domain,name,ip,timestamp,ttl
Case "__InstanceDeletionEvent"
OnDeletion domain,name,ip
End Select
End If
End With
End Sub

'Handler for modify event
Sub OnModify( domain, name,ip,timestamp,ttl )
update = "domainname='" & domain & "',hostname='" & name & "',ipaddress=inet_aton('" & ip & "')," & _ 
"refreshon=IF(" & timestamp & "=0,Null,'1601-01-01 00:00') + INTERVAL " & timestamp & " HOUR,ttl=" & ttl
MySQLExecute "INSERT INTO dns_cache SET " & update & " ON DUPLICATE KEY UPDATE " & update
End Sub

'Handler for create event
Sub OnCreation( domain, name,ip,timestamp,ttl )
update = "domainname='" & domain & "',hostname='" & name & "',ipaddress=inet_aton('" & ip & "')," & _
"refreshon=IF(" & timestamp & "=0,Null,'1601-01-01 00:00') + INTERVAL " & timestamp & " HOUR,ttl=" & ttl
MySQLExecute "INSERT INTO dns_cache SET " & update & " ON DUPLICATE KEY UPDATE " & update 
End Sub

'Handler for delete event
Sub OnDeletion( domain, name,ip )
MySQLExecute "DELETE FROM dns_cache WHERE hostname='" & name & "' AND ipaddress=inet_aton('" & ip & "') AND domainname='" & domain & "'"
End Sub

'Create database and tables if it wasn't done
Function PrepareDatabase
CreateDatabase = False
On Error Resume Next
MySQLExecute "CREATE DATABASE IF NOT EXISTS " & db & " CHARACTER SET utf8 COLLATE utf8_general_ci"
On Error Goto 0
MySQLExecute "USE " & db
MySQLExecute "CREATE TABLE IF NOT EXISTS dns_cache(" & _
"hostname VARCHAR(255) NOT NULL," & _
"domainname VARCHAR(255) NOT NULL," & _
"ipaddress INT(11) UNSIGNED NOT NULL," & _
"refreshon DATETIME DEFAULT NULL," & _
"ttl INT(11) NOT NULL DEFAULT 0," & _
"PRIMARY KEY (ipaddress, hostname, domainname)," & _
"INDEX IX_dns_cache_deadline (refreshon)," & _
"INDEX IX_dns_cache_domainname (domainname)," & _
"INDEX IX_dns_cache_ipaddress (ipaddress)," & _
"INDEX IX_dns_cache_name (hostname)," & _
"INDEX IX_dns_cache_ttl (ttl)" & _
") " & _
"ENGINE = INNODB " & _
"AVG_ROW_LENGTH = 68 " & _
"CHARACTER SET utf8 " & _
"COLLATE utf8_general_ci;"
If Err.Number <> 0 Then: CreateDatabase = True
End Function

Function alreadyRunning()
alreadyRunning = False
wscrCount = ProcessCount( "%wscript%" & WScript.ScriptName & "%" )
cscrCount = ProcessCount( "%cscript%" & WScript.ScriptName & "%" )
If wscrCount > 1 or cscrCount > 1 Then:alreadyRunning = True
End Function

Public Function ProcessCount(likestr)
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}\\.\root\cimv2")
Set colItems = objWMI.ExecQuery("SELECT Name,CommandLine FROM Win32_Process WHERE CommandLine Like '" & likestr & "'")
ProcessCount = colItems.Count
End Function 

'MySQL routines
Function MySQLExecute( cmd )
On Error Resume Next
Set rst = conn.Execute( cmd )
If conn.Errors.Count > 0 Then
If conn.Errors(conn.Errors.Count-1).NativeError = 2006 Then 
conn.Errors.Clear
If InitConnection() Then
Set rst = conn.Execute( cmd )
End If
End If 
End If
If rst.State = 1 And Err.Number = 0 Then
Set MySQLExecute = rst
Else
Set MySQLExecute = conn.Execute( "SELECT Null LIMIT 0" )
End If
On Error Goto 0
End Function

Function MySQLConnect
Set conn = CreateObject("ADODB.Connection")
MySQLConnect = False
On Error Resume next
conn.ConnectionString = "DRIVER={" & MYDRIVER & "};" & _
"SERVER=" & host & ";" & _
"UID=" & login & ";" & _
"PWD=" & password & ";" & _
"OPTION=" & (FLAG_BIG_PACKETS + FLAG_COMPRESSED_PROTO + FLAG_NO_BIGINT + FLAG_MULTI_STATEMENTS)
conn.ConnectionTimeout = 3
conn.Open
If Err.Number = -2147467259 Then
MsgBox "MyODBC isn't installed. Can't connect to MySQL!"
Exit Function
End If
If Err.Number <> 0 Then
MsgBox err.description
Exit Function
End If
MySQLConnect = True
On Error GoTo 0
End Function

Sub MySQLDisconnect
conn.Close
Set conn = Nothing
End Sub

USB device insert/remove monitoring with VBScript

2011-07-16T16:55:00.004+03:00

Some time ago I got an Android Phone. To manage it from PC I installed MyPhoneExplorer.
Thats great software but it doesn't have one vital feature: reconnect automatically when phone is connected via USB. On other hand it have such an option as "Connect on start".
So my idea was to write some program/script to kill MyPhoneExplorer's process on disconnect and start it on connect.
This script just sitting and watching when "Android ADB Interface" device get connected or disconnected via USB executing corresponding action on each event.

Download VBS script

Const DEVICENAME = "Android ADB Interface"
Const EXENAME = "MyPhoneExplorer.exe"
Dim lastOperation
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}\\.\root\cimv2")

'Exit if already running
If alreadyRunning() Then: WScript.Quit

Set objSink = WScript.CreateObject("WBemScripting.SWbemSink","event_")
Set objShell = CreateObject("WScript.Shell")
Set deviceIDs = CreateObject("Scripting.Dictionary")

'Set event hook
objWMIService.ExecNotificationQueryAsync objSink, "Select * from __InstanceOperationEvent within 1 where TargetInstance ISA 'Win32_PnPEntity'"

'Get device IDs by name
EnumerateDevices DEVICENAME
objShell.Popup "USB monitoring started",2
'Infinite loop
Do
 WScript.Sleep 1000
Loop

'USB insert/remove hook procedure
Sub event_OnObjectReady( objEvent, objContext )
 With objEvent
  If deviceIDs.Exists(.TargetInstance.DeviceId) Then
   Select Case .Path_.Class
    Case "__InstanceCreationEvent"
     If lastOperation <> "Insert" Then
      lastOperation = "Insert"
      OnInsert
     End If
      
    Case "__InstanceDeletionEvent"
     If lastOperation <> "Remove" Then
      lastOperation = "Remove"
      OnRemove
     End If
    End Select
  End If
 End With
End Sub

Sub OnInsert
 objShell.Run EXENAME,1,0
End Sub

Sub OnRemove
 objShell.Run "taskkill /f /im " & EXENAME,0,0
End Sub

Sub EnumerateDevices(name)
 Set objDevices = objWMIService.ExecQuery("SELECT DeviceId FROM Win32_PnPSignedDriver WHERE Description='" & name & "'")
 For Each dev in objDevices
  deviceId = dev.DeviceId
  If Not deviceIDs.Exists(deviceId) Then
   deviceIDs.Add deviceId, deviceId
  End If
  d = d + 1
 Next
End Sub

Function alreadyRunning()
 alreadyRunning = False
 wscrCount = ProcessCount( "%wscript%" & WScript.ScriptName & "%" )
 cscrCount = ProcessCount( "%cscript%" & WScript.ScriptName & "%" )
 If  wscrCount > 1 or cscrCount > 1 Then:alreadyRunning = True
End Function

Public Function ProcessCount(likestr)
 Set colItems = objWMIService.ExecQuery("SELECT Name,CommandLine FROM Win32_Process WHERE CommandLine Like '" & likestr & "'")
 ProcessCount = colItems.Count
End Function

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

2010-02-04T18:01:00.003+02:00

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

2010-02-04T16:15:00.000+02:00

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

2010-02-04T11:24:00.008+02:00

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

Excel Dictionary Password Attack macro

2010-01-23T12:41:00.000+02:00

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.

Download Add-In

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!

Excel macro. Multiple range formula quick input

2010-01-22T18:56:00.003+02:00

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:

Download Add-In

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 !

Excel password crack. Recover your forgotten password for free.

2010-01-21T15:47:00.011+02:00

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:

Download Add-In

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

Crack Microsoft Word password

2010-01-20T13:07:00.010+02:00

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

2010-01-20T12:40:00.003+02:00

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

Last cell in range

2010-01-19T10:09:00.000+02:00

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.