Archive for category Excel

Removing the password of an Excel VBA project

' to remove the password of a excel with .xlam extension
' 1. use the Savexlam2xls subroutine to save a copy of xlam file to xls file
' 2. run the moveprotect subroutine to remove the password of the xls file
' 3. save as the xls file to xlam (vba addin)


' 把2007加载宏xlam文件修改成工作簿,再另存为2003格式工作簿可以用下面代码:
Sub Savexlam2xls()
    Dim strFile, wb As Workbook
    strFile = Application.GetOpenFilename(FileFilter:="Micrsofe Excel文件(*.xlam), *.xlam")
    If strFile = False Then Exit Sub
    With Workbooks.Open(strFile)
        .IsAddin = False
        .SaveAs FileName:=Replace(strFile, "xlam", "xls"), FileFormat:=xlExcel8
        .Close
    End With
End Sub


'移除VBA编码保护
Sub RemoveProtect()
    Dim FileName As String
    FileName = Application.GetOpenFilename("Excel文件(*.xls & *.xla),*.xls;*.xla", , "VBA破解")
    If FileName = CStr(False) Then
       Exit Sub
    Else
       VBAPassword FileName, False
    End If
End Sub

'设置VBA编码保护
Sub SetProtect()
    Dim FileName As String
    FileName = Application.GetOpenFilename("Excel文件(*.xls & *.xla),*.xls;*.xla", , "VBA破解")
    If FileName = CStr(False) Then
       Exit Sub
    Else
       VBAPassword FileName, True
    End If
End Sub

Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
      If Dir(FileName) = "" Then
         Exit Function
      Else
         FileCopy FileName, FileName & ".bak"
      End If

      Dim GetData As String * 5
      Open FileName For Binary As #1
      Dim CMGs As Long
      Dim DPBo As Long
      For i = 1 To LOF(1)
          Get #1, i, GetData
          If GetData = "CMG=""" Then CMGs = i
          If GetData = "[Host" Then DPBo = i - 2: Exit For
      Next
      If CMGs = 0 Then
         MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
         Exit Function
      End If
      If Protect = False Then
         Dim St As String * 2
         Dim s20 As String * 1
         '取得一个0D0A十六进制字串
         Get #1, CMGs - 2, St
         '取得一个20十六制字串
         Get #1, DPBo + 16, s20
         '替换加密部份机码
         For i = CMGs To DPBo Step 2
             Put #1, i, St
         Next
         '加入不配对符号
         If (DPBo - CMGs) Mod 2 <> 0 Then
            Put #1, DPBo + 1, s20
         End If
         MsgBox "文件解密成功......", 32, "提示"
      Else
         Dim MMs As String * 5
         MMs = "DPB="""
         Put #1, CMGs, MMs
         MsgBox "对文件特殊加密成功......", 32, "提示"
      End If
      Close #1
End Function
Share

Tags: , , ,

Add a worksheet function to extract hyperlinks

There is no worksheet function to extract hyperlink in a given cell. We can use VBA to create a function to do this. The simple function is listed here.

Function getlink(rng)
getlink = rng.Hyperlinks(1).Address
End Function

In your worksheet, you can simply use = getlink(A1) to get the hyperlink tied to the cell A1.

 

Share

Tags: , ,

Day length, sunrise and sunset calculation

There are a lot of situations we need compute day length, sunrise and sunset time. I collected a set of web pages that discuss how to compute them in different ways. I posted the information just for reference.

Length of Day and Twilight – It provide details for how the length of day can be calculated for any given Northern latitude and any day of year. It also includes calculation of the twilight duration.

The longest night is over – this page provide a nice Excel spreadsheet that can calculate day length for a give latitude and any day of a year and generate a nice graph.

Sunrise and sunset calculator – this is nice web page that can calculate sunrise and sunset time for any cities.

A c++ project for sunrise and sunset computation

Extra:

The following information were from http://mathforum.org/.
I figured that if other people were having trouble finding this information, too, maybe it would be worth saving them some time by letting you know what I found. So, here’s the model:

D = daylength
L = latitude
J = day of the year
P = asin[.39795*cos(.2163108 + 2*atan{.9671396*tan[.00860(J-186)]})]
                      / sin(0.8333*pi/180) + sin(L*pi/180)*sin(P) \
D = 24 - (24/pi)*acos{ ------------------------------------------ }
                      \              cos(L*pi/180)*cos(P)         /

