excel宏
模版一
Sub 宏1()
'
' 宏1 宏
'
'
Cells.Select
With Selection.Font
.Name = "微软雅黑"
.Size = 10.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("C13").Select
End Sub
Sub 宏2()
'
' 宏2 宏
'
'
Range("A1:E1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Range("C5").Select
End Sub
遗留公共问题代码
Sub 按钮6_Click()
If MsgBox("确认要归档“挂起”状态与“已关闭”问题吗？操作过程将不可逆！", vbYesNo + vbDefaultButton2 + vbExclamation, "提示") <> vbYes Then
Exit Sub
End If
'搬移已关闭问题
MoveRecord "CLOSED", "已关闭问题归档"
MoveRecord "PENDING", "挂起问题"
End Sub
Public Sub RefreshColor()
Dim CurSheet As Worksheet
Set CurSheet = Sheets("设计问题跟踪")
'源页面的记录数
RowNum = CurSheet.UsedRange.Rows.Count
For i = RowNum To 3 Step -1
CurSheet.Rows(i).Font.ColorIndex = 15
strStatus = CurSheet.Cells(i, "H").Text
property = CurSheet.Cells(i, "C").Text
Select Case UCase(strStatus)
Case "OPEN"
CurSheet.Rows(i).Font.ColorIndex = 0
CurSheet.Cells(i, "D").Font.ColorIndex = 5
If Not IsDate(CurSheet.Cells(i, "E").Value) Then
MsgBox "第" + CStr(i) + "行E列日期格式不对！"
Else
iDiff = Date - CurSheet.Cells(i, "E").Value
If iDiff > 0 Then
'超期，标红色
CurSheet.Rows(i).Font.ColorIndex = 3
Else
If iDiff > -30 Then
'1个月内到期，标蓝色
CurSheet.Rows(i).Font.ColorIndex = 5
Else
CurSheet.Rows(i).Font.ColorIndex = 0
End If
End If
If property = "高" Then
Rows(i).Font.ColorIndex = 3
End If
End If
If CurSheet.Cells(i, "D").Value = "" Then
MsgBox "第" + CStr(i) + "行D列责任人不能为空！"
End If
Case "CLOSED"
CurSheet.Rows(i).Font.ColorIndex = 15
Case "CONFIRMING"
CurSheet.Rows(i).Font.ColorIndex = 10
Case "PENDING"
CurSheet.Rows(i).Font.ColorIndex = 54
Case ""
If Cells(i, "A").Value <> "" And Cells(i, "B").Value <> "" And Cells(i, "D").Value <> "" And Cells(i, "E").Value <> "" Then
Cells(i, "H").Value = "OPEN"
Rows(i).Font.ColorIndex = 0
Cells(i, "D").Font.ColorIndex = 5
Cells(i, "F").Value = ""
If Not IsDate(Cells(i, "E").Value) Then
MsgBox "第" + CStr(i) + "行E列日期格式不对！"
Else
iDiff = Date - Cells(i, "E").Value
If iDiff > 0 Then
'超期，标红色
Rows(i).Font.ColorIndex = 3
Else
If iDiff > -30 Then
'1个月内到期，标蓝色
Rows(i).Font.ColorIndex = 5
Else
Rows(i).Font.ColorIndex = 0
End If
End If
End If
End If
Case Else
CurSheet.Rows(i).Font.ColorIndex = 0
End Select
'格式化责任人
strNameList = FormatStr(CurSheet.Cells(i, "D").Value)
If strNameList <> CurSheet.Cells(i, "D").Value Then
CurSheet.Cells(i, "D").Value = strNameList
End If
Next i
End Sub
Public Sub ChangeIssueColor(Target As Range)
Dim i, j As Integer
i = Target.Row
j = Target.Column
If j <> 8 And j <> 5 And j <> 4 And j <> 3 Then
Exit Sub
End If
strStatus = Cells(i, "H").Text
property = Cells(i, "C").Text
Select Case UCase(strStatus)
Case "OPEN"
Rows(i).Font.ColorIndex = 0
Cells(i, "D").Font.ColorIndex = 5
Cells(i, "F").Value = ""
If Not IsDate(Cells(i, "E").Value) Then
MsgBox "第" + CStr(i) + "行E列日期格式不对！"
Else
iDiff = Date - Cells(i, "E").Value
If iDiff > 0 Then
'超期，标红色
Rows(i).Font.ColorIndex = 3
Else
If iDiff > -30 Then
'1个月内到期，标蓝色
Rows(i).Font.ColorIndex = 5
Else
Rows(i).Font.ColorIndex = 0
End If
If property = "高" Then
Rows(i).Font.ColorIndex = 3
End If
End If
End If
If Cells(i, "D").Value = "" Then
MsgBox "第" + CStr(i) + "行D列责任人不能为空！"
End If
Case "CLOSED"
Rows(i).Font.ColorIndex = 15
Cells(i, "F").Value = Date
Case "CONFIRMING"
Rows(i).Font.ColorIndex = 10
Cells(i, "F").Value = Date
Case "PENDING"
Rows(i).Font.ColorIndex = 54
Cells(i, "F").Value = Date
Case ""
If Cells(i, "A").Value <> "" And Cells(i, "B").Value <> "" And Cells(i, "D").Value <> "" And Cells(i, "E").Value <> "" Then
Cells(i, "H").Value = "OPEN"
Rows(i).Font.ColorIndex = 0
Cells(i, "D").Font.ColorIndex = 5
Cells(i, "F").Value = ""
If Not IsDate(Cells(i, "E").Value) Then
MsgBox "第" + CStr(i) + "行E列日期格式不对！"
Else
iDiff = Date - Cells(i, "E").Value
If iDiff > 0 Then
'超期，标红色
Rows(i).Font.ColorIndex = 3
Else
If iDiff > -30 Then
'1个月内到期，标蓝色
Rows(i).Font.ColorIndex = 5
Else
Rows(i).Font.ColorIndex = 0
End If
End If
End If
End If
Case Else
End Select
'格式化责任人
strNameList = FormatStr(Cells(i, "D").Value)
If strNameList <> Cells(i, "D").Value Then
Cells(i, "D").Value = strNameList
End If
End Sub
Public Sub MoveRecord(strStatus As String, DstSheet As String)
Dim RowNum As Integer, i As Integer
SrcSheet = "设计问题跟踪"
'源页面的记录数
RowNum = Sheets(SrcSheet).UsedRange.Rows.Count
'目标页面的记录数
j = Sheets(DstSheet).UsedRange.Rows.Count
For i = RowNum To 3 Step -1
If UCase(Sheets(SrcSheet).Cells(i, "H").Value) = UCase(strStatus) Then
Sheets(SrcSheet).Rows(i).Copy Destination:=Sheets(DstSheet).Rows(j + 1)
j = j + 1
Sheets(SrcSheet).Rows(i).Delete
End If
Next i
'排序
End Sub
Public Function CopyRecord(CurSheet As Worksheet, strName As String, strStatus As String, DstSheet As Worksheet)
Dim RowNum As Integer, i As Integer
'源页面的记录数
iRowNum = CurSheet.UsedRange.Rows.Count
'目标页面的记录数
j = DstSheet.UsedRange.Rows.Count
If j <= 1 Then
'拷贝标题
CurSheet.Rows(2).Copy Destination:=DstSheet.Rows(1)
End If
iAlreadyDue = 0
iWillDue = 0
For i = 3 To iRowNum
strTemp = GetFirstName(CurSheet.Cells(i, "D").Value)
If IsDate(CurSheet.Cells(i, "E").Value) Then
iDiff = Date - CurSheet.Cells(i, "E").Value
If UCase(CurSheet.Cells(i, "H").Value) = UCase(strStatus) And strTemp = strName And iDiff > -30 Then
CurSheet.Rows(i).Copy Destination:=DstSheet.Rows(j + 1)
j = j + 1
iDiff = Date - DstSheet.Cells(j, "E").Value
If iDiff > 0 Then
iAlreadyDue = iAlreadyDue + 1
Else
iWillDue = iWillDue + 1
End If
End If
End If
Next i
'刷新问题数
DstSheet.Cells(1, "K").Value = "超期问题总数"
DstSheet.Cells(2, "K").Value = iAlreadyDue
DstSheet.Cells(1, "L").Value = "到期或将到期问题总数"
DstSheet.Cells(2, "L").Value = iWillDue
DstSheet.Cells(1, "M").Value = "责任人"
DstSheet.Cells(2, "M").Value = strName
End Function
Public Sub SetBorder(rg As Range)
rg.Borders(xlDiagonalDown).LineStyle = xlNone
rg.Borders(xlDiagonalUp).LineStyle = xlNone
With rg.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
With rg.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
With rg.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
With rg.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
With rg.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
With rg.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlHairline
End With
End Sub
Public Sub ClearBorder(rg As Range)
rg.Borders(xlDiagonalDown).LineStyle = xlNone
rg.Borders(xlDiagonalUp).LineStyle = xlNone
With rg.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With rg.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With rg.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With rg.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With rg.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With rg.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Public Function IsSheetExist(strSheetName As String) As Boolean
Dim sht As Worksheet
Dim bExist As Boolean
IsSheetExist = False
For Each sht In ThisWorkbook.Worksheets
If sht.Name = strSheetName Then
IsSheetExist = True
Exit For
End If
Next sht
End Function
Public Function FindTheRow(CurSheet As Worksheet, strRowName As String) As Integer
Dim ret As Range
Set ret = CurSheet.Columns(1).Find(what:=strRowName, LookAt:=xlWhole)
If Not ret Is Nothing Then
FindTheRow = ret.Row
Else
MsgBox "找不到" + strRowName, vbOKOnly, ""
FindTheRow = 0
Exit Function
End If
End Function
Public Function getTextColor(strStatus As String, dtDate As Date) As String
getTextColor = "black"
Select Case strStatus
Case "CLOSED"
getTextColor = "gray"
Case "OPEN"
If IsDate(dtDate) Then
iDiff = Date - dtDate
If iDiff > 0 Then
getTextColor = "red"
End If
If iDiff <= 0 And iDiff > -30 Then
getTextColor = "blue"
End If
End If
Case "CONFIRMING"
getTextColor = "Green"
Case "PENDING"
getTextColor = "Purple"
Case Else
getTextColor = "black"
End Select
End Function
错误记录操作
Public Function InitErrSheet() As Worksheet
Dim TempWS As Worksheet
Dim bFound As Boolean
Dim iWSNum As Integer
Set InitErrSheet = Nothing
bFound = False
iWSNum = ActiveWorkbook.Worksheets.Count
For i = 1 To iWSNum
If ActiveWorkbook.Sheets(i).Name = "Log" Then
bFound = True
Exit For
End If
Next i
If Not bFound Then
ActiveWorkbook.Worksheets.Add After:=Sheets(iWSNum)
iWSNum = iWSNum + 1
Sheets(iWSNum).Name = "Log"
Set TempWS = Sheets(iWSNum)
Call ClearBorder(TempWS.Cells)
TempWS.Cells.Font.Name = "微软雅黑"
TempWS.Cells.Font.Size = 10
TempWS.Rows(1).Font.Bold = True
Call SetBorder(TempWS.Columns("A:E"))
TempWS.Columns("A:A").ColumnWidth = 14 '时间
TempWS.Columns("B:B").ColumnWidth = 28 '操作
TempWS.Columns("C:C").ColumnWidth = 20 '操作对象
TempWS.Columns("D:D").ColumnWidth = 12 '操作结果
TempWS.Columns("E:E").ColumnWidth = 50 '相关信息
TempWS.Cells(1, "A").Value = "时间"
TempWS.Cells(1, "B").Value = "操作"
TempWS.Cells(1, "C").Value = "操作对象"
TempWS.Cells(1, "D").Value = "操作结果"
TempWS.Cells(1, "E").Value = "相关信息"
With TempWS.Range("A1:E1").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
With TempWS.Range("A1:E1").Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Else
Set TempWS = Sheets("Log")
iRowNum = TempWS.UsedRange.Rows.Count
For i = iRowNum To 2 Step -1
If TempWS.Cells(i, 1).Value = "" Then
TempWS.Rows(i).Delete Shift:=xlUp
End If
Next i
'TempWS.Rows("1:1000").Delete Shift:=xlUp
End If
'TempWS.Visible = xlSheetHidden
Set InitErrSheet = TempWS
Set TempWS = Nothing
End Function
Public Sub RecordTheLog(strOp As String, strObj As String, iResult As Integer, strInfo As String, iSuppress As Integer)
Dim ErrSheet As Worksheet
Dim iTimeCol, iOpCol, iObjCol, iResultCol, iInfoCol As Integer
iTimeCol = 1
iOpCol = 2
iObjCol = 3
iResultCol = 4
iInfoCol = 5
If Not IsSheetExist("Log") Then
Exit Sub
End If
Set ErrSheet = Sheets("Log")
iRowNum = ErrSheet.UsedRange.Rows.Count
Select Case iSuppress
Case 0 '不抑制
ErrSheet.Cells(iRowNum + 1, iTimeCol) = Now
ErrSheet.Cells(iRowNum + 1, iOpCol) = strOp
ErrSheet.Cells(iRowNum + 1, iObjCol) = strObj
Select Case iResult
Case 0
ErrSheet.Cells(iRowNum + 1, iResultCol) = "成功！"
Case Else
ErrSheet.Cells(iRowNum + 1, iResultCol) = "失败！（" + CStr(iResult) + "）"
End Select
ErrSheet.Cells(iRowNum + 1, iInfoCol) = strInfo
Case 1 '抑制上一条
ErrSheet.Cells(iRowNum, iTimeCol) = Now
ErrSheet.Cells(iRowNum, iOpCol) = strOp
ErrSheet.Cells(iRowNum, iObjCol) = strObj
Select Case iResult
Case 0
ErrSheet.Cells(iRowNum, iResultCol) = "成功！"
Case Else
ErrSheet.Cells(iRowNum, iResultCol) = "失败！（" + CStr(iResult) + "）"
End Select
ErrSheet.Cells(iRowNum, iInfoCol) = strInfo
Case Else '暂不支持
ErrSheet.Cells(iRowNum + 1, iTimeCol) = Now
ErrSheet.Cells(iRowNum + 1, iOpCol) = strOp
ErrSheet.Cells(iRowNum + 1, iObjCol) = strObj
Select Case iResult
Case 0
ErrSheet.Cells(iRowNum + 1, iResultCol) = "成功！"
Case Else
ErrSheet.Cells(iRowNum + 1, iResultCol) = "失败！（" + CStr(iResult) + "）"
End Select
ErrSheet.Cells(iRowNum + 1, iInfoCol) = strInfo
Exit Sub
End Select
End Sub
通信录操作
Dim InfoStr(100) As String
Sub GetInfoFromID(iSheetNo As Integer)
Dim i, iRowNum, iErrCount As Integer
Dim strID As String
Dim shtContact As Worksheet
If iSheetNo > Worksheets.Count Or iSheetNo < 1 Then
Call RecordTheLog("由工号获取员工信息", CStr(iSheetNo), 1, "无效表单ID！", 0)
MsgBox "无效表单ID！(" + CStr(iSheetNo) + ")", vbOKOnly + vbExclamation, "出错"
Exit Sub
End If
Set shtContact = Sheets(iSheetNo)
iRowNum = shtContact.UsedRange.Rows.Count
iErrCount = 0
For i = 4 To iRowNum
strID = CStr(shtContact.Cells(i, 2).Value)
If strID <> "" Then
strEmail = GetEmailFromID(strID)
If strEmail <> "" Then
shtContact.Cells(i, 1).Value = InfoStr(1) '中文名
shtContact.Cells(i, 3).Value = strEmail 'Email
shtContact.Cells(i, 4).Value = InfoStr(2) '部门
Else
iErrCount = iErrCount + 1
'查不到Email，记录错误并继续
Call RecordTheLog("由工号获取员工信息", strID, 1, "查不到有效Email！", 0)
End If
Else
Exit For
End If
Next i
If iErrCount <> 0 Then
MsgBox "有 " + CStr(iErrCount) + " 个工号查不到有效Email地址", vbOKOnly + vbExclamation, "出错"
End If
End Sub
Function CheckID(strID As String) As Boolean
Dim iLen As Integer
Dim str1 As String
CheckID = False
iLen = Len(strID)
If iLen = 6 Or iLen = 8 Then
If (iLen = 8 And Left(strID, 2) = "WX") Or IsNumeric(strID) Then
CheckID = True
Exit Function
End If
End If
End Function
Function GetEmailFromID(strID As String) As String
Dim i, j, iCount As Integer
Dim strFields, strTemp, strQuery As String
Dim objConn, objCommand, objRecord As Object
GetEmailFromID = ""
If Not CheckID(strID) Then
Call RecordTheLog("由工号获取员工信息", strID, 1, "无效工号！", 0)
MsgBox "无效工号！(" + CStr(strID) + ")", vbOKOnly + vbExclamation, "出错"
Exit Function
End If
'需要查询的字段
strFields = "mail,extensionattribute1,physicaldeliveryofficename,hw-departname5,department,streetaddress,sn,name"
iCount = 8
For i = 0 To iCount - 1
InfoStr(i) = ""
Next i
'创建一个ADODB连接
Set objConn = CreateObject("ADODB.Connection")
objConn.ConnectionString = "DS Query"
objConn.Provider = "ADsDSoobject"
objConn.Open
' 设置查询字符串
strTemp = "(&(objectClass=user)(|(sn=" + strID + ")(sAMAccountName=" + strID + ")(mailnickname=" + strID + ")))"
strQuery = "<LDAP://china.huawei.com/DC=china,DC=huawei,DC=com>;" + strTemp + ";" + strFields + ";subtree"
Set objCommand = CreateObject("ADODB.Command")
objCommand.CommandText = strQuery
objCommand.ActiveConnection = objConn
Set objRecord = objCommand.Execute()
If objRecord.EOF Then
Else
GetEmailFromID = objRecord.Fields(0).Value
On Error Resume Next
For i = 0 To iCount - 1
InfoStr(i) = objRecord.Fields(i).Value
Next i
End If
objConn.Close
Set objConn = Nothing
Set objCommand = Nothing
Set objRecord = Nothing
End Function
Public Function FindIDList(strName As String) As String
Dim ret As Range
Dim CurSheet As Worksheet
Set CurSheet = Sheets("通信录")
Set ret = CurSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
FindIDList = CurSheet.Cells(ret.Row, 2).Value
Else
FindIDList = ""
End If
End Function
Public Function GetFirstName(strNameList As String) As String
iPos = InStr(strNameList, "、")
If iPos = 0 Then
GetFirstName = strNameList
Else
GetFirstName = Left(strNameList, iPos - 1)
End If
End Function
Public Function FindTheAddress(strName As String) As String
Dim ContactSheet As Worksheet
Dim ret As Range
Set ContactSheet = Sheets("通信录")
Set ret = ContactSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
strEmail = Trim(ContactSheet.Cells(ret.Row, ret.Column + 2).Value)
If strEmail <> "" Then
FindTheAddress = FindTheAddress + "; " + strEmail
Else
Call RecordTheLog("查找责任人Email地址", strName, 1, "Email地址均为空！", 0)
End If
Else
'添加责任人到通信录
ContactSheet.Cells(ContactSheet.UsedRange.Rows.Count + 1, "A").Value = strName
Call RecordTheLog("查找通信录责任人", strName, 1, "通信录中未找到责任人，已添加！", 0)
FindTheAddress = ""
End If
End Function
Public Function FindTheAddressOLD(strName As String) As String
Dim ContactSheet As Worksheet
Dim ret As Range
Set ContactSheet = Sheets("通信录")
Set ret = ContactSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
strSN = Trim(ContactSheet.Cells(ret.Row, ret.Column + 1).Value)
strEmail = Trim(ContactSheet.Cells(ret.Row, ret.Column + 2).Value)
If strSN <> "" Then
FindTheAddress = strSN + "@notesmail.huawei.com.cn"
If strEmail <> "" Then
FindTheAddress = FindTheAddress + "; " + strEmail
End If
Else
If strEmail <> "" Then
FindTheAddress = strEmail
Else
Call RecordTheLog("查找责任人Notes ID及Email地址", strName, 1, "Notes ID及Email地址均为空！", 0)
End If
End If
Else
'添加责任人到通信录
ContactSheet.Cells(ContactSheet.UsedRange.Rows.Count + 1, "A").Value = strName
Call RecordTheLog("查找通信录责任人", strName, 1, "通信录中未找到责任人，已添加！", 0)
FindTheAddress = ""
End If
End Function
Public Function AddToMailAddr(strMailAddr As String, strNameList As String, iStartPos As Integer, strNameAll As String) As String
Dim ContactSheet As Worksheet
Dim strName As String
Dim strTemp As String
Dim iPos As Integer
Set ContactSheet = Sheets("通信录")
AddToMailAddr = strMailAddr
Select Case iStartPos
Case 1
strTemp = strNameList
Case 2
iPos = InStr(strNameList, "、")
If iPos = 0 Then
'找不到分隔符
Exit Function
End If
strTemp = Mid(strNameList, iPos + 1)
Case Else
'暂不支持
Exit Function
End Select
While strTemp <> ""
iPos = InStr(strTemp, "、")
'strName = IIf(iPos > 0, Left(strTemp, iPos - 1), strTemp)
If iPos = 0 Then
strName = strTemp
Else
strName = Left(strTemp, iPos - 1)
End If
'之前未处理过的名字才查找
If InStr(strNameAll, strName) = 0 Then
strAddr = FindTheAddress(strName)
If strAddr <> "" Then
AddToMailAddr = AddToMailAddr + IIf(AddToMailAddr = "", "", "; ") + strAddr
End If
End If
strTemp = IIf(iPos = 0, "", Mid(strTemp, iPos + 1))
Wend
End Function
Public Function CombineNameList(strNameAll As String, strNameList As String, iStartPos As Integer, strNameAllRef As String) As String
CombineNameList = strNameAll
strNameList = FormatStr(strNameList)
If strNameList = "" Then
Exit Function
End If
Select Case iStartPos
Case 1
strTemp = strNameList
Case 2
iPos = InStr(strNameList, "、")
If iPos = 0 Then
'找不到分隔符
Exit Function
End If
strTemp = Mid(strNameList, iPos + 1)
Case Else
'暂不支持
Exit Function
End Select
While strTemp <> ""
iPos = InStr(strTemp, "、")
If iPos = 0 Then
strName = strTemp
Else
strName = Left(strTemp, iPos - 1)
End If
'之前未处理过的名字则添加
If InStr(strNameAllRef, strName) = 0 Then
strNameAll = strNameAll + IIf(strNameAll = "", "", "、") + strName
End If
'处理下一个名字
If iPos = 0 Then
strTemp = ""
Else
strTemp = Mid(strTemp, iPos + 1)
End If
Wend
CombineNameList = strNameAll
End Function
Public Function FormatStr(strNameList As String) As String
If strNameList <> "" Then
strTemp = Replace(strNameList, "，", "、")
strTemp = Replace(strTemp, "；", "、")
strTemp = Replace(strTemp, ",", "、")
strTemp = Replace(strTemp, ";", "、")
strTemp = Replace(strTemp, "/", "、")
strTemp = Replace(strTemp, "\", "、")
strTemp = Replace(strTemp, " ", "")
strTemp = Trim(strTemp)
While strTemp <> Replace(strTemp, "、、", "、")
strTemp = Replace(strTemp, "、、", "、")
Wend
While Left(strTemp, 1) = "、"
strTemp = Mid(strTemp, 2)
Wend
While Right(strTemp, 1) = "、"
strTemp = Left(strTemp, Len(strTemp) - 1)
Wend
Else
strTemp = ""
End If
FormatStr = strTemp
End Function
问题报告
Dim InfoStr(100) As String
Sub GetInfoFromID(iSheetNo As Integer)
Dim i, iRowNum, iErrCount As Integer
Dim strID As String
Dim shtContact As Worksheet
If iSheetNo > Worksheets.Count Or iSheetNo < 1 Then
Call RecordTheLog("由工号获取员工信息", CStr(iSheetNo), 1, "无效表单ID！", 0)
MsgBox "无效表单ID！(" + CStr(iSheetNo) + ")", vbOKOnly + vbExclamation, "出错"
Exit Sub
End If
Set shtContact = Sheets(iSheetNo)
iRowNum = shtContact.UsedRange.Rows.Count
iErrCount = 0
For i = 4 To iRowNum
strID = CStr(shtContact.Cells(i, 2).Value)
If strID <> "" Then
strEmail = GetEmailFromID(strID)
If strEmail <> "" Then
shtContact.Cells(i, 1).Value = InfoStr(1) '中文名
shtContact.Cells(i, 3).Value = strEmail 'Email
shtContact.Cells(i, 4).Value = InfoStr(2) '部门
Else
iErrCount = iErrCount + 1
'查不到Email，记录错误并继续
Call RecordTheLog("由工号获取员工信息", strID, 1, "查不到有效Email！", 0)
End If
Else
Exit For
End If
Next i
If iErrCount <> 0 Then
MsgBox "有 " + CStr(iErrCount) + " 个工号查不到有效Email地址", vbOKOnly + vbExclamation, "出错"
End If
End Sub
Function CheckID(strID As String) As Boolean
Dim iLen As Integer
Dim str1 As String
CheckID = False
iLen = Len(strID)
If iLen = 6 Or iLen = 8 Then
If (iLen = 8 And Left(strID, 2) = "WX") Or IsNumeric(strID) Then
CheckID = True
Exit Function
End If
End If
End Function
Function GetEmailFromID(strID As String) As String
Dim i, j, iCount As Integer
Dim strFields, strTemp, strQuery As String
Dim objConn, objCommand, objRecord As Object
GetEmailFromID = ""
If Not CheckID(strID) Then
Call RecordTheLog("由工号获取员工信息", strID, 1, "无效工号！", 0)
MsgBox "无效工号！(" + CStr(strID) + ")", vbOKOnly + vbExclamation, "出错"
Exit Function
End If
'需要查询的字段
strFields = "mail,extensionattribute1,physicaldeliveryofficename,hw-departname5,department,streetaddress,sn,name"
iCount = 8
For i = 0 To iCount - 1
InfoStr(i) = ""
Next i
'创建一个ADODB连接
Set objConn = CreateObject("ADODB.Connection")
objConn.ConnectionString = "DS Query"
objConn.Provider = "ADsDSoobject"
objConn.Open
' 设置查询字符串
strTemp = "(&(objectClass=user)(|(sn=" + strID + ")(sAMAccountName=" + strID + ")(mailnickname=" + strID + ")))"
strQuery = "<LDAP://china.huawei.com/DC=china,DC=huawei,DC=com>;" + strTemp + ";" + strFields + ";subtree"
Set objCommand = CreateObject("ADODB.Command")
objCommand.CommandText = strQuery
objCommand.ActiveConnection = objConn
Set objRecord = objCommand.Execute()
If objRecord.EOF Then
Else
GetEmailFromID = objRecord.Fields(0).Value
On Error Resume Next
For i = 0 To iCount - 1
InfoStr(i) = objRecord.Fields(i).Value
Next i
End If
objConn.Close
Set objConn = Nothing
Set objCommand = Nothing
Set objRecord = Nothing
End Function
Public Function FindIDList(strName As String) As String
Dim ret As Range
Dim CurSheet As Worksheet
Set CurSheet = Sheets("通信录")
Set ret = CurSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
FindIDList = CurSheet.Cells(ret.Row, 2).Value
Else
FindIDList = ""
End If
End Function
Public Function GetFirstName(strNameList As String) As String
iPos = InStr(strNameList, "、")
If iPos = 0 Then
GetFirstName = strNameList
Else
GetFirstName = Left(strNameList, iPos - 1)
End If
End Function
Public Function FindTheAddress(strName As String) As String
Dim ContactSheet As Worksheet
Dim ret As Range
Set ContactSheet = Sheets("通信录")
Set ret = ContactSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
strEmail = Trim(ContactSheet.Cells(ret.Row, ret.Column + 2).Value)
If strEmail <> "" Then
FindTheAddress = FindTheAddress + "; " + strEmail
Else
Call RecordTheLog("查找责任人Email地址", strName, 1, "Email地址均为空！", 0)
End If
Else
'添加责任人到通信录
ContactSheet.Cells(ContactSheet.UsedRange.Rows.Count + 1, "A").Value = strName
Call RecordTheLog("查找通信录责任人", strName, 1, "通信录中未找到责任人，已添加！", 0)
FindTheAddress = ""
End If
End Function
Public Function FindTheAddressOLD(strName As String) As String
Dim ContactSheet As Worksheet
Dim ret As Range
Set ContactSheet = Sheets("通信录")
Set ret = ContactSheet.Columns(1).Find(what:=strName, LookAt:=xlWhole)
If Not ret Is Nothing Then
strSN = Trim(ContactSheet.Cells(ret.Row, ret.Column + 1).Value)
strEmail = Trim(ContactSheet.Cells(ret.Row, ret.Column + 2).Value)
If strSN <> "" Then
FindTheAddress = strSN + "@notesmail.huawei.com.cn"
If strEmail <> "" Then
FindTheAddress = FindTheAddress + "; " + strEmail
End If
Else
If strEmail <> "" Then
FindTheAddress = strEmail
Else
Call RecordTheLog("查找责任人Notes ID及Email地址", strName, 1, "Notes ID及Email地址均为空！", 0)
End If
End If
Else
'添加责任人到通信录
ContactSheet.Cells(ContactSheet.UsedRange.Rows.Count + 1, "A").Value = strName
Call RecordTheLog("查找通信录责任人", strName, 1, "通信录中未找到责任人，已添加！", 0)
FindTheAddress = ""
End If
End Function
Public Function AddToMailAddr(strMailAddr As String, strNameList As String, iStartPos As Integer, strNameAll As String) As String
Dim ContactSheet As Worksheet
Dim strName As String
Dim strTemp As String
Dim iPos As Integer
Set ContactSheet = Sheets("通信录")
AddToMailAddr = strMailAddr
Select Case iStartPos
Case 1
strTemp = strNameList
Case 2
iPos = InStr(strNameList, "、")
If iPos = 0 Then
'找不到分隔符
Exit Function
End If
strTemp = Mid(strNameList, iPos + 1)
Case Else
'暂不支持
Exit Function
End Select
While strTemp <> ""
iPos = InStr(strTemp, "、")
'strName = IIf(iPos > 0, Left(strTemp, iPos - 1), strTemp)
If iPos = 0 Then
strName = strTemp
Else
strName = Left(strTemp, iPos - 1)
End If
'之前未处理过的名字才查找
If InStr(strNameAll, strName) = 0 Then
strAddr = FindTheAddress(strName)
If strAddr <> "" Then
AddToMailAddr = AddToMailAddr + IIf(AddToMailAddr = "", "", "; ") + strAddr
End If
End If
strTemp = IIf(iPos = 0, "", Mid(strTemp, iPos + 1))
Wend
End Function
Public Function CombineNameList(strNameAll As String, strNameList As String, iStartPos As Integer, strNameAllRef As String) As String
CombineNameList = strNameAll
strNameList = FormatStr(strNameList)
If strNameList = "" Then
Exit Function
End If
Select Case iStartPos
Case 1
strTemp = strNameList
Case 2
iPos = InStr(strNameList, "、")
If iPos = 0 Then
'找不到分隔符
Exit Function
End If
strTemp = Mid(strNameList, iPos + 1)
Case Else
'暂不支持
Exit Function
End Select
While strTemp <> ""
iPos = InStr(strTemp, "、")
If iPos = 0 Then
strName = strTemp
Else
strName = Left(strTemp, iPos - 1)
End If
'之前未处理过的名字则添加
If InStr(strNameAllRef, strName) = 0 Then
strNameAll = strNameAll + IIf(strNameAll = "", "", "、") + strName
End If
'处理下一个名字
If iPos = 0 Then
strTemp = ""
Else
strTemp = Mid(strTemp, iPos + 1)
End If
Wend
CombineNameList = strNameAll
End Function
Public Function FormatStr(strNameList As String) As String
If strNameList <> "" Then
strTemp = Replace(strNameList, "，", "、")
strTemp = Replace(strTemp, "；", "、")
strTemp = Replace(strTemp, ",", "、")
strTemp = Replace(strTemp, ";", "、")
strTemp = Replace(strTemp, "/", "、")
strTemp = Replace(strTemp, "\", "、")
strTemp = Replace(strTemp, " ", "")
strTemp = Trim(strTemp)
While strTemp <> Replace(strTemp, "、、", "、")
strTemp = Replace(strTemp, "、、", "、")
Wend
While Left(strTemp, 1) = "、"
strTemp = Mid(strTemp, 2)
Wend
While Right(strTemp, 1) = "、"
strTemp = Left(strTemp, Len(strTemp) - 1)
Wend
Else
strTemp = ""
End If
FormatStr = strTemp
End Function
问题邮件提醒
Sub SendMailByIssue_Click()
Dim CurSheet As Worksheet
Dim SendSheet As Worksheet
Dim ErrSheet As Worksheet
Dim strName As String, strNameAll As String
Dim i As Integer
Dim strSubject As String
Dim strTo As String
Dim strCopy As String
Dim strErr As String, strErrInfo As String
Set CurSheet = Sheets("设计问题跟踪")
If MsgBox("确定要发送邮件吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "提示") <> vbYes Then
Exit Sub
End If
Set ErrSheet = InitErrSheet()
'重新激活焦点
CurSheet.Activate
'源页面的记录数
iRowNum = CurSheet.UsedRange.Rows.Count
iSuccess = 0
iErr = 0
strErr = ""
strErrInfo = ""
strNameAll = ""
For i = 3 To iRowNum
If CurSheet.Cells(i, "H").Value = "OPEN" And IsDate(CurSheet.Cells(i, "E").Value) Then
strName = GetFirstName(CurSheet.Cells(i, "D").Value)
'名字非空
If strName <> "" Then
Set SendSheet = InitTempSheet()
'拷贝标题
CurSheet.Rows(2).Copy Destination:=SendSheet.Rows(1)
'拷贝内容
CurSheet.Rows(i).Copy Destination:=SendSheet.Rows(2)
'发送邮件
strErr = MySendEmailByIssue(SendSheet, strName)
If strErr = "" Then
iSuccess = iSuccess + 1
Call RecordTheLog("按问题发送邮件", CStr(CurSheet.Cells(i, "A").Value) + "(" + strName + ")", 0, "", 0)
Else
iErr = iErr + 1
Call RecordTheLog("按问题发送邮件", CStr(CurSheet.Cells(i, "A").Value) + "(" + strName + ")", 1, strErr, 0)
If InStr(strErrInfo, strErr) = 0 Then
strErrInfo = strErrInfo + Chr(10) + strErr
End If
End If
strNameAll = CombineNameList(strNameAll, strName, 1, strNameAll)
End If
End If
Next i
MsgBox "邮件已发送完毕！共发送 " & iSuccess & " 封邮件" & IIf(iErr > 0, "，失败 " & iErr & " 封。失败信息如下：" + Chr(10) + strErrInfo, "。"), vbOKOnly + vbInformation, "提示"
If iErr > 0 Then
ErrSheet.Visible = xlSheetVisible
ErrSheet.Activate
End If
End Sub
Sub SelectIssueNotify_Click()
Dim myRow As Range
Dim CurSheet As Worksheet
Dim SendSheet As Worksheet
Dim ErrSheet As Worksheet
Dim strName As String, strNameAll As String
Dim i As Integer
Dim strSubject As String
Dim strTo As String
Dim strCopy As String
Dim strErr As String, strErrInfo As String
Set CurSheet = Sheets("设计问题跟踪")
strList = ""
For Each myRow In Selection.EntireRow
i = myRow.Row
strList = strList + IIf(strList = "", "", ",") + CStr(i)
Next
If MsgBox("将针对第" + strList + "行发送邮件，确定要发送吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "提示") <> vbYes Then
Exit Sub
End If
Set ErrSheet = InitErrSheet()
'重新激活焦点
CurSheet.Activate
'源页面的记录数
iRowNum = CurSheet.UsedRange.Rows.Count
iSuccess = 0
iErr = 0
strErr = ""
strErrInfo = ""
strNameAll = ""
For Each myRow In Selection.EntireRow
i = myRow.Row
If CurSheet.Cells(i, "H").Value = "OPEN" And IsDate(CurSheet.Cells(i, "E").Value) Then
strName = GetFirstName(CurSheet.Cells(i, "D").Value)
'名字非空
If strName <> "" Then
Set SendSheet = InitTempSheet()
'拷贝标题
CurSheet.Rows(2).Copy Destination:=SendSheet.Rows(1)
'拷贝内容
CurSheet.Rows(i).Copy Destination:=SendSheet.Rows(2)
'发送邮件
strErr = MySendEmailByIssue(SendSheet, strName)
If strErr = "" Then
iSuccess = iSuccess + 1
Call RecordTheLog("按问题发送邮件", CStr(CurSheet.Cells(i, "A").Value) + "(" + strName + ")", 0, "", 0)
Else
iErr = iErr + 1
Call RecordTheLog("按问题发送邮件", CStr(CurSheet.Cells(i, "A").Value) + "(" + strName + ")", 1, strErr, 0)
If InStr(strErrInfo, strErr) = 0 Then
strErrInfo = strErrInfo + Chr(10) + strErr
End If
End If
strNameAll = CombineNameList(strNameAll, strName, 1, strNameAll)
End If
End If
Next
MsgBox "邮件已发送完毕！共发送 " & iSuccess & " 封邮件" & IIf(iErr > 0, "，失败 " & iErr & " 封。失败信息如下：" + Chr(10) + strErrInfo, "。"), vbOKOnly + vbInformation, "提示"
If iErr > 0 Then
ErrSheet.Visible = xlSheetVisible
ErrSheet.Activate
End If
End Sub
Public Function MySendEmailByIssue(CurSheet As Worksheet, strName As String) As String
'On Error Resume Next
Dim objOutlook As Object
Dim objMail As Object
Dim TextHtml As String
Dim strCopy As String
Dim strSubject As String
iRowNum = CurSheet.UsedRange.Rows.Count
'检查表单是否空
If iRowNum < 2 And CurSheet.Cells(2, "B").Value = "" Then
MySendEmailByIssue = "待发送内容为空！"
Exit Function
End If
strTo = FindTheAddress(strName)
If strTo = "" Then
MySendEmailByIssue = "找不到责任人 '" + strName + "' 的邮件地址！"
Exit Function
End If
strCopy = AddToMailAddr("", CurSheet.Cells(2, "D").Value, 2, "")
iDiff = Date - CurSheet.Cells(2, "E")
strSubject = "[设计问题跟踪] 遗留问题 <" + CStr(CurSheet.Cells(2, "A").Value) + "> " + IIf(iDiff > 0, "已经超期 " + CStr(Abs(iDiff)) + " 天，请反馈处理进展！", IIf(iDiff = 0, "今天已到期，请反馈处理进展！", "还有" + CStr(Abs(iDiff)) + "天将即将到期，请及时处理并反馈问题进展！"))
TextHtml = "<body>"
TextHtml = TextHtml + "<div style='margin-left:10pt;text-indent:0pt'>"
TextHtml = TextHtml + "<b>" + strName + "，您好！</b><br />"
TextHtml = TextHtml + "<p class=MsoNormal style='text-indent:20.0pt'>" & _
"您名下的问题 <" + CStr(CurSheet.Cells(2, "A").Value) + "> " + IIf(iDiff > 0, "<b><font color=red>已超期</font></b> " + CStr(Abs(iDiff)) + " 天", IIf(iDiff = 0, "<b><font color=orange>今天到期</font></b>", "<b><font color=blue>即将到期</font></b>")) + "，请及时处理并反馈问题进展！<br />"
TextHtml = TextHtml + "<table class=MsoNormalTable border=1 cellspacing=0 cellpadding=0 width=1715 style='width:1286.0pt;margin-left:20pt;border-collapse:collapse;mso-yfti-tbllook:1184;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>"
TextHtml = TextHtml + "<tr style='background:#C5D9F1;font-size:10.5pt;padding:0cm 5.4pt 0cm 5.4pt;height:40.75pt'>"
'标题
For j = 1 To 10
TextHtml = TextHtml + "<th>" & CurSheet.Cells(1, j) & "</th>"
Next j
'问题内容
'先划表格
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "<tr style='font-size:10.2pt;padding:0cm 5.4pt 0cm 5.4pt;height:65.25pt'>"
TextHtml = TextHtml + "<td width=93>" & CurSheet.Cells(2, 1) & "</td>"
TextHtml = TextHtml + "<td width=309>" & CurSheet.Cells(2, 2) & "</td>"
TextHtml = TextHtml + "<td width=61>" & CurSheet.Cells(2, 3) & "</td>"
TextHtml = TextHtml + "<td width=101>" & CurSheet.Cells(2, 4) & "</td>"
TextHtml = TextHtml + "<td width=85" + IIf(iDiff > 0, " style='color:red'", IIf(iDiff = 0, " style='color:orange'", "")) + ">" & CurSheet.Cells(2, 5) & "</td>"
TextHtml = TextHtml + "<td width=85>" & CurSheet.Cells(2, 6) & "</td>"
TextHtml = TextHtml + "<td width=485>" & CurSheet.Cells(2, 7) & "</td>"
TextHtml = TextHtml + "<td width=77>" & CurSheet.Cells(2, 8) & "</td>"
TextHtml = TextHtml + "<td width=165>" & CurSheet.Cells(2, 9) & "</td>"
TextHtml = TextHtml + "<td width=207>" & CurSheet.Cells(2, 10) & "</td>"
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "</table>"
TextHtml = TextHtml + "<br />"
TextHtml = TextHtml + "</div>"
TextHtml = TextHtml + "<hr>"
TextHtml = TextHtml + "<div style='margin-left:none;text-indent:0pt'>"
TextHtml = TextHtml + "<b>说明：</b><br />"
TextHtml = TextHtml + "<p class=MsoNormal style='font-size:10.1pt;text-indent:5pt'>" & _
"1、由第一责任人负责刷新并反馈问题进展，必要时提供反应问题进展的附件<br />"
TextHtml = TextHtml + "<p class=MsoNormal style='font-size:10.1pt;text-indent:5pt'>" & _
"2、非第一责任人可以对问题进展进行补充说明<br />"
TextHtml = TextHtml + "</body>"
Set objOutlook = CreateObject("outlook.application")
Set objMail = objOutlook.CreateItem(0)
On Error GoTo ErrHandle
With objMail
.To = strTo
.cc = strCopy
.Subject = strSubject
.HTMLbody = TextHtml
'.attachments.Add "E:\新建 Microsoft Office Excel 工作表.xlsx"
.send
End With
Set objMail = Nothing
Set objOutlook = Nothing
MySendEmailByIssue = ""
Exit Function
ErrHandle:
If Not objOutlook Is Nothing Then
Set objOutlook = Nothing
Set objMail = Nothing
End If
Select Case Err.Number
Case -2147467259
MySendEmailByIssue = "邮件地址错误！"
Case -2147024894
MySendEmailByIssue = "附件不存在！"
Case Else
MySendEmailByIssue = Err.Description
End Select
End Function
Sub SendEmailByName_Click()
Dim CurSheet As Worksheet
Dim SendSheet As Worksheet
Dim strName As String, strNameAll As String
Dim i As Integer
Dim strSubject As String
Dim strTo As String
Dim strCopy As String
Dim strErr As String, strErrInfo As String
Set CurSheet = Sheets("设计问题跟踪")
If MsgBox("确定要发送邮件吗？", vbYesNo + vbDefaultButton2 + vbQuestion, "提示") <> vbYes Then
Exit Sub
End If
Set ErrSheet = InitErrSheet()
'重新激活焦点
CurSheet.Activate
'源页面的记录数
iRowNum = CurSheet.UsedRange.Rows.Count
iSuccess = 0
iErr = 0
strErr = ""
strErrPrev = ""
strErrInfo = ""
strNameAll = ""
For i = 3 To iRowNum
If CurSheet.Cells(i, "H").Value = "OPEN" And IsDate(CurSheet.Cells(i, "E").Value) Then
strName = GetFirstName(CurSheet.Cells(i, "D").Value)
'名字非空且之前未处理过
If strName <> "" And InStr(strNameAll, strName) = 0 Then
Set SendSheet = InitTempSheet()
'拷贝内容(含标题)
iRet = CopyRecord(CurSheet, strName, "OPEN", SendSheet)
'发送邮件
strErr = MySendEmailByName(SendSheet, strName)
If strErr = "" Then
iSuccess = iSuccess + 1
Call RecordTheLog("按第一责任人发送邮件", strName, 0, "", 0)
Else
iErr = iErr + 1
Call RecordTheLog("按第一责任人发送邮件", strName, 1, strErr, 0)
If InStr(strErrInfo, strErr) = 0 Then
strErrInfo = strErrInfo + Chr(10) + strErr
End If
End If
strNameAll = CombineNameList(strNameAll, strName, 1, strNameAll)
End If
End If
Next i
MsgBox "邮件已发送完毕！共发送 " & iSuccess & " 封邮件" & IIf(iErr > 0, "，失败 " & iErr & " 封。失败信息如下：" + Chr(10) + strErrInfo, "。"), vbOKOnly + vbInformation, "提示"
If iErr > 0 Then
ErrSheet.Visible = xlSheetVisible
ErrSheet.Activate
End If
End Sub
Public Function MySendEmailByName(CurSheet As Worksheet, strName As String) As String
'On Error Resume Next
Dim objOutlook As Object
Dim objMail As Object
Dim TextHtml As String
Dim strCopy As String
Dim strNameAll As String
Dim strSubject As String
iRowNum = CurSheet.UsedRange.Rows.Count
'检查表单是否空
If iRowNum < 2 And CurSheet.Cells(2, "B").Value = "" Then
MySendEmailByName = "待发送内容为空！"
Exit Function
End If
strTo = FindTheAddress(strName)
If strTo = "" Then
MySendEmailByName = "找不到责任人 '" + strName + "' 的邮件地址！"
Exit Function
End If
strCopy = ""
strNameAll = ""
iAlreadyDue = CurSheet.Cells(2, "K").Value
iWillDue = CurSheet.Cells(2, "L").Value
If iAlreadyDue + iWillDue = 0 Then
'无内容，无需发邮件
MySendEmailByName = ""
Exit Function
End If
strSubject = "[设计问题跟踪] 您有 " & IIf(iAlreadyDue > 0, CStr(iAlreadyDue) + " 个超期问题", "") & IIf(iWillDue > 0, IIf(iAlreadyDue > 0, "，以及", "") + CStr(iWillDue) + " 个即将到期问题", "") & "请及时处理并反馈进展！"
TextHtml = "<body>"
TextHtml = TextHtml + "<div style='margin-left:10pt;text-indent:0pt'>"
TextHtml = TextHtml + "<b>" + strName + "，您好！</b><br />"
'有超期问题
If iAlreadyDue > 0 Then
TextHtml = TextHtml + "<p class=MsoNormal style='text-indent:20.0pt'>" & _
"您有" + CStr(iAlreadyDue) + " 个问题<b><font color=red>已超期</font></b>，请及时处理并反馈进展！<br />"
TextHtml = TextHtml + "<table class=MsoNormalTable border=1 cellspacing=0 cellpadding=0 width=1715 style='width:1286.0pt;margin-left:20pt;border-collapse:collapse;mso-yfti-tbllook:1184;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>"
TextHtml = TextHtml + "<tr style='background:#C5D9F1;font-size:10.5pt;padding:0cm 5.4pt 0cm 5.4pt;height:40.75pt'>"
'标题
For j = 1 To 10
TextHtml = TextHtml + "<th>" & CurSheet.Cells(1, j) & "</th>"
Next j
'问题内容
For i = 2 To iRowNum
strStatus = CurSheet.Cells(i, "H").Value
If strStatus = "OPEN" And IsDate(CurSheet.Cells(i, "E").Value) Then
iDiff = Date - CurSheet.Cells(i, "E").Value
If iDiff > 0 Then
'先划表格
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "<tr style='font-size:10.2pt;padding:0cm 5.4pt 0cm 5.4pt;height:65.25pt'>"
'再填内容
TextHtml = TextHtml + "<td width=93>" & CurSheet.Cells(i, 1) & "</td>"
TextHtml = TextHtml + "<td width=309>" & CurSheet.Cells(i, 2) & "</td>"
TextHtml = TextHtml + "<td width=61>" & CurSheet.Cells(i, 3) & "</td>"
TextHtml = TextHtml + "<td width=101>" & CurSheet.Cells(i, 4) & "</td>"
TextHtml = TextHtml + "<td width=85 style='color:red'>" & CurSheet.Cells(i, 5) & "</td>"
TextHtml = TextHtml + "<td width=85>" & CurSheet.Cells(i, 6) & "</td>"
TextHtml = TextHtml + "<td width=485>" & CurSheet.Cells(i, 7) & "</td>"
TextHtml = TextHtml + "<td width=77>" & CurSheet.Cells(i, 8) & "</td>"
TextHtml = TextHtml + "<td width=165>" & CurSheet.Cells(i, 9) & "</td>"
TextHtml = TextHtml + "<td width=207>" & CurSheet.Cells(i, 10) & "</td>"
strCopy = AddToMailAddr(strCopy, CurSheet.Cells(i, "D").Value, 2, strNameAll)
strNameAll = CombineNameList(strNameAll, CurSheet.Cells(i, "D").Value, 2, strNameAll)
'If strNameAll = "" Then
' strNameAll = CurSheet.Cells(i, "D").Value
'Else
' strNameAll = strNameAll + "、" + CurSheet.Cells(i, "D").Value
'End If
End If
End If
Next i
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "</table>"
TextHtml = TextHtml + "<br />"
TextHtml = TextHtml + "</div>"
End If
'有到期即将到期问题
If iWillDue > 0 Then
TextHtml = TextHtml + "<div style='margin-left:10pt;text-indent:0pt'>"
TextHtml = TextHtml + "<p class=MsoNormal style='text-indent:20.0pt'>" & _
"您有" + CStr(iWillDue) + " 个问题<b><font color=blue>即将到期</font></b>，请及时处理并反馈进展！<br />"
TextHtml = TextHtml + "<table class=MsoNormalTable border=1 cellspacing=0 cellpadding=0 width=1715 style='width:1286.0pt;margin-left:20pt;border-collapse:collapse;mso-yfti-tbllook:1184;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>"
TextHtml = TextHtml + "<tr style='background:#C5D9F1;font-size:10.5pt;padding:0cm 5.4pt 0cm 5.4pt;height:40.75pt'>"
'标题
For j = 1 To 10
TextHtml = TextHtml + "<th>" & CurSheet.Cells(1, j) & "</th>"
Next j
'问题内容
For i = 2 To iRowNum
strStatus = CurSheet.Cells(i, "H").Value
If strStatus = "OPEN" And IsDate(CurSheet.Cells(i, "E").Value) Then
iDiff = Date - CurSheet.Cells(i, "E").Value
If iDiff <= 0 Then
'先划表格
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "<tr style='font-size:10.2pt;padding:0cm 5.4pt 0cm 5.4pt;height:65.25pt'>"
TextHtml = TextHtml + "<td width=93>" & CurSheet.Cells(i, 1) & "</td>"
TextHtml = TextHtml + "<td width=309>" & CurSheet.Cells(i, 2) & "</td>"
TextHtml = TextHtml + "<td width=61>" & CurSheet.Cells(i, 3) & "</td>"
TextHtml = TextHtml + "<td width=101>" & CurSheet.Cells(i, 4) & "</td>"
TextHtml = TextHtml + "<td width=85>" & CurSheet.Cells(i, 5) & "</td>"
TextHtml = TextHtml + "<td width=85>" & CurSheet.Cells(i, 6) & "</td>"
TextHtml = TextHtml + "<td width=485>" & CurSheet.Cells(i, 7) & "</td>"
TextHtml = TextHtml + "<td width=77>" & CurSheet.Cells(i, 8) & "</td>"
TextHtml = TextHtml + "<td width=165>" & CurSheet.Cells(i, 9) & "</td>"
TextHtml = TextHtml + "<td width=207>" & CurSheet.Cells(i, 10) & "</td>"
strCopy = AddToMailAddr(strCopy, CurSheet.Cells(i, "D").Value, 2, strNameAll)
strNameAll = CombineNameList(strNameAll, CurSheet.Cells(i, "D").Value, 2, strNameAll)
'If strNameAll = "" Then
' strNameAll = CurSheet.Cells(i, "D").Value
'Else
' strNameAll = strNameAll + "、" + CurSheet.Cells(i, "D").Value
'End If
End If
End If
Next i
TextHtml = TextHtml + "</tr>"
TextHtml = TextHtml + "</table>"
TextHtml = TextHtml + "<br />"
TextHtml = TextHtml + "<br />"
TextHtml = TextHtml + "</div>"
End If
TextHtml = TextHtml + "<hr>"
TextHtml = TextHtml + "<div style='margin-left:none;text-indent:0pt'>"
TextHtml = TextHtml + "<b>说明：</b><br />"
TextHtml = TextHtml + "<p class=MsoNormal style='font-size:10.1pt;text-indent:5pt'>" & _
"1、由第一责任人负责刷新并反馈问题进展，必要时提供反应问题进展的附件<br />"
TextHtml = TextHtml + "<p class=MsoNormal style='font-size:10.1pt;text-indent:5pt'>" & _
"2、非第一责任人可以对问题进展进行补充说明<br />"
TextHtml = TextHtml + "</body>"
Set objOutlook = CreateObject("outlook.application")
Set objMail = objOutlook.CreateItem(0)
On Error GoTo ErrHandle
With objMail
.To = strTo
.cc = strCopy
.Subject = strSubject
.HTMLbody = TextHtml
'.attachments.Add "E:\新建 Microsoft Office Excel 工作表.xlsx"
.send
End With
Set objMail = Nothing
Set objOutlook = Nothing
MySendEmailByName = ""
Exit Function
ErrHandle:
If Not objOutlook Is Nothing Then
Set objOutlook = Nothing
Set objMail = Nothing
End If
Select Case Err.Number
Case -2147467259
MySendEmailByName = "邮件地址错误！"
Case -2147024894
MySendEmailByName = "附件不存在！"
Case Else
MySendEmailByName = Err.Description
End Select
End Function
Public Function InitTempSheet() As Worksheet
Dim TempWS As Worksheet
Dim bFound As Boolean
Dim iWSNum As Integer
Set InitTempSheet = Nothing
bFound = False
iWSNum = ActiveWorkbook.Worksheets.Count
For i = 1 To iWSNum
If ActiveWorkbook.Sheets(i).Name = "Temp" Then
bFound = True
Exit For
End If
Next i
If Not bFound Then
ActiveWorkbook.Worksheets.Add After:=Sheets(iWSNum)
iWSNum = iWSNum + 1
Sheets(iWSNum).Name = "Temp"
Set TempWS = Sheets(iWSNum)
Else
Set TempWS = Sheets("Temp")
TempWS.Rows("1:100").Delete Shift:=xlUp
End If
TempWS.Visible = xlSheetHidden
Call ClearBorder(TempWS.Cells)
TempWS.Cells.Font.Size = 10
Call SetBorder(TempWS.Columns("A:J"))
TempWS.Columns("A:A").ColumnWidth = 11 '93
TempWS.Columns("B:B").ColumnWidth = 38 '309
TempWS.Columns("C:C").ColumnWidth = 7 '61
TempWS.Columns("D:D").ColumnWidth = 12 '101
TempWS.Columns("E:E").ColumnWidth = 10 '85
TempWS.Columns("F:F").ColumnWidth = 10 '85
TempWS.Columns("G:G").ColumnWidth = 60 '485
TempWS.Columns("H:H").ColumnWidth = 9 '77
TempWS.Columns("I:I").ColumnWidth = 20 '165
TempWS.Columns("J:J").ColumnWidth = 25 '207
Set InitTempSheet = TempWS
Set TempWS = Nothing
End Function
ThisWorkBook
Private Sub Workbook_Open()
Call RefreshColor
End Sub
通信录
Private Sub CommandButton1_Click()
GetInfoFromID Index
End Sub
已关闭问题归档
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
设计问题跟踪
Private Sub Worksheet_Change(ByVal Target As Range)
ChangeIssueColor Target
End Sub
本文来自博客园，作者：易先讯，转载请注明原文链接：https://www.cnblogs.com/gongxianjin/p/17059352.html
