word的VBA办公助手 源代码

 

Option Explicit
'需要引用 excel 16.0  库'
'所有内容仅供个人学习使用，严禁传播。
'
'1-公共变量-表格属性-------------------------------------------------------------------------
Dim Hg% 'hg:行高
Const K1 = 0.1
Dim Flg_bh As Boolean '是否取消编号
'1-公共变量-表格属性-------------------------------------------------------------------------
'2-公共变量-表格更改-------------------------------------------------------------------------
Dim str_Row As Long
Dim end_Row As Long
Dim str_Col As Long
Dim end_Col As Long
'2-公共变量-表格更改-------------------------------------------------------------------------
'3-公共变量-停止程序-------------------------------------------------------------------------
Dim my_Stop As Boolean'3-公共变量-停止程序-------------------------------------------------------------------------
'4-公共变量-EXCEL
''Excel 相关功能定义序-------------------------------------------------------------------------
Dim xlAPP As New Excel.Application
Dim WkBook As Excel.Workbook
Dim Wksheet As Excel.Worksheet
Dim Findexcel As Boolean
'4-公共变量-EXCEL序-------------------------------------------------------------------------'11-公共变量-IO计算-------------------------------------------------------------------------
Public St%, En% '起始、结束单元格位置，用来自动选择
Public S_st$, S_en$ '起始结束单元格
'---------------------------------------
'AI AO DI DO计算
Public AITD#, AOTD#, DITD#, DOTD#
Public AIKS#, AOKS#, DIKS#, DOKS#
Public AIDS#, AODS#, DIDS#, DODS#
Public TI_AIDS As TextBox
Public TI_AODS As TextBox
Public TI_DIDS As TextBox
Public TI_DODS As TextBox
'11-公共变量-IO计算-------------------------------------------------------------------------
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'11-公共变量-IO计算-------------------------------------------------------------------------'让窗口大小可以用鼠标调节-------------------------------------------------------
'----------win64-user64.dll-------------------------------------
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As PointAPI) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Type PointAPI '定义一个类型 PointAPIX As LongY As Long
End Type
Private P As PointAPI
Private Sel As Boolean
Private S As String
Private VHwnd As Long 'windows窗口句柄变量
Private Vlen As Long    'windows窗口主题名称长度变量
'----------win64-user64.dll-------------------------------------Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)
Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)
Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)
'让窗口大小可以用鼠标调节-------------------------------------------------------'模块级类型type存储【施工/建设】单位名称和个数
Private Type Type_sgORjsSZ_Name() As StringSZ_Count() As IntegerSZ_Page() As Stringsz_Filename() As String
End Type'公共函数-文字处理----------------------------------------------------Public Function Cint1(ByVal i As Variant)If IsNumeric(i) ThenCint1 = CInt(i)End IfIf Cint1 < 0 ThenCint1 = Abs(Cint1)End If
End FunctionPublic Function CDbl1(ByVal i As Variant)If IsNumeric(i) ThenCDbl1 = CDbl(i)End If
End Function
Public Function Get_Val(ByVal i_s As Variant) As Variant
'去除单元格内容中的换行符和手动换行符
'去除单元格内容中的空格
'获得纯文本或者获得纯数值
Dim TEM_S As StringTEM_S = Replace(i_s, Chr(13), "")TEM_S = Replace(TEM_S, Chr(7), "")TEM_S = Replace(TEM_S, " ", "")
If TEM_S <> "" ThenGet_Val = TEM_S
ElseGet_Val = ""
End If
End Function
Public Function Get_Dbl(ByVal i_s As Variant) As Double
'获得双精度数值
'去除单元格内容中的换行符和手动换行符
'去除单元格内容中的空格
'获得纯文本或者获得纯数值
Dim TEM_S As String, i%, ss$, Ds$
TEM_S = Replace(i_s, Chr(13), "")
TEM_S = Replace(TEM_S, Chr(7), "")
TEM_S = Replace(TEM_S, " ", "")
TEM_S = Replace(TEM_S, "±", "")For i = 1 To Len(TEM_S)ss = Mid(TEM_S, i, 1)If InStr(1, "0123456789.+-", ss) > 0 ThenDs = Ds & ssElseExit ForEnd IfNext i'去除数字右边的一些-+等非数字字符TEM_S = DsDs = ""For i = Len(TEM_S) To 1 Step -1ss = Mid(TEM_S, i, 1)If InStr(1, "0123456789.", ss) > 0 ThenDs = Left(TEM_S, i)Exit ForElseIf i = 1 ThenDs = TEM_SExit ForEnd IfNext iIf Len(Ds) > 0 ThenGet_Dbl = CDbl1(Ds)ElseGet_Dbl = 0#End If
'End If
End Function
'公共函数-设定小数位数
Public Function Set_P(ByVal i_s As Integer) As String
'设定小数点If i_s = 0 ThenSet_P = "0"ElseIf i_s > 0 ThenSet_P = "0." & String(i_s, "0")End If
End Function
Public Function fun_XiaoShu(ByVal Tem_i_S As String, ByVal i_s As Integer) As String
'设定小数位数
Dim S_set_P As StringIf i_s = 0 ThenS_set_P = "0"ElseIf i_s > 0 ThenS_set_P = "0." & String(i_s, "0")End Iffun_XiaoShu = Format(Tem_i_S, S_set_P)
End Function'9-公共函数-热电阻计算<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'GBT30121-2013工业铂热电阻及铂感温元件   电阻与温度的关系计算公式。规定了误差范围，温度范围，试验合格要求。
'A级铂热电阻，要求误差为，1.5摄氏度左右，约0.543欧姆。
Public Function Fun_Pt100(ByVal iT As Double) As Double
Dim iRt#, iR0#, iA#, iB#, iC#
iA = 0.0039083
iB = -0.0000005775
iC = 0.000000000004183
iR0 = 100
If iT >= -200 And iT < 0 TheniRt = iR0 * (1 + iA * iT + iB * iT ^ 2 + iC * (iT - 100) * iT ^ 3)
ElseIf iT >= 0 And iT <= 850 TheniRt = iR0 * (1 + iA * iT + iB * iT ^ 2)
ElseMsgBox "温度不在Pt100规定测量范围之内"
End If
Fun_Pt100 = iRtEnd Function
'9-公共函数-热电阻计算'12-公共函数-IO计算<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'计算点数
Public Function DSjs(ByVal TD_i#, ByVal KS_i#)
DSjs = TD_i * KS_i
End Function
'-----------------------------------
'计算块数
Public Function KSjs(ByVal DS_i#, ByVal TD_i#)
KSjs = DS_i / TD_i
End Function
'计算通道-----------------------------------
Public Function TDjs(ByVal DS_i#, ByVal KS_i#)
TDjs = DS_i / KS_i
End Function
'12-公共函数-IO计算<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'13-公共函数-获得量程单位<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Private Function fun_Unit_YaLi(ByVal i_tem_S As String) As String
'针对压力量程获得不同压力单位
Dim i_s As String
i_s = ""
i_tem_S = UCase(i_tem_S) '将字母改成大写方便识别。
If InStr(1, i_tem_S, "MPA") > 0 Theni_s = "MPa"
ElseIf InStr(1, i_tem_S, "KPA") > 0 Theni_s = "KPa"
ElseIf InStr(1, i_tem_S, "PA") > 0 Theni_s = "Pa"
ElseIf InStr(1, i_tem_S, "MA") > 0 Theni_s = "mA"
ElseIf InStr(1, i_tem_S, "V") > 0 Theni_s = "V"
Elsefun_Unit_YaLi = ""MsgBox "压力量程缺少单位，请核实压力变送器量程是否有问题，必须增加单位例如：0-100kPa"
End If
fun_Unit_YaLi = i_sEnd Function
'13-公共函数-获得量程单位<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'14-公共函数-计算选中单元格个数<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Public Function Cell_counts() As Integer
'计算选中单元格个数
Dim i%
i = Selection.Cells.Count
Cell_counts = i
End Function
'14-公共函数-计算选中单元格个数位<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'公共过程-延迟命令----------------------------------------------------
Sub Delay(T As Long)
'单位msDim time1 As Longtime1 = timeGetTimeDoDoEventsLoop While timeGetTime - time1 < T
End Sub
Sub Delay1(ms As Long)Dim start As Singlestart = TimerDo While Timer < start + (ms / 1000)DoEventsLoop
End Sub
'公共过程-延迟命令----------------------------------------------------
'1-公共过程-停止程序================================================
Public Sub Judge_Stop()
'判断是否停止程序
If my_Stop = True ThenExit SubMsgBox "程序停止"
End If
End Sub'1-公共过程-停止程序================================================'1-公共过程-改字体================================================
Public Sub Gaiziti(ByVal i_ziti As String, ByVal i_zihao As Integer, ByVal i_hangju As Integer)
'字体/自高/行距
'更改字体
If i_zihao > 5 Then
Application.Selection.Font.Name = i_ziti
Application.Selection.Font.Size = i_zihao
With Selection.ParagraphFormat.LineSpacing = i_hangju
End With
End If
End Sub
Public Sub ziti_Red()
'改红色
Application.Selection.Font.Color = wdColorRed
End Sub
Public Sub ziti_Blk()
'改黑色
Application.Selection.Font.Color = wdColorBlack
End Sub
'1-公共过程-改字体================================================'2-公共过程-改行高《《《《《《《《《《《《《《《
Public Sub Hanggao(ByVal Hg%, ByVal K1#)
'更改行高
If Hg * K1 > 0 ThenOn Error Resume NextSelection.Rows.HeightRule = wdRowHeightExactlySelection.Rows.height = CentimetersToPoints(Hg * K1)
End If
End Sub
'2-函数-改行高》》》》》》》》》》》》》》》》Private Sub CheckBox1_Click()End SubPrivate Sub chk_4_col_Click()If chk_4_col.Value = True ThenCmd_Tianxie.Enabled = FalseChk_fugai1.Value = False
ElseCmd_Tianxie.Enabled = TrueChk_fugai1.Value = True
End If
End SubPrivate Sub Chk_fugai1_Click()End SubPrivate Sub Chk_HG_YE_Click()End SubPrivate Sub chk_newLine_Click()
If chk_newLine.Value = 0 Then: T_INS.WordWrap = True
End SubPrivate Sub Chk_suiji_Click()
T_INS.Text = "请在这里输入随机数范围：例如(1-10)"
T_INS.SetFocus
End SubPrivate Sub Chk_tianxie_dizeng_Click()
If Chk_tianxie_dizeng.Value = -1 Then
T_TX_dizeng.Text = InputBox("请输入递增递减间隔，输入负值，则递减", "递增递减功能", 1)
MsgBox "清输入起始值："
MultiPage1.Value = 0
With T_str_dz
.SelStart = 0
.SelLength = Len(.Text)
.SetFocus
End With
End If
End SubPrivate Sub clr_list_writes_Click()
List_writes.Clear
End SubPrivate Sub clear_combo_Ziduan_Click()
Combo_ZiDuan.Clear
End SubPrivate Sub Cmb_sty_01_Change()
'新模板 HGT 3543-2017施工过程文件表格/3503-2017 交工文件表格
Dim TEM_S$
T_point_wucha.Enabled = False
t_YiBiao_Style.Text = Cmb_sty_01.Text
Select Case Cmb_sty_01.ListIndexCase Is = 1'热电阻TEM_S = "GB/T 30121-2013工业铂热电阻及铂感温元件" & vbCrLf & _"本标准规定了对工业铂电阻感温元件和工业铂热电阻的要求及其温度-电阻关系。它们的电阻值是温度的规定函数。" & vbCrLf & _"（-200~0度）Rt=R0*[1+A*t+B*t^2+C*(t-100)*t^3)]" & vbCrLf & _"(0-850度)Rt=R0*(1+A*t+B*t^2)" & vbCrLf & _"AA-A-B-C级热电阻分别对应:0.1-0.15-0.3-0.6摄氏度误差"T_Tips.Text = TEM_ST_str_Row.Text = 9T_str_Col.Text = 1T_end_Row.Text = 11T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 1T_P_ShuJu.Text = 3T_jiancedian.Enabled = TrueT_jiancedian.Text = "0,50,100"Case Is = 2'温度变送器T_str_Row.Text = 10T_str_Col.Text = 1T_end_Row.Text = 12T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 1T_P_ShuJu.Text = 3T_jiancedian.Enabled = TrueT_jiancedian.Text = "25,50,100"Case Is = 3'压力变送器T_str_Row.Text = 10T_str_Col.Text = 1T_end_Row.Text = 14T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 2T_P_ShuJu.Text = 3T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_Tips.Text = "只需输入量程0-100kpa，精度：0.05%；其他不用输入"Case Is = 4'温度计T_str_Row.Text = 3T_str_Col.Text = 8T_end_Row.Text = 40T_end_Col.Text = 8T_Point.Text = 1T_HD_k.Text = 2T_jingdu.Text = 1.5T_jiancedian.Enabled = FalseCase Is = 5'压力表T_str_Row.Text = 3T_str_Col.Text = 8T_end_Row.Text = 40T_end_Col.Text = 8T_Point.Text = 4T_HD_k.Text = 2T_jingdu.Text = 1.5T_Tips.Text = "压力表数据列必须为9列，否则出错，例如：序号-名称-编号-型号-量程-精度-允许误差-最大误差-调校结果"T_jiancedian.Enabled = FalseCase Is = 6'调节阀T_str_Row.Text = 18T_str_Col = 2T_end_Row = 23T_end_Col = 4T_VA_bz_Row.Text = T_str_Row.TextT_xc_Row.Text = 4T_xc_Col.Text = 2T_jingdu.Text = 0.5T_jiancedian.Enabled = FalseT_P_ShuJu.Text = 2Case Is = 7'模拟量回路测试T_str_Row.Text = 5T_str_Col.Text = 4T_end_Row.Text = 36T_end_Col.Text = 10T_col_BZ.Text = 3 '量程所在列T_Point.Text = 1T_jingdu.Text = 0.1T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_P_ShuJu.Text = 2Case Is = 8'基础化I/O组件模拟量测试T_str_Row.Text = 5T_str_Col.Text = 4T_end_Row.Text = 36T_end_Col.Text = 10T_col_BZ.Text = 3 '量程所在列T_Point.Text = 2T_P_ShuJu.Text = 2T_jingdu.Text = 0.1T_jiancedian.Enabled = FalseCase Is = 9'安全栅T_str_Row.Text = 4T_str_Col.Text = 8T_end_Row.Text = 35T_end_Col.Text = 12T_col_BZ.Text = 5 '精度所在列T_Point.Text = 2T_jingdu.Text = 0.1T_point_wucha.Enabled = TrueT_jiancedian.Enabled = FalseCase Is = 10'数显表T_str_Row.Text = 10T_str_Col.Text = 2T_end_Row.Text = 14T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 5T_LC_Col.Text = 2T_Point.Text = 2T_P_ShuJu.Text = 3T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_Tips.Text = "数显表数据"Case ElseT_point_wucha.Enabled = FalseT_jiancedian.Enabled = False
End Select
End SubPrivate Sub Cmd_all_row_col_Click()
'获得第一个表格的总行数和总列数
T_str_Row.Text = 1
T_end_Row.Text = ActiveDocument.Tables(1).Rows.Count
T_str_Col.Text = 1
T_end_Col.Text = ActiveDocument.Tables(1).Columns.Count
End Sub'3-公共过程-段落------------------------------------------------------------------
Private Sub Cmd_bianhao_Click()
'取消编号
Flg_bh = Not Flg_bh
If Flg_bh = True ThenCmd_bianhao.Caption = "取消编号"Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _True, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _wdWord10ListBehavior
ElseIf Flg_bh = False ThenCmd_bianhao.Caption = "增加编号"Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
End If
End Sub
'3-公共过程-段落------------------------------------------------------------------'4-公共过程-表格属性更改------------------------------------------------------------------
Sub biao() '选中word所有表格Dim T As TableActiveDocument.DeleteAllEditableRanges wdEditorEveryoneFor Each T In ActiveDocument.TablesT.Range.Editors.Add wdEditorEveryoneNextActiveDocument.SelectAllEditableRanges wdEditorEveryoneActiveDocument.DeleteAllEditableRanges wdEditorEveryone
End Sub
Sub QianRu_mid()
' qianru Macro
' 宏在 2019/2/26 由 keke 录制
'将表格更改为嵌入式
Dim i As Table
For Each i In ActiveDocument.Tables '在表格中循环With i'禁止环绕文字i.Rows.WrapAroundText = False'表格居中页面i.Rows.Alignment = wdAlignRowCenter'禁止表格跨页断行i.Rows.AllowBreakAcrossPages = FalseEnd With
Next iEnd Sub
Sub YeBianJu()
'表格版式改为--------无,同时居中
QianRu_mid'页边距2,2,2,2，页眉边距0.0With ActiveDocument.Styles(wdStyleNormal).FontIf .NameFarEast = .NameAscii Then.NameAscii = ""End If.NameFarEast = ""End WithWith ActiveDocument.PageSetup.LineNumbering.Active = False.orientation = wdOrientPortrait.topMargin = CentimetersToPoints(1).BottomMargin = CentimetersToPoints(1).leftMargin = CentimetersToPoints(2.5).RightMargin = CentimetersToPoints(1).Gutter = CentimetersToPoints(0).HeaderDistance = CentimetersToPoints(0).FooterDistance = CentimetersToPoints(0).PageWidth = CentimetersToPoints(21) 'a4尺寸.PageHeight = CentimetersToPoints(29.7) 'a4尺寸.FirstPageTray = wdPrinterDefaultBin.OtherPagesTray = wdPrinterDefaultBin.SectionStart = wdSectionNewPage.OddAndEvenPagesHeaderFooter = False.DifferentFirstPageHeaderFooter = False.VerticalAlignment = wdAlignVerticalTop.SuppressEndnotes = False.MirrorMargins = False.TwoPagesOnOne = False.BookFoldPrinting = False.BookFoldRevPrinting = False.BookFoldPrintingSheets = 1.GutterPos = wdGutterPosLeft.LayoutMode = wdLayoutModeLineGridEnd With
End Sub
Sub YEBIANJU1()
'页边距2,2,2,2，页眉边距0.0With ActiveDocument.Styles(wdStyleNormal).FontIf .NameFarEast = .NameAscii Then.NameAscii = ""End If.NameFarEast = ""End WithOn Error Resume NextWith ActiveDocument.PageSetup.LineNumbering.Active = False.orientation = wdOrientPortrait.topMargin = CentimetersToPoints(1).BottomMargin = CentimetersToPoints(1).leftMargin = CentimetersToPoints(2.5).RightMargin = CentimetersToPoints(1).Gutter = CentimetersToPoints(0).HeaderDistance = CentimetersToPoints(0).FooterDistance = CentimetersToPoints(0).PageWidth = CentimetersToPoints(21) 'a4尺寸.PageHeight = CentimetersToPoints(29.7) 'a4尺寸.FirstPageTray = wdPrinterDefaultBin.OtherPagesTray = wdPrinterDefaultBin.SectionStart = wdSectionNewPage.OddAndEvenPagesHeaderFooter = False.DifferentFirstPageHeaderFooter = False.VerticalAlignment = wdAlignVerticalTop.SuppressEndnotes = False.MirrorMargins = False.TwoPagesOnOne = False.BookFoldPrinting = False.BookFoldRevPrinting = False.BookFoldPrintingSheets = 1.GutterPos = wdGutterPosLeft.LayoutMode = wdLayoutModeLineGridEnd With
End Sub
Public Sub T_jz()
'文字在单元格居中Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenterSelection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End SubPublic Sub my_Find(ByVal TEM_S As String)
'查找
Dim i%With Selection.Find.Text = TEM_S.Replacement.Text = "".Forward = True.Wrap = wdFindContinue.Format = False.MatchCase = False.MatchWholeWord = False.MatchByte = False.MatchAllWordForms = False.MatchSoundsLike = False.MatchWildcards = TrueEnd WithSelection.Find.Execute
End Sub'4-公共过程-表格属性更改------------------------------------------------------------------'5-公共过程-图片属性更改------------------------------------------------------------------
Sub mac_TuPianDaXiao()
''批量修改图片大小
' Macro3 Macro
' 宏在 2019/9/22 Sunday 由 keke 录制Dim my_H#, my_W#
Dim i%
Dim Num%
Num = Word.Selection.InlineShapes.Count
Dim my_Shape As Objectmy_H = InputBox("请输入图片高度，必须是数字，默认500", "图片尺寸", 500)
my_W = InputBox("请输入图片宽度，必须是数字，默认500", "图片尺寸", 500)For Each my_Shape In ActiveDocument.InlineShapesWith my_Shape.LockAspectRatio = msoFalse.height = my_H.width = my_W.SelectApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenterEnd With
NextEnd Sub
'5-公共过程-图片属性更改------------------------------------------------------------------'6-公共过程-液位计算------------------------------------------------------------------
Private Sub yw_S_js()
'计算差压值
Dim yw_Ro#, yw_G#, yw_H#, yw_dP#, yw_LdP#, yw_UdP#
yw_Ro = CDbl1(T_yw_Ro.Text)
yw_G = CDbl1(T_yw_g.Text)
yw_H = CDbl1(T_yw_H.Text)
yw_dP = yw_Ro * yw_G * yw_H
yw_LdP = CDbl1(T_yw_LdP.Text)T_yw_dP.Text = Format(yw_dP, "0.000")
T_yw_UdP.Text = Format(yw_LdP + yw_dP, "0.000")T_yw_LCh.Text = "0-" & yw_H & "m(" & T_yw_LdP & "~" & T_yw_UdP & "kpa)"
End Sub
'6-公共过程-液位计算------------------------------------------------------------------
'7-公共过程-插入信息>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub Ins_data()
Selection.Text = Left(Date, 4) & "-" & Left(Replace("0" & Mid(Date, 5, 3), "/", ""), 2) & "-" & Replace(Right(Date, 2), "/", "0")
End Sub
'7-公共过程-插入信息>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'8-公共过程-批量更改word文档指定单元格内容>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Sub Sub_Word_Bath()
'批量更改word文档的指定单元格的内容
Dim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%
Dim MyPath$, MyName$, This_doc_name$Dim mydoc As Object
Dim myWord As Object
Dim my_tbls As TablesDim i%, j%, k%str_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
my_Stop = FalseThis_doc_name = Application.ActiveDocument.Name
MyPath = T_Doc_Path.Text & "\"
MyName = Dir(MyPath & "*.doc*")Do While MyName <> ""Set mydoc = GetObject(MyPath & MyName)Set my_tbls = mydoc.TablesIf InStr(MyName, "目录") < 1 Then'不更改目录文档For i = 1 To mydoc.Tables.CountIf my_Stop = True Then: Exit Sub '停止程序On Error Resume Nextmy_tbls(i).Cell(1, 1).Range.Text = Comb_SGDW.Textmy_tbls(i).Cell(1, 3).Range.Text = T_GCMC.TextNext iIf mydoc.Name <> This_doc_name Thenmydoc.Savemydoc.CloseT_DOC_OK.Text = "更改完毕---" & MyName & vbCrLf & "----------" & vbCrLf & T_DOC_OK.TextEnd IfEnd IfDelay (1000)MyName = Dir
Loop
MsgBox "更改完成！"
End Sub'8-公共过程-批量更改word文档指定单元格内容>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>Public Sub Sub_Word_Bath_jiancha()
'批量检查word文档的指定单元格的内容
Dim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%
Dim MyPath$, MyName$, This_doc_name$Dim mydoc As Object
Dim myWord As Object
Dim my_tbls As TablesDim S1$, S2$, TEM_S$, N_err%, SZ_SGDW() As String, SZ_GCMC() As String
Dim i%, j%, k%, i11%, i12%, i21%, i22%Dim SGDW As Type_sgORjs, GCMC As Type_sgORjs, TJ_SGDW As Type_sgORjs, TJ_GCMC As Type_sgORjs
'施工单位；工程名称；施工单位统计；工程名称统计；统计用来分析；str_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
my_Stop = FalseThis_doc_name = Application.ActiveDocument.Name
MyPath = T_Doc_Path.Text & "\"
MyName = Dir(MyPath & "*.doc*")S1 = ""
S2 = ""
TEM_S = ""
Open MyPath & "检查结果.txt" For Output As #1
Close #1
Open MyPath & "检查结果.txt" For Append As #1ReDim SGDW.SZ_Name(0), SGDW.SZ_Count(0), SGDW.SZ_Page(0), SGDW.sz_Filename(0)
ReDim GCMC.SZ_Name(0), GCMC.SZ_Count(0), GCMC.SZ_Page(0), GCMC.sz_Filename(0)
ReDim TJ_SGDW.SZ_Name(0), TJ_SGDW.SZ_Count(0), TJ_SGDW.SZ_Page(0), TJ_SGDW.sz_Filename(0)
ReDim TJ_GCMC.SZ_Name(0), TJ_GCMC.SZ_Count(0), TJ_GCMC.SZ_Page(0), TJ_GCMC.sz_Filename(0)Do While MyName <> ""Set mydoc = GetObject(MyPath & MyName)Set my_tbls = mydoc.TablesIf InStr(MyName, "目录") < 1 And my_tbls.Count >= 1 Then'不更改目录文档SGDW.sz_Filename(UBound(SGDW.sz_Filename)) = MyNameReDim SGDW.SZ_Name(0), SGDW.SZ_Count(0), SGDW.SZ_Page(0)ReDim GCMC.SZ_Name(0), GCMC.SZ_Count(0), GCMC.SZ_Page(0)For i = 1 To mydoc.Tables.CountIf my_Stop = True Then: Exit Sub '停止程序On Error Resume Next'避免匹配错位，初始化赋值S1 = Get_Val(my_tbls(i).Cell(1, 1).Range.Text)S2 = Get_Val(my_tbls(i).Cell(1, 3).Range.Text)SGDW.SZ_Name(UBound(SGDW.SZ_Name)) = S1GCMC.SZ_Name(UBound(GCMC.SZ_Name)) = S2'施工单位检查，单位名称写入数组，并记录不同施工单位名称的个数For i11 = LBound(SGDW.SZ_Name) To UBound(SGDW.SZ_Name)If SGDW.SZ_Name(i11) = S1 Then'在统计数据库中寻找是否存在For i12 = LBound(TJ_SGDW.SZ_Name) To UBound(TJ_SGDW.SZ_Name)If TJ_SGDW.SZ_Name(i12) = S1 ThenTJ_SGDW.SZ_Count(i12) = TJ_SGDW.SZ_Count(i12) + 1ElseIf i12 = UBound(TJ_SGDW.SZ_Name) And TJ_SGDW.SZ_Name(i12) <> S1 ThenReDim Preserve TJ_SGDW.SZ_Name(UBound(TJ_SGDW.SZ_Name) + 1)ReDim Preserve TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count) + 1)ReDim Preserve TJ_SGDW.SZ_Page(UBound(TJ_SGDW.SZ_Page) + 1)TJ_SGDW.SZ_Name(UBound(TJ_SGDW.SZ_Name)) = S1TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count)) = 1N_err = N_err + 1End IfNext i12SGDW.SZ_Count(i11) = SGDW.SZ_Count(i11) + 1TJ_SGDW.SZ_Count(i11) = TJ_SGDW.SZ_Count(i11) + 1Exit ForElseIf i11 = UBound(SGDW.SZ_Name) And SGDW.SZ_Name(i11) <> S1 ThenReDim Preserve SGDW.SZ_Name(UBound(SGDW.SZ_Name) + 1)ReDim Preserve SGDW.SZ_Count(UBound(SGDW.SZ_Count) + 1)ReDim Preserve SGDW.SZ_Page(UBound(SGDW.SZ_Page) + 1)SGDW.SZ_Name(UBound(SGDW.SZ_Name)) = S1SGDW.SZ_Count(UBound(SGDW.SZ_Count)) = 1If i11 > 0 Then: SGDW.SZ_Page(UBound(SGDW.SZ_Page)) = SGDW.SZ_Page(UBound(SGDW.SZ_Page)) & ";" & i'在统计数据库中寻找是否存在For i12 = LBound(TJ_SGDW.SZ_Name) To UBound(TJ_SGDW.SZ_Name)If TJ_SGDW.SZ_Name(i12) = S1 ThenTJ_SGDW.SZ_Count(i12) = TJ_SGDW.SZ_Count(i12) + 1ElseIf i12 = UBound(TJ_SGDW.SZ_Name) And TJ_SGDW.SZ_Name(i12) <> S1 ThenReDim Preserve TJ_SGDW.SZ_Name(UBound(TJ_SGDW.SZ_Name) + 1)ReDim Preserve TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count) + 1)ReDim Preserve TJ_SGDW.SZ_Page(UBound(TJ_SGDW.SZ_Page) + 1)TJ_SGDW.SZ_Name(UBound(TJ_SGDW.SZ_Name)) = S1TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count)) = 1End IfNext i12End IfNext i11For i11 = LBound(GCMC.SZ_Name) To UBound(GCMC.SZ_Name)If GCMC.SZ_Name(i11) = S2 ThenGCMC.SZ_Count(i11) = GCMC.SZ_Count(i11) + 1TJ_GCMC.SZ_Count(i11) = TJ_GCMC.SZ_Count(i11) + 1'在统计数据库中寻找是否存在For i12 = LBound(TJ_GCMC.SZ_Name) To UBound(TJ_GCMC.SZ_Name)If TJ_GCMC.SZ_Name(i12) = S2 ThenTJ_GCMC.SZ_Count(i12) = TJ_GCMC.SZ_Count(i12) + 1ElseIf i12 = UBound(TJ_GCMC.SZ_Name) And TJ_GCMC.SZ_Name(i12) <> S2 ThenReDim Preserve TJ_GCMC.SZ_Name(UBound(TJ_GCMC.SZ_Name) + 1)ReDim Preserve TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count) + 1)ReDim Preserve TJ_GCMC.SZ_Page(UBound(TJ_GCMC.SZ_Page) + 1)TJ_GCMC.SZ_Name(UBound(TJ_GCMC.SZ_Name)) = S2TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count)) = 1End IfNext i12Exit ForElseIf i11 = UBound(GCMC.SZ_Name) And GCMC.SZ_Name(i11) <> S2 ThenReDim Preserve GCMC.SZ_Name(UBound(GCMC.SZ_Name) + 1)ReDim Preserve GCMC.SZ_Count(UBound(GCMC.SZ_Count) + 1)ReDim Preserve GCMC.SZ_Page(UBound(GCMC.SZ_Page) + 1)GCMC.SZ_Name(UBound(GCMC.SZ_Name)) = S2GCMC.SZ_Count(UBound(GCMC.SZ_Count)) = 1If i11 > 0 Then: GCMC.SZ_Page(UBound(GCMC.SZ_Page)) = GCMC.SZ_Page(UBound(GCMC.SZ_Page)) & ";" & i'在统计数据库中寻找是否存在For i12 = LBound(TJ_GCMC.SZ_Name) To UBound(TJ_GCMC.SZ_Name)If TJ_GCMC.SZ_Name(i12) = S2 ThenTJ_GCMC.SZ_Count(i12) = TJ_GCMC.SZ_Count(i12) + 1ElseIf i12 = UBound(TJ_GCMC.SZ_Name) And TJ_GCMC.SZ_Name(i12) <> S2 ThenReDim Preserve TJ_GCMC.SZ_Name(UBound(TJ_GCMC.SZ_Name) + 1)ReDim Preserve TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count) + 1)ReDim Preserve TJ_GCMC.SZ_Page(UBound(TJ_GCMC.SZ_Page) + 1)TJ_GCMC.SZ_Name(UBound(TJ_GCMC.SZ_Name)) = S2TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count)) = 1N_err = N_err + 1End IfNext i12End IfNext i11Next iIf mydoc.Name <> This_doc_name Thenmydoc.Savemydoc.CloseEnd IfEnd If'写入txt文档。因为每个文档写一次所以，只写入最新的那个For i12 = UBound(SGDW.sz_Filename) To UBound(SGDW.sz_Filename)Write #1, "文件名称：" & SGDW.sz_Filename(i12)For i11 = LBound(SGDW.SZ_Name) To UBound(SGDW.SZ_Name)Write #1, "施工单位名称：" & SGDW.SZ_Name(i11) & "- - -数量：" & SGDW.SZ_Count(i11) & "- - 错误页码：第" & SGDW.SZ_Page(i11) & "页:"Next i11For i21 = LBound(GCMC.SZ_Name) To UBound(GCMC.SZ_Name)Write #1, GCMC.SZ_Name(i21) & "- - -数量：" & GCMC.SZ_Count(i21) & "- - 错误页码：第" & GCMC.SZ_Page(i21) & "页:"Next i21Write #1, "--------------------------------------------------------------"Next i12'写入完毕，文件名数组加1ReDim Preserve SGDW.sz_Filename(UBound(SGDW.sz_Filename) + 1)T_DOC_OK.Text = "完成--" & MyName & vbCrLf & T_DOC_OKDelay (1000)MyName = Dir
LoopWrite #1, "--------------------------------------------------------------" & vbCrLf & vbCrLf & vbCrLf & "统计结果：--------------------------------------------------------------"
i22 = 0
For i12 = LBound(TJ_SGDW.SZ_Name) + 1 To UBound(TJ_SGDW.SZ_Name)Write #1, TJ_SGDW.SZ_Name(i12) & "----数量：" & TJ_SGDW.SZ_Count(i12)If TJ_SGDW.SZ_Count(i12) > i22 Then: i22 = TJ_SGDW.SZ_Count(i12): i21 = i12
Next i12
S1 = "最可能的正确名称是：" & TJ_SGDW.SZ_Name(i21) & "----数量为：" & i22
i22 = 0
For i12 = LBound(TJ_GCMC.SZ_Name) + 1 To UBound(TJ_GCMC.SZ_Name)Write #1, TJ_GCMC.SZ_Name(i12) & "----数量：" & TJ_GCMC.SZ_Count(i12)If TJ_GCMC.SZ_Count(i12) > i22 Then: i22 = TJ_GCMC.SZ_Count(i12): i21 = i12
Next i12
S2 = "最可能的正确名称是：" & TJ_GCMC.SZ_Name(i21) & "----数量为：" & i22Write #1, "统计结束--------------------------------------------------------------"Write #1, vbCrLf & vbCrLf & vbCrLf & "分析结果：--------------------------------------------------------------"
Write #1, S1
Write #1, S2
Write #1, "分析结束--------------------------------------------------------------"T_DOC_OK.Text = "检查结果见文件：" & MyPath & "检查结果.txt" & vbCrLf & T_DOC_OK.TextT_DOC_OK.Text = _
"统计结果：----------------------------------------------------" & vbCrLf & _
S1 & vbCrLf & _
S2 & vbCrLf & _
"--------------------------------------------------------------" & vbCrLf & _
vbCrLf & vbCrLf & _
T_DOC_OK.Texti = MsgBox("表头内容检查完毕！错误数量大可能值：" & N_err - 1 & vbCrLf & "是否打开检查文件？", vbYesNo)
If i = 6 ThenClose #1Shell "notepad.exe " + MyPath + "\检查结果.txt", 1
Else: Close #1
End IfS1 = ""
S2 = ""End SubPublic Sub Chushi_AIAODIDO() '初始化过程With AIAODIDO_COM.AddItem "AI", 0.AddItem "AO", 1.AddItem "DI", 2.AddItem "DO", 3.AddItem "RTD", 4.ListIndex = 0End With
'St = Cint1(T_st_h.Text) '获得数据开始第一行
'初始AIAODIDO
AITD = CDbl1(T_AITD.Text)
AOTD = CDbl1(T_AOTD.Text)
DITD = CDbl1(T_DITD.Text)
DOTD = CDbl1(T_DOTD.Text)AIKS = CDbl1(T_AIKS.Text)
AOKS = CDbl1(T_AOKS.Text)
DIKS = CDbl1(T_DIKS.Text)
DOKS = CDbl1(T_DOKS.Text)T_AIDS.Text = DSjs(AITD, AIKS)
T_AODS.Text = DSjs(AOTD, AOKS)
T_DIDS.Text = DSjs(DITD, DIKS)
T_DODS.Text = DSjs(DOTD, DOKS)
End SubPublic Sub Chushi_Comb_AIAO_Range() '初始化AIAO量程过程
Dim S_Range$, Sz_Range As Variant, i%
S_Range = "4-20mA;1-5V;0-10V;0-100%;18.520-390.481Ω;-200-850℃;0-100℃"
Sz_Range = Split(S_Range, ";")With Comb_AIAO_RangeFor i = LBound(Sz_Range) To UBound(Sz_Range).AddItem Sz_Range(i), iNext i.ListIndex = 0End With
End Sub
'12-公共函数-IO计算<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'13-公共过程-开关量回路测试=================================================================================================
Public Sub Ref_zt_Types()
'更新不同的开关量类型
Dim zt_S$, zt_S1$
zt_S = "-QT;-远程;-运行;-故障;-GD;-FK"
zt_S1 = "-QT;-远程;-运行;-故障"With T_zt_LastSelect Case Comb_zt_types.ListIndexCase Is = 0.Text = zt_SCase Is = 1.Text = zt_S1Case Is = 2.Text = "-KG;-KGW"Case Is = 3.Text = "-KG;-KDW"Case Is = 4.Text = "-KG;-GDW"Case Else.Text = zt_S1End Select
End With
End Sub
Public Sub CSH_ZT_types()
Comb_zt_types.AddItem "变频", 0
Comb_zt_types.AddItem "直启", 1
Comb_zt_types.AddItem "开关阀-双位", 2
Comb_zt_types.AddItem "开关阀-开到位", 3
Comb_zt_types.AddItem "开关阀-关到位", 4
End Sub
'13-公共过程-开关量回路测试=================================================================================================Private Sub AIAODIDO_COM_Change()Select Case AIAODIDO_COM.TextCase "AI"Bit_1.Text = 8Comb_AIAO_Range.Enabled = TrueCase "AO"Bit_1.Text = 4Comb_AIAO_Range.Enabled = TrueCase "DI"Bit_1.Text = 32Comb_AIAO_Range.Enabled = FalseCase "DO"Bit_1.Text = 32Comb_AIAO_Range.Enabled = FalseCase "RTD"Bit_1.Text = 16Comb_AIAO_Range.Enabled = TrueEnd Select
'-------------------------------------
Select Case AIAODIDO_COM.TextCase Is = "AI"'基础化I/O组件模拟量创建AIAODIDOT_str_Row.Text = 5T_str_Col.Text = 2T_end_Row.Text = 36T_end_Col.Text = 2Case Is = "AO"'基础化I/O组件模拟量创建AIAODIDOT_str_Row.Text = 5T_str_Col.Text = 2T_end_Row.Text = 36T_end_Col.Text = 2Case Is = "DI"'基础化I/O组件模拟量创建AIAODIDOT_str_Row.Text = 4T_str_Col.Text = 2T_end_Row.Text = 35T_end_Col.Text = 2Case Is = "DO"'基础化I/O组件模拟量创建AIAODIDOT_str_Row.Text = 4T_str_Col.Text = 2T_end_Row.Text = 35T_end_Col.Text = 2Case Is = "RTD"'基础化热电阻模块变送器 组件模拟量创建AIAODIDOT_str_Row.Text = 5T_str_Col.Text = 2T_end_Row.Text = 36T_end_Col.Text = 2
End Select
'-------------------------------------
End SubPrivate Sub AIAODIDO_creat_Click()
Dim Num, Bit_num, Num_st, Num_end As Integer
Dim S As String
Dim X, Y As Integer
Dim S_H$, S_L$ '将数据填入对应单元格
Dim H%, L$Bit_num = Int(Bit_1.Text)Num_st = Int(Num_TEXT_ST.Text)Num = Int(Num_2.Text)my_Stop = False
If Bit_1.Text <> "" And Num_TEXT_ST.Text <> "" And Num_2.Text <> "" ThenWith AIAODIDO_COMFor X = Num_st To Num_st + Num - 1For Y = Bit_st To Bit_st + Bit_num - 1'在文本框中写入数据S = .Text & X & T_fenge.Text & YIf Comb_AIAO_Range.Enabled = True Then 'AI/AO/RTD等带量程的数据S = S & ";" & Comb_AIAO_Range.TextEnd IfT_AD.Text = T_AD.Text & S & vbCrLfNext YNext XEnd WithElseMsgBox "请在文本框输入数字！"
End IfEnd Sub
'14-公共过程-根据【仪表名称】删除文档中不需要的单体报告=================================================================================================
Public Sub Yibiao_split()
'仪表报告分割
'删除混合单体报告中不需要的单体
'例如：删除涡街流量计和电磁流量计混合word中的所有电磁流量计，可以输入“涡街”，保留涡街流量计，删除电磁流量计。
Dim i%, j%, n%
Dim mytbls As Tables
Dim S_name$
Dim k%
k = MsgBox("删除混合报告中不需要的仪表报告，例如：一个word中有涡街流量计也有电磁流量计，可以删除电磁流量计只保留涡街流量计。" & vbCrLf _
& "word必须每页之间都有分页符！，否则会多删内容。是否继续？？", vbOKCancel, "毁天灭地！！严重警告！！！")If k = 1 Then
S_name = InputBox("请输入要保留的仪表名称：（简称：例如“涡街”“电磁”）", "保留需要的单体，删除其他单体报告！谨慎操作不可逆转！！！！")
k = MsgBox("必须将文档保留备份，否则禁止进行该操作，不可逆转，后患无穷！！！！谨慎谨慎", vbOKCancel, "严重警告！！！")
End If
If k = 1 Then
k = MsgBox("你备份了该word了吗，再次确认！！！！", vbOKCancel)
End If
If k = 1 Then
k = MsgBox("我不靠谱，你不要骗我，赶紧把word备份，否则可能永久损坏该文档！！！", vbOKCancel, "严重警告！！！")
End If
If k = 1 Then
k = MsgBox("最后一次反悔机会，点击【确定】后会【直接执行】【毁灭性操作】！！", vbOKCancel, "严重警告！！！")
End IfIf k = 1 ThenSet mytbls = ActiveDocument.Tablesn = 0For i = 1 To mytbls.Countn = n + 1On Error Resume Nextj = InStr(1, mytbls(n).Cell(2, 2).Range.Text, S_name)If j < 1 Thenmytbls(n).Deleten = n - 1End IfNext i
End If
End Sub
'14-公共过程-根据【仪表名称】删除文档中不需要的单体报告================================================================================================='15-公共过程-将仪表报告其他表格与第一个表格尺寸统一=================================================================================================
Public Sub Sub_Yibiao_Tongyi()'参考某一页，将仪表格式统一
'一般参考第一页
Dim Str_Page%, End_Page%, CanKao_Page%
Dim n%, i%, j%, k%
Dim my_tables As Tables, my_table As TableDim oCell As CellDim WidthOfoCell(5000) As Single
Dim HeightOfoCell(5000) As SingleSet my_tables = ActiveDocument.TablesStr_Page = T_str_P.Text
End_Page = T_end_P.Text
CanKao_Page = T_CanKao_P.Text
str_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)i = 0
my_tables(CanKao_Page).Select
For Each oCell In Word.Selection.Cells
'获取参考页的每个单元格的宽度和高度。i = i + 1oCell.SelectIf Selection.Range.Cells.Count = 1 ThenIf Selection.Information(wdStartOfRangeRowNumber) >= end_Row And Selection.Information(wdStartOfRangeColumnNumber) >= end_Col ThenExit ForGoTo p1End IfIf Selection.Information(wdStartOfRangeRowNumber) >= str_Row ThenWidthOfoCell(i) = oCell.widthHeightOfoCell(i) = Selection.Rows.heightEnd IfEnd IfNext
p1:
'根据行列采集数据，采集完毕跳转P1'开始更改其他页面中每个单元格的宽度和高度，保持和参考页单元格的尺寸一致
For n = Str_Page To End_Pagei = 0 '初始化iIf n <> CanKao_Page Then'不更改参考页,否则后续更改无效my_tables(n).SelectIf my_tables(n).Columns.Count <> my_tables(CanKao_Page).Columns.Count Or my_tables(n).Rows.Count <> my_tables(CanKao_Page).Rows.Count Then'表格不一致退程序MsgBox "表格" & n & "的行列数与参考表格不一致无法继续操作"GoTo p3End IfFor Each oCell In Word.Selection.Cellsi = i + 1If i > 5000 ThenMsgBox "表格单元格数量超过5000，数量过多，无法继续执行"GoTo p3End IfoCell.SelectIf Selection.Range.Cells.Count = 1 ThenIf Selection.Information(wdStartOfRangeRowNumber) >= end_Row And Selection.Information(wdStartOfRangeColumnNumber) >= end_Col ThenExit ForGoTo P2End IfIf Selection.Information(wdStartOfRangeRowNumber) >= str_Row ThenSelection.Cells.width = WidthOfoCell(i)Selection.Rows.height = HeightOfoCell(i)End IfEnd IfNextEnd IfP2:
Next np3:
End Sub
'15-公共过程-将仪表报告其他表格与第一个表格尺寸统一================================================================================================='16-公共过程-初始化页码，针对第一页页码不是1的情况进行处理=================================================================================================
Sub Sub_ReSet_Page_No()
'第一页页码改为1，页眉页码格式更改，将第一页设置为1MoveToDocStartActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeaderWith Selection.HeaderFooter.PageNumbers.NumberStyle = wdPageNumberStyleArabic.HeadingLevelForChapter = 0.IncludeChapterNumber = False.ChapterPageSeparator = wdSeparatorHyphen.RestartNumberingAtSection = False.StartingNumber = 0End WithActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
'16-公共过程-初始化页码，针对第一页页码不是1的情况进行处理================================================================================================='17-公共过程-对表格尺寸进行统一规格===========================================================================================================================
Sub sub_Tong_Yi_Table_H_W()
'统一表格总高度和总宽度
Dim Flg_n%, Flg_m%, H#, W#
Dim i_H#, i_w#
Dim n%, W_n%, Rows_n%, Rows_Cols%, i%, j%, k%, M%H = CDbl1(T_Table_Height.Text)
W = CDbl1(T_Table_Width.Text)n = ActiveDocument.Tables.Count
'更改页面第一行尺寸；
Flg_n = MsgBox("确定更改页面中表格的尺寸吗？只更改第一行，最后三行的行高和列宽，其他行需要手动调整第一页，然后使用【统一格式】指令，将其他页的格式与第一页统一", vbOKCancel, "更改表格尺寸使所有表格总高总宽一致")
Flg_m = MsgBox("先更改第一页看看效果吧，是/否，点击【否】更改全部页面，点击【是】只更改第一页。", vbYesNo, "毁天灭地操作，出错可关闭word不保存即可")Rows_n = ActiveDocument.Tables(1).Range.Rows.Count
ActiveDocument.Tables(1).Cell(Rows_n - 2, 1).Select
Selection.SelectRow
Rows_Cols = Selection.Columns.CountIf Rows_Cols > 1 ThenMsgBox "【倒数第三行必须是合并的】，【发现表格不是单体报告】，可能存在过多行，不宜进行自动调整，请手动调整，否则会出现不可逆混乱", , "严重警告！！！"ElseIf Flg_n = 1 Then'是否只对第一页操作If Flg_m = 6 Thenn = 1End IfFor i = 1 To nWith ActiveDocument'获得当前表格的总行数M = .Tables(i).Rows.Count'更改第一行行高.Tables(i).Cell(1, 1).SelectSelection.Cells.height = CentimetersToPoints(3)'更改第一行各单元格宽度.Tables(i).Cell(1, 1).width = CentimetersToPoints(4).Tables(i).Cell(1, 2).width = CentimetersToPoints(5.5).Tables(i).Cell(1, 3).width = CentimetersToPoints(8)'更改单元格文字尺寸.Tables(i).Cell(1, 1).Range.Font.Size = 12'第三个没问题.Tables(i).Cell(1, 3).Range.Font.Size = 12'预先更改好倒数第一行和倒数第二行的行高If M >= 3 Then.Tables(i).Rows(M).height = CentimetersToPoints(1.5).Tables(i).Rows(M - 1).height = CentimetersToPoints(2)End If'更改列宽和行高i_H = 0If M >= 3 ThenFor j = 1 To M'计算除了倒数第三行之外其他行的行高，方便以后对倒数第三行行高重新定义，使页面总行高固定为25.5cmIf j <> M - 2 Theni_H = i_H + PointsToCentimeters(.Tables(i).Cell(j, 1).height).Tables(i).Cell(j, 1).SelectEnd Ifi_w = 0'更改每行中最后一列的列宽，使每行的总列宽等于W(17.5)W_n = .Tables(i).Rows(j).Cells.CountIf W_n >= 2 ThenFor k = 1 To W_n - 1i_w = i_w + .Tables(i).Cell(j, k).widthNext kEnd If.Tables(i).Cell(j, W_n).width = CentimetersToPoints(17.5) - i_wNext j'更改倒数第三行行高，内容行，最高那行;防止更改多列行，必须是合并的整行(一开始已经排除这种情况了).Tables(i).Rows(M - 2).height = CentimetersToPoints(H - i_H)ElseIf M = 2 Then.Tables(i).Rows(M).height = CentimetersToPoints(H - 3)ElseMsgBox "表格行数必须大于2"End IfEnd WithNext iFor j = 1 To 2For i = 1 To n'第二个单元格可能存在多行单独处理ActiveDocument.Tables(i).Cell(1, 2).SelectSelection.MoveLeftSelection.EndKey Unit:=wdLine, Extend:=wdExtendSelection.Font.Size = 18Next iNext jEnd If
End IfEnd Sub
'17-公共过程-对表格尺寸进行统一规格==========================================================================================================================='18-公共过程-优化目录
Public Sub sub_MuLu_youhua()
Dim H#, i%, H1#
H = 0
With ActiveDocument.Tables(1)H1 = (23 / .Rows.Count)If H1 > 1 ThenH1 = 1ElseIf H1 < 0.6 ThenH1 = 0.6End If.Rows.height = CentimetersToPoints(H1)
End WithEnd Sub
'公共过程18-光标控制===========================================================================================================================
'————————————————
'版权声明：本文为CSDN博主「ssson」的原创文章，遵循CC 4.0 BY-SA版权协议，转载请附上原文出处链接及本声明。
'原文链接：https://blog.csdn.net/ssson/article/details/88771194
'移动光标至文档开始
'下面的供参考:
Sub MoveToCurrentLineStart()
'移动光标至当前行首
Selection.HomeKey Unit:=wdLine
End Sub
Sub MoveToCurrentLineEnd()
'移动光标至当前行尾
Selection.EndKey Unit:=wdLine
End Sub
Sub SelectToCurrentLineStart()
'选择从光标至当前行首的内容
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
End Sub
Sub SelectToCurrentLineEnd()
'选择从光标至当前行尾的内容
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
End Sub
Sub SelectCurrentLine()
'选择当前行
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
End Sub
Sub MoveToDocStart()
'移动光标至文档开始
Selection.HomeKey Unit:=wdStory
End Sub
Sub MoveToDocEnd()
'移动光标至文档结尾
Selection.EndKey Unit:=wdStory
End Sub
Sub SelectToDocStart()
'选择从光标至文档开始的内容
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
End Sub
Sub SelectToDocEnd()
'选择从光标至文档结尾的内容
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
End Sub
Sub SelectDocAll()
'选择文档全部内容（从WholeStory可猜出Story应是当前文档的意思）
Selection.WholeStory
End Sub
Sub MoveToCurrentParagraphStart()
'移动光标至当前段落的开始
Selection.MoveUp Unit:=wdParagraph
End Sub
Sub MoveToCurrentParagraphEnd()
'移动光标至当前段落的结尾
Selection.MoveDown Unit:=wdParagraph
End Sub
Sub SelectToCurrentParagraphStart()
'选择从光标至当前段落开始的内容
Selection.MoveUp Unit:=wdParagraph, Extend:=wdExtend
End Sub
Sub SelectToCurrentParagraphEnd()
'选择从光标至当前段落结尾的内容
Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
End Sub
Sub SelectCurrentParagraph()
'选择光标所在段落的内容
Selection.MoveUp Unit:=wdParagraph
Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
End Sub
Sub DisplaySelectionStartAndEnd()
'显示选择区的开始与结束的位置，注意：文档第1个字符的位置是0
MsgBox ("第" & Selection.start & "个字符至第" & Selection.End & "个字符")
End Sub
Sub DeleteCurrentLine()
'删除当前行
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete
End Sub
Sub DeleteCurrentParagraph()
'删除当前段落
Selection.MoveUp Unit:=wdParagraph
Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
Selection.Delete
End Sub
'公共过程18-光标控制==========================================================================================================================='公共过程18-末尾插入表格===========================================================================================================================
Sub sub_New_tbl(ByVal i_my_tbls As Tables, ByVal i%, ByVal i_str_Row%, ByVal i_str_Col%, ByVal i_end_Row%, ByVal i_end_Col%)
'插入表格
Dim tem_i%, tem_j%, tem_cols%
Dim my_Rng As VariantMoveToDocEnd
Selection.InsertBreak Type:=wdPageBreak '插入分页符
i_my_tbls(i).Select
Selection.Copy
MoveToDocEnd
Selection.Paste
Delay (10)
'清空新表格
'For tem_i = i_str_row To i_end_row
'    i_my_tbls(i + 1).Cell(tem_i, 1).Select
'    Selection.SelectRow
'    tem_cols = Selection.Cells.Count '获得当前行一共有多少列，防止列数出错
'    For tem_j = i_str_col To tem_cols
'        i_my_tbls(i + 1).Cell(tem_i, tem_j).Range.Text = ""
'    Next tem_j
'Next tem_i
Set my_Rng = ActiveDocument.Range(i_my_tbls(i + 1).Cell(i_str_Row, i_str_Col).Range.start, i_my_tbls(i + 1).Cell(i_end_Row, i_end_Col).Range.End)
my_Rng.Select
Selection.Delete
End Sub
'公共过程18-末尾插入表格===========================================================================================================================
'公共过程19-填写AIAO数据===========================================================================================================================Sub sub_AIAO_ShuJu(ByVal i_my_tbls As Tables, ByVal i_str_P%, ByVal i_end_P%, ByVal i_str_Row%, _
ByVal i_end_Row%, ByVal i_str_Col%, ByVal i_end_Col%)Dim i_jingdu#, i_s_p$, i%, j%, k%, i_tem_S$, i_MyRange As Variant, i_L_Range#, i_U_Range#, i_Jdxs#, i_Tem_wucha#i_s_p = Set_P(T_P_ShuJu.Text)i_jingdu = CDbl1(T_jingdu.Text)i_Jdxs = CDbl1(T_jdxs.Text)For i = i_str_P To i_end_PIf i_end_Row > i_my_tbls(i).Rows.Count - 2 Theni_end_Row = i_my_tbls(i).Rows.Count - 2End IfFor j = i_str_Row To i_end_RowIf my_Stop = True Then: Exit Sub '停止程序If Chk__Ref_Date = False Then'检查到表格中有数据就跳过本行i_tem_S = Get_Val(i_my_tbls(i).Cell(j, Cint1(T_col_BZ.Text) + 1).Range.Text)If i_tem_S <> "" ThenGoTo Tiao_moniliangEnd IfEnd If'获得量程下限和上限i_tem_S = Get_Val(i_my_tbls(i).Cell(j, Cint1(T_col_BZ.Text)).Range.Text)If i_tem_S <> "" Then '空数据行和跳过i_tem_S = Get_Range(i_tem_S) '获得量程i_MyRange = Split(i_tem_S, ";")i_L_Range = CDbl1(i_MyRange(0))i_U_Range = CDbl1(i_MyRange(1))For k = i_str_Col To i_end_Coli_my_tbls(i).Cell(j, k).Select'计算误差Randomizei_Tem_wucha = ((-1) ^ (CInt((10 * Rnd)))) * i_Jdxs * Rnd * (i_U_Range - i_L_Range) * i_jingdu / 100# '混沌Delay (0.5)'逐项赋值 0%；50%；100%With i_my_tbls(i)If k < i_str_Col + 2 Then.Cell(j, k).Range.Text = Format(i_L_Range + i_Tem_wucha, i_s_p)ElseIf k < i_str_Col + 4 Then.Cell(j, k).Range.Text = Format(i_L_Range + (i_U_Range - i_L_Range) * 0.5 + i_Tem_wucha, i_s_p)ElseIf k < i_str_Col + 6 Then.Cell(j, k).Range.Text = Format(i_U_Range + i_Tem_wucha, i_s_p)ElseIf k = i_end_Col Then.Cell(j, k).Range.Text = "合格"End IfEnd WithNext kEnd If
Tiao_moniliang:Next jNext i
End Sub
'公共过程19-填写AIAO数据==========================================================================================================================='公共过程20-获得表格内容===========================================================================================================================
Private Function fun_GetTable_Data(ByVal i_Tables As Tables, ByVal i_str_P As Integer, ByVal i_end_P As Integer, ByVal i_str_Row As Integer, ByVal i_end_Row As Integer, _ByVal i_str_Col As Integer, ByVal i_end_Col As Integer) As VariantDim i%, j%, k%, i_s$, i_Exl_Row, i_Exl_Col%Dim i_sz_S() As String
i_Exl_Row = (i_end_P - i_str_P + 1)
i_Exl_Col = (i_end_Row - i_str_Row + 1) * (i_end_Col - i_str_Col + 1)i_s = ""
ReDim i_sz_S(1 To i_Exl_Row)
If T_INS.Text <> "" Then T_INS.Text = T_INS.Text & vbCrLf
For i = i_str_P To i_end_PFor j = i_str_Row To i_end_RowFor k = i_str_Col To i_end_ColOn Error Resume Nexti_s = i_s + Get_Val(i_Tables(i).Cell(j, k).Range.Text) + vbTabNext kNext ji_sz_S(i) = Mid(i_s, 1, Len(i_s) - 1)i_s = ""
Next ifun_GetTable_Data = i_sz_S'For i = i_str_P To i_end_P
'    T_INS.Text = T_INS.Text & i_Sz_S(i) & vbCrLf
'Next i
Erase i_sz_S()End Function
'公共过程20-获得表格内容===========================================================================================================================
'公共过程21-word转换为pdf,前提是安装好adobe acrobat DC===========================================================================================================================
'当前文件夹内所有word全部转换为pdf，另存为一个pdf文件夹内
Sub Doc2Pdf()
Dim MyPath$, MyName$, pdf_Path$, MyDocName$
Dim mydoc As Document, myDoc1(1000) As Document
Dim i%, n%
Dim myNamelist(1000) As StringSet mydoc = Word.ActiveDocument
MyDocName = mydoc.Name'加载word所在文件夹路径
MyPath = mydoc.Path & "\"
MyName = Dir(MyPath & "*.doc*")
Do While MyName <> ""myNamelist(i) = MyNameMyName = Diri = i + 1
Loop'创建pdf文件夹
pdf_Path = mydoc.Path & "\pdf\"
If Dir(pdf_Path, vbDirectory) = "" ThenVBA.MkDir pdf_Path
End Ifn = 0
'将word文档全部打开
For i = LBound(myNamelist) To UBound(myNamelist)If myNamelist(i) <> "" Thenn = n + 1MyName = myNamelist(i)Set myDoc1(i) = GetObject(MyPath & MyName)T_DOC_OK.Text = MyName & "--读取完毕！" & vbCrLf & T_DOC_OK.TextDelay (50)ElseExit ForEnd IfDelay (50)
Next iT_DOC_OK.Text = "--------------------" & vbCrLf & T_DOC_OK.Text
'将打开的n个word文档转换成pdf
For i = 0 To n - 1myDoc1(i).ExportAsFixedFormat OutputFileName:= _pdf_Path & myDoc1(i).Name & ".pdf", ExportFormat:= _wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _BitmapMissingFonts:=False, UseISO19005_1:=FalseDelay (200)MyName = myDoc1(i).NameT_DOC_OK.Text = MyName & "-转换pdf完成！" & vbCrLf & T_DOC_OK.TextIf MyName <> MyDocName ThenmyDoc1(i).Close wdDoNotSaveChangesEnd IfIf i >= n - 1 ThenT_DOC_OK.Text = "【转换完成！】" & vbCrLf & vbCrLf & T_DOC_OK.TextExit ForEnd If
Next iEnd Sub
'公共过程21-word转换为pdf,前提是安装好adobe acrobat DC==========================================================================================================================='公共过程22-创建表格
Public Sub Creat_Tables(ByVal theDoc As Document)
Dim doc_Mulu As Document
Set doc_Mulu = theDoc
'将目录表格内容删除只留下表头
'删除所有表格
Do While doc_Mulu.Tables.Count > 0doc_Mulu.Tables(1).Delete
Loop
'创建新表格
doc_Mulu.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _wdAutoFitFixed
'序号，资料名称，页数，备注
With doc_Mulu.Tables(1).Cell(1, 1).PreferredWidth = CentimetersToPoints(1.5).Cell(1, 2).PreferredWidth = CentimetersToPoints(10).Cell(1, 3).PreferredWidth = CentimetersToPoints(1.5).Cell(1, 4).PreferredWidth = CentimetersToPoints(3)'表格内容文字居中.Rows(1).SelectSelection.ParagraphFormat.Alignment = wdAlignParagraphCenterSelection.Cells.VerticalAlignment = wdCellAlignVerticalCenter.Rows.Alignment = wdAlignRowCenter'填入文字'序号，资料名称，页数，备注.Cell(1, 1).Range.Text = "序号".Cell(1, 2).Range.Text = "资料名称".Cell(1, 3).Range.Text = "页数".Cell(1, 4).Range.Text = "备注"
End With
End SubPublic Sub Create_Tables_duohuilu()
'创建多回路表格
Dim ii%, jj%
Dim doc_Mulu As DocumentYeBianJu '优化页边距Set doc_Mulu = ActiveDocument'将目录表格内容删除只留下表头'删除所有表格'创建新表格doc_Mulu.Tables.Add Range:=Selection.Range, NumRows:=40, NumColumns:= _10, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _wdAutoFitFixed'序号，资料名称，页数，备注With doc_Mulu.Tables(1)For ii = 1 To 40.Cell(ii, 1).width = CentimetersToPoints(1).Cell(ii, 2).width = CentimetersToPoints(3.9).Cell(ii, 3).width = CentimetersToPoints(1.2).Cell(ii, 4).width = CentimetersToPoints(1.2).Cell(ii, 5).width = CentimetersToPoints(1.2).Cell(ii, 6).width = CentimetersToPoints(1).Cell(ii, 7).width = CentimetersToPoints(3.9).Cell(ii, 8).width = CentimetersToPoints(1.2).Cell(ii, 9).width = CentimetersToPoints(1.2).Cell(ii, 10).width = CentimetersToPoints(1.2)Next ii'表格内容文字居中.SelectSelection.ParagraphFormat.Alignment = wdAlignParagraphCenterSelection.Cells.VerticalAlignment = wdCellAlignVerticalCenter.Rows.Alignment = wdAlignRowCenter'先操作列，在操作行，否则会混乱。'合并第8列，2，3行。.Cell(Row:=2, Column:=7).SelectSelection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtendSelection.Cells.Merge'合并第7列，2，3行。.Cell(Row:=2, Column:=6).SelectSelection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtendSelection.Cells.Merge'列的合并很特殊'合并第2列，2，3行。.Cell(Row:=2, Column:=2).SelectSelection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtendSelection.Cells.Merge'合并第1列，2，3行。.Cell(Row:=2, Column:=1).SelectSelection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtendSelection.Cells.MergeActiveDocument.Range(.Cell(1, 1).Range.start, .Cell(1, 2).Range.End).Cells.MergeActiveDocument.Range(.Cell(1, 2).Range.start, .Cell(1, 5).Range.End).Cells.MergeActiveDocument.Range(.Cell(1, 3).Range.start, .Cell(1, 6).Range.End).Cells.MergeActiveDocument.Range(.Cell(2, 3).Range.start, .Cell(2, 4).Range.End).Cells.MergeActiveDocument.Range(.Cell(2, 7).Range.start, .Cell(2, 8).Range.End).Cells.MergeActiveDocument.Range(.Cell(40, 1).Range.start, .Cell(40, 10).Range.End).Cells.Merge'更改尺寸.Cell(1, 1).width = CentimetersToPoints(4.5).Cell(1, 2).width = CentimetersToPoints(5.5).Cell(1, 3).width = CentimetersToPoints(7).Cell(40, 1).height = CentimetersToPoints(1)'填入文字'序号，资料名称，页数，备注.Cell(1, 1).Range.Text = "天俱时工程科技集团有限公司".Cell(1, 2).Range.Text = "DCS多回路" & vbCrLf & "测试记录".Cell(1, 3).Range.Text = "工程名称：伊犁川宁生物技术有限公司万吨抗生素中间体建设项目（二期工程）工程" & vbCrLf & "单元名称：氯化铵母液和苯乙酸回收项目".Cell(2, 1).Range.Text = "序号".Cell(2, 2).Range.Text = "仪表位号".Cell(2, 3).Range.Text = "实际动作".Cell(3, 3).Range.Text = "输入".Cell(3, 4).Range.Text = "状态".Cell(2, 4).Range.Text = "备注".Cell(2, 5).Range.Text = "序号".Cell(2, 6).Range.Text = "仪表位号".Cell(2, 7).Range.Text = "实际动作".Cell(3, 8).Range.Text = "输入".Cell(3, 9).Range.Text = "状态".Cell(2, 8).Range.Text = "备注".Cell(40, 1).Range.Text = "技术负责人                          调试人                          年  月  日"End With
End SubPublic Sub Sub_TiaoJieFao()
'根据原始内容和精度更改数据,调节阀
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%, col_BZ%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S As Variant, tem_Ss As Variant, MyRange As Variant
Dim Jingdu#, tem_Wucha#, Points%, S_P$
Dim Wucha1#, Wucha2#, Huicha#
Dim U_Range#, L_Range#
Dim my_tbls As Tables
Dim my_table As TableDim my_XCh As Variant '行程
Dim xc_Row%, xc_Col% '行程所在单元格位置
Dim tem_i% '临时变量
Dim Flg_i% '起点数据特殊处理，置零。Dim Up1#, Up2#, Dn1#, Dn2# '正行程1，2；反行程1，2。
Dim HD_k As Variant  '随机数的混沌程度
my_Stop = FalseSet my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)Jingdu = CDbl(T_VA_JD.Text)
Points = Cint1(T_VA_S_P.Text)
col_BZ = Cint1(T_VA_bz_Row.Text)CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)xc_Row = Cint1(T_xc_Row.Text)
xc_Col = Cint1(T_xc_Col.Text)
HD_k = CDbl1(T_HD_k.Text)n = my_tbls.CountIf CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_P
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_Col + 1T_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End If'设定小数点
S_P = Set_P(Points)
Randomize
For i = str_P To end_PIf my_Stop = True Then: Exit Sub '停止程序'获得行程数值'获得量程TEM_S = Get_Range(my_tbls(i).Cell(xc_Row, xc_Col).Range.Text)MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))my_XCh = Get_Dbl(U_Range - L_Range)For j = str_Row To end_RowWith my_tbls(i).Cell(j, k).SelectDelay (10)Select Case jCase Is = str_Row'写入标准值所在行For k = str_Col To end_Col.Cell(j, k).Range.Text = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)Next kCase Is <= str_Row + 2'第1遍正反行程str_Col = str_Col + 1end_Col = end_Col + 1For k = str_Col To end_ColIf k = str_Col Or k = end_Col ThenFlg_i = 0ElseFlg_i = 1End Iftem_Wucha = Flg_i * Jingdu * Rnd * Int(Rnd * 2 + Rnd * (k - str_Col) / str_Col - 1)tem_Wucha = tem_Wucha * ((HD_k * (Rnd)) / (HD_k / 3)) '混沌TEM_S = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)TEM_S = TEM_S + tem_Wucha.Cell(j, k).Range.Text = Format(TEM_S, S_P)Next kstr_Col = str_Col - 1end_Col = end_Col - 1Case Is <= str_Row + 4'第2遍正反行程str_Col = str_Col + 1end_Col = end_Col + 1For k = str_Col To end_ColIf k = str_Col Or k = end_Col ThenFlg_i = 0ElseFlg_i = 1End Iftem_Wucha = Flg_i * Jingdu * Rnd * Int(Rnd * 2 + Rnd * (k - str_Col) / str_Col - 1)tem_Wucha = tem_Wucha * ((HD_k * (Rnd)) / (HD_k / 3)) '混沌TEM_S = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)TEM_S = TEM_S + tem_Wucha.Cell(j, k).Range.Text = Format(TEM_S, S_P)Next kstr_Col = str_Col - 1end_Col = end_Col - 1Case Is <= str_Row + 5'正反行程误差的较大值For k = str_Col To end_ColUp1 = Get_Dbl(.Cell(str_Row + 1, k + 1).Range.Text)Dn1 = Get_Dbl(.Cell(str_Row + 2, k + 1).Range.Text)Up2 = Get_Dbl(.Cell(str_Row + 3, k + 1).Range.Text)Dn2 = Get_Dbl(.Cell(str_Row + 4, k + 1).Range.Text).Cell(j, k).Range.Text = Format(Max(Abs(Up1 - Dn1), Abs(Up2 - Dn2)), S_P)Next kCase ElseMsgBox "超出行数"End SelectEnd WithNext j
Next iEnd Sub'公共过程结束----------------------------------'12--AIAODIDO相关计算指令---------------------------------------------------
Private Sub cmd_AIAODIDO_IN_Click()
'生成AIAODIDO
Dim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%, TEM_S$
Dim tem_i As Long, i_sz_S%, SZ_S As Variant, i_Rows%
Dim Array_DI As Variant, Array_DO As Variant, Array_AI As Variant, Array_AO As Variant, Array_RTD As VariantDim my_tbls As Tables, my_table As TableSet my_tbls = ActiveDocument.Tablesstr_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
'AIAO/DIDO的起始行不一样，一个是第5行，一个是第4行
str_Row = 5
TEM_S = T_AD.Text
If InStr(TEM_S, "AI") Then: str_Row = 5
If InStr(TEM_S, "AO") Then: str_Row = 5
If InStr(TEM_S, "RT") Then: str_Row = 5If InStr(TEM_S, "DI") Then str_Row = 4
If InStr(TEM_S, "DO") Then str_Row = 4str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)Array_DI = Split("有;1;亮;无;0;灭;合格", ";")
Array_DO = Split("打开;ON;亮;关闭;OFF;灭;合格", ";")Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If T_AD.Text <> "" ThenSZ_S = Split(Left(T_AD.Text, Len(T_AD.Text) - 2), vbCrLf)
End Iftem_i = 0: i_sz_S = 0: n = 1: i = 0: k = 0If IsEmpty(SZ_S) = True Then: GoTo p1 '空值退出i_Rows = str_RowDo While i_sz_S <= UBound(SZ_S)With my_tbls(n)If Len(.Cell(i_Rows, 2).Range.Text) > 2 ThenGoTo p_NewRows '非空行跳转下一行ElseSelect Case Left(SZ_S(i_sz_S), 2)Case Is = "DI".Cell(i_Rows, 2).Range.Text = SZ_S(i_sz_S)For k = 0 To UBound(Array_DI).Cell(i_Rows, str_Col + 1 + k).Range.Text = Array_DI(k)Next kCase Is = "DO".Cell(i_Rows, 2).Range.Text = SZ_S(i_sz_S)For k = 0 To UBound(Array_DO).Cell(i_Rows, str_Col + 1 + k).Range.Text = Array_DO(k)Next kCase Is = "AI"Array_AI = Split(SZ_S(i_sz_S), ";").Cell(i_Rows, 2).Range.Text = Array_AI(0).Cell(i_Rows, 3).Range.Text = Array_AI(1)Case Is = "AO"Array_AO = Split(SZ_S(i_sz_S), ";").Cell(i_Rows, 2).Range.Text = Array_AO(0).Cell(i_Rows, 3).Range.Text = Array_AO(1)Case ElseIf InStr(SZ_S(i_sz_S), "RTD") ThenArray_RTD = Split(SZ_S(i_sz_S), ";").Cell(i_Rows, 2).Range.Text = Array_RTD(0).Cell(i_Rows, 3).Range.Text = Array_RTD(1)End IfEnd Selecti_sz_S = i_sz_S + 1p_NewRows:i = i + 1i_Rows = str_Row + iEnd If'增加表格If i_Rows > my_tbls(n).Rows.Count - 2 And n = my_tbls.Count And i_sz_S < UBound(SZ_S) Theni = 0: i_Rows = str_RowIf InStr(1, ActiveDocument.Name, "数字量") > 0 Then '数字量9列模拟量10列sub_New_tbl my_tbls, n, str_Row, 1, end_Row, 9Elsesub_New_tbl my_tbls, n, str_Row, 1, end_Row, 10End Ifn = n + 1ElseIf i_Rows > end_Row And n < my_tbls.Count Theni = 0: i_Rows = str_Rown = n + 1End IfEnd WithDelay (1)
LoopSet my_tbls = ActiveDocument.Tables
If InStr(1, ActiveDocument.Name, "模拟量") > 0 Then '开始更新内部数据'基础化I/O组件模拟量测试T_str_Row.Text = 5T_str_Col.Text = 4T_end_Row.Text = 36T_end_Col.Text = 10T_col_BZ.Text = 3 '量程所在列T_Point.Text = 2T_P_ShuJu.Text = 2T_jingdu.Text = 0.1T_jiancedian.Enabled = Falsesub_AIAO_ShuJu my_tbls, 1, my_tbls.Count, 5, 36, 4, 10 '填写AIAO数据
End Ifp1:
End SubPrivate Sub cmd_ChuangJianWenDang_Click()Dim ExcelPath$Dim DataArray() As VariantDim wb As Workbook '必须引入excel库Dim ws As WorksheetDim SheetName As StringDim FieldName As String, SZ_FieldIndex() As Variant, iFieldIndex%Dim BoxWidth As Double, BoxHeight As DoubleDim Txt_FountSize As DoubleDim i%, j%, jj%, J1%, J2%, Jx%, Jy%Dim ZBJX#, SBJY#, Zbjx1#, Sbjy1#, StrX, StrY, JianGeX#, JianGeY#, X1#, Y1#, X2#, Y2#Dim StrRow As Long, EndRow As LongDim NoOfPage%, BookMarkName$, BuChang%ExcelPath = T_ExcelPath.Text' 打开Excel文件Set wb = Workbooks.Open(ExcelPath)Set ws = wb.Sheets(1)' 确定字段数据范围Dim LastCol As LongLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column'文本框宽度13mm，高度40mm'xy,起始坐标'每行每列的间隔BoxWidth = T_BoxWidth.TextBoxHeight = T_BoxHeight.TextZBJX = T_ZBJX.TextSBJY = T_SBJY.TextZbjx1 = T_ZBJX1.TextSbjy1 = T_SBJy1.TextStrX = T_StrX.TextStrY = T_StrY.TextJianGeX = T_JianGeX.TextJianGeY = T_JianGeY.TextStrRow = T_StrRow.TextEndRow = T_EndRow.TextSheetName = combo_sheetsName.Text'根据字段内容，确定要打印的字段所在的列号ReDim SZ_FieldIndex(1 To listZiDuan.ListCount)DataArray = ReadExcel2SZ(ExcelPath, SheetName, 1, 1, 1, LastCol)iFieldIndex = 1For j = 1 To listZiDuan.ListCount' 查找字段在数组中的列索引For i = 1 To UBound(DataArray, 2)If DataArray(1, i) = listZiDuan.List(j - 1) ThenSZ_FieldIndex(iFieldIndex) = iiFieldIndex = iFieldIndex + 1End IfNext iNext'获取每行对应字段的内容，输入数组ReDim dataarry(1 To EndRow)DataArray = ReadExcel2SZBOX(ExcelPath, SheetName, StrRow, EndRow, SZ_FieldIndex)MoveToDocStart '光标移动到文档开始'创建文本框NoOfPage = T_NoOfPage.TextDim myPage%myPage = 1For i = LBound(DataArray) To UBound(DataArray)j = i - 6 * (myPage - 1)'一组间距9mm，两组之间间距8mm，需要做补偿jj = jSelect Case jjCase 1 To 5'BuChang = -1J1 = 1J2 = 0Jx = jj - 1Jy = 0'MsgBox JxCase 6 To 10'BuChang = -1J1 = 0J2 = 1Jx = jj - 1 - 5Jy = 0'MsgBox JxCase 11 To 15'BuChang = -3J1 = 1J2 = 0Jx = jj - 1 - 10Jy = 1Case 16 To 20'BuChang = -3J1 = 0J2 = 1Jx = jj - 1 - 15Jy = 1Case 21 To 25'BuChang = -8J1 = 1J2 = 0Jx = jj - 1 - 20Jy = 2Case 26 To 30'BuChang = -9J1 = 0J2 = 1Jx = jj - 1 - 25Jy = 2End Select'X1 = ZBJX + StrX * (((j - 1) \ 5 + 1) Mod 2) + ((j - 1) Mod 5) * (BoxWidth) * 2 + ((j - 1) Mod 5) * JianGeX'左边距+起始坐标奇数偶数不同+5的倍数不同+5的倍数间隔不同'Y1 = SBJY + StrY + ((j - 1) \ 5) * (JianGeY + BoxHeight) + BuChangX1 = J1 * ZBJX + J2 * Zbjx1 + Jx * (T_JianGeX.Text)Y1 = J1 * SBJY + J2 * Sbjy1 + Jy * (T_JianGeY.Text)X2 = X1 + BoxWidthY2 = Y1Call CreateTextBoxFromData((DataArray(i)), BoxHeight, BoxWidth, X1, Y1, wdTextOrientationUpward)Call CreateTextBoxFromData((DataArray(i)), BoxHeight, BoxWidth, X2, Y2, wdTextOrientationDownward)'检查是否需要插入分页符If i Mod NoOfPage = 0 And i <> UBound(DataArray) ThenDelay1 (1000)MoveToDocEnd1 '将光标移动到当前页面底部Delay1 (1000)Selection.InsertBreak Type:=wdPageBreakDelay1 (1000)MoveToDocStart1 '将光标移动到下一页的开头Delay1 (1000)myPage = myPage + 1Delay1 (1000) '毫秒End IfNext i
End SubSub MoveToDocEnd1()Selection.EndKey Unit:=wdStory
End SubSub MoveToDocStart1()Selection.HomeKey Unit:=wdStory
End Sub'===========================================================================================================Public Function del_StrEnter(ByVal iStr As String)
'去除换行符Dim str As Stringstr = iStr' 移除开头和结尾的回车符str = Replace(str, vbCrLf, "", 1, 1) ' 移除开头的回车符str = Replace(str, vbCrLf, "", , 1) ' 移除结尾的回车符' 由于Replace函数只移除了回车符，你可能还需要移除换行符("\n")str = Replace(str, vbCrLf, "", 1, 1) ' 移除开头的换行符str = Replace(str, vbCrLf, "", , 1) ' 移除结尾的换行符' 最后，使用Trim移除两端的空白字符str = Trim(str)del_StrEnter = str
End Function'===================================================
Public Sub chushihua_qizhibiaoqian()
Combox_FangXiang.AddItem "正,反"
Combox_FangXiang.AddItem "反,正"
Combox_FangXiang.AddItem "正"
Combox_FangXiang.ListIndex = 0
End SubPublic Function ReadExcel2SZ(ByVal iPath As String, I_Sheet As String, ByVal iStrRow As Long, ByVal iEndRow As Long, ByVal iStrCol As Long, ByVal iEndCol As Long) As VariantDim ExcelPath$Dim wb As Workbook '必须引入excel库Dim ws As WorksheetDim DataArray() As VariantDim i As Long, j As LongExcelPath = iPath' 打开Excel文件Set wb = Workbooks.Open(ExcelPath)Set ws = wb.Sheets(I_Sheet)' 确定数据范围Dim lastRow As Long, LastCol As LonglastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).RowLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).ColumnIf lastRow > 0 And LastCol > 0 ThenReDim DataArray(1 To lastRow, 1 To LastCol)' 读取数据到数组For i = iStrRow To iEndRowFor j = iStrCol To iEndColDataArray(i, j) = ws.Cells(i, j).ValueNext jNext iElseDebug.Print "No data found in the worksheet."End If' 关闭Excel文件wb.Close SaveChanges:=FalseReadExcel2SZ = DataArrayEnd Function
Private Function ReadExcel2SZBOX(ByVal iPath As String, ByVal I_SheetName As String, ByVal iStrRow As Long, ByVal iEndRow As Long, ByVal iSz_FieldIndex As Variant) As Variant'读取excel指定字段数组的内容，存入新数组Dim ExcelPath$Dim wb As Workbook '必须引入excel库Dim ws As WorksheetDim tem_Str As StringDim DataArray() As VariantDim i As Long, j As LongExcelPath = iPath' 打开Excel文件Set wb = Workbooks.Open(ExcelPath)Set ws = wb.Sheets(I_SheetName)ReDim DataArray(1 To iEndRow - iStrRow + 1)' 读取数据到数组For i = iStrRow To iEndRowtem_Str = ""For j = LBound(iSz_FieldIndex) To UBound(iSz_FieldIndex)tem_Str = tem_Str & ws.Cells(i, iSz_FieldIndex(j)).Value & vbCrLfNext jtem_Str = Left(tem_Str, Len(tem_Str) - 2) '去掉最后一个回车DataArray(i - iStrRow + 1) = tem_StrNext i' 关闭Excel文件wb.Close SaveChanges:=FalseReadExcel2SZBOX = DataArrayEnd FunctionPublic Sub CreateTextBoxFromData(ByVal BoxText As String, ByVal height As Double, ByVal width As Double, ByVal xCoord As Double, ByVal yCoord As Double, ByVal orientation As MsoTextOrientation)
'变量定义：field字段'DATAARRAY:2维数组'height：文本框高度'width：文本框宽度'xcoord：x绝对坐标'ycoord：y绝对坐标'orientation:方向'autosize:自动尺寸Dim fieldValue As VariantDim txtBox As ShapeDim txtFrame As TextFrameDim txtRange As RangeDim fontSize As IntegerDim pt2mm As Doublept2mm = 0.352778 'vba单位是pt，1pt=0.352778mmheight = height / pt2mmwidth = width / pt2mmxCoord = xCoord / pt2mmyCoord = yCoord / pt2mm' 创建文本框Set txtBox = ActiveDocument.Shapes.AddTextbox(orientation, xCoord, yCoord, width, height)With txtBox'禁止随文字移动.LockAnchor = True' 固定文本框尺寸，禁止自动改变大小.LockAspectRatio = msoTrue' 设置文本框的填充为无色（透明）.Fill.Visible = msoFalse' 设置文本框的线条为无色（透明），即无边框.Line.Visible = msoFalse'设置文本框文本的边距,将0.1cm转化为VBA的点数，CentimetersToPoints函数End WithWith txtBox.TextFrame.MarginLeft = CentimetersToPoints(0.2)   ' 左边距.MarginTop = CentimetersToPoints(0.5)    ' 上边距.MarginRight = CentimetersToPoints(0.1)  ' 右边距.MarginBottom = CentimetersToPoints(0.1) ' 下边距End With' 设置文本框文本Set txtFrame = txtBox.TextFrameSet txtRange = txtFrame.TextRangetxtFrame.VerticalAnchor = msoAnchorMiddle '文本框中文字垂直剧中txtRange.Text = BoxText' 设置文本为5号字txtRange.Font.Size = T_FontSize.Text  ' 注意：Word VBA中的字体大小单位是点（pt），5号字大约等于5/2=2.5磅txtRange.Font.Name = "宋体" ' 更改字体，如果需要' 设置固定行距为11磅txtRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactlytxtRange.ParagraphFormat.LineSpacing = T_ZiJianJu.Text ' 单位是磅Set txtBox = Nothing
End Sub'Public Sub CreateTextBoxFromData(ByVal BoxText As String, ByVal height As Single, ByVal width As Single, ByVal xCoord As Single, ByVal yCoord As Single, ByVal orientation As MsoTextOrientation)
'
'    Dim pt2mm As Double
'    Dim doc As Document
'    Dim rng As Range
'    Dim currentPage As Integer
'    Dim pageStart As Long
'    Dim topMargin As Double
'    Dim leftMargin As Double
'    Dim txtBox As Shape
'    Dim txtFrame As TextFrame
'    Dim txtRange As Range
'    Dim fontSize As Integer
'    Dim wdActiveEndCharactersFromPageStart As Variant
'    Set doc = ActiveDocument
'    Set rng = doc.Windows(1).Selection.Range
'    currentPage = rng.Information(wdActiveEndPageNumber)
'    pageStart = 1
'
'    pt2mm = 0.352778 ' vba单位是pt，1pt=0.352778mm
'    height = height / pt2mm
'    width = width / pt2mm
'    xCoord = xCoord / pt2mm
'    yCoord = yCoord / pt2mm
'
'    ' 调整y坐标，使其相对于当前页面的顶部
'    topMargin = doc.PageSetup.topMargin
'    yCoord = yCoord + pageStart + topMargin
'
'    ' 调整x坐标，使其相对于当前页面的左侧
'    leftMargin = doc.PageSetup.leftMargin
'    xCoord = xCoord + leftMargin
'
'    ' 创建文本框
'    Set txtBox = doc.Shapes.AddTextbox(orientation, xCoord, yCoord, width, height)
'
'    With txtBox
'        .LockAnchor = True
'        .LockAspectRatio = msoTrue
'        .Fill.Visible = msoFalse
'        .Line.Visible = msoFalse
'    End With
'
'    With txtBox.TextFrame
'        .MarginLeft = CentimetersToPoints(0.1)
'        .MarginTop = CentimetersToPoints(0.1)
'        .MarginRight = CentimetersToPoints(0.1)
'        .MarginBottom = CentimetersToPoints(0.1)
'    End With
'
'    fontSize = T_FontSize.text
'    Set txtFrame = txtBox.TextFrame
'    Set txtRange = txtFrame.TextRange
'    txtFrame.VerticalAnchor = msoAnchorMiddle
'    txtRange.text = BoxText
'    txtRange.Font.Size = fontSize
'    txtRange.Font.Name = "宋体"
'    txtRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'    txtRange.ParagraphFormat.LineSpacing = T_ZiJianJu.text ' 设置固定行距
'
'    Set txtBox = Nothing
'End Sub
' 将厘米转换为点的函数
Function CentimetersToPoints(cm As Double) As DoubleCentimetersToPoints = cm * 28.3464567 ' 1厘米=28.3464567点
End FunctionPrivate Sub Cmd_cjwh_Click()
Dim i%, j%, k%
Dim n_Str%, n_End%
Dim s_Stic$, s_New$n_Str = Asc(T_wh_str.Text)
n_End = Asc(T_wh_end.Text)s_Stic = T_weihao.Text
For i = n_Str To n_EndIf i <= 57 Or i >= 65 Then '排除特殊字符，保留0-9，A-Fs_New = s_Stic & Chr(i) & T_wh_hz.TextT_INS.Text = T_INS.Text & s_New & vbCrLfEnd If
Next i
End SubPrivate Sub Cmd_clr_zt_Click()
T_Equ.Text = ""
End SubPrivate Sub cmd_NewPage_Click()
Dim i%For i = 1 To T_NewPages.TextSelection.InsertBreak'ThisDocument.Content.InsertAfter Chr(12)
Next i
MoveToDocStart '光标移动到文档开始
MoveToCurrentLineStart
End SubPrivate Sub cmd_DaXiao_Click()
'改变窗口大小
With cmd_DaXiaoSelect Case .CaptionCase Is = "最小化".Caption = "最大化"Frm_WORD.height = 50Frm_WORD.width = 160Case Is = "最大化".Caption = "最小化"Frm_WORD.height = 400Frm_WORD.width = 500End Select
End With
End SubPrivate Sub Cmd_Doc2Pdf_Click()
Dim a%, pdf_Path$
a = MsgBox("是否转换所有word文件：【是】转换所有word；【否】只转换该word", vbYesNoCancel)If a = 2 ThenElseIf a = 6 ThenDoc2Pdf
ElseIf a = 7 ThenWith ActiveDocument'创建pdf文件夹pdf_Path = .Path & "\pdf\"If Dir(pdf_Path, vbDirectory) = "" ThenVBA.MkDir pdf_PathEnd If.ExportAsFixedFormat OutputFileName:= _pdf_Path & .Name & ".pdf", ExportFormat:= _wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _BitmapMissingFonts:=False, UseISO19005_1:=FalseT_DOC_OK.Text = .Name & "转换pdf完成" & vbCrLf & T_DOC_OK.TextEnd With
End IfEnd SubPrivate Sub cmd_end_P_Click()
T_end_P.Text = ActiveDocument.Tables.Count
End SubPrivate Sub cmd_Excel_Click()
sub_Find_Excel '如果没有excel打开则运行一个新的工作簿。
If Findexcel = True ThenFrm_WORD.HideFrm_Excel.Show 0
ElseMsgBox "请手动打开一个excel否则后续操作会出错误"
End If
End Sub
Public Sub sub_Find_Excel()
'如果没有EXCEL打开则创建新的excel
Dim E_name As String
Dim Objs As Object
Dim Obj As Object
Dim new_XlApp As Excel.Application, new_Wkbook As Excel.WorkbookSet Objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
E_name = "EXCEL"
Findexcel = FalseFor Each Obj In ObjsIf InStr(1, Obj.Description, E_name) > 0 ThenFindexcel = TrueExit ForEnd If
NextEnd SubPrivate Sub Cmd_GetTable_Data_Click()
Dim str_Row%, end_Row%, str_Col%, end_Col%, str_P%, end_P%
Dim SZ_S As Variant
Dim i%
Dim myTables As Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
Lab_state.Caption = "拼命获取中..."
Set myTables = ActiveDocument.Tables
SZ_S = fun_GetTable_Data(myTables, str_P, end_P, str_Row, end_Row, str_Col, end_Col)
For i = LBound(SZ_S) To UBound(SZ_S)T_INS.Text = T_INS.Text & SZ_S(i) & vbCrLf
Next i
Lab_state.Caption = "获取完成！"
End SubPrivate Sub cmd_help_FYF_Click()
MsgBox "未防止死循环；支持最大页数5000页左右的word表格整理，如果页数过多，清自行将word分割后，分别整理"
End SubPrivate Sub cmd_MuLu_Click()
'在目录表格自动生成目录
Dim MyPath$, MyName$, This_doc_name$Dim mydoc As Object
Dim myWord As Object
Dim my_tbls As Tables, n_Pages As IntegerDim doc_Mulu As DocumentDim docPath As String, docName As String
Dim i%, j%, k%, L%, i_m$
Dim Xuhao As Variant, SZ_S As Variant
Dim myPage As Integer, Page_all As Integer
Dim TEM_S$Dim flg_XuHao As Boolean, flg_Name As Boolean, flg_Page As Boolean
'序号，名称，页数
'三维数组ReDim Xuhao(1 To 50, 1 To 3, 1 To 3) As Integer
ReDim SZ_S(1 To 50, 1 To 4) As StringdocPath = InputBox("请粘贴文件夹目录：", "生成目录文件夹地址", Application.ActiveDocument.Path & "\")
If Right(docPath, 1) <> "\" Then: docPath = docPath & "\"
'光标移动到最后一行
MoveToDocEnd
'增加回车
'Selection.TypeText (Chr(13))'创建目录表格
Set doc_Mulu = ActiveDocument
Creat_Tables doc_MuludocName = Dir(docPath & "*.doc*")
TEM_S = docName
L = 0Do While TEM_S <> ""Set mydoc = GetObject(docPath & TEM_S)Set my_tbls = mydoc.Tablesn_Pages = my_tbls.Countflg_XuHao = Falseflg_Name = Falseflg_Page = FalseL = L + 1 '第一个word名称TEM_S = Replace(Replace(TEM_S, " ", ""), "-", "")For i = 1 To Len(TEM_S)If flg_XuHao = False And i = 1 And IsNumeric(Mid(TEM_S, i, 1)) = True Then'第一个就是序号数字On Error Resume NextXuhao(L, 1, 1) = iEnd IfIf Xuhao(L, 1, 1) = 0 And IsNumeric(Mid(TEM_S, i, 1)) = True Then'第一次：数字和非数字的分割点Xuhao(L, 1, 1) = iElseIf Xuhao(L, 1, 1) > 0 And Xuhao(L, 1, 2) = 0 And IsNumeric(Mid(TEM_S, i, 1)) = True And IsNumeric(Mid(TEM_S, i + 1, 1)) = False Then'非数字分割，序号结束位置Xuhao(L, 1, 2) = i'名称起始位置Xuhao(L, 2, 1) = i + 1flg_XuHao = TrueEnd IfIf i < Len(TEM_S) And Xuhao(L, 2, 1) > 0 And Xuhao(L, 2, 2) = 0 And IsNumeric(Mid(TEM_S, i, 1)) = False And IsNumeric(Mid(TEM_S, i + 1, 1)) = True And _i / Len(TEM_S) > 0.5 Then'名称结束位置Xuhao(L, 2, 2) = i'页码起始位置Xuhao(L, 3, 1) = i + 1flg_Name = TrueElseIf i = Len(TEM_S) And Xuhao(L, 3, 1) = 0 Then'名称结束位置Xuhao(L, 2, 2) = iMsgBox "[" & TEM_S & "]" & "文件名缺少页码，文件名最后必须增加页数，例如：****1页.doc"Xuhao(L, 3, 1) = iflg_Name = TrueEnd IfIf i < Len(TEM_S) And Xuhao(L, 3, 1) > 0 And Xuhao(L, 3, 2) = 0 And IsNumeric(Mid(TEM_S, i, 1)) = True And IsNumeric(Mid(TEM_S, i + 1, 1)) = False Then'页码结束位置Xuhao(L, 3, 2) = iflg_Page = TrueElseIf i = Len(TEM_S) And Xuhao(L, 3, 1) > 0 And Xuhao(L, 3, 2) = 0 Then'页码结束位置Xuhao(L, 3, 2) = iflg_Page = TrueEnd IfNext iIf flg_XuHao = True And flg_Name = True And flg_Page = True Then'找到序号，名称，页码SZ_S(L, 1) = Mid(TEM_S, Xuhao(L, 1, 1), 1 + Xuhao(L, 1, 2) - Xuhao(L, 1, 1))SZ_S(L, 2) = Mid(TEM_S, Xuhao(L, 2, 1), 1 + Xuhao(L, 2, 2) - Xuhao(L, 2, 1))SZ_S(L, 3) = Mid(TEM_S, Xuhao(L, 3, 1), 1 + Xuhao(L, 3, 2) - Xuhao(L, 3, 1))'如果文档名称缺少页码If IsNumeric(SZ_S(L, 3)) = False ThenSZ_S(L, 3) = n_PagesEnd IfEnd If'页数与内部表格内容不符If n_Pages = Cint1(SZ_S(L, 3)) ThenSZ_S(L, 4) = ""ElseSZ_S(L, 4) = "表格数：" & n_PagesEnd IfIf mydoc.Name <> doc_Mulu.Name Thenmydoc.Savemydoc.CloseEnd IfTEM_S = Dir
Loop'准备写入目录数据
For L = LBound(SZ_S, 1) To UBound(SZ_S, 1)If L >= doc_Mulu.Tables(1).Rows.Count Thendoc_Mulu.Tables(1).Rows.AddEnd IfIf SZ_S(L, 2) <> "" ThenWith doc_Mulu.Tables(1).Cell(L + 1, 1).Range.Text = Format(L, "00").Cell(L + 1, 2).Range.Text = SZ_S(L, 2).Cell(L + 1, 3).Range.Text = SZ_S(L, 3).Cell(L + 1, 4).Range.Text = SZ_S(L, 4)'计算总页数Page_all = Page_all + SZ_S(L, 3).Cell(L, 1).SelectSelection.SelectRowSelection.Rows.height = CentimetersToPoints(0.6)End WithElseExit ForEnd If
Next
'写入总页数
With doc_Mulu.Tables(1)If L <= .Rows.Count Then.Rows.Add.Rows.Add.Cell(.Rows.Count, 2).Range.Text = "合计：".Cell(.Rows.Count, 3).Range.Text = Page_allEnd If
End With
'优化目录表格尺寸
sub_MuLu_youhuaEnd SubPrivate Sub Cmd_Creat_TXT_Click()
Open T_path_Record.Text For Output As #1
Close #1
End SubPrivate Sub cmd_ReadWorkBook_Click()Dim wb As Workbook '必须引入excel库Dim ws As WorksheetDim exlPath$, n%, i%Label400.Caption = ""combo_sheetsName.ClearexlPath = T_ExcelPath.Text' 打开Excel文件Set wb = Workbooks.Open(exlPath)n = wb.Sheets.Count'MsgBox nFor i = 1 To ncombo_sheetsName.AddItem wb.Sheets(i).NameNext icombo_sheetsName.ListIndex = 0wb.Close SaveChanges:=FalseLabel400.Caption = "读取成功!"
End SubPrivate Sub Cmd_Record_Txt_Click()
Dim S$, P_Txt$
P_Txt = T_path_Record.Text
S = Mid(Comb_writes.Text, 1, Len(Comb_writes.Text))
Open P_Txt For Append As #1Write #1, S
Close #1
End SubPrivate Sub Cmd_Reset_Page_No_Click()
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
End SubPrivate Sub cmd_str_P_Click()
T_str_P.Text = 1
End SubPrivate Sub cmd_t_clear_Click()
T_GCMC.Text = ""
End SubPrivate Sub cmd_T_clear1_Click()
T_DOC_OK.Text = ""
End SubPrivate Sub cmd_table_Nor_h_w_Click()
T_Table_Height = 25.5
T_Table_Width = 17.5
End SubPrivate Sub Cmd_Tianxie1_Click()
'将txt中内容写入word的指定行，按规律
'控制word刷新
Application.ScreenUpdating = FalseDim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%, i_s$, i_s2$, i_s3$, i_s4$, ii%
Dim CanKao_P%, str_P%, end_P%, Laster_Row%
Dim TEM_S$Dim SZ_S As Variant, SZ_S2 As Variant, SZ_S3 As Variant, SZ_S4 As Variant, i_sz_S%Dim my_tbls As Tables
Set my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
Laster_Row = Cint1(T_laster_Row.Text)Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If T_INS.Text <> "" ThenSZ_S = Split(T_INS.Text, vbCrLf)
End If
If T_INS2.Text <> "" ThenSZ_S2 = Split(T_INS2.Text, vbCrLf)
End If
If T_INS3.Text <> "" ThenSZ_S3 = Split(T_INS3.Text, vbCrLf)
End If
If T_INS4.Text <> "" ThenSZ_S4 = Split(T_INS4.Text, vbCrLf)
End If
Lab_state.Caption = "拼命填写中..."If Cint1(L_T_INS.Caption) = Cint1(L_T_INS2.Caption) And Cint1(L_T_INS3.Caption) = Cint1(L_T_INS4.Caption) And Cint1(L_T_INS.Caption) = Cint1(L_T_INS3.Caption) And chk_4_col.Value = True Then
'4列需要相等i_sz_S = 0k = str_Colj = str_Rowi = str_P'前缀；后缀；或者直接赋值If IsEmpty(SZ_S) = False ThenIf Chk_fugai1.Value = True ThenDo While i_sz_S <= UBound(SZ_S)'my_tbls(i).Cell(j, k).SelectIf Chk_fugai.Value = True Thenmy_tbls(i).Cell(j, k).Range.Text = ""End IfDelay (1)TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)i_s = SZ_S(i_sz_S)i_s2 = SZ_S2(i_sz_S)i_s3 = SZ_S3(i_sz_S)i_s4 = SZ_S4(i_sz_S)With my_tbls(i).Cell(j, k).Range.Text = i_s.Cell(j, 3).Range.Text = i_s2.Cell(j, 4).Range.Text = i_s3.Cell(j, 5).Range.Text = i_s4.Cell(j, 6).Range.Text = 50.Cell(j, 7).Range.Text = 50.Cell(j, 8).Range.Text = "合格"End WithIf j + 1 > end_Row Then             '增加一页新表格j = str_RowIf i = my_tbls.Count Then: sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Coli = i + 1my_tbls(i).Cell(j, k).SelectElsej = j + 1End Ifi_sz_S = i_sz_S + 1LoopElse'不覆盖数据Do While i_sz_S <= UBound(SZ_S)For ii = 1 To T_TX_ChongFu.Text'my_tbls(i).Cell(j, k).SelectIf Chk_fugai1.Value = True Thenmy_tbls(i).Cell(j, k).Range.Text = ""End IfDelay (1)TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)If TEM_S <> "" Theni_s = SZ_S(i_sz_S)i_s2 = SZ_S2(i_sz_S)i_s3 = SZ_S3(i_sz_S)i_s4 = SZ_S4(i_sz_S)With my_tbls(i).Cell(j, k).Range.Text = i_s.Cell(j, 3).Range.Text = i_s2.Cell(j, 4).Range.Text = i_s3.Cell(j, 5).Range.Text = i_s4.Cell(j, 6).Range.Text = 50.Cell(j, 7).Range.Text = 50.Cell(j, 8).Range.Text = "合格"End WithElsei_sz_S = i_sz_S - 1End IfIf j + 1 > end_Row Then             '增加一页新表格j = str_RowIf i = my_tbls.Count Then: sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Coli = i + 1my_tbls(i).Cell(j, k).SelectEnd Ifj = j + 1Next iii_sz_S = i_sz_S + 1LoopEnd IfEnd If
ElseIf chk_4_col.Value = False Then
'只填写一列i_sz_S = 0k = str_Colj = str_Rowi = str_P'前缀；后缀；或者直接赋值If IsEmpty(SZ_S) = False ThenIf Chk_fugai1.Value = True Then '覆盖数据Do While i_sz_S <= UBound(SZ_S)For ii = 1 To Cint1(T_TX_ChongFu.Text)'my_tbls(i).Cell(j, k).SelectDelay (1)TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)i_s = SZ_S(i_sz_S)If Chk_qianzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_s & TEM_SEnd IfIf CHK_houzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = TEM_S & i_sEnd IfIf CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_sEnd IfIf j + 1 > end_Row Then         '增加一页新表格j = str_RowIf i = my_tbls.Count Then: sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Coli = i + 1my_tbls(i).Cell(j, k).SelectElsej = j + 1End IfNext iii_sz_S = i_sz_S + 1LoopElse'跳过数据行'无法重复填写。。。代码困难If i > ActiveDocument.Tables.Count Then                '增加一页新表格j = str_Rowsub_New_tbl my_tbls, i - 1, str_Row, str_Col, end_Row, end_ColEnd IfDo While i_sz_S <= UBound(SZ_S)If j + 1 > end_Row Then            '增加一页新表格j = str_RowIf i = my_tbls.Count Then: sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Coli = i + 1End IfDelay (1)TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)If Len(TEM_S) <> 0 Thenj = j + 1Elsei_s = SZ_S(i_sz_S)If Chk_qianzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_s & TEM_SEnd IfIf CHK_houzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = TEM_S & i_sEnd IfIf CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_sEnd Ifj = j + 1i_sz_S = i_sz_S + 1my_tbls(i).Cell(1, 1).SelectEnd IfLoopEnd IfEnd If
End If
Lab_state.Caption = "填写完成！"
'控制word刷新
Application.ScreenUpdating = True
End SubPrivate Sub Cmd_Tianxie2_Click()
'将txt中内容写入word的指定行，按规律
'按行填写
'控制word刷新
Application.ScreenUpdating = False
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%, i_s$
Dim CanKao_P%, str_P%, end_P%
Dim TEM_S$
Dim N_cishu%, My_range As Variant
Dim SZ_S As Variant, i_sz_S%Dim my_tbls As Tables
Set my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1Lab_state.Caption = "拼命填写中..."
i_sz_S = 0
k = str_Col
j = str_Row
i = str_P
'前缀；后缀；或者直接赋值Do While N_cishu < T_TX_ChongFu.TextRandomizemy_tbls(i).Cell(j, k).SelectIf Chk_fugai1.Value = True Thenmy_tbls(i).Cell(j, k).Range.Text = ""End IfDelay (5)TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)If Chk_suiji.Value = True Theni_s = Get_Range(T_INS.Text)My_range = Split(i_s, ";")i_s = fun_XiaoShu(My_range(0) + Rnd() * (My_range(1) - My_range(0)), T_ins_P.Text)Elsei_s = T_INS.TextEnd IfIf Chk_qianzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_s & TEM_SEnd IfIf CHK_houzhui1.Value = -1 Thenmy_tbls(i).Cell(j, k).Range.Text = TEM_S & i_sEnd IfIf CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Thenmy_tbls(i).Cell(j, k).Range.Text = i_sEnd IfIf j + 2 > my_tbls(i).Rows.Count Then  '增加一页新表格j = str_RowIf i = my_tbls.Count Then: sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Coli = i + 1Elsej = j + 1End IfN_cishu = N_cishu + 1If N_cishu = T_TX_ChongFu.Text Then: Lab_state.Caption = "填写完成！"Loop'控制word刷新
Application.ScreenUpdating = True
End Sub'停止当前进程
Private Sub cmd_TingZhi_Click()
DoEvents
my_Stop = True
End SubPrivate Sub Cmd_Word_Bath_Click()
'控制word刷新
Application.ScreenUpdating = False
'批量更改word文档的指定单元格的内容
MsgBox "文档更改完毕，【目录】无法自动更改，需要手动更改！！！！【点击确定开始】"
Sub_Word_Bath
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private Sub cmd_Get_Doc_Path_Click()
'获取当前文档所在文件夹的路径
T_Doc_Path.Text = Application.ActiveDocument.Path
End SubPrivate Sub Cmd_Get_Range_RowCol_Click()
Dim iRow%, iCol%
iRow = Selection.Information(wdEndOfRangeRowNumber)
iCol = Selection.Information(wdEndOfRangeColumnNumber)
T_LC_Row.Text = iRow
T_LC_Col.Text = iCol
End Sub'Private Sub Cmd_Tianxie1_Click()
''将txt中内容写入word的指定行，按规律
'Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, I%, j%, k%, i_S$, ii%
'Dim CanKao_P%, str_P%, end_P%, Laster_Row%
'Dim TEM_S$
'
'Dim SZ_S As Variant, i_Sz_S%
'
'Dim my_tbls As Tables
'Set my_tbls = ActiveDocument.Tables
'
'str_Row = Cint1(T_str_Row.Text)
'str_Col = Cint1(T_str_Col.Text)
'end_Row = Cint1(T_end_Row.Text)
'end_Col = Cint1(T_end_Col.Text)
'str_P = Cint1(T_str_P.Text)
'end_P = Cint1(T_end_P.Text)
'Laster_Row = Cint1(T_laster_Row.Text)
'
'Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
'Lab_state.Caption = "拼命填写中..."
'If T_INS.Text <> "" Then
'    SZ_S = Split(T_INS.Text, vbCrLf)
'End If
'
'i_Sz_S = 0
'k = str_Col
'j = str_Row
'I = str_P
''前缀；后缀；或者直接赋值
'If IsEmpty(SZ_S) = False Then
'    Do While i_Sz_S <= UBound(SZ_S)
'        For ii = 1 To T_TX_ChongFu.Text
'            my_tbls(I).Cell(j, k).Select
'            If Chk_fugai.Value = -1 Then
'                my_tbls(I).Cell(j, k).Range.Text = ""
'            End If
'            Delay (1)
'            TEM_S = Get_Val(my_tbls(I).Cell(j, k).Range.Text)
'            i_S = SZ_S(i_Sz_S)
'
'            If Chk_qianzhui1.Value = -1 Then
'                my_tbls(I).Cell(j, k).Range.Text = i_S & TEM_S
'            End If
'            If CHK_houzhui1.Value = -1 Then
'                my_tbls(I).Cell(j, k).Range.Text = TEM_S & i_S
'            End If
'            If CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Then
'                my_tbls(I).Cell(j, k).Range.Text = i_S
'            End If
'            j = j + 1
'            If j > my_tbls(I).Rows.Count Or j > my_tbls(I).Rows.Count - Laster_Row Or j > end_Row Then              '增加一页新表格
'                j = str_Row
'                If I = my_tbls.Count Then: sub_New_tbl my_tbls, I, str_Row, str_Col, end_Row, end_Col
'                I = I + 1
'            End If
'        Next ii
'        If i_Sz_S = UBound(SZ_S) Then: Lab_state.Caption = "填写完成！"
'        i_Sz_S = i_Sz_S + 1
'    Loop
'
'End If
'
'
'End SubPrivate Sub Cmd_Word_biaotou_jiancha_Click()
'控制word刷新
Application.ScreenUpdating = False
Sub_Word_Bath_jiancha
'控制word刷新
Application.ScreenUpdating = True
End SubPrivate Sub Cmd_write_duohuilu_Click()
'控制word刷新
Application.ScreenUpdating = FalseDim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%Dim zt_Last As Variant, zt_First As VariantDim zt_S$Dim Arry_QT As Variant, Arry_YC As Variant, Arry_YX As Variant, Arry_GZ As VariantDim Arry_KG As Variant, Arry_KGW As Variant, Arry_KDW As Variant, Arry_GDW As VariantDim Arry_Equ As VariantDim SZ_S As Variant, SZ_S_i%, Flg_new_page As BooleanDim i%, ii%, j%, k%, i_Col%, tem_i%, tem_j%, TEM_S$, n_Row%, i_Row%, i_Equ%, i_Row1%, i_Col1%, i_num%Dim my_tbls As TablesDim my_table As Tablemy_Stop = FalseSet my_tbls = ActiveDocument.TablesSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1'准备各项变量，为写入数据做准备Arry_QT = Split("1/0;启停;正常", ";")Arry_YC = Split("1;远程;正常", ";")Arry_YX = Split("1;运行;正常", ";")Arry_GZ = Split("1;故障;正常", ";")'    Arry_KG = Split("DO;ON;打开;DO;OFF;关闭;合格", ";")
'    Arry_KGW = Split("DI;ON;开位;DI;OFF;关位;合格", ";")
'    Arry_KDW = Split("DI;ON;开位;DI;OFF;无;合格", ";")
'    Arry_GDW = Split("DI;ON;关位;DI;OFF;无;合格", ";")SZ_S = Split(T_zt_Last.Text, ";")If ActiveDocument.Tables.Count < 1 ThenMsgBox "缺少表格我将自动创建表格模板"Create_Tables_duohuiluComb_zt_types.ListIndex = 1ElseIf ActiveDocument.Tables(1).Rows.Count <> 40 Thenii = MsgBox("[表格格式：必须为表头：3行，数据36行，最后备注一行]" & vbCrLf & "是否【删除】所有表格！！！创建【多回路报告表格】？", vbYesNoCancel)If ii = 6 Then'删除所有表格Do While ActiveDocument.Tables.Count > 0ActiveDocument.Tables(1).DeleteLoopCreate_Tables_duohuiluComb_zt_types.ListIndex = 1End IfExit SubEnd If'判断前缀和后缀If InStr(T_zt_First.Text, ";") > 0 Thenzt_First = Split(T_zt_First.Text, ";")End IfIf InStr(T_zt_Last.Text, ";") > 0 Thenzt_Last = Split(T_zt_Last.Text, ";")End IfIf T_Equ.Text = "" ThenT_Equ.Text = "P001" & vbCrLf & "P002" & vbCrLfEnd IfIf Right(T_Equ.Text, 1) <> vbCrLf ThenT_Equ.Text = T_Equ.Text & vbCrLfEnd IfArry_Equ = Split(T_Equ.Text, vbCrLf) '设备位号赋值给数组集合'获得word表格页数str_P = Cint1(T_str_P.Text)end_P = Cint1(T_end_P.Text)str_Row = 4 '起始行end_Row = 39 '结束行str_Col = 1end_Col = 10'获得页数和行数，准备写入i = 1: k = 0: i_Equ = 0: SZ_S_i = 0: i_Row = str_Rowi = Selection.Information(wdActiveEndPageNumber)'多回路测试报告DoIf my_Stop = True Then: Exit Sub '停止程序'行数是36的整数倍的时候会出现bug，36 76这两个数要单独处理If i_Row = (36 * 2 + 4) Theni_Row1 = 4i_Row = i_Row + 1GoTo Tiao_kaiguanliang1Else:i_Row1 = (i_Row - 4) Mod 36 + 4End If'根据行数来计算填写数据的列数。i_Col1 = 2 + ((i_Row - 4) \ 36) * 5If i_Col1 > 7 Theni_Col1 = 7End If'检查到表格中有数据就跳过本行my_tbls(i).Cell(i_Row1, i_Col1).SelectTEM_S = Get_Val(my_tbls(i).Cell(i_Row1, i_Col1).Range.Text)If TEM_S <> "" Theni_Row = i_Row + 1'跳转下一页判断GoTo Tiao_kaiguanliang1End If'每行按列，写入表格数据If i_Row1 <= 39 - UBound(SZ_S) Then  '不能超过数据行数,至少要保证填写整数个设备If i_Row1 < 4 + UBound(SZ_S) + 1 ThenIf i = 1 And i_Col1 = 2 Theni_num = 0ElseIf i = 1 And i_Col1 = 7 Then'寻找非空的序号，真是困难,本页上一列寻找For ii = 0 To UBound(SZ_S) + 1TEM_S = Get_Val(my_tbls(i).Cell(39 - ii, 1).Range.Text)If TEM_S <> "" Theni_num = Get_Val(TEM_S)Exit ForEnd IfNext iiElseIf i > 1 And i_Col1 = 2 Then'寻找非空的序号，真是困难，上一页寻找For ii = 0 To UBound(SZ_S) + 1my_tbls(i - 1).Cell(39 - ii, 6).SelectTEM_S = Get_Val(my_tbls(i - 1).Cell(39 - ii, 6).Range.Text)If TEM_S <> "" Theni_num = Get_Val(TEM_S)Exit ForEnd IfNext iiElseIf i > 1 And i_Col1 = 7 Then'寻找非空的序号，真是困难,本页上一列寻找For ii = 0 To UBound(SZ_S) + 1TEM_S = Get_Val(my_tbls(i).Cell(39 - ii, 1).Range.Text)If TEM_S <> "" Theni_num = Get_Val(TEM_S)Exit ForEnd IfNext iiEnd IfElsei_num = Get_Val(my_tbls(i).Cell(i_Row1 - 1, i_Col1 - 1).Range.Text)End IfFor SZ_S_i = LBound(SZ_S) To UBound(SZ_S)my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1 - 1).Range.Text = i_num + 1   '写入序号my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1).Range.Text = Arry_Equ(i_Equ) '写入位号Select Case SZ_S(SZ_S_i)Case Is = "-远程"'YCFor tem_i = LBound(Arry_YC) To UBound(Arry_YC)my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1 + tem_i + 1).Range.Text = Arry_YC(tem_i)Next tem_iCase Is = "-运行"'YXFor tem_i = LBound(Arry_YX) To UBound(Arry_YX)my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1 + tem_i + 1).Range.Text = Arry_YX(tem_i)Next tem_iCase Is = "-故障"'GZFor tem_i = LBound(Arry_GZ) To UBound(Arry_GZ)my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1 + tem_i + 1).Range.Text = Arry_GZ(tem_i)Next tem_iCase Is = "-QT"'QTFor tem_i = LBound(Arry_QT) To UBound(Arry_QT)my_tbls(i).Cell(i_Row1 + SZ_S_i, i_Col1 + tem_i + 1).Range.Text = Arry_QT(tem_i)Next tem_iEnd SelectNext SZ_S_iElse:GoTo Tiao_kaiguanliang1: '如果该设备未写入完毕，那就跳到下一列或者新建word页，继续填写，这时候设备号不再加1，跳过i_equ=i_equ+1End Ifi_Equ = i_Equ + 1i_Row = i_Row + UBound(SZ_S)  '注意设备增加1个，行数要增加好几行，寻找非空行的时候，只需要增加1行，跳过该指令Tiao_kaiguanliang1:              '非空行跳过,跳——开关量，判断If i_Row = end_Row - UBound(SZ_S) And i_Col = 2 Theni_Row = 40End IfIf i_Row >= (end_Row - 3) * 2 + 4 - UBound(SZ_S) Then'增加新表格的判断If i = my_tbls.Count And i_Equ < UBound(Arry_Equ) Then '设备尚未填写完毕Flg_new_page = TrueElseIf i = my_tbls.Count And SZ_S_i <> 0 Then '某设备的回路尚未填写完毕Flg_new_page = TrueEnd IfIf Flg_new_page = True Thensub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Col '插入新表格，并清空指定区域内容i_Col1 = 0Flg_new_page = False '重置判断End IfIf i_Equ < UBound(Arry_Equ) Or i_Row >= (end_Row - 3) * 2 + 4 Then  '设备尚未填写完毕，或者某台设备的回路尚未填写完毕i = i + 1 '页码加1i_Row = str_RowElseIf i_Equ = UBound(Arry_Equ) And SZ_S_i <= UBound(SZ_S) Theni = i + 1 '页码加1i_Row = str_RowEnd IfEnd IfLoop Until i_Equ > UBound(Arry_Equ) Or Arry_Equ(i_Equ) = ""FP1:
'控制word刷新
Application.ScreenUpdating = True
End SubPrivate Sub Cmd_YiBiao_Split_Click()
'仪表报告分割
'删除混合单体报告中不需要的单体
'例如：删除涡街流量计和电磁流量计混合word中的所有电磁流量计，可以输入“涡街”，保留涡街流量计，删除电磁流量计。
Dim TEM_S$
TEM_S = Comb_fyf.Text
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
Yibiao_split '执行删除保留之外的仪表报告
YeBianJu '更改表格板式和页面格式
ChaRu_FenYeFu TEM_S '在指定内容前插入分页符
MsgBox "删除报告完毕，保留报告" & ActiveDocument.Tables.Count & "页。"
End SubPrivate Sub Cmd_Yibiao_Tongyi_Click()
'统一仪表尺寸，将仪表报告其他页面表格尺寸与第一页统一，默认第一页，也可以更改参考页。Dim i%Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
i = MsgBox("是否将所有表格尺寸与参考页表格尺寸统一？", vbOKCancel, "统一表格尺寸")
If i = 1 ThenSub_Yibiao_Tongyi
End If
End SubPrivate Sub cmd_ZengJia_Click()T_StrRow.Text = CInt(T_StrRow.Text) + CInt(T_NoOfPage.Text)End SubPrivate Sub cmd_zt_start_Click()
'控制word刷新
Application.ScreenUpdating = FalseDim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%Dim zt_Last As Variant, zt_First As VariantDim zt_S$Dim Arry_QT As Variant, Arry_YC As Variant, Arry_YX As Variant, Arry_GZ As VariantDim Arry_KG As Variant, Arry_KGW As Variant, Arry_KDW As Variant, Arry_GDW As VariantDim Arry_Equ As VariantDim SZ_S As Variant, SZ_S_i%, Flg_new_page As BooleanDim i%, j%, k%, i_Col%, tem_i%, tem_j%, TEM_S$, n_Row%, i_Row%, i_Equ%, i_Row1%, i_Col1%Dim my_tbls As TablesDim my_table As Tablemy_Stop = FalseSet my_tbls = ActiveDocument.TablesSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1'准备各项变量，为写入数据做准备Arry_QT = Split("DO;ON;启动;DO;OFF;停止;合格", ";")Arry_YC = Split("DI;ON;远程;DI;OFF;现场;合格", ";")Arry_YX = Split("DI;ON;运行;DI;OFF;停止;合格", ";")Arry_GZ = Split("DI;ON;故障;DI;OFF;正常;合格", ";")Arry_KG = Split("DO;ON;打开;DO;OFF;关闭;合格", ";")Arry_KGW = Split("DI;ON;开位;DI;OFF;关位;合格", ";")Arry_KDW = Split("DI;ON;开位;DI;OFF;无;合格", ";")Arry_GDW = Split("DI;ON;关位;DI;OFF;无;合格", ";")'    If InStr(T_zt_Last.Text, ";") > 0 Then
'        SZ_S = Split(T_zt_Last.Text, ";")
'    End If'判断前缀和后缀If InStr(T_zt_First.Text, ";") > 0 Thenzt_First = Split(T_zt_First.Text, ";")Else '没有分号ReDim zt_First(0)zt_First(0) = T_zt_First.TextEnd IfIf InStr(T_zt_Last.Text, ";") > 0 Thenzt_Last = Split(T_zt_Last.Text, ";")Else '没有分号ReDim zt_Last(0)zt_Last(0) = T_zt_Last.TextEnd IfSZ_S = zt_LastIf T_Equ.Text = "" ThenT_Equ.Text = "P001" & vbCrLf & "P002"End IfArry_Equ = Split(T_Equ.Text, vbCrLf) '设备位号赋值给数组集合'获得word表格页数str_P = Cint1(T_str_P.Text)end_P = Cint1(T_end_P.Text)str_Row = Cint1(T_str_Row.Text) '起始行end_Row = Cint1(T_end_Row.Text) '结束行str_Col = Cint1(T_str_Col.Text)end_Col = Cint1(T_end_Col.Text)'获得页数和行数，准备写入i = 1: k = 0: i_Equ = 0: SZ_S_i = 0: i_Row = str_Rowi = Selection.Information(wdActiveEndPageNumber)Do While i_Equ <= UBound(Arry_Equ)If my_Stop = True Then: Exit Sub '停止程序'检查到表格中有数据就跳过本行my_tbls(i).Cell(i_Row, 2).SelectTEM_S = Get_Val(my_tbls(i).Cell(i_Row, 2).Range.Text)If TEM_S <> "" ThenGoTo Tiao_kaiguanliangEnd If'每行按列，写入表格数据my_tbls(i).Cell(i_Row, 2).Range.Text = Arry_Equ(i_Equ) & zt_Last(SZ_S_i) '增加后缀Select Case zt_Last(SZ_S_i)Case Is = "-QT"'QTFor tem_i = LBound(Arry_QT) To UBound(Arry_QT)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_QT(tem_i)Next tem_iCase Is = "-远程"'YCFor tem_i = LBound(Arry_YC) To UBound(Arry_YC)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_YC(tem_i)Next tem_iCase Is = "-运行"'YXFor tem_i = LBound(Arry_YX) To UBound(Arry_YX)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_YX(tem_i)Next tem_iCase Is = "-故障"'GZFor tem_i = LBound(Arry_GZ) To UBound(Arry_GZ)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_GZ(tem_i)Next tem_iCase Is = "-KG"'GZFor tem_i = LBound(Arry_KG) To UBound(Arry_KG)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_KG(tem_i)Next tem_iCase Is = "-KGW"'GZFor tem_i = LBound(Arry_KGW) To UBound(Arry_KGW)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_KGW(tem_i)Next tem_iCase Is = "-KDW"'GZFor tem_i = LBound(Arry_KDW) To UBound(Arry_KDW)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_KDW(tem_i)Next tem_iCase Is = "-GDW"'GZFor tem_i = LBound(Arry_GDW) To UBound(Arry_GDW)my_tbls(i).Cell(i_Row, 3 + tem_i).Range.Text = Arry_GDW(tem_i)Next tem_iEnd SelectIf SZ_S_i >= UBound(SZ_S) Or SZ_S(SZ_S_i) = "" Theni_Equ = i_Equ + 1SZ_S_i = 0 '某设备单条填写完毕，准备填写下一条ElseSZ_S_i = SZ_S_i + 1End IfTiao_kaiguanliang:     '非空行跳过i_Row = i_Row + 1'跳转下一页判断If i_Row > end_Row Then'增加新表格的判断If i = my_tbls.Count And i_Equ < UBound(Arry_Equ) Then '设备尚未填写完毕Flg_new_page = TrueElseIf i = my_tbls.Count And SZ_S_i <> 0 Then '某设备的回路尚未填写完毕Flg_new_page = TrueEnd IfIf Flg_new_page = True Thensub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Col '插入新表格，并清空指定区域内容Flg_new_page = False '重置判断End IfIf i_Equ < UBound(Arry_Equ) Then    '设备尚未填写完毕，或者某台设备的回路尚未填写完毕i = i + 1 '页码加1i_Row = str_RowElseIf i_Equ = UBound(Arry_Equ) And SZ_S_i <= UBound(SZ_S) Theni = i + 1 '页码加1i_Row = str_RowEnd IfEnd IfDelay (1)Looptem_i = 0
FP1:
'控制word刷新
Application.ScreenUpdating = True
End SubPrivate Sub Comb_DYMC_Click()
T_GGNR.Text = Get_Val(Comb_DYMC.Text)
End SubPrivate Sub cmdJiaRuBiaoQian_Click()
LbZhengMian.Caption = LbZhengMian.Caption & Combo_ZiDuan.Text & vbCrLf
LbFanMian.Caption = LbFanMian.Caption & Combo_ZiDuan.Text & vbCrLf
listZiDuan.AddItem Combo_ZiDuanEnd SubPrivate Sub cmdQingKongBiaoQian_Click()
LbZhengMian.Caption = ""
LbFanMian.Caption = ""
listZiDuan.ClearEnd SubPrivate Sub Comb_writes_Change()
'辅助填写文件，创建并维护字典
Dim S$, S1$
Open T_path_Record.Text For Input As #1
S1 = Comb_writes.Text
Do While Not EOF(1)Input #1, SIf InStr(1, S, S1) > 0 ThenSelection.Text = SExit DoEnd If
Loop
List_KeyWord.Clear
Do While Not EOF(1)Input #1, SIf InStr(1, S, S1) > 0 ThenList_KeyWord.AddItem SEnd If
Loop
Close #1
End SubPrivate Sub Comb_zt_types_Change()
Ref_zt_TypesT_str_Row.Text = 4
T_str_Col.Text = 2
T_end_Row.Text = 35
T_end_Col.Text = 9End SubPrivate Sub Cmd_FYF_Click()
'根据找到的相同文本数量确定页数
'控制word刷新
Application.ScreenUpdating = False
Dim TEM_S$
TEM_S = Comb_fyf.Text
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
YeBianJu '更改表格板式和页面格式
ChaRu_FenYeFu TEM_S '在指定内容前插入分页符
sub_ShouHangYouHua '优化首页首行显示，删除不必要的分页符和换行
'控制word刷新
Application.ScreenUpdating = True
End SubPublic Sub Del_FenYeFu()
'删除所有分页符
Const wdReplaceAll = 2
Dim oRng As Range
With ActiveWindow.ActivePane.View.Zoom.PageRows = 1
End WithSet oRng = Word.ActiveDocument.Content
Selection.HomeKey Unit:=wdStory '光标移动到首行
With oRng.Find.ClearFormatting.MatchWildcards = False'手动分页符.Text = "^m".Execute ReplaceWith:="", Replace:=wdReplaceAll
End With
End Sub
Public Sub ChaRu_FenYeFu(ByVal TEM_S As String)
'针对word表格混乱的情况，对表格处理，防止表格重叠，表格混乱拼接，整理成每个表格占一页word
'在指定内容前插入分页符
'插入新的分页符，保证都有分页符
Dim find_No%, tem_Tims%, i%, tem_Line%, L%, j%, tem_Page%With ActiveWindow.ActivePane.View.Zoom '必须改为单页显示.PageRows = 1
End With
ActiveWindow.ActivePane.View.Zoom.Percentage = 100 '必须将视口比例设置为100，否则按页操作，页面会错乱。
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage '必须将窗口视图模式改为单页视图，否则无法正常执行增加分页符的操作，删除表哥之间的多余内容无效。要在100%之后设置'删除所有分页符
Const wdReplaceAll = 2
Dim oRng As Range
Set oRng = Word.ActiveDocument.Content
Selection.HomeKey Unit:=wdStory '光标移动到首行
With oRng.Find.ClearFormatting.MatchWildcards = False'手动分页符.Text = "^m".Execute ReplaceWith:="", Replace:=wdReplaceAll
End With'根据找到的相同文本数量[确定页数]
find_No = 0
Selection.HomeKey Unit:=wdStory '光标移动到首行
With ActiveDocument.Content.FindDo While .Execute(findtext:=TEM_S) = Truefind_No = find_No + 1Loop
End WithIf find_No >= 2 Then '找到大于2条相同记录，说明至少有2个表格。只有1个表格情况会死循环，排除这个情况'【删除表格之间多余内容】删除多余换行符和空格和分页符等不属于表格的内容tem_Tims = 0Selection.HomeKey Unit:=wdStory '光标移动到首行Selection.Find.ClearFormattingWith Selection.Find.Text = TEM_S.Replacement.Text = "".Forward = True.Wrap = wdFindAsk.Format = False.MatchCase = False.MatchWholeWord = False.MatchByte = False.MatchAllWordForms = False.MatchSoundsLike = False.MatchWildcards = TrueEnd WithSelection.Find.Executetem_Line = Selection.Information(wdFirstCharacterLineNumber)L = 0Do Until Selection.Information(wdActiveEndAdjustedPageNumber) >= Selection.Information(wdNumberOfPagesInDocument)L = L + 1If L > 5000 Then: Exit Do'防止查重'删除非表格内容数据Selection.MoveUp Unit:=wdLine, Count:=1j = 0Do While Selection.Information(Word.WdInformation.wdWithInTable) = FalseDelay (10)Selection.DeleteSelection.MoveUp Unit:=wdLine, Count:=1j = j + 1If j > 100 Then: Exit DoLooptem_Tims = tem_Tims + 1Selection.Find.Execute '由于光标上移，通过查找将光标重新定位到插入点tem_Page = Selection.Information(wdActiveEndPageNumber)Delay (10)If tem_Tims >= 1 And tem_Page >= 1 Then '第一页不插入分页符，导致1、2页连到一起无法分开Selection.InsertBreak Type:=wdPageBreak '插入分页符Selection.Find.Execute '光标再次定位到插入点End If'防止重复插入分页符If Selection.Information(wdFirstCharacterLineNumber) = tem_Line ThenSelection.Find.ExecuteElsetem_Line = Selection.Information(wdFirstCharacterLineNumber)End If'破死循环,超过找到真正表格数量If tem_Tims >= find_No + 2 ThenExit DoEnd IfLoop'最后一页单独增加一个分页符If Selection.Information(wdActiveEndAdjustedPageNumber) >= Selection.Information(wdNumberOfPagesInDocument) Then'删除非表格内容数据Selection.MoveUp Unit:=wdLine, Count:=1j = 0Do While Selection.Information(Word.WdInformation.wdWithInTable) = FalseDelay (10)Selection.DeleteSelection.MoveUp Unit:=wdLine, Count:=1j = j + 1If j > 100 Then: Exit DoLoopSelection.Find.ExecuteSelection.InsertBreak Type:=wdPageBreak'删除第一页之前多余的一个分页符Selection.HomeKey Unit:=wdStory '光标移动到首行Selection.DeleteEnd If
End If'首行增加回车Selection.HomeKey Unit:=wdStory '光标移动到首行On Error Resume NextSelection.SplitTable'移动到最后一行MoveToDocEnd'再次删除非表格内容数据Selection.MoveUp Unit:=wdLine, Count:=1j = 0Do While Selection.Information(Word.WdInformation.wdWithInTable) = FalseDelay (10)Selection.DeleteSelection.MoveUp Unit:=wdLine, Count:=1j = j + 1If j > 100 Then: Exit DoLoopsub_ShouHangYouHua    '优化首页首行显示，删除不必要的分页符和换行End SubPrivate Sub Cmd_Tong_Yi_Table_H_W_Click()
YeBianJu '先将表格居中
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
YEBIANJU1 '统一页边距，不然更改表格尺寸没意义
sub_Tong_Yi_Table_H_W '更改表格尺寸适合A4纸打印
End SubPrivate Sub CMD_Cell_counts_Click()
On Error Resume Next
T_jishu.Text = Cell_counts
End SubPrivate Sub sub_ShouHangYouHua()'移动到首行删除首行的分页符增加一个回车'优化首页首行显示，删除不必要的分页符和换行Dim j%MoveToDocStart'再次删除非表格内容数据Selection.MoveUp Unit:=wdLine, Count:=1j = 0Do While Selection.Information(Word.WdInformation.wdWithInTable) = FalseDelay (10)Selection.Delete'Selection.MoveUp Unit:=wdLine, Count:=1j = j + 1If j > 100 Then: Exit DoLoopMoveToDocStartSelection.SplitTable
End SubPrivate Sub combo_sheetsName_Change()End SubPrivate Sub Combox_FangXiang_Change()End SubPrivate Sub CommandButton1_Click()
Dim i%, j%, tbl As Tables, MyPath$
Dim mulu_Table As Table
Dim muluDoc As Document
Set muluDoc = ActiveDocument
t_YiBiao_Style.Text = 12'Set tbl = ActiveDocument.Tables
'
'For i = 1 To tbl.Count
'    For j = 1 To 32
'        tbl(i).Cell(3 + j, 1).Range.Text = ""
'    Next j
'Next i'i = MsgBox("", vbYesNo)
'MsgBox i
'MsgBox Asc(9)
'myPath = "E:\F\所有报告\01-工作报告-20210523\02-环保\第三批-环保-合同报告-20211007\第三批-环保-预处理厂房-仪表-20211007\增加-20211007\" & "检查结果.txt"
'Shell "notepad.exe " & Chr(34) & myPath & Chr(34), 1
End SubPrivate Sub Cmd_InsertRows_Click()
' 插入行()
Dim myTable As Tables '
Dim i%, n%, n1%, j%
Dim str_Row%, end_Row%, str_Col%, end_Col%, str_P%, end_P%Dim my_tbls As Tables
Dim my_table As TableSet my_tbls = ActiveDocument.Tablesstr_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)Set myTable = ActiveDocument.Tablesn = myTable.Count
n1 = 34
For i = str_P To end_Pn = myTable(i).Rows.CountFor j = 0 To 1myTable(i).Rows(n - j).DeleteNext jn = myTable(i).Rows.CountmyTable(i).Rows(n).SelectSelection.InsertRowsBelow 1Selection.Text = "技术负责人：                                 调校人：                     " & T_riqi.TextNext i
End SubPrivate Sub CommandButton2_Click()
Dim S$, P_Txt$
P_Txt = T_path_Record.Text
Shell "notepad.exe " + P_Txt, 1
End SubPrivate Sub CommandButton3_Click()
Dim S_time As Variant, i_s$, TXT_Path$
Dim S$, S1$, SZ_S As Variant
Dim i%
Dim str_Row%, end_Row%, str_Col%, end_Col%, str_P%, end_P%
Dim myTables As Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)Set myTables = ActiveDocument.Tables
SZ_S = fun_GetTable_Data(myTables, str_P, end_P, str_Row, end_Row, str_Col, end_Col)Lab_state.Caption = "拼命获取中..."'获得时间戳
S_time = Split(Time(), ":")
For i = 0 To 2
i_s = i_s & S_time(i)
Next iTXT_Path = ActiveDocument.Path & "\" & "数据导出_" & i_s & ".txt"
'创建txt文档
Open TXT_Path For Output As #1
Close #1
Delay 100
'写入数据
Open TXT_Path For Append As #1For i = LBound(SZ_S) To UBound(SZ_S)Print #1, SZ_S(i)Next i
Close #1
Lab_state.Caption = "获取完成！"
Shell "notepad.exe " + TXT_Path, 1End SubPrivate Sub CommandButton6_Click()End SubPrivate Sub cmd_getziduan_Click()
'获取字段
Dim SZ_ZiDuan As Variant, StrRow As Long, EndRow As Long, StrCol As Long, EndCol As Long
Dim ExcelPath As String, SheetName As StringDim wb As Workbook '必须引入excel库Dim ws As WorksheetDim i As Long, j As LongExcelPath = T_ExcelPath.TextSheetName = combo_sheetsName.Text' 打开Excel文件Set wb = Workbooks.Open(ExcelPath)Set ws = wb.Sheets(SheetName)' 确定数据范围Dim lastRow As Long, LastCol As LonglastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).RowLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Columnwb.Close SaveChanges:=FalseStrRow = 1EndRow = 1StrCol = 1EndCol = LastColSZ_ZiDuan = ReadExcel2SZ(ExcelPath, SheetName, StrRow, EndRow, StrCol, EndCol)For i = LBound(SZ_ZiDuan, 1) To UBound(SZ_ZiDuan, 1)For j = LBound(SZ_ZiDuan, 2) To UBound(SZ_ZiDuan, 2)Combo_ZiDuan.AddItem SZ_ZiDuan(i, j)Next jNext iCombo_ZiDuan.ListIndex = 0End SubPrivate Sub CommandButton5_Click()End SubPrivate Sub delete_All_Click()
DeletePageContent '删除当前页所有文本框
End Sub
Sub DeletePageContent()Dim currentPage As RangeSet currentPage = Selection.Range'选择并删除当前页上的所有内容currentPage.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=1currentPage.WholeStorycurrentPage.Delete'清空本页内容Selection.TypeText Text:=""
End SubPrivate Sub Lab_CanKao_P_Click()
ActiveDocument.Tables(T_CanKao_P.Text).Cell(1, 1).Select
End SubPrivate Sub Lab_end_P_Click()
ActiveDocument.Tables(T_end_P.Text).Cell(1, 1).Select
End SubPrivate Sub Lab_state_Click()End SubPrivate Sub Lab_str_P_Click()
ActiveDocument.Tables(T_str_P.Text).Cell(1, 1).Select
End SubPrivate Sub Label103_Click()End SubPrivate Sub Label80_Click()
If Cmb_sty.Text = "热电阻" ThenT_jiancedian.Text = "0,100"
ElseIf Cmb_sty.Text = "温度变送器" ThenT_jiancedian.Text = "25,50,100"
End IfEnd SubPrivate Sub ListBox1_Click()End SubPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
MsgBox ListBox1.Selected
End SubPrivate Sub Label99_Click()End SubPrivate Sub List_KeyWord_Click()
Selection.Text = List_KeyWord.Text
End SubPrivate Sub listZiDuan_Click()
MsgBox listZiDuan.List(0)End SubPrivate Sub MultiPage1_Change()
'MsgBox MultiPage1.ValueSelect Case MultiPage1.ValueCase Is = 6T_Doc_Path.Text = ActiveDocument.PathCase Is = 5'分析是开关量回路还是多回路On Error Resume NextIf ActiveDocument.Tables.Count >= 1 ThenIf InStr(0, ActiveDocument.Tables(1).Cell(1, 2).Range.Text, "多回路") > 0 Then'发现多回路报告Comb_zt_types.ListIndex = 1End IfEnd IfCase Is = 9Frm_WORD.width = 1000Frm_WORD.height = 600Case ElseFrm_WORD.width = 600Frm_WORD.height = 400
End Select
End SubPrivate Sub OBut_style_01_Click()
If OBut_style_01.Value = -1 ThenCmb_sty_01.Enabled = TrueCmb_sty.Enabled = False
End If
End SubPrivate Sub OBut_style_Click()
If OBut_style.Value = -1 ThenCmb_sty_01.Enabled = FalseCmb_sty.Enabled = True
End If
End Sub'AIAODIDO辅助计算
Private Sub T_AITD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AITD.Text) = True ThenOn Error Resume NextAITD = CDbl1(T_AITD.Text)AIKS = CDbl1(T_AIKS.Text)AIDS = CDbl1(T_AIDS.Text)If DSS.Value = -1 ThenAIKS = KSjs(AIDS, AITD)T_AIKS.Text = AIKSElseAIDS = DSjs(AITD, AIKS)T_AIDS.Text = AIDSEnd IfEnd If
End SubPrivate Sub T_AOTD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AOTD.Text) = True ThenOn Error Resume NextAOTD = CDbl1(T_AOTD.Text)AOKS = CDbl1(T_AOKS.Text)AODS = CDbl1(T_AODS.Text)If DSS.Value = -1 ThenAOKS = KSjs(AODS, AOTD)T_AOKS.Text = AOKSElseAODS = DSjs(AOTD, AOKS)T_AODS.Text = AODSEnd IfEnd If
End SubPrivate Sub T_Box_Height_Change()End SubPrivate Sub T_BoxWidth_Change()End SubPrivate Sub T_DITD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DITD.Text) = True ThenOn Error Resume NextDITD = CDbl1(T_DITD.Text)DIKS = CDbl1(T_DIKS.Text)DIDS = CDbl1(T_DIDS.Text)If DSS.Value = -1 ThenDIKS = KSjs(DIDS, DITD)T_DIKS.Text = DIKSElseDIDS = DSjs(DITD, DIKS)T_DIDS.Text = DIDSEnd If
End If
End SubPrivate Sub T_DOC_OK_Change()End SubPrivate Sub T_Doc_Path_Change()End SubPrivate Sub T_DOTD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DOTD.Text) = True ThenOn Error Resume NextDOTD = CDbl1(T_DOTD.Text)DOKS = CDbl1(T_DOKS.Text)DODS = CDbl1(T_DODS.Text)If DSS.Value = -1 ThenDOKS = KSjs(DODS, DOTD)T_DOKS.Text = DOKSElseDODS = DSjs(DOTD, DOKS)T_DODS.Text = DODSEnd If
End IfEnd Sub
Private Sub T_AIKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AIKS.Text) = True ThenOn Error Resume NextAITD = CDbl1(T_AITD.Text)AIKS = CDbl1(T_AIKS.Text)AIDS = CDbl1(T_AIDS.Text)If DSS.Value = -1 ThenAITD = TDjs(AIDS, AIKS)T_AITD.Text = AITDElseAIDS = DSjs(AIKS, AIKS)T_AIDS.Text = AIDSEnd IfEnd If
End SubPrivate Sub T_AOKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AOKS.Text) = True ThenOn Error Resume NextAOTD = CDbl1(T_AOTD.Text)AOKS = CDbl1(T_AOKS.Text)AODS = CDbl1(T_AODS.Text)If DSS.Value = -1 ThenAOTD = TDjs(AODS, AOKS)T_AOTD.Text = AOTDElseAODS = DSjs(AOKS, AOKS)T_AODS.Text = AODSEnd If
End If
End Sub
Private Sub T_DIKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DIKS.Text) = True ThenOn Error Resume NextDITD = CDbl1(T_DITD.Text)DIKS = CDbl1(T_DIKS.Text)DIDS = CDbl1(T_DIDS.Text)If DSS.Value = -1 ThenDITD = TDjs(DIDS, DIKS)T_DITD.Text = DITDElseDIDS = DSjs(DIKS, DIKS)T_DIDS.Text = DIDSEnd If
End If
End Sub
Private Sub T_DOKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DOKS.Text) = True ThenOn Error Resume NextDOTD = CDbl1(T_DOTD.Text)DOKS = CDbl1(T_DOKS.Text)DODS = CDbl1(T_DODS.Text)If DSS.Value = -1 ThenDOTD = TDjs(DODS, DOKS)T_DOTD.Text = DOTDElseDODS = DSjs(DOKS, DOKS)T_DODS.Text = DODSEnd If
End If
End Sub
Private Sub T_AIDS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AIDS.Text) = True ThenOn Error Resume NextAITD = CDbl1(T_AITD.Text)AIKS = CDbl1(T_AIKS.Text)AIDS = CDbl1(T_AIDS.Text)If KSS.Value = -1 ThenAITD = TDjs(AIDS, AIKS)T_AITD.Text = AITDElseAIKS = KSjs(AIDS, AITD)T_AIKS.Text = AIKSEnd IfEnd If
End Sub
Private Sub T_AODS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AODS.Text) = True ThenOn Error Resume NextAOTD = CDbl1(T_AOTD.Text)AOKS = CDbl1(T_AOKS.Text)AODS = CDbl1(T_AODS.Text)If KSS.Value = -1 ThenAOTD = TDjs(AODS, AOKS)T_AOTD.Text = AOTDElseAOKS = KSjs(AODS, AOTD)T_AOKS.Text = AOKSEnd IfEnd If
End Sub
Private Sub T_DIDS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DIDS.Text) = True ThenOn Error Resume NextDITD = CDbl1(T_DITD.Text)DIKS = CDbl1(T_DIKS.Text)DIDS = CDbl1(T_DIDS.Text)If KSS.Value = -1 ThenDITD = TDjs(DIDS, DIKS)T_DITD.Text = DITDElseDIKS = KSjs(DIDS, DITD)T_DIKS.Text = DIKSEnd IfEnd If
End Sub
Private Sub T_DODS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DODS.Text) = True ThenOn Error Resume NextDOTD = CDbl1(T_DOTD.Text)DOKS = CDbl1(T_DOKS.Text)DODS = CDbl1(T_DODS.Text)If KSS.Value = -1 ThenDOTD = TDjs(DODS, DOKS)T_DOTD.Text = DOTDElseDOKS = KSjs(DODS, DOTD)T_DOKS.Text = DOKSEnd IfEnd If
End Sub
'12--AIAODIDO相关计算指令---------------------------------------------------'2--指令-表格数据批量更改-------------------------------------------------------
Private Sub Cmb_sty_Click()
Dim TEM_S$
T_point_wucha.Enabled = False
t_YiBiao_Style.Text = Cmb_sty.TextSelect Case Cmb_sty.ListIndexCase Is = 1'热电阻TEM_S = "GB/T 30121-2013工业铂热电阻及铂感温元件" & vbCrLf & _"本标准规定了对工业铂电阻感温元件和工业铂热电阻的要求及其温度-电阻关系。它们的电阻值是温度的规定函数。" & vbCrLf & _"（-200~0度）Rt=R0*[1+A*t+B*t^2+C*(t-100)*t^3)]" & vbCrLf & _"(0-850度)Rt=R0*(1+A*t+B*t^2)" & vbCrLf & _"AA-A-B-C级热电阻分别对应:0.1-0.15-0.3-0.6摄氏度误差"T_Tips.Text = TEM_ST_str_Row.Text = 9T_str_Col.Text = 1T_end_Row.Text = 11T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 1T_P_ShuJu.Text = 3T_jiancedian.Enabled = TrueT_jiancedian.Text = "0,50,100"Case Is = 2'温度变送器T_str_Row.Text = 11T_str_Col.Text = 1T_end_Row.Text = 13T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 1T_P_ShuJu.Text = 3T_jiancedian.Enabled = TrueT_jiancedian.Text = "25,50,100"Case Is = 3'压力变送器T_str_Row.Text = 11T_str_Col.Text = 1T_end_Row.Text = 15T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 4T_LC_Col.Text = 2T_Point.Text = 2T_P_ShuJu.Text = 3T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_Tips.Text = "只需输入量程0-100kpa，精度：0.05%；其他不用输入"Case Is = 4'温度计T_str_Row.Text = 3T_str_Col.Text = 8T_end_Row.Text = 40T_end_Col.Text = 8T_Point.Text = 1T_HD_k.Text = 2T_jingdu.Text = 1.5T_jiancedian.Enabled = FalseCase Is = 5'压力表T_str_Row.Text = 3T_str_Col.Text = 8T_end_Row.Text = 40T_end_Col.Text = 8T_Point.Text = 4T_HD_k.Text = 2T_jingdu.Text = 1.5T_Tips.Text = "压力表数据列必须为9列，否则出错，例如：序号-名称-编号-型号-量程-精度-允许误差-最大误差-调校结果"T_jiancedian.Enabled = FalseCase Is = 6'调节阀T_str_Row.Text = 19T_str_Col = 2T_end_Row = 24T_end_Col = 6T_VA_bz_Row.Text = T_str_Row.TextT_xc_Row.Text = 4T_xc_Col.Text = 2T_jingdu.Text = 0.5T_jiancedian.Enabled = FalseT_P_ShuJu.Text = 2Case Is = 7'模拟量回路测试T_str_Row.Text = 5T_str_Col.Text = 4T_end_Row.Text = 36T_end_Col.Text = 10T_col_BZ.Text = 3 '量程所在列T_Point.Text = 1T_jingdu.Text = 0.1T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_P_ShuJu.Text = 2Case Is = 8'基础化I/O组件模拟量测试T_str_Row.Text = 5T_str_Col.Text = 4T_end_Row.Text = 36T_end_Col.Text = 10T_col_BZ.Text = 3 '量程所在列T_Point.Text = 2T_P_ShuJu.Text = 2T_jingdu.Text = 0.1T_jiancedian.Enabled = FalseCase Is = 9'安全栅T_str_Row.Text = 4T_str_Col.Text = 8T_end_Row.Text = 35T_end_Col.Text = 12T_col_BZ.Text = 5 '精度所在列T_Point.Text = 2T_jingdu.Text = 0.1T_point_wucha.Enabled = TrueT_jiancedian.Enabled = FalseCase Is = 10'数显表T_str_Row.Text = 10T_str_Col.Text = 2T_end_Row.Text = 14T_end_Col.Text = 8T_jingdu.Text = 0.5T_LC_Row.Text = 5T_LC_Col.Text = 2T_Point.Text = 2T_P_ShuJu.Text = 3T_jdxs.Text = 0.4T_jiancedian.Enabled = FalseT_Tips.Text = "数显表数据"Case ElseT_point_wucha.Enabled = FalseT_jiancedian.Enabled = False
End Select
End Sub
'2--指令-表格数据批量更改-------------------------------------------------------Private Sub Cmd_acitve_me_Click()MsgBox "所有内容仅供个人学习使用，严禁传播。", , "声明："
End SubPrivate Sub Cmd_biaogejuzhong_Click()
YeBianJu '更改页边距后自动居中。
End SubPrivate Sub CMD_cell_copy_Click()
'每个表格的指定区域内容与第一页该区域内容一致
'控制word刷新
Application.ScreenUpdating = False
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S$, tem_Ss$Dim my_tbls As Tables
Dim my_table As Table
Set my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)n = my_tbls.CountSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_PT_str_P.Text = 1
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End IfFor i = str_P To end_PFor j = str_Row To end_RowFor k = str_Col To end_ColIf Chk_BGFZ_ZT.Value = False ThenTEM_S = Get_Val(my_tbls(CanKao_P).Cell(j, k).Range.Text)my_tbls(i).Cell(j, k).SelectDelay (10)If Chk_fugai.Value = -1 ThenSelection.Text = ""End Ifmy_tbls(i).Cell(j, k).Range.Text = TEM_SElsemy_tbls(CanKao_P).Cell(j, k).Range.CopyDelay (2)my_tbls(i).Cell(j, k).Range.Selectmy_tbls(i).Cell(j, k).Range.PasteEnd If'更改行高If Chk_BGFZ_HG.Value = True Thenmy_tbls(i).Cell(j, k).height = my_tbls(str_P).Cell(j, k).heightEnd IfNext kNext j
Next i
Selection.HomeKey Unit:=wdStory
'控制word刷新
Application.ScreenUpdating = True
End Sub'0===============================================================================================
'公共指令
Private Sub Cmd_END_Click()
End
End Sub
'0==============================================================================================='1-操作-改字体****************************************************
Private Sub cmd_Blk_Click()
ziti_Blk
End SubPrivate Sub Cmd_get_col_BZ_Click()
'获取标准值所在数据列
T_col_BZ.Text = Selection.Information(wdEndOfRangeColumnNumber)
End SubPrivate Sub Cmd_get_Row_Click()
'获取标准值所在数据行
T_VA_bz_Row.Text = Selection.Information(wdEndOfRangeRowNumber)
End SubPrivate Sub Cmd_get_xingcheng_Click()
Dim iRow%, iCol%
iRow = Selection.Information(wdEndOfRangeRowNumber)
iCol = Selection.Information(wdEndOfRangeColumnNumber)
T_xc_Row.Text = iRow
T_xc_Col.Text = iCol
End SubPrivate Sub cmd_insert_date_Click()
Ins_data
End SubPrivate Sub cmd_IO_CLEAR_Click()
T_AD.Text = ""
End SubPrivate Sub Cmd_pilianggaitu_Click()'mac_TuPianDaXiao'适合96dpi的图片Dim img As InlineShape' 根据你的发现，直接使用特定比例来设置宽度以近似5cm（仅适用于96dpi）Dim targetWidthMultiplier As SingleDim Width_1cm As DoubleWidth_1cm = 28.318584  '1厘米宽度对应的像素值If IsNumeric(T_PIC_Width.Text) = False Or T_PIC_Width.Text = "" Then '防止输入错误T_PIC_Width.Text = 5End IftargetWidthMultiplier = T_PIC_Width.Text * Width_1cm  ' 文本框输入厘米数转换成word对应的数值' 遍历文档中的所有内嵌图片For Each img In ActiveDocument.InlineShapes        ' 等比例调整图片尺寸，首先获取原始尺寸，然后应用特定比例With img.LockAspectRatio = True ' 保持宽高比锁定If .width = targetWidthMultiplier <> targetWidthMultiplier Then.width = targetWidthMultiplierEnd IfEnd WithNext imgMsgBox "文档中的图片已全部调整为大约" & T_PIC_Width & "厘米宽度。"End SubPrivate Sub Cmd_quanlujing_Click()
'标题栏显示完整路径
On Error Resume Next
ActiveWindow.Caption = ActiveDocument.FullName
End SubPrivate Sub cmd_Red_Click()
ziti_Red
End SubPrivate Sub Cmd_Ref_Date_Click()
'根据原始内容和精度更改数据,温度/压力
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%, t_Style$
Dim CanKao_P%, str_P%, end_P%, col_BZ%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S As Variant, tem_Ss As Variant
Dim Jingdu#, tem_Wucha#, Points%, S_P$, S_P1%, Jdxs#
Dim Wucha1#, Wucha2#, Huicha#Dim U_Range#, L_Range#, sL_range#, sU_range#, YXWC# '量程上下限
Dim MyRange As Variant '通过get_range函数获得量程，赋值给myrange 通过数组进行下限上限剥离
Dim Lc_Row%, Lc_Col%, T_Range As Variant '量程所在单元格位置Dim my_tbls As Tables
Dim my_table As Table
Dim HD_k#, JD_k# '随机数的混沌程度,精度系数'热电阻计算
Dim kR0#, R0#, Rt#, Temper# '定义三个系数和电阻值，温度值Dim SZ_YaLi(11 To 15, 1 To 8) As String, Tem_3#, Tem_4#, Tem_5#, Tem_6#, Tem_7#, Tem_8#, flg_Zero# '压力温度计算需要的临时变量Const kRA = 0.0039083, kRB = -0.0000005775, kRC = 0.000000000004183
'程序允许
my_Stop = False
'禁用word刷新
Application.ScreenUpdating = FalseSet my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
Jingdu = CDbl(T_jingdu.Text) / 100 / 1.5
JD_k = CDbl(T_jdxs.Text)
Points = Cint1(T_Point.Text)
col_BZ = Cint1(T_col_BZ.Text)CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)Lc_Row = Cint1(T_LC_Row.Text) '获得量程所在单元格，以便确定校准点位
Lc_Col = Cint1(T_LC_Col.Text)Jdxs = CDbl1(T_jdxs.Text) '精度系数，用来提高数据精度的，防止计算出的随机度过大导致精度太低
HD_k = CDbl1(T_HD_k.Text) '混沌系数n = my_tbls.CountIf CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_P
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End IfS_P = Set_P(Points)
t_Style = t_YiBiao_Style.Text
S_P = Cint1(T_Point.Text)
S_P1 = Cint1(T_P_ShuJu.Text) '数据小数位数'开始数据更新
'------------------
If t_Style = "压力变送器" ThenFor i = str_P To end_PIf my_Stop = True Then: Exit Sub '停止程序'获得量程单元格内容，并转换成下限和上限TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text)'获得量程下限和上限MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))'根据量程单位更改输入单位,自动更改，无需人文更改。my_tbls(i).Cell(10, 2).Range.Text = "(" & fun_Unit_YaLi(Get_Val(my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text)) & ")"'获得信号输出量程TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row + 1, Lc_Col).Range.Text)MyRange = Split(TEM_S, ";")sL_range = CDbl1(MyRange(0))sU_range = CDbl1(MyRange(1))Jingdu = Get_Dbl(my_tbls(i).Cell(3, 4).Range.Text) '获得精度my_tbls(i).Cell(4, 4).Range.Text = "±" & fun_XiaoShu((sU_range - sL_range) * Jingdu * 0.01, 3) & _fun_Unit_YaLi(Get_Val(my_tbls(i).Cell(Lc_Row + 1, Lc_Col).Range.Text)) '误差自动填写-自动识别mA 和 V信号For j = str_Row To end_Row '11-15行填写数据RandomizeDelay (5)SZ_YaLi(j, 1) = fun_XiaoShu((j - 11) / 4 * 100, S_P) '百分比SZ_YaLi(j, 2) = fun_XiaoShu(L_Range + (j - 11) / 4 * (U_Range - L_Range), S_P) '标准输入值Tem_3 = Round(sL_range + (j - 11) / 4 * (sU_range - sL_range), S_P1)SZ_YaLi(j, 3) = fun_XiaoShu(Tem_3, S_P1) '标准电流值Randomizeflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1flg_Zero = flg_Zero / Abs(flg_Zero)Tem_4 = Round(sL_range + (j - 11) / 4 * (sU_range - sL_range) + _Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + _Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd)) * flg_Zero, S_P1)SZ_YaLi(j, 4) = fun_XiaoShu(Tem_4, S_P1) '上行值Randomizeflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1flg_Zero = flg_Zero / Abs(flg_Zero)Tem_6 = Round(sL_range + (j - 11) / 4 * (sU_range - sL_range) + _Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + _Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd)) * flg_Zero, S_P1)SZ_YaLi(j, 6) = fun_XiaoShu(Tem_6, S_P1) '下行值Tem_5 = Round(Tem_4 - Tem_3, S_P1)SZ_YaLi(j, 5) = fun_XiaoShu(Tem_5, S_P1) 'Tem_7 = Round(Tem_6 - Tem_3, S_P1)SZ_YaLi(j, 7) = fun_XiaoShu(Tem_7, S_P1) 'Tem_8 = Round(Abs(Tem_7 - Tem_5), S_P1)SZ_YaLi(j, 8) = fun_XiaoShu(Tem_8, S_P1) ''            For k = str_Col To end_Col
'                'my_tbls(i).Cell(j, k).Select
'                Delay (10)
'                Select Case k
'                    Case Is = 1 '量程百分比
'                        TEM_S = (j - 11) / 4 * 100
'                        TEM_S = fun_XiaoShu(TEM_S, S_P)
'                    Case Is = 2 '当前检测点位
'                        TEM_S = L_Range + (j - 11) / 4 * (U_Range - L_Range)
'                        TEM_S = fun_XiaoShu(TEM_S, S_P)
'                    Case Is = 3 '标准电流值
'                        TEM_S = sL_range + (j - 11) / 4 * (sU_range - sL_range)
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                    Case Is = 4
'                        tem_Wucha = Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd))  '混沌
'
'                        TEM_S = sL_range + (j - 11) / 4 * (sU_range - sL_range) + tem_Wucha
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                    Case Is = 6
'                        tem_Wucha = Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd))  '混沌
'
'                        TEM_S = sL_range + (j - 11) / 4 * (sU_range - sL_range) + tem_Wucha
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                    Case Is = 5
'                        TEM_S = Get_Dbl(my_tbls(i).Cell(j, 4).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                    Case Is = 7
'                        TEM_S = Get_Dbl(my_tbls(i).Cell(j, 6).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                    Case Is = 8
'                        Wucha1 = Get_Val(my_tbls(i).Cell(j, str_Col + 4).Range.Text)
'                        Wucha2 = Get_Val(my_tbls(i).Cell(j, str_Col + 6).Range.Text)
'
'                        TEM_S = Abs(Wucha1 - Wucha2)
'                        TEM_S = fun_XiaoShu(TEM_S, S_P1)
'                End Select
'                    SZ_YaLi(j, k) = TEM_S '先赋值给数组，再填写内容
'
'                    'my_tbls(i).Cell(j, k).Range.Text = TEM_S
'            Next kNext jFor j = str_Row To end_Row '11-15行填写数据For k = str_Col To end_Colmy_tbls(i).Cell(j, k).Range.Text = SZ_YaLi(j, k)Next kNext jErase SZ_YaLi '清空静态数组my_tbls(i).Cell(1, 1).Select '动态更新页面If i = end_P Then: MsgBox "更新完毕！"Next iElseIf t_Style = "数显表" ThenFor i = str_P To end_PIf my_Stop = True Then: Exit Sub '停止程序'获得量程单元格内容，并转换成下限和上限TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text)'获得量程下限和上限MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))'获得信号输出量程TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row, Lc_Col + 2).Range.Text)MyRange = Split(TEM_S, ";")sL_range = CDbl1(MyRange(0))sU_range = CDbl1(MyRange(1))Jingdu = Get_Dbl(my_tbls(i).Cell(3, 4).Range.Text) '获得精度my_tbls(i).Cell(4, 4).Range.Text = "±" & fun_XiaoShu((sU_range - sL_range) * Jingdu * 0.01, 3) & _fun_Unit_YaLi(Get_Val(my_tbls(i).Cell(Lc_Row, Lc_Col + 2).Range.Text)) '误差自动填写-自动识别mA 和 V信号For j = str_Row To end_Row '10-14行填写数据For k = str_Col To end_ColRandomizeS_P = Cint1(T_Point.Text)S_P1 = Cint1(T_P_ShuJu.Text) '数据小数位数'my_tbls(i).Cell(j, k).SelectDelay (10)Select Case k
'                    Case Is = 1 '量程百分比，不需要，起始列是第2列
'                        Tem_S = (j - str_Row) / 4 * 100
'                        Tem_S = fun_XiaoShu(Tem_S, S_P)Case Is = 2 '当前检测点位TEM_S = L_Range + (j - str_Row) / 4 * (U_Range - L_Range)TEM_S = fun_XiaoShu(TEM_S, S_P)Case Is = 3 '标准电流值TEM_S = sL_range + (j - str_Row) / 4 * (sU_range - sL_range)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 4tem_Wucha = Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd))  '混沌TEM_S = sL_range + (j - str_Row) / 4 * (sU_range - sL_range) + tem_WuchaTEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 6tem_Wucha = Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd))  '混沌TEM_S = sL_range + (j - str_Row) / 4 * (sU_range - sL_range) + tem_WuchaTEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 5TEM_S = Get_Dbl(my_tbls(i).Cell(j, 4).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 7TEM_S = Get_Dbl(my_tbls(i).Cell(j, 6).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 8Wucha1 = Get_Val(my_tbls(i).Cell(j, str_Col + 3).Range.Text)Wucha2 = Get_Val(my_tbls(i).Cell(j, str_Col + 5).Range.Text)TEM_S = Abs(Wucha1 - Wucha2)TEM_S = fun_XiaoShu(TEM_S, S_P1)End Selectmy_tbls(i).Cell(j, k).Range.Text = TEM_SNext kNext jIf i = end_P Then: MsgBox "更新完毕！"Next iElseIf t_Style = "热电阻" ThenTEM_S = "GB/T 30121-2013工业铂热电阻及铂感温元件" & vbCrLf & _"本标准规定了对工业铂电阻感温元件和工业铂热电阻的要求及其温度-电阻关系。它们的电阻值是温度的规定函数。" & vbCrLf & _
"（-200~0度）Rt=R0*[1+A*t+B*t^2+C*(t-100)*t^3)]" & vbCrLf & _
"(0-850度)Rt=R0*(1+A*t+B*t^2)" & vbCrLf & _
"铂热电阻绕线型：AA,A,B,C;-50-250;-100~450;-196~600;-196~600;"RandomizeFor i = str_P To end_PIf my_Stop = True Then: Exit Sub '停止程序'确定小数位数S_P = Cint1(T_Point.Text)S_P1 = Cint1(T_P_ShuJu.Text)'获得精度Dim R_jingdu$, tem_Range$R_jingdu = Get_Val(my_tbls(i).Cell(3, 4).Range.Text)Select Case R_jingdu '获得精度.AA级,A级，B级，C级。Case Is = "A级", "A"Jingdu = 0.15tem_Range = "-100~450℃"Case Is = "B级", "B"Jingdu = 0.3tem_Range = "-196~600℃"Case Is = "C级", "C"Jingdu = 0.6tem_Range = "-196~600℃"Case Is = "AA级", "AA"Jingdu = 0.3tem_Range = "-50~250℃"Case ElseJingdu = 0.15tem_Range = "-100~450℃"End Select'获得量程,为计算百分比做准备TEM_S = my_tbls(i).Cell(Lc_Row, Lc_Col).Range.TextIf Get_Val(TEM_S) = "" Then '如果量程忘记填写，重新赋值量程my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text = tem_RangeTEM_S = Get_Range(tem_Range)ElseTEM_S = Get_Range(TEM_S)End IfMyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))'填写允许误差值my_tbls(i).Cell(4, 4).Range.Text = "±" & fun_XiaoShu(Jingdu, S_P1) & "℃"'准备检测点数值，准备部署数据T_Range = Split(T_jiancedian.Text, ",") '人为定义检测点，但是要考虑规范要求'按检测点个数，填写数据end_Row = str_Row + UBound(T_Range)If end_Row > my_tbls(i).Rows.Count - 2 Then: end_Row = my_tbls(i).Rows.Count - 2For j = str_Row To end_RowDim tem_S_jcd# '定义当前检测点数值tem_S_jcd = CDbl1(T_Range(j - str_Row))For k = str_Col To end_Col '按列写入标准值和检测数据'my_tbls(i).Cell(j, k).SelectDelay (10)Select Case kCase Is = 1 '量程百分比If U_Range = L_Range ThenMsgBox "量程下限和上限相等，除数为0，请检查量程，尽量改成这样的形式：0-100单位"End IfTEM_S = (tem_S_jcd - U_Range) / (U_Range - L_Range) * 100TEM_S = fun_XiaoShu(TEM_S, S_P)Case Is = 2 '当前检测点位TEM_S = tem_S_jcdTEM_S = fun_XiaoShu(TEM_S, S_P)Case Is = 3 '标准电阻值TEM_S = Fun_Pt100(tem_S_jcd)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 4tem_Wucha = (Fun_Pt100(tem_S_jcd) - Fun_Pt100(tem_S_jcd - 1.5)) * JD_k * Rnd '计算当前温度下的允许误差值，确保在误差范围tem_Wucha = tem_Wucha * (HD_k * (Rnd))   '混沌TEM_S = Fun_Pt100(tem_S_jcd) + tem_WuchaTEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 5TEM_S = Get_Dbl(my_tbls(i).Cell(j, 4).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 6tem_Wucha = (Fun_Pt100(tem_S_jcd) - Fun_Pt100(tem_S_jcd - 1.5)) * JD_k * (0.5 + Rnd) * Rnd '计算当前温度下的允许误差值，确保在误差范围tem_Wucha = tem_Wucha * (HD_k * (Rnd))   '混沌TEM_S = Fun_Pt100(tem_S_jcd) + tem_WuchaTEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 7TEM_S = Get_Dbl(my_tbls(i).Cell(j, 6).Range.Text) - Get_Dbl(my_tbls(i).Cell(j, 3).Range.Text)TEM_S = fun_XiaoShu(TEM_S, S_P1)Case Is = 8Wucha1 = Get_Val(my_tbls(i).Cell(j, str_Col + 4).Range.Text)Wucha2 = Get_Val(my_tbls(i).Cell(j, str_Col + 6).Range.Text)TEM_S = Abs(Wucha1 - Wucha2)TEM_S = fun_XiaoShu(TEM_S, S_P1)End Selectmy_tbls(i).Cell(j, k).Range.Text = TEM_SNext kNext jIf i = end_P Then: MsgBox "更新完毕！"Next iElseIf t_Style = "温度变送器" ThenRandomize'准备检测点数值，准备布署数据T_Range = Split(T_jiancedian.Text, ",") '人为定义检测点，但是要考虑规范要求For i = str_P To end_PIf my_Stop = True Then: Exit Sub '停止程序Jingdu = Get_Dbl(my_tbls(i).Cell(3, 4).Range.Text) '获得精度TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text) '获得量程MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))'获得信号输出量程TEM_S = Get_Range(my_tbls(i).Cell(Lc_Row + 1, Lc_Col).Range.Text)MyRange = Split(TEM_S, ";")sL_range = CDbl1(MyRange(0))sU_range = CDbl1(MyRange(1))S_P = Cint1(T_Point.Text)S_P1 = Cint1(T_P_ShuJu.Text)my_tbls(i).Cell(4, 4).Range.Text = "±" & Format(Jingdu * (sU_range - sL_range) / 100#, Set_P(3)) & "mA"end_Row = str_Row + UBound(T_Range)If end_Row > my_tbls(i).Rows.Count - 2 Then: end_Row = my_tbls(i).Rows.Count - 2For j = str_Row To end_Row '根据检测点位，逐行填写数据RandomizeDelay (5)SZ_YaLi(j, 1) = fun_XiaoShu((T_Range(j - str_Row) - L_Range) / (U_Range - L_Range) * 100, S_P) '百分比SZ_YaLi(j, 2) = fun_XiaoShu(T_Range(j - str_Row), S_P) '标准输入值Tem_3 = Round(sL_range + (T_Range(j - str_Row) - L_Range) / (U_Range - L_Range) * (sU_range - sL_range), S_P1) '标准电流值SZ_YaLi(j, 3) = fun_XiaoShu(Tem_3, S_P1) '标准电流值Randomizeflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1flg_Zero = flg_Zero / Abs(flg_Zero)Tem_4 = Round(sL_range + (T_Range(j - str_Row) - L_Range) / (U_Range - L_Range) * (sU_range - sL_range) + _Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd)) * flg_Zero, S_P1)SZ_YaLi(j, 4) = fun_XiaoShu(Tem_4, S_P1) '上行值Randomizeflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1flg_Zero = flg_Zero / Abs(flg_Zero)Tem_6 = Round(sL_range + (T_Range(j - str_Row) - L_Range) / (U_Range - L_Range) * (sU_range - sL_range) + _Jingdu / 100 * (sU_range - sL_range) * JD_k * Rnd * ((1 + j + Abs(end_Row / 2 - j)) / j) * (HD_k * (Rnd)) * flg_Zero, S_P1)SZ_YaLi(j, 6) = fun_XiaoShu(Tem_6, S_P1) 'Tem_5 = Round(Tem_4 - Tem_3, S_P1)SZ_YaLi(j, 5) = fun_XiaoShu(Tem_5, S_P1) 'Tem_7 = Round(Tem_6 - Tem_3, S_P1)SZ_YaLi(j, 7) = fun_XiaoShu(Tem_7, S_P1) 'Tem_8 = Round(Abs(Tem_7 - Tem_5), S_P1)SZ_YaLi(j, 8) = fun_XiaoShu(Tem_8, S_P1) 'Next jFor j = str_Row To end_Row '11-15行填写数据For k = str_Col To end_Colmy_tbls(i).Cell(j, k).Range.Text = SZ_YaLi(j, k)Next kNext jErase SZ_YaLi '清空静态数组my_tbls(i).Cell(1, 1).SelectIf i = end_P Then: MsgBox "更新完毕！"Next i
ElseIf t_Style = "温度计" Or Cmb_sty.Text = "压力表" Then
i = 1
j = 1
S_P1 = Cint1(T_P_ShuJu.Text) '数据小数位数RandomizeFor i = str_P To end_PFor j = str_Row To my_tbls(i).Rows.Count - 2If my_Stop = True Then: Exit Sub '停止程序If Len(my_tbls(i).Cell(j, 2).Range.Text) > 2 ThenTEM_S = Get_Range(my_tbls(i).Cell(j, 5).Range.Text)MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))'获得精度'MsgBox L_range & ":" & U_rangeTEM_S = Replace(Get_Val(my_tbls(i).Cell(j, 6).Range.Text), "%", "")Jingdu = CDbl1(TEM_S) / 100#'计算允许误差YXWC = (U_Range - L_Range) * Jingdu'my_tbls(i).Cell(j, 7).Selectmy_tbls(i).Cell(j, 7).Range.Text = fun_XiaoShu(YXWC, S_P1)'实际误差tem_Wucha = ((-1) ^ (CInt((10 * Rnd)))) * YXWC * Jdxs * 2 * ((HD_k * (Rnd)) / HD_k) '混沌my_tbls(i).Cell(j, 8).Range.Text = fun_XiaoShu(tem_Wucha, S_P1)On Error Resume Nextmy_tbls(i).Cell(j, 9).Range.Text = "合格"End IfNext jIf i = end_P Then: MsgBox "更新完毕！"Next i
ElseIf t_Style = "模拟量回路测试" Or Cmb_sty.Text = "基础化I/O组件模拟量测试" Thensub_AIAO_ShuJu my_tbls, str_P, end_P, str_Row, end_Row, str_Col, end_Col
ElseIf t_Style = "安全栅" ThenFor i = str_P To end_PIf end_Row > my_tbls(i).Rows.Count - 2 Then: end_Row = my_tbls(i).Rows.Count - 2For j = str_Row To end_RowIf my_Stop = True Then: Exit Sub '停止程序If Chk__Ref_Date = False Then'检查到表格中有数据就跳过本行TEM_S = Get_Val(my_tbls(i).Cell(j, Cint1(T_col_BZ.Text) + 1).Range.Text)If TEM_S <> "" Then'MsgBox TEM_SGoTo Tiao_anquanshanEnd IfEnd IfTEM_S = Get_Val(my_tbls(i).Cell(j, Cint1(T_col_BZ.Text)).Range.Text)If TEM_S <> "" Then  '测量范围没有数据的话就认为是空数据行直接跳过L_Range = CDbl1(Get_Val(my_tbls(i).Cell(j, Cint1(T_col_BZ.Text)).Range.Text))U_Range = CDbl1(Get_Val(my_tbls(i).Cell(j, Cint1(T_col_BZ.Text + 2)).Range.Text))For k = str_Col To end_Col'my_tbls(i).Cell(j, k).Select'计算误差RandomizeYXWC = (U_Range - L_Range) * CDbl1(T_jingdu.Text) / 100#tem_Wucha = ((-1) ^ (CInt((10 * Rnd)))) * YXWC * Jdxs * ((HD_k * (Rnd)) / HD_k)  '混沌Delay (1)'逐项赋值 0%；50%；100%If k < 11 Thenmy_tbls(i).Cell(j, k).Range.Text = Format(CDbl1(Get_Val(my_tbls(i).Cell(j, k - 3).Range.Text)) + tem_Wucha, S_P)ElseIf k = 11 ThenJingdu = Get_Dbl(my_tbls(i).Cell(j, Cint1(T_col_BZ.Text) - 1).Range.Text)my_tbls(i).Cell(j, k).Range.Text = "±" & fun_XiaoShu((U_Range - L_Range) * CDbl1(Jingdu) / 100#, Cint1(T_point_wucha))End IfIf k = end_Col Thenmy_tbls(i).Cell(j, k).Range.Text = "合格"End IfNext kEnd IfTiao_anquanshan:Next jIf i = end_P Then: MsgBox "更新完毕！"Next i
End If'启用word刷新
Application.ScreenUpdating = True
End SubPrivate Sub Cmd_ref_VA_Click()
'根据原始内容和精度更改数据,调节阀
'控制word刷新
Application.ScreenUpdating = FalseDim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%, flg_Zero#
Dim CanKao_P%, str_P%, end_P%, col_BZ%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S As Variant, tem_Ss As Variant, MyRange As Variant
Dim Jingdu#, tem_Wucha#, Points%, S_P$
Dim Wucha1#, Wucha2#, Huicha#
Dim U_Range#, L_Range#, tem_Unit$, tem_Unit_len%
Dim my_tbls As Tables
Dim my_table As TableDim my_XCh As Variant '行程
Dim xc_Row%, xc_Col% '行程所在单元格位置
Dim tem_i% '临时变量
Dim Flg_i% '起点数据特殊处理，置零。Dim Up1#, Up2#, Dn1#, Dn2# '正行程1，2；反行程1，2。
Dim HD_k As Variant  '随机数的混沌程度
Dim Sz1() As Variant, Sz2() As Variantmy_Stop = FalseSet my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)Jingdu = CDbl(T_VA_JD.Text)
Points = Cint1(T_VA_S_P.Text)
col_BZ = Cint1(T_VA_bz_Row.Text)CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)xc_Row = Cint1(T_xc_Row.Text)
xc_Col = Cint1(T_xc_Col.Text)
HD_k = CDbl1(T_HD_k.Text)n = my_tbls.CountIf CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_P
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_Col + 1T_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End If'设定小数点
S_P = Set_P(Points)
Randomize
For i = str_P To end_Pmy_tbls(i).Cell(1, 1).SelectIf my_Stop = True Then: Exit Sub '停止程序'获得行程数值'获得量程TEM_S = Get_Range(my_tbls(i).Cell(xc_Row, xc_Col).Range.Text)MyRange = Split(TEM_S, ";")L_Range = CDbl1(MyRange(0))U_Range = CDbl1(MyRange(1))my_XCh = Get_Dbl(U_Range - L_Range)ReDim Sz1(end_Row - str_Row, end_Col - str_Col)With my_tbls(i)For j = str_Row To end_Row'.Cell(j, k).SelectSelect Case jCase Is = str_Row'更正单位tem_Unit = .Cell(4, 1).Range.Texttem_Unit_len = Len(tem_Unit) - 1.Cell(19, 1).Range.Text = "标准行程" & Mid(tem_Unit, 3, tem_Unit_len).Cell(20, 1).Range.Text = "实测行程" & Chr(13) & Mid(tem_Unit, 3, tem_Unit_len).Cell(22, 1).Range.Text = "实测行程" & Chr(13) & Mid(tem_Unit, 3, tem_Unit_len).Cell(24, 1).Range.Text = "正反行程回差" & Chr(13) & Mid(tem_Unit, 3, tem_Unit_len)'写入标准值所在行For k = str_Col To end_Col.Cell(j, k).Range.Text = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)Next kCase Is <= str_Row + 2'第1遍正反行程For k = str_Col To end_ColIf k = str_Col Or k = end_Col ThenFlg_i = 0ElseFlg_i = 1End Ifflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1tem_Wucha = flg_Zero / Abs(flg_Zero) * Flg_i * Jingdu * Int(Rnd * (2 + (k - str_Col) / str_Col) - 1) * ((HD_k * (Rnd)) / (HD_k / 3))     '混沌TEM_S = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)TEM_S = TEM_S + tem_WuchaSz1(j - str_Row, k - str_Col) = Format(TEM_S, S_P)
'                            .Cell(j, k).Range.Text = Format(TEM_S, S_P)Next kCase Is <= str_Row + 4, Is > str_Row + 2'第2遍正反行程For k = str_Col To end_ColIf k = str_Col Or k = end_Col ThenFlg_i = 0ElseFlg_i = 1End Ifflg_Zero = Rnd - 0.5If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1tem_Wucha = flg_Zero / Abs(flg_Zero) * Flg_i * Jingdu * Rnd * Int(Rnd * (2 + (k - str_Col) / str_Col) - 1) * ((HD_k * (Rnd)) / (HD_k / 3))  '混沌TEM_S = Format(L_Range + (k - str_Col) * my_XCh / (end_Col - str_Col), S_P)TEM_S = TEM_S + tem_WuchaSz1(j - str_Row, k - str_Col) = Format(TEM_S, S_P)
'                        .Cell(j, k).Range.Text = Format(TEM_S, S_P)Next kCase ElseMsgBox "超出行数"End SelectNext jEnd With'正反行程误差的较大值'正反行程误差的较大值For k = str_Col To end_ColUp1 = Sz1(1, k - str_Col)Dn1 = Sz1(2, k - str_Col)Up2 = Sz1(3, k - str_Col)Dn2 = Sz1(4, k - str_Col)Sz1(5, k - str_Col) = Format(Max(Abs(Up1 - Dn1), Abs(Up2 - Dn2)), S_P)
'           .Cell(j, k).Range.Text = Format(Max(Abs(Up1 - Dn1), Abs(Up2 - Dn2)), S_P)Next k'集中写入数据With my_tbls(i)For j = str_Row To end_RowFor k = str_Col To end_ColIf Sz1(j - str_Row, k - str_Col) <> "" ThenIf j <= str_Row + 4 Then  '第5行列数少1，需要减1.Cell(j, k + 1).Range.Text = Sz1(j - str_Row, k - str_Col)Else.Cell(j, k).Range.Text = Sz1(j - str_Row, k - str_Col)End IfEnd IfNext kNext jEnd With
Next i
'控制word刷新
Application.ScreenUpdating = True
End Sub
Public Function Max(ByVal a#, ByVal b#) As Double
'获得2个数中较大值
If a >= b ThenMax = a
ElseMax = b
End If
End FunctionPublic Function Get_Range(ByVal R_S As Variant) As String
'获得仪表量程
Dim L_R_S%, i%, i1_R_S$, i2_R_S$, i3_R_S$, URL$, URH$, i_URL%, i_urL1%, i_URH%, URH_1%
Dim PL%, PL1%, PH%, PH1% '保护数据不在更新
Dim ZIMU$
ZIMU = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ°℃℉％mol㏒㎡?㏄㎞㎝㎜㎏ml′″"
L_R_S = Len(R_S)
PL = 0 '定位下限位置
PH = 0 '定位上限位置
If L_R_S > 0 ThenR_S = Replace(R_S, Chr(13) & Chr(7), "") '替换掉换行符R_S = Replace(R_S, " ", "") '替换掉空格R_S = Replace(R_S, "+", "") '替换掉正号L_R_S = Len(R_S)'去除量程范围右侧连续的无效字符For i = L_R_S To 1 Step -1If InStr(1, "0123456789.", Mid(R_S, i, 1)) > 0 ThenR_S = Left(R_S, i)L_R_S = Len(R_S)Exit ForEnd IfNext i'从量程左侧开始获取量程For i = 1 To L_R_Si1_R_S = Mid(R_S, i, 1)i2_R_S = Mid(R_S, i + 1, 1)i3_R_S = Mid(R_S, i + 2, 1)If PL = 0 And InStr(1, "-.0123456789", i1_R_S) < 1 And InStr(1, ".0123456789", i2_R_S) < 1 Then'发现2个连续的非数值，定位量程下限URL = Left(R_S, i - 1)i_URL = i - 1PL = 1ElseIf PL = 0 And InStr(1, "-.0123456789", i1_R_S) > 0 And InStr(1, ".0123456789", i2_R_S) < 1 And InStr(1, "-+.0123456789", i3_R_S) > 0 Then'数字/非数字/数字模式。量程下限和上限的分割点i;先发现量程下限URL = Left(R_S, i)i_URL = iURH_1 = i + 1PL = 1PH1 = 1ElseIf PL = 0 And i = L_R_S Then '下限是0，只有上限的量程URL = 0URH = Left(R_S, i)PL = 1PH = 1Exit ForEnd IfIf PL = 1 And PH = 0 And PH1 = 0 And InStr(1, "-.0123456789", i1_R_S) < 1 And InStr(1, ".0123456789", i2_R_S) > 0 Then'发现量程上限的起始值URH_1 = i + 1PH1 = 1End IfIf PL = 1 And PH1 = 1 And PH = 0 And InStr(1, "-.0123456789", i3_R_S) < 1 Then'已经发现量程下限和上限起始值，发现非数字值，发现单位第一个字母；后发现量程上限终止值i_URH = i + 1URH = Mid(R_S, URH_1 + 1, i_URH - URH_1)PH = 1End IfIf PL = 1 And PH = 0 And i = L_R_S Then'没有单位的量程i_URH = iURH = Mid(R_S, URH_1 + 1, i_URH - URH_1)PH = 1'MsgBox "无单位"End IfIf i >= L_R_S And PH = 0 And PL = 0 Then'没有量程URL = 0URH = 0PH = 1PH1 = 1PL = 1Exit ForEnd IfNext iGet_Range = URL & ";" & URHElseGet_Range = "0;0"PL = 1PH = 1PH1 = 1
End IfEnd Function
Private Sub cmd_ziti_Click()
'更改字体
'每个表格的指定区域内容与第一页该区域内容一致
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S$, tem_Ss$Dim my_tbls As Tables
Dim my_table As Table
Dim rng As RangeSet my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)n = my_tbls.CountSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_PT_str_P.Text = 1
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End If
If Chk_HG_YE.Value = True ThenFor i = str_P To end_P'选中一个表格区域,区域选择Set rng = ActiveDocument.Range(my_tbls(i).Cell(str_Row, str_Col).Range.start, my_tbls(i).Cell(end_Row, end_Col).Range.End)rng.SelectGaiziti T_ziti.Text, Cint1(T_zihao.Text), Cint1(T_JJ.Text)Next i
ElseGaiziti T_ziti.Text, Cint1(T_zihao.Text), Cint1(T_JJ.Text)
End If
'Selection.HomeKey Unit:=wdStoryEnd SubPrivate Sub lab_ref_VA_Click()
Cmd_ref_VA.Enabled = True
End SubPrivate Sub lab_show_page4_Click()
MultiPage1.page4.Visible = Not MultiPage1.page4.Visible
MultiPage1.page5.Visible = Not MultiPage1.page5.Visible
MultiPage1.page6.Visible = Not MultiPage1.page6.Visible
MultiPage1.page8.Visible = Not MultiPage1.page8.Visible
End SubPrivate Sub Lb_zihao_Click()
Gaiziti T_ziti.Text, Cint1(Lb_zihao.Caption), Cint1(T_JJ.Text)
End SubPrivate Sub Lbl_flg_cmd_Click()
Cmd_Ref_Date.Enabled = True
End SubPrivate Sub T_end_Col_Change()
end_Col = Cint1(T_end_Col.Text)
End SubPrivate Sub T_end_P_Change()
Dim my_tbls As Tables
Set my_tbls = ActiveDocument.Tables
If Cint1(T_end_P.Text) > my_tbls.Count ThenMsgBox "页数超出word中表格的实际页数，已经更正为word的表格总页数:" & my_tbls.Count & "页"T_end_P.Text = my_tbls.Count
End If
End SubPrivate Sub T_end_Row_Change()Dim my_tbls As Tables
Set my_tbls = ActiveDocument.Tables
On Error Resume Next
If Cint1(T_end_Row.Text) > my_tbls(Cint1(T_str_P.Text)).Rows.Count Then'MsgBox "更正表格行数"T_end_Row.Text = my_tbls(1).Rows.Count
End If
end_Row = Cint1(T_end_Row.Text)
End SubPrivate Sub T_ExcelPath_Change()End SubPrivate Sub T_INS_Change()
L_T_INS.Caption = T_INS.LineCount
End Sub'Private Sub T_INS_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'If T_INS.Text = "请在这里输入随机数范围：例如(1-10)" Then T_INS.Text = "1.9~2.3dB"
'If InStr(1, Lab_state.Caption, "完成") > 0 Then: Lab_state.Caption = "休息中,喵～"
'End SubPrivate Sub T_INS2_Change()
L_T_INS2.Caption = T_INS2.LineCount
End SubPrivate Sub T_INS3_Change()
L_T_INS3.Caption = T_INS3.LineCount
End SubPrivate Sub T_INS4_Change()
L_T_INS4.Caption = T_INS4.LineCount
End SubPrivate Sub T_jiancedian_Change()
Dim i As Integer
For i = 1 To Len(T_jiancedian.Text)If InStr(1, "0123456789.,", Mid(T_jiancedian.Text, i, 1)) = False ThenMsgBox "检测点只能输入【数值】和【.】和【英文半角逗号】"End If
Next i
End SubPrivate Sub T_NewPages_Change()End SubPrivate Sub T_PIC_Width_Change()End SubPrivate Sub T_StartX_Change()End SubPrivate Sub T_str_Col_Change()
str_Col = Cint1(T_str_Col.Text)
End SubPrivate Sub T_str_Row_Change()
str_Row = Cint1(T_str_Row.Text)
End SubPrivate Sub T_StrRow_Change()
T_EndRow.Text = CInt(T_StrRow.Text) + CInt(T_NoOfPage.Text) - 1
End SubPrivate Sub T_StrY_Change()End SubPrivate Sub T_yw_dP_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
T_yw_UdP.Text = Format(T_yw_LdP + T_yw_dP, "0.000")
End SubPrivate Sub T_yw_LdP_Change()
yw_S_js
End SubPrivate Sub T_ZBJX_Change()End SubPrivate Sub T_zihao_Change()
Gaiziti T_ziti.Text, Cint1(T_zihao.Text), Cint1(T_JJ.Text)
End Sub
'1-操作-改字体****************************************************'2-操作-行高********************************************************Private Sub T_hanggao_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) '更改行高
Dim i As Integer
'MsgBox KeyCode
If T_hanggao.Text <> "" Then
i = CInt(T_hanggao.Text)
If KeyCode = 38 ThenT_hanggao.Text = i + 1
ElseIf KeyCode = 40 ThenT_hanggao.Text = i - 1
ElseIf KeyCode < 58 And KeyCode > 47 ThenHg = CInt(T_hanggao.Text)Hanggao Hg, K1
End If
End If
End Sub
Public Sub Cmd_hanggao_Click()'每个表格的指定区域内容与第一页该区域内容一致
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S$, tem_Ss$
Dim my_tbls As Tables
Dim my_table As Table
Set my_tbls = ActiveDocument.TablesSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If Chk_HG_YE.Value = False ThenHg = CInt(T_hanggao.Text)Hanggao Hg, K1
Elsestr_Row = Cint1(T_str_Row.Text)str_Col = Cint1(T_str_Col.Text)end_Row = Cint1(T_end_Row.Text)end_Col = Cint1(T_end_Col.Text)CanKao_P = (T_CanKao_P.Text)str_P = Cint1(T_str_P.Text)end_P = Cint1(T_end_P.Text)str_DZ = Cint1(T_str_dz.Text)n = my_tbls.CountIf CanKao_P > n Or CanKao_P < 1 ThenMsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_PEnd IfIf end_P > n ThenMsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_PT_str_P.Text = 1End IfIf end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_RowEnd IfIf end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_ColEnd IfIf end_P < str_P Thenend_P = str_PT_end_P.Text = end_PEnd IfFor i = str_P To end_PFor j = str_Row To end_RowFor k = str_Col To end_Col'my_tbls(i).Cell(j, k).Selectmy_tbls(i).Cell(j, k).height = my_tbls(str_P).Cell(j, k).heightNext kNext jNext i
End If
End Sub
Private Sub T_hanggao_Change()
If T_hanggao.Text <> "" Then
Hg = CInt(T_hanggao.Text)
Hanggao Hg, K1
End If
End SubPrivate Sub L6_Click()
Hg = 6
Hanggao Hg, K1
End SubPrivate Sub L8_Click()
Hg = 8
Hanggao Hg, K1
End Sub
Private Sub L10_Click()
Hg = 10
Hanggao Hg, K1
End SubPrivate Sub L12_Click()
Hg = 12
Hanggao Hg, K1
End SubPrivate Sub L20_Click()
Hg = 20
Hanggao Hg, K1
End Sub
'2-操作-行高********************************************************'3-操作-段落*********************************************************
Private Sub cmd_LP_Click()
'更改行距
Dim i As Double
i = Cint1(T_JJ.Text)
If i > 0.7 ThenWith Selection.ParagraphFormat.LineSpacing = T_JJ.TextEnd With
End If
End Sub
Private Sub T_JJ_Change()
Dim i As Double
i = Cint1(T_JJ.Text)
If i > 0.7 ThenWith Selection.ParagraphFormat.LineSpacing = T_JJ.TextEnd With
End If
End Sub
'3-操作-段落*********************************************************
'4-操作-表格*********************************************************
Private Sub cmd_str_Rowcol_Click()
'获得选中单元格的行号和列号
Dim iRow%, iCol%iRow = Selection.Information(wdEndOfRangeRowNumber)
iCol = Selection.Information(wdEndOfRangeColumnNumber)
T_str_Row.Text = iRow
T_str_Col.Text = iCol
T_str_P.Text = Selection.Information(wdActiveEndAdjustedPageNumber)
End Sub
Private Sub cmd_end_Rowcol_Click()
'获得选中单元格的行号和列号
Dim iRow%, iCol%iRow = Selection.Information(wdEndOfRangeRowNumber)
iCol = Selection.Information(wdEndOfRangeColumnNumber)T_end_Row.Text = iRow
T_end_Col.Text = iCol
T_end_P.Text = Selection.Information(wdActiveEndAdjustedPageNumber)
End Sub
Private Sub cmd_biaogefuzhi_Click()
'每个表格的指定区域内容与第一页该区域内容一致
'控制word刷新
Application.ScreenUpdating = False
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S$, tem_Ss$Dim my_tbls As Tables
Dim my_table As Table
Set my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)n = my_tbls.CountSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_P
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End IfFor i = str_P To end_PFor j = str_Row To end_RowFor k = str_Col To end_ColTEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text) '获取单元格原始内容If Chk_fugai.Value = -1 Then: TEM_S = "" '如果需要覆盖原始内容的话Delay (10)If Chk_dizeng.Value = -1 Thentem_Ss = T_QianZhui.Text & TEM_S & T_HouZhui.Text & (str_DZ + i_DZ)Elsetem_Ss = T_QianZhui.Text & TEM_S & T_HouZhui.TextEnd Ifmy_tbls(i).Cell(j, k).Range.Text = tem_Sstem_Ss = ""i_DZ = i_DZ + 1Next kNext j
Next i
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private Sub Cmd_Tianxie_Click()
'控制word刷新
Application.ScreenUpdating = False'将txt中内容写入word的指定表格，按规律
Dim str_Row%, end_Row%, str_Col%, end_Col%, n%, i%, j%, k%
Dim CanKao_P%, str_P%, end_P%
Dim str_DZ%, i_DZ% '递增
Dim TEM_S$, tem_Ss$Dim SZ_S As VariantDim my_tbls As Tables
Dim my_table As Table
Set my_tbls = ActiveDocument.Tablesstr_Row = Cint1(T_str_Row.Text)
str_Col = Cint1(T_str_Col.Text)
end_Row = Cint1(T_end_Row.Text)
end_Col = Cint1(T_end_Col.Text)
CanKao_P = (T_CanKao_P.Text)
str_P = Cint1(T_str_P.Text)
end_P = Cint1(T_end_P.Text)
str_DZ = Cint1(T_str_dz.Text)n = my_tbls.CountSub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
Lab_state.Caption = "拼命填写中..."
If T_INS.Text <> "" ThenSZ_S = Split(T_INS.Text, vbCrLf)
End IfIf CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"CanKao_P = nT_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"end_P = nT_end_P.Text = end_P
End If
If end_Row < str_Row Thenend_Row = str_RowT_end_Row.Text = end_Row
End If
If end_Col < str_Col Thenend_Col = str_ColT_end_Col = end_Col
End If
If end_P < str_P Thenend_P = str_PT_end_P.Text = end_P
End If'前缀；后缀；或者直接赋值
If IsEmpty(SZ_S) = False Then
For j = str_Row To end_RowFor k = str_Col To end_ColFor i = str_P To end_PWith my_tbls(i).Cell(j, k)If Chk_fugai1 = True Or Len(my_tbls(i).Cell(j, k).Range.Text) <= 2 Then.Range.Text = ""Delay (10)If i - str_P >= LBound(SZ_S) And i - str_P <= UBound(SZ_S) ThenIf Chk_qianzhui1.Value = -1 Then.Range.Text = SZ_S(i - str_P) & Replace(.Range.Text, Chr(13), "")End IfIf CHK_houzhui1.Value = -1 Then.Range.Text = Replace(.Range.Text, Chr(13), "") & SZ_S(i - str_P)End IfIf CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Then.Range.Text = SZ_S(i - str_P)End IfEnd IfEnd IfEnd With'           If I = end_P Then: MsgBox "填写完成！"If i = end_P Then: Lab_state.Caption = "填写完成！"Next iNext k
Next j
Else
MsgBox "写入表格的数据列为空值，请确认！"
MultiPage1(3).Visible = True
T_INS.Text = "请在这里输入数据"
End If'控制word刷新
Application.ScreenUpdating = True
End Sub
Private Sub cmd_T_jz_Click()
Me.T_jz
End Sub
Private Sub Cmd_YBJ_Click()
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
YEBIANJU1
End Sub
Private Sub cmd_cls_Click()
T_INS.SetFocus
T_INS.Text = ""
T_INS2.SetFocus
T_INS2.Text = ""
T_INS3.SetFocus
T_INS3.Text = ""
T_INS4.SetFocus
T_INS4.Text = ""
End Sub
'4-操作-表格*********************************************************'5-操作-液位计算*********************************************************
Private Sub T_yw_ro_Change()
yw_S_js
End Sub
Private Sub T_yw_g_Change()
yw_S_js
End SubPrivate Sub T_yw_h_Change()
yw_S_js
End Sub
Private Sub cmd_yw_dp_Copy_Click()
Selection.Text = T_yw_dP.Text
End SubPrivate Sub cmd_yw_Ldp_Copy_Click()
Selection.Text = T_yw_LdP.Text
End SubPrivate Sub cmd_yw_Udp_Copy_Click()
Selection.Text = T_yw_UdP.Text
End Sub
Private Sub cmd_yw_Copy_Click()
Selection.Text = T_yw_LCh.Text
End Sub
Private Sub cmd_yw_Ro_Click()
Selection.Text = T_yw_Ro.Text & "x1000kg/m3"
End SubPrivate Sub CSH_Comb_DYMC()
'初始化单元名称列表
Dim S_Cmb_STY$, i%
Dim Sz_Cmb As Variant
S_Cmb_STY = "天俱时工程科技集团有限公司;" & _
"河北莫兰斯环境科技股份有限公司;" & _
"伊犁川宁生物技术有限公司;" & _
"伊犁川宁生物技术股份有限公司"
Sz_Cmb = Split(S_Cmb_STY, ";")
For i = LBound(Sz_Cmb) To UBound(Sz_Cmb)Comb_SGDW.AddItem Sz_Cmb(i), i
Next i
End Sub
Public Sub csh_comb_FYF()
'初始化分页符分页位置列表
Dim TEM_S$, i%, SZ_fyf As Variant
TEM_S = "天俱时工程,河北莫兰斯"
SZ_fyf = Split(TEM_S, ",")For i = LBound(SZ_fyf) To UBound(SZ_fyf)Comb_fyf.AddItem SZ_fyf(i), i
Next i
Comb_fyf.ListIndex = 0
End SubPrivate Sub TextBox1_Change()End SubPrivate Sub UserForm_Activate()
Dim i%, S_Cmb_STY$
Dim Sz_Cmb As Variant
MultiPage1.Value = 0
MultiPage1.page4.Visible = False
MultiPage1.page8.Visible = False
S_Cmb_STY = "数据类型,热电阻,温度变送器,压力变送器,温度计,压力表,调节阀,模拟量回路测试,基础化I/O组件模拟量测试,安全栅,数显表" '名字不可以更改，数据更新参考的是中文名字不是序号
Sz_Cmb = Split(S_Cmb_STY, ",")
For i = LBound(Sz_Cmb) To UBound(Sz_Cmb)Cmb_sty.AddItem Sz_Cmb(i), iCmb_sty_01.AddItem Sz_Cmb(i), i
Next i
Cmb_sty.ListIndex = 0
Chushi_AIAODIDO '初始化自动化IO组件相关变量
Chushi_Comb_AIAO_Range '初始化AI/AO量程
CSH_ZT_types '初始化开关量回路类型
CSH_Comb_DYMC
csh_comb_FYF '初始化分页符复合框
chushihua_qizhibiaoqian '初始化旗帜标签
Close #1
End Sub
'让窗口大小可以用鼠标调节-------------------------------------------------------
Private Sub UserForm_Initialize()Dim hWndForm As LongDim IStyle As LonghWndForm = FindWindow("ThunderDFrame", Me.Caption)IStyle = GetWindowLong(hWndForm, GWL_STYLE)IStyle = IStyle Or WS_THICKFRAME '还原IStyle = IStyle Or WS_MINIMIZEBOX '最小化IStyle = IStyle Or WS_MAXIMIZEBOX '最大化SetWindowLong hWndForm, GWL_STYLE, IStyle
End Sub
'让窗口大小可以用鼠标调节-------------------------------------------------------
'5-操作-液位计算*********************************************************