Use a radian mode here, but latitude should be entered in degrees. Here is a PERL function to calculate daylength.

sub calcDL($, $)
{
# lat should be in Degrees
# doy = day of the year
my ($lat, $doy) = @_;
$p = asin(0.39795 * cos(0.2163108 + 2.0 * atan(0.9671396 * tan(0.0086*($doy-186.0)))));
$dl = 24.0-(24.0/pi) * acos((sin(0.8333 * pi/180.0)+sin($lat*pi/180.0)*sin($p))/cos($lat*pi/180.0)/cos($p));
return $dl;
}

 

Share

Tags: , , , , , ,

System API and file system access in VBA

Brief Introduction

Microsoft Visual Basic for Application (VBA) is a powerful tool for Microsoft Office Suite. General users usually only use a small portion of functions Microsoft Office provides and never have a chance to touch VBA. However, Microsoft Excel is an great tool to do math and graph. If VBA is used with the Excel functions you can achieve dramatic improvement in productivity and avoid tedious repetitive work. Further VBA makes your work more fun than dry boring work.  This article is focusing on how to utilize Window API functionality and access Windows file system. Sample VBA codes are provided to illustrate the method. Some of the codes are from the Internet. You can reuse the code in your project freely.

Add a BrowseForFolder button in VBA dialog window

VBA does not provide a folder selection dialog component / control. Windows Shell Application API provides this function. In VBA code, we can easy call Windows Shell Application object and utilize this function.  The key part is VBA CreateObject function. We can use this function to create an object that point to “Shell.Application” and then use its “BrowseForFolder” function. See the sample code below.

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

In your VBA project,  you can add a textbox control to hold the returned folder name and a button control on your form, then create a click event handler for the button like the following.

Private Sub CommandButton1_Click()
foldername = BrowseForFolder
tbFolderName.Value = foldername
End Sub

Create a list of files with a given extension

The FileSystemObject (FSO) provides an API to access the Windows filesystem, providing access to files, drives, text streams etc. The FSO is embedded within the Microsoft Scripting run-time, and is available to stand-alone applications (coded using Visual Basic, for example), to web page designers using VBScript or JScript and to users of Microsoft Office applications using Visual Basic for Applications (VBA). Here I introduce the FSO and to create a example function that is used to get a list of files with a given extension.  We still need use CreateObject to crate an object to point “Scripting.FileSystemObject”. After that we can call its functions. See detail in the following sample VBA code. In order to get the list and number of files, we need create two variables outside the subroutine. In your project, these variables can be declared as private variable in modules, forms and classes.


Private FileList(100) As String
Private nFiles As Integer ' base = 1

Sub ListFilesInFolder(SourceFolderName As String, Extension As String)
Dim FSO, SourceFolder, SubFolder, FileItem
Dim r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set FC = SourceFolder.Files
r = 1
For Each FileItem In FC
FileType = Right(FileItem, 4)
If (FileType = Extension) Then
FileList(r) = FileItem.Name
r = r + 1
End If
Next FileItem
nFiles = r - 1
End Sub

To use the function is pretty easy, just call the subroutine like the following.

ListFilesInFolder foldername, ".txt"

Create, read, and write text files

In VBA we can use the same “Scripting.FileSystemObject” to process text files. The following is an example to read text file and extract useful data from it. Similarly, we can use “Scripting.FileSystemObject” to write data to a text file.

Private Sub ReadDataFile(Filename As String)
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFS
Set oFS = oFSO.OpenTextFile(filename)
nline = 1
Do Until oFS.AtEndOfStream
sText = oFS.ReadLine
If (nline = 2) Then
obsdt = Mid(sText, 3)
End If
If (nline >= 9) Then
temparr = Split(sText, " ")
ind = Val(Left(sText, 2))
obsvals(ind) = temparr(12)
End If
nline = nline + 1
Loop
End Sub

Create, read, and write binary files

In addition to text file, VBA also can handle binary files. Here are example code for creating, reading and editing a binary file. The key part is using open function to open a file in binary format and use get to read data and use put to write data. At the top of code sample, we declare an data type with multiple fields. We will use it to hold data and read and write data to file as an unit.


Type MyRec
Name As String * 10
Age As Integer
End Type

