Posts Tagged VBA

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
    End With
End Sub

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

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

Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
      If Dir(FileName) = "" Then
         Exit Function
         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
      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
         Get #1, CMGs - 2, St
         Get #1, DPBo + 16, s20
         For i = CMGs To DPBo Step 2
             Put #1, i, St
         If (DPBo - CMGs) Mod 2 <> 0 Then
            Put #1, DPBo + 1, s20
         End If
         MsgBox "文件解密成功......", 32, "提示"
         Dim MMs As String * 5
         MMs = "DPB="""
         Put #1, CMGs, MMs
         MsgBox "对文件特殊加密成功......", 32, "提示"
      End If
      Close #1
End Function

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.



Tags: , ,

Dealing with Strings in VBA

Format string to a fixed length in VBA

I was working on a project to write out a text file. All variables should be written out in a fixed length. Spaces will be used to fill empty before strings or numbers. I come across a neat function to do it as the following:

Right(Space(6) & Format(amp, "0.0"), 6)

Split a string into an array

Break a line string into an array and get rid of the extra empty elements. The following VBA script can be used to do this trick

' parsing data into an array
Dim TestArray() As String
TestArray = Split(line)
Dim LastNonEmpty As Integer
LastNonEmpty = -1
For i = 0 To UBound(TestArray)
  If (StrComp(TestArray(i), "", vbBinaryCompare) <> 0) Then
     LastNonEmpty = LastNonEmpty + 1
     TestArray(LastNonEmpty) = TestArray(i)
  End If
Next i
ReDim Preserve TestArray(LastNonEmpty)

Tags: , , , ,

A better VBA function to read CSV files

When you deal with a large number of CSV files, the best way to do it is develop an algorithm and automate the whole process. That will release you from the boring and error-prone process to do more productive work. The following is the framework of the CSV file reader function. You can modify it to adapt to your situation.

Function ReadCSV(filename, data)
    csvFilename = filename & ".csv"
    Dim fso, f, line, Column, CellStart, CellEnd, Row
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.OpenTextFile(csvFilename, 1)
    ' define the data array
    Row = 0
    While Not f.AtEndOfStream
        line = """" & Replace(f.readline, ",", """,""") & """"
        Row = Row + 1
        If Row > 1 Then ' get rid of the first row - header
            Column = 0
            While line <> ""
                Column = Column + 1
                CellStart = 2
                CellEnd = InStr(2, line, """", vbTextCompare)
                Field = Mid(line, CellStart, CellEnd - CellStart)
                If Column = 1 Then ' date is in dd-mm-yyyy format, has to convert to yyyy-mm-dd
                    dateparts = Split(Field, "/")
                    Field = dateparts(2) & "-" & dateparts(1) & "-" & dateparts(0)
                End If
                data(Row - 1, Column) = Field
                line = Mid(line, CellEnd + 2)
        End If
    Set f = Nothing
    Set fso = Nothing
    ReadCSV = Row - 1
End Function

Tags: , , ,

A skeleton of a MS Access VBA function operating data tables

Use Microsoft Access VBA can do all sorts of database operations. The following is the framework of a VBA subroutine. It includes all VBA database operation mechanisms. You can just borrow it and adapt it to your situation.

Sub FillAField(tablename)
    Dim db As Database
    Dim db_record As DAO.Recordset
    Dim sql As String
    Dim id As String
    Dim field2 As Long

    'Open connection to current Access database
    Set db = CurrentDb()

    ' Create SQL statement to retrieve value from GST table
    ' replace to your sql statement
    sql = "select field1, field2 from " & tablename

    Set db_record = db.OpenRecordset(sql)
    ' move the record pointer
    'Retrieve value if data is found
    Do While Not db_record.EOF
        id = db_record("id")
        field2 = db_record("field2")
        ' process the field2 and generate some data for another field
        Fields = Split(field2, "_")
        theyear = Fields(UBound(Fields))
        sql = "update " & tablename & " set year = " & theyear & " where id=" & id & ";"
        ' update data in the same table
        db.Execute sql
        ' move the record pointer

    Set map_record = Nothing
End Sub

Tags: , , ,