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
        .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: , ,

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)
Share

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)
            Wend
        End If
    Wend
    f.Close
    Set f = Nothing
    Set fso = Nothing
    ReadCSV = Row - 1
End Function
Share

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
    db_record.MoveFirst
    
    '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
        db_record.MoveNext
    Loop

    map_record.Close
    Set map_record = Nothing
End Sub
Share

Tags: , , ,