Sub CreateBinaryFile()
Dim intUnit As Integer
Dim typInfo(5) As MyRec
Dim lngIndex As Long, lngPos As Long
intUnit = FreeFile
Open ThisWorkbook.Path & "Test.bin" For Binary Access Read Write As intUnit Len = Len(typInfo(1))
typInfo(1).Name = "Andy"
typInfo(1).Age = 40
typInfo(2).Name = "Bob"
typInfo(2).Age = 20
typInfo(3).Name = "Charlie"
typInfo(3).Age = 24
typInfo(4).Name = "David"
typInfo(4).Age = 58
typInfo(5).Name = "Ernie"
typInfo(5).Age = 32
lngPos = 1
For lngIndex = 1 To 5
Put #intUnit, lngPos, typInfo(lngIndex)
lngPos = lngPos + Len(typInfo(lngIndex))
Next
Close intUnit
End Sub

Sub ReadBinaryFile()
Dim intUnit As Integer
Dim typInfo As MyRec
Dim lngIndex As Long, lngPos As Long
intUnit = FreeFile
Open ThisWorkbook.Path & "Test.bin" For Binary Access Read As intUnit Len = Len(typInfo)
lngPos = 1
For lngIndex = 1 To 5
Get #intUnit, lngPos, typInfo
MsgBox "Record " & lngIndex & " contains " & vbLf & typInfo.Name & " Aged " & typInfo.Age
lngPos = lngPos + Len(typInfo)
Next
Close intUnit
End Sub

Sub EditBinaryFile()
Dim intUnit As Integer
Dim typInfo As MyRec
Dim lngIndex As Long, lngPos As Long
intUnit = FreeFile
Open ThisWorkbook.Path & "Test.bin" For Binary Access Write As intUnit Len = Len(typInfo)
typInfo.Name = "Peter"
typInfo.Age = 18
' Replace record 3 - Charlie
lngPos = 1 + ((3 - 1) * Len(typInfo))
Put #intUnit, lngPos, typInfo
Close intUnit
' show changes
ReadBinaryFile
End Sub

Share

Tags: , , , , , , , , , , ,

Return an array from a customized VBA function

Instruction

You may use Visual Basic for Application for a while and wrote a lot of customized functions. I found majority of VBA users do not know how to use array as function arguments or return values in an array. Excel provides some of Worksheet functions that can return an array, such as “frequency”. For this type of Excel worksheet functions, we have to select a range of cells and enter a formula, then hold Ctrl + Shift and press Enter key to complete the formula. They are special anyway. Now let me explain how we can use array in our customized worksheet functions.

Use array in function arguments

Refer to Use array in a costomized worksheet function to find out how to use array in your customized worksheet function argument list.

Return a row vector

To allow a customized Excel function return a row vector is pretty easy. Just declare a single dimension array and assign values  to each elements of the array. At the end of the function, assign the function to the array. See demonstration in the “retrow()” function in the following VBA code.  To use the function, you have to select 3 cells in a single row, enter “=retrow()”. Then hold Ctrl + Shift and press Enter to complete the formula. Now you will see three returned values in the selected cells.

Return a column vector

To allow a customized Excel function return a row vector is a little complicated. Just declare a two dimensional array, such as x(10,1). The key is the second dimension is 1.  And assign values  to each elements of the array. At the end of the function, assign the function to the array. See demonstration in the “retcol()” function in the following VBA code.  To use the function, you have to select 3 cells in a single column, enter “=retcol()”. Then hold Ctrl + Shift and press Enter to complete the formula. Now you will see three returned values in the selected cells.

Return an matrix

In reality, the above function that returns a column vector is one special example of the function return a matrix. Just extend the second dimension value from 1 to a greater number. When you use the function, remember to select a rectangular range in the spreadsheet and enter a corresponding formula properly.

The following VBA code demonstrates the three functions. In the real world, you need extending the functionality of these prototype functions.

Function retrow()
ReDim x(3)
x(0) = 1
x(1) = 2
x(2) = 3
retrow = x
End Function

Function retcol()
ReDim x(3, 1)
x(0, 0) = 1
x(1, 0) = 2
x(2, 0) = 3
retcol = x
End Function

Function retmatrix()
ReDim x(3, 2)
x(0, 0) = 1
x(1, 0) = 2
x(2, 0) = 3
x(0, 1) = 2
x(1, 1) = 3
x(2, 1) = 4
retmatrix = x
End Function

Reference

In the website, we have published a lot of customized VBA worksheet functions that either use array as function arguments or return values in an array. They are listed below.

Share

Tags: , , , , , ,