'
'Date: 2012/04/10
'Author: xi wei cheng
'
'Option Explicit
Public dict As Object
'
' 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 addflg As Boolean
addflg = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").CheckBox3.value
Dim template As String
template = "{start}{content}{end}"
If Not addflg Then
startStr = ""
endStr = ""
End If
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 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
Dim addflg, todoFlg As Boolean
addflg = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").CheckBox1.value
todoFlg = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").CheckBox2.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 And addflg Then
rowData = startStr & rowData & endStr
End If
If todoFlg 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()
If dict Is Nothing Then
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
End If
Dim c1 As Range
Dim valArr As String
valArr = ""
For Each c1 In Selection
c1.Activate
Dim val, cellVal As String
cellVal = ActiveCell.value
Dim i1, i2 As Integer
i1 = Strings.InStr(1, cellVal, "[")
i2 = Strings.InStr(1, cellVal, "]")
If i1 > 0 And i2 > i1 Then
cellVal = Left(cellVal, i1 - 1) & Right(cellVal, Len(cellVal) - i2)
End If
val = dict.item(cellVal)
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
valArr = valArr & val & vbCrLf
If Not val = "" Then
If Strings.InStr(1, ActiveCell.value, val) > 0 Then
ActiveCell.value = Strings.Replace(ActiveCell.value, "[" & val & "]", "")
Else
ActiveCell.value = ActiveCell.value & "[" & val & "]"
End If
End If
Next
If valArr <> "" Then
valArr = Strings.Left(valArr, Len(valArr) - 2)
End If
Dim dataObj As DataObject
Set dataObj = New DataObject
dataObj.SetText valArr
dataObj.PutInClipboard
End Sub
'
' Comment: Copy Bean properties to another.
' ShortCutKeys: Ctrl+T
'
Sub CopyBeanProps()
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 beanFrom, beanTo As String
beanFrom = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(8, "D").value
beanTo = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(8, "E").value
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
Dim indexB, indexE As Integer
indexB = Strings.InStr(1, rowData, "[")
indexE = Strings.InStr(2, rowData, "]")
Dim idEn, FirstChUpperIdEn, codeStr As String
idEn = Strings.Mid(rowData, indexB + 1, indexE - indexB - 1)
FirstChUpperIdEn = UCase(Left(idEn, 1)) & Right(idEn, Len(idEn) - 1)
'b1.setProp(b2.getProp());
codeStr = beanTo & ".set" & FirstChUpperIdEn & "(" & beanFrom & ".get" & FirstChUpperIdEn & "());"
rowData = Strings.Replace(rowData, "[" & idEn & "]", "")
rowsData = rowsData & rowData & vbCrLf
rowsData = rowsData & codeStr & 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: Make index for UT test items.
' ShortCutKeys: Ctrl+Shift+W
'
Sub MakeIndex()
Dim joinIndex, cellVal, newVal As String
joinIndex = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(9, "D").value
Dim indexArr, rowArr, in0 As String
indexArr = Split(joinIndex, ",")
cellVal = ActiveCell.value
rowArr = Split(cellVal, vbLf)
newVal = ""
in0 = 0
For Each row In rowArr
Dim in1 As Integer
in1 = Strings.InStr(1, rowArr(in0), "D")
If in1 > 0 Then
Dim content As String
content = Strings.Right(rowArr(in0), Len(rowArr(in0)) - in1)
newVal = newVal & (indexArr(in0) & "D" & content & vbCrLf)
End If
in0 = in0 + 1
Next
newVal = Strings.Left(newVal, Len(newVal) - 2)
'Dim dataobj As DataObject
'Set dataobj = New DataObject
'dataobj.SetText newVal
'dataobj.PutInClipboard
ActiveCell.value = newVal
End Sub
'
' Comment: Append index for UT test items.
' ShortCutKeys: Ctrl+W
'
Sub AppendIndex()
Dim joinIndex, cellVal As String
joinIndex = Workbooks("ProgramTools.xls").Worksheets("ExcelTools").Cells(9, "D").value
Dim indexArr, rowArr, in0 As String
indexArr = Split(joinIndex, ",")
cellVal = ActiveCell.value
rowArr = Split(cellVal, vbLf)
in0 = 0
For Each row In rowArr
Dim in1 As Integer
in1 = Strings.InStr(1, rowArr(in0), "D")
If in1 > 0 Then
in0 = in0 + 1
End If
Next
ActiveCell.NumberFormatLocal = "@"
If in0 <> 0 Then
ActiveCell.value = cellVal & vbCrLf & indexArr(in0) & "D"
Else
ActiveCell.value = cellVal & indexArr(in0) & "D"
End If
End Sub
Public Sub CompareHandle()
UserForm1.Show
End Sub
Public Sub ExportSheetAsTxt()
Call DoExportTxt(ActiveSheet)
End Sub
Sub DoExportTxt(ws As Worksheet)
Dim lastRow, count As Integer
lastRow = MaxRowIndex(ws)
count = 0
Dim row As Range
Dim txt, txtRow, fileName As String
txt = ""
txtRow = ""
For Each row In Rows
If count > lastRow Then Exit For
txtRow = GetRowData(row)
txt = txt & txtRow & vbCrLf
count = count + 1
Next
txt = Strings.Left(txt, Len(txt) - 2)
fileName = ActiveWorkbook.Name & "_" & ws.Name & "_" & ReplaceAll(DateTime.Time, ":", "-") & ".txt"
If MakeTxtFile(txt, fileName) Then
MsgBox "Export txt file success!" & vbCrLf & vbCrLf & "FileName: yC:\ExportSheetTxtFiles\" & fileName & "z"
End If
End Sub
Function ReplaceAll(str As String, src As String, dest As String)
Dim index As Integer
index = Strings.InStr(1, str, src)
While index > 0
str = Strings.Replace(str, src, dest)
index = Strings.InStr(1, str, src)
Wend
ReplaceAll = str
End Function
Function IsFileExist(path As String)
On Error GoTo EarlyExit
If Not Dir(path, vbDirectory) = vbNullString Then
IsFileExist = True
End If
Exit Function
EarlyExit:
IsFileExist = False
End Function
Function MakeTxtFile(ByVal txt As String, ByVal fileName As String)
'On Error GoTo msgLabel
Dim MyFile As Object
If Not IsFileExist("C:\ExportSheetTxtFiles\") Then
MkDir "C:\ExportSheetTxtFiles\"
End If
Dim filePath As String
filePath = "C:\ExportSheetTxtFiles\" & fileName
Open filePath For Output As #1
Print #1, txt
Close #1
Reset
MakeTxtFile = True
Exit Function
msgLabel:
MsgBox "Make file failed! Maybe the file has bean opened!"
MakeTxtFile = False
End Function
Function GetRowData(row As Range)
Dim cell As Range
Dim retVal As String
retVal = ""
Dim count, colCount1 As Integer
count = 0
colCount1 = row.Worksheet.Range("IV" & row.row).End(xlToLeft).Column
For Each cell In row.Cells
If count >= colCount1 Then Exit For
If cell.value = "" Then
retVal = retVal & " "
Else
retVal = retVal & cell.value
End If
count = count + 1
Next
GetRowData = retVal
End Function
Function MaxRowIndex(ws As Worksheet)
Dim i, index, tempIndex As Integer
index = 0
For i = 1 To 100
tempIndex = ws.Cells(65536, i).End(xlUp).row
If tempIndex > index Then index = tempIndex
Next
MaxRowIndex = index
End Function
