编码工具VBA代码
'
'Date: 2012/04/10
'Author: xi wei cheng
'
'Option Explicit
'
' Comment: Copy activeCell's value to the clipboard.
' ShortCutKeys: Ctrl+C
'
Sub CopyCellValue2Clipboard()
Dim cellVal As String
Dim startStr, endStr As String
startStr = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(2, "D").value
endStr = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(2, "E").value
cellVal = ActiveCell.value
Dim template As String
template = "{start}{content}{end}"
Dim result As String
result = Strings.Replace(template, "{start}", startStr)
result = Strings.Replace(result, "{end}", endStr)
result = Strings.Replace(result, "{content}", cellVal)
'cellVal = CopyFilter(cellVal)
Dim dataobj As DataObject
Set dataobj = New DataObject
dataobj.SetText result
dataobj.PutInClipboard
End Sub
Function CopyFilter(value As String)
Dim flg1, flg2 As String
flg1 = "y"
flg2 = "z"
Dim index1, index2 As Integer
index1 = Strings.InStr(1, value, flg1)
index2 = Strings.InStr(1, value, flg2)
Dim retVal As String
retVal = Strings.Right(value, Len(value) - (index2))
CopyFilter = retVal
End Function
'
'Open select sql create form.
'
Sub SelectSql_Click()
'MsgBox "Begin."
'SelectSQLForm.Show
End Sub
'
' Comment: Change the Japan item to English.
' ShortCutKeys: Ctrl+Shift+F
'
Sub ChangeJp2En()
Dim ocell As Range
Dim startIndex, activeIndex As Integer
startIndex = 13
activeIndex = ActiveCell.Row
While Not Cells(activeIndex, ActiveCell.Column).value = ""
startIndex = 13
While Not Cells(startIndex, "B").value = ""
If Cells(startIndex, "B").value = Cells(activeIndex, ActiveCell.Column).value Then
Cells(activeIndex, ActiveCell.Column + 1).value = Cells(startIndex, "C").value
End If
startIndex = startIndex + 1
Wend
activeIndex = activeIndex + 1
Wend
End Sub
'
' Comment: Insert the set value at the activeCell.
' ShortCutKeys: Ctrl+Q
'
Sub InsertSetValue()
ActiveCell.value = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(4, "D").value
End Sub
'
' Comment: Copy current row and insert to the down location.
' ShortCutKeys: Ctrl+Shift+I
'
Sub CopyCurrentRowDown()
Dim rowIndex As Integer
rowIndex = ActiveCell.Row
Dim currenRow, nexRow As String
currenRow = rowIndex & ":" & rowIndex
nexRow = (rowIndex + 1) & ":" & (rowIndex + 1)
Rows(currenRow).Select
Selection.Copy
Rows(nexRow).Select
Selection.Insert Shift:=xlDown
End Sub
'
' Comment: Copy current row data to clipboard.
' ShortCutKeys: Ctrl+X
'
Sub CopyCurrentRowData()
Dim rowIndex As Integer
rowIndex = ActiveCell.Row
Dim currenRow, rowData As String
currenRow = rowIndex & ":" & rowIndex
'rowData = "//"
rowData = ""
Dim c As Range
For Each c In ActiveSheet.Range(currenRow).Cells
If Not c.value = "" Then
rowData = (rowData & " " & c.value)
End If
Next
Dim dataobj As DataObject
Set dataobj = New DataObject
dataobj.SetText rowData
dataobj.PutInClipboard
End Sub
'
' Comment: Copy Selection row data to clipboard.
' ShortCutKeys: Ctrl+X
'
Sub CopySelectionRowData()
Dim startStr, endStr, todoFlg As String
startStr = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(6, "D").value
'startStr = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").ComboBox1.value
endStr = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(6, "E").value
todoFlg = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(6, "G").value
Dim r As Range
Set r = Selection
'Dim ws As Worksheet
Dim c, c1 As Range
Dim rowIndex As Integer
Dim currenRow, rowData, rowsData As String
rowsData = ""
Dim count As Integer
For Each c1 In r
rowIndex = c1.Row
currenRow = rowIndex & ":" & rowIndex
rowData = ""
count = 0
For Each c In ActiveSheet.Range(currenRow).Cells
If Not c.value = "" Then
count = count + 1
If count = 1 Then
rowData = (rowData & c.value)
Else
rowData = (rowData & " " & c.value)
End If
End If
Next
If Not count = 0 Then
rowData = startStr & rowData & endStr
End If
If todoFlg = "Y" And Strings.InStr(1, rowData, "yŠO•”ƒR[ƒhz") > 0 Then
rowData = rowData & vbCrLf & "// TODO"
End If
rowsData = rowsData & rowData & vbCrLf
Next
rowsData = Strings.Left(rowsData, Len(rowsData) - 2)
Dim dataobj As DataObject
Set dataobj = New DataObject
dataobj.SetText rowsData
dataobj.PutInClipboard
End Sub
'
' Comment: Mapping Japan to English.
' ShortCutKeys: Ctrl+A
'
Sub Key2Value()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim c As Range
For Each c In Workbooks("ProgramTools.xls").Worksheets("PropDic").Range("A:A").Cells
If Not dict.exists(c.value) And Not c.value = "" Then
dict.Add c.value, c.Offset(0, 1).value
End If
Next
Dim val As String
val = dict.item(ActiveCell.value)
If val = "" Then
k = dict.keys
v = dict.items
Dim i As Integer
For i = 0 To dict.count - 1
If Strings.InStr(1, ActiveCell.value, k(i)) > 0 Then
val = v(i)
Exit For
End If
Next
End If
Dim dataobj As DataObject
Set dataobj = New DataObject
dataobj.SetText val
dataobj.PutInClipboard
If Not val = "" Then
ActiveCell.value = ActiveCell.value & "[" & val & "]"
End If
End Sub