工具函数

  1  Function DicCheck(ValueColum, dicColum)
  2     ‘待检查数据列的表头
  3     Dim valueColumnTitle As String
  4     ‘待检查数据列的字典表头
  5     Dim dicColumnTitle As String
  6     ‘数据表格的行数
  7     Dim valueRowCount As Long
  8     ‘需要校验的sheet
  9     Dim curMsgRow As Integer
 10     
 11     Dim valueTitle As String
 12     
 13     valueTitle = Sheets(valueSheetName).Cells(1, ValueColum)
 14     
 15     valueRowCount = Sheets(valueSheetName).UsedRange.Rows.count
 16     For i = dataRowStart To valueRowCount
 17         cellValue = Sheets(valueSheetName).Cells(i, ValueColum)
 18         If cellValue = "" Then
 19             Exit Function
 20         End If
 21         If cellValue <> "" And DoDicCheck(cellValue, dicColum) = False Then
 22              errorMsg = "第" & i & "行的数据项：" & valueTitle & "不符合规范，请检查!"
 23              writeLog (errorMsg)
 24         End If
 25       
 26       Next i
 27 End Function
 28 ‘检查字典项是否合法
 29 Function DoDicCheck(valueCol As TypeValueColum, rowIndex)
 30  ‘字典sheet
 31     value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex)
 32     For j = dataRowStart To Sheets(dicSheetName).UsedRange.Rows.count - 1
 33         dicvalue = Sheets(dicSheetName).Cells(j, valueCol.dicColumnIndex)
 34         If dicvalue = "" Then
 35             Exit For
 36         End If
 37         If dicvalue = value Then
 38           DoDicCheck = True
 39              Exit Function
 40         End If
 41    Next j
 42    If valueCol.dicColumnName = "民族" Or valueCol.dicColumnName = "国籍/地区" Then
 43         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不符合规范，请检查"
 44         writeLog (errorMsg)
 45    Else
 46         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不符合规范，请检查" & getTextByDicName(valueCol.dicColumnName, valueCol.dicColumnIndex)
 47         writeLog (errorMsg)
 48    End If
 49    
 50    DoDicCheck = False
 51 End Function
 52  ‘根据字典名称，获得字典的内容
 53  Function getTextByDicName(dicName, dicIndex)
 54     Dim str As String
 55     Dim count As Integer
 56     str = "(" & dicName & "："
 57     For j = dataRowStart To Sheets(dicSheetName).UsedRange.Rows.count - 1
 58         dicvalue = Sheets(dicSheetName).Cells(j, dicIndex)
 59         If dicvalue <> "" Then
 60             str = str + dicvalue + "、"
 61             count = count + 1
 62         Else
 63             lastIndex = InStrRev(str, "、")
 64             str = Application.WorksheetFunction.Substitute(str, "、", ")", count)
 65             str = Application.WorksheetFunction.Substitute(str, "、", "和", count - 1)
 66             getTextByDicName = str
 67             Exit Function
 68         End If
 69    Next j
 70  End Function
 71  ‘校验长度是否符合要求，参数
 72  ‘value:需要校验的内容
 73  ‘length:限定长度
 74  ‘strick:是否相等
 75  Function CheckValueLength(valueCol As TypeValueColum, rowIndex, length, strick)
 76     value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex)
 77     valueLength = Len(value)
 78     
 79     If strick Then
 80         If valueLength = length Then
 81             CheckValueLength = True
 82             Exit Function
 83         Else
 84             CheckValueLength = False
 85             errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "必须为" & length & "位，请检查！"
 86             writeLog (errorMsg)
 87             Exit Function
 88         End If
 89     End If
 90     If valueLength <= length Then
 91         CheckValueLength = True
 92         Exit Function
 93     Else
 94         CheckValueLength = False
 95         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "长度不能大于" & length & "位，请检查！"
 96         writeLog (errorMsg)
 97         Exit Function
 98     End If
 99  End Function
100  ‘获得内容的字节数
101  ‘返回字节长度
102  Function checkByteLength(value)
103     Dim byteLen As Integer
104     byteLen = 0
105     If IsEmpty(value) Then
106         Exit Function
107     End If
108     valueLength = Len(value)
109     For i = 1 To valueLength
110         If Abs(Asc(Mid(value, i, 1))) > 255 Then
111             byteLen = byteLen + 3
112         Else
113             byteLen = byteLen + 1
114         End If
115     Next i
116     checkByteLength = byteLen
117  End Function
118  
119 ‘根据列查询是否有字典
120 ‘找到返回列索引
121 ‘找不到返回0
122 Function findDic(value)
123     Dim index As Integer
124     index = 1
125     Title = Sheets(dicSheetName).Cells(1, index)
126     While Title <> ""
127         
128         If Title = value Then
129             findDic = index
130             Exit Function
131         End If
132         index = index + 1
133          Title = Sheets(dicSheetName).Cells(1, index)
134     Wend
135     findDic = 0
136 End Function
137 
138 ‘是否为数字
139 ‘不是数字写入日志 返回 False
140 ‘是数字  返回 True
141 Function checkBeNumeric(valueCol As TypeValueColum, rowIndex)
142     Dim beNumeric As Boolean
143     value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex)
144     beNumeric = IsNumeric(value)
145     If beNumeric Then
146     Else
147          errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "必须为数字，请检查！"
148          writeLog (errorMsg)
149          checkBeNumeric = False
150          Exit Function
151     End If
152     checkBeNumeric = True
153 End Function
154 ‘检查是否为20111001日期格式
155 ‘合法，返回True
156 ‘不合法，返回False
157 Function CheckIsDate(valueCol As TypeValueColum, rowIndex)
158     Dim beNumeric As Boolean
159     value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex)
160     If Len(value) <> 8 Then
161         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：20121001)！"
162         writeLog (errorMsg)
163         CheckIsDate = False
164         Exit Function
165     End If
166     
167     beNumeric = IsNumeric(value)
168     If beNumeric Then
169     
170     Else
171         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：20121001)！"
172         writeLog (errorMsg)
173         CheckIsDate = False
174         Exit Function
175     End If
176     
177     dateStr = Left(value, 4) & "/" & Mid(value, 5, 2) & "/" & Right(value, 2)
178     beDate = IsDate(dateStr)
179     If beDate Then
180     Else
181         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不合法，请检查(例如：20121001)！"
182         writeLog (errorMsg)
183         CheckIsDate = False
184         Exit Function
185     End If
186     CheckIsDate = True
187 End Function
188 ‘检查是否为20110101日期格式
189 ‘合法，返回True
190 ‘不合法，返回False
191 Function CheckBeDate(value)
192     Dim beNumeric As Boolean
193     If Len(value) <> 8 Then
194         CheckBeDate = False
195         Exit Function
196     End If
197     
198     beNumeric = IsNumeric(value)
199     If beNumeric Then
200     Else
201         CheckBeDate = False
202         Exit Function
203     End If
204     
205     dateStr = Left(value, 4) & "/" & Mid(value, 5, 2) & "/" & Right(value, 2)
206     beDate = IsDate(dateStr)
207     If beDate Then
208     Else
209         CheckBeDate = False
210         Exit Function
211     End If
212     CheckBeDate = True
213 End Function
214 ‘检查是否为201101日期格式
215 ‘合法，返回True
216 ‘不合法，返回False
217 Function CheckIsYmDate(valueCol As TypeValueColum, rowIndex)
218     Dim beNumeric As Boolean
219     value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex)
220     If Len(value) <> 6 Then
221         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：201201)！"
222         writeLog (errorMsg)
223         CheckIsYmDate = False
224         Exit Function
225     End If
226     
227     beNumeric = IsNumeric(value)
228     If beNumeric Then
229     
230     Else
231         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：201201)！"
232         writeLog (errorMsg)
233         CheckIsYmDate = False
234         Exit Function
235     End If
236     
237     dateStr = Left(value, 4) & "/" & Right(value, 2) & "/01"
238     beDate = IsDate(dateStr)
239     If beDate Then
240     Else
241         errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不合法，请检查(例如：20120101)！"
242         writeLog (errorMsg)
243         CheckIsYmDate = False
244         Exit Function
245     End If
246     CheckIsYmDate = True
247 End Function
248 ‘比较两个日期大小
249 ‘date1>date2 返回1
250 ‘date1=date2 返回0
251 ‘date1<date2 返回-1
252 ‘其他返回2
253 Function compareDate(dateStr1, dateStr2)
254     Dim date1 As Date
255     Dim date2 As Date
256     If Len(dateStr1) <> 8 Or Len(dateStr2) <> 8 Then
257         compareDate = 2
258         Exit Function
259     End If
260     
261      
262     If IsNumeric(dateStr1) And IsNumeric(dateStr2) Then
263     Else
264         compareDate = 2
265         Exit Function
266     End If
267     
268     date1 = Left(dateStr1, 4) & "/" & Mid(dateStr1, 5, 2) & "/" & Right(dateStr1, 2)
269     date2 = Left(dateStr2, 4) & "/" & Mid(dateStr2, 5, 2) & "/" & Right(dateStr2, 2)
270     If date1 - date2 > 0 Then
271         compareDate = 1
272     ElseIf date1 - date2 = 0 Then
273         compareDate = 0
274     Else
275         compareDate = -1
276     End If
277 End Function
278 ‘检查必填项
279 ‘空时返回0
280 ‘不为空时返回1
281 Function checkRequired(rowIndex, columnIndex)
282     ‘表头内容
283     Dim valueTitle As String
284     ‘单元格内容
285     Dim cellValue As String
286     
287     valueTitle = Sheets(valueSheetName).Cells(1, columnIndex)
288     
289     cellValue = Sheets(valueSheetName).Cells(rowIndex, columnIndex)
290     If cellValue = "" Then
291          checkRequired = 0
292          errorMsg = "第" & rowIndex & "行的数据项：" & valueTitle & "不能为空，请填写！"
293          writeLog (errorMsg)
294     Else
295         checkRequired = 1
296     End If
297 End Function
298 ‘检查身份证件号码是否合法
299 ‘不合法，返回0
300 ‘合法，返回1
301 ‘15位 升级18位
302 Function IDcheck(ID)
303     Dim s, i As Integer
304     Dim e, z As String
305     ‘----------------------------身份证号码合法性检查---------------------------------------
306     If Not (Len(ID) = 18 Or Len(ID) = 15) Then                                            ‘位数检验
307        IDcheck = 0
308        Exit Function
309        Else
310        If Len(ID) = 15 Then ID = Left(ID, 6) & "19" & Right(ID, 9)
311        If IsNumeric(Left(ID, 17)) = False Or InStr(ID, ".") > 0 Then                      ‘字符检验
312           IDcheck = 0
313           Exit Function
314        End If
315        On Error Resume Next                                                               ‘日期检验
316        If DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) < 1 Or _
317           DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) > Date Then
318           IDcheck = 0
319           Exit Function
320        End If
321     End If
322      ‘-----------------------------校验码的生成及检查----------------------------------------
323     s = 0
324     For i = 1 To 17
325        s = s + Val(Mid(ID, 18 - i, 1)) * (2 ^ i Mod 11)
326     Next
327     e = Mid("10X98765432", (s Mod 11) + 1, 1)                                           ‘生成校验码
328     If Len(ID) = 18 Then
329        z = UCase(Right(ID, 1))
330        If z = e Then                                                                    ‘校验码对比
331           IDcheck = 1
332           Else
333           IDcheck = 0                  ‘如果要返回校验码，请把本行语句改为：IDcheck = e
334        End If
335        Else
336        IDcheck = ID & e                                                         ‘15位身份证号码升位
337     End If
338 
339 End Function
340 ‘校验电子邮箱
341 Function matchEmail(value)
342     Dim beIndex As Integer
343     beIndex = InStr(value, "@")
344     If beIndex = 0 Then
345         matchEmail = False
346         Exit Function
347     End If
348     matchEmail = True
349 End Function
350 ‘获取表头信息
351 Function getValueColumCount(sheetName)
352     index = 1
353     Title = Sheets(sheetName).Cells(1, index)
354     While Title <> ""
355         index = index + 1
356         Title = Sheets(sheetName).Cells(1, index)
357     Wend
358     getValueColumCount = index - 1
359 End Function
360 ‘删除日志
361 Function clearLog()
362     Sheets(msgSheetName).Columns(1).Delete
363 
364 End Function
365 ‘写日志
366 Function writeLog(content As String)
367     Sheets(msgSheetName).Cells(curMsgRow, 1) = content
368     curMsgRow = curMsgRow + 1
369 End Function
370 
371 ‘获得总列数
372 Function getColumnCount(sheetName)
373     index = 1
374     Title = Sheets(sheetName).Cells(1, index)
375     While Title <> ""
376         index = index + 1
377         Title = Sheets(sheetName).Cells(1, index)
378     Wend
379     getColumnCount = index - 1 - 2
380 End Function
381 ‘回填数据信息
382 Function fileXsExportModel(xep As TypeValueCell)
383     bb = getExportCell(xep)
384     If xep.cellContent <> "" Then
385         If xep.cellName = "班号" Then
386            If Len(xep.cellContent) = 7 Then
387              Dim jyjdInt As Integer
388              Dim bjStr As String
389              Dim bjMess As String
390              Dim njStr As String
391              Dim njMess As String
392              bjMess = ""
393              jyjdInt = Mid(xep.cellContent, 5, 1)
394              njStr = Mid(xep.cellContent, 1, 4)
395              bjStr = Mid(xep.cellContent, 6, 2)
396              If jyjdInt = 1 Then
397                 njMess = "小学" & njStr & "级"
398                 bjMess = bjStr & "班(" & xep.cellContent & ")"
399              ElseIf jyjdInt = 2 Then
400                 njMess = "初中" & njStr & "级"
401                 bjMess = bjStr & "班(" & xep.cellContent & ")"
402              ElseIf jyjdInt = 3 Then
403                 njMess = "高中" & njStr & "级"
404                 bjMess = bjStr & "班(" & xep.cellContent & ")"
405              End If
406              xep.cellContent = bjMess
407              Sheets(XsExportSheet).Cells(19, 3) = njMess
408              Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = xep.cellContent
409            End If
410         Else
411             If xep.cellName <> "学籍接续标识" Then
412                 Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = xep.cellContent
413             End If
414         End If
415     Else
416          If xep.cellName <> "隐藏" Then
417             Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = ""
418          End If
419     End If
420 End Function
421 ‘清空模板信息
422 Function clearXsExportModel(xep As TypeValueCell)
423     Dim columnName As String
424     columnName = xep.cellName
425     If columnName <> "学籍接续标识" Then
426         bb = getExportCell(xep)
427         Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = ""
428     End If
429     ‘年级清空
430     Sheets(XsExportSheet).Cells(19, 3) = ""
431 End Function