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 Long
Private Type PointAPI '定义一个类型 PointAPI
X As Long
Y 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_sgORjs
SZ_Name() As String
SZ_Count() As Integer
SZ_Page() As String
sz_Filename() As String
End Type
'公共函数-文字处理----------------------------------------------------
Public Function Cint1(ByVal i As Variant)
If IsNumeric(i) Then
Cint1 = CInt(i)
End If
If Cint1 < 0 Then
Cint1 = Abs(Cint1)
End If
End Function
Public Function CDbl1(ByVal i As Variant)
If IsNumeric(i) Then
CDbl1 = CDbl(i)
End If
End Function
Public Function Get_Val(ByVal i_s As Variant) As Variant
'去除单元格内容中的换行符和手动换行符
'去除单元格内容中的空格
'获得纯文本或者获得纯数值
Dim TEM_S As String
TEM_S = Replace(i_s, Chr(13), "")
TEM_S = Replace(TEM_S, Chr(7), "")
TEM_S = Replace(TEM_S, " ", "")
If TEM_S <> "" Then
Get_Val = TEM_S
Else
Get_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 Then
Ds = Ds & ss
Else
Exit For
End If
Next i
'去除数字右边的一些-+等非数字字符
TEM_S = Ds
Ds = ""
For i = Len(TEM_S) To 1 Step -1
ss = Mid(TEM_S, i, 1)
If InStr(1, "0123456789.", ss) > 0 Then
Ds = Left(TEM_S, i)
Exit For
ElseIf i = 1 Then
Ds = TEM_S
Exit For
End If
Next i
If Len(Ds) > 0 Then
Get_Dbl = CDbl1(Ds)
Else
Get_Dbl = 0#
End If
'End If
End Function
'公共函数-设定小数位数
Public Function Set_P(ByVal i_s As Integer) As String
'设定小数点
If i_s = 0 Then
Set_P = "0"
ElseIf i_s > 0 Then
Set_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 String
If i_s = 0 Then
S_set_P = "0"
ElseIf i_s > 0 Then
S_set_P = "0." & String(i_s, "0")
End If
fun_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 Then
iRt = iR0 * (1 + iA * iT + iB * iT ^ 2 + iC * (iT - 100) * iT ^ 3)
ElseIf iT >= 0 And iT <= 850 Then
iRt = iR0 * (1 + iA * iT + iB * iT ^ 2)
Else
MsgBox "温度不在Pt100规定测量范围之内"
End If
Fun_Pt100 = iRt
End 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 Then
i_s = "MPa"
ElseIf InStr(1, i_tem_S, "KPA") > 0 Then
i_s = "KPa"
ElseIf InStr(1, i_tem_S, "PA") > 0 Then
i_s = "Pa"
ElseIf InStr(1, i_tem_S, "MA") > 0 Then
i_s = "mA"
ElseIf InStr(1, i_tem_S, "V") > 0 Then
i_s = "V"
Else
fun_Unit_YaLi = ""
MsgBox "压力量程缺少单位，请核实压力变送器量程是否有问题，必须增加单位例如：0-100kPa"
End If
fun_Unit_YaLi = i_s
End 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)
'单位ms
Dim time1 As Long
time1 = timeGetTime
Do
DoEvents
Loop While timeGetTime - time1 < T
End Sub
Sub Delay1(ms As Long)
Dim start As Single
start = Timer
Do While Timer < start + (ms / 1000)
DoEvents
Loop
End Sub
'公共过程-延迟命令----------------------------------------------------
'1-公共过程-停止程序================================================
Public Sub Judge_Stop()
'判断是否停止程序
If my_Stop = True Then
Exit Sub
MsgBox "程序停止"
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 Then
On Error Resume Next
Selection.Rows.HeightRule = wdRowHeightExactly
Selection.Rows.height = CentimetersToPoints(Hg * K1)
End If
End Sub
'2-函数-改行高》》》》》》》》》》》》》》》》
Private Sub CheckBox1_Click()
End Sub
Private Sub chk_4_col_Click()
If chk_4_col.Value = True Then
Cmd_Tianxie.Enabled = False
Chk_fugai1.Value = False
Else
Cmd_Tianxie.Enabled = True
Chk_fugai1.Value = True
End If
End Sub
Private Sub Chk_fugai1_Click()
End Sub
Private Sub Chk_HG_YE_Click()
End Sub
Private Sub chk_newLine_Click()
If chk_newLine.Value = 0 Then: T_INS.WordWrap = True
End Sub
Private Sub Chk_suiji_Click()
T_INS.Text = "请在这里输入随机数范围：例如(1-10)"
T_INS.SetFocus
End Sub
Private 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 Sub
Private Sub clr_list_writes_Click()
List_writes.Clear
End Sub
Private Sub clear_combo_Ziduan_Click()
Combo_ZiDuan.Clear
End Sub
Private 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.ListIndex
Case 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_S
T_str_Row.Text = 9
T_str_Col.Text = 1
T_end_Row.Text = 11
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 1
T_P_ShuJu.Text = 3
T_jiancedian.Enabled = True
T_jiancedian.Text = "0,50,100"
Case Is = 2
'温度变送器
T_str_Row.Text = 10
T_str_Col.Text = 1
T_end_Row.Text = 12
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 1
T_P_ShuJu.Text = 3
T_jiancedian.Enabled = True
T_jiancedian.Text = "25,50,100"
Case Is = 3
'压力变送器
T_str_Row.Text = 10
T_str_Col.Text = 1
T_end_Row.Text = 14
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 2
T_P_ShuJu.Text = 3
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_Tips.Text = "只需输入量程0-100kpa，精度：0.05%；其他不用输入"
Case Is = 4
'温度计
T_str_Row.Text = 3
T_str_Col.Text = 8
T_end_Row.Text = 40
T_end_Col.Text = 8
T_Point.Text = 1
T_HD_k.Text = 2
T_jingdu.Text = 1.5
T_jiancedian.Enabled = False
Case Is = 5
'压力表
T_str_Row.Text = 3
T_str_Col.Text = 8
T_end_Row.Text = 40
T_end_Col.Text = 8
T_Point.Text = 4
T_HD_k.Text = 2
T_jingdu.Text = 1.5
T_Tips.Text = "压力表数据列必须为9列，否则出错，例如：序号-名称-编号-型号-量程-精度-允许误差-最大误差-调校结果"
T_jiancedian.Enabled = False
Case Is = 6
'调节阀
T_str_Row.Text = 18
T_str_Col = 2
T_end_Row = 23
T_end_Col = 4
T_VA_bz_Row.Text = T_str_Row.Text
T_xc_Row.Text = 4
T_xc_Col.Text = 2
T_jingdu.Text = 0.5
T_jiancedian.Enabled = False
T_P_ShuJu.Text = 2
Case Is = 7
'模拟量回路测试
T_str_Row.Text = 5
T_str_Col.Text = 4
T_end_Row.Text = 36
T_end_Col.Text = 10
T_col_BZ.Text = 3 '量程所在列
T_Point.Text = 1
T_jingdu.Text = 0.1
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_P_ShuJu.Text = 2
Case Is = 8
'基础化I/O组件模拟量测试
T_str_Row.Text = 5
T_str_Col.Text = 4
T_end_Row.Text = 36
T_end_Col.Text = 10
T_col_BZ.Text = 3 '量程所在列
T_Point.Text = 2
T_P_ShuJu.Text = 2
T_jingdu.Text = 0.1
T_jiancedian.Enabled = False
Case Is = 9
'安全栅
T_str_Row.Text = 4
T_str_Col.Text = 8
T_end_Row.Text = 35
T_end_Col.Text = 12
T_col_BZ.Text = 5 '精度所在列
T_Point.Text = 2
T_jingdu.Text = 0.1
T_point_wucha.Enabled = True
T_jiancedian.Enabled = False
Case Is = 10
'数显表
T_str_Row.Text = 10
T_str_Col.Text = 2
T_end_Row.Text = 14
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 5
T_LC_Col.Text = 2
T_Point.Text = 2
T_P_ShuJu.Text = 3
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_Tips.Text = "数显表数据"
Case Else
T_point_wucha.Enabled = False
T_jiancedian.Enabled = False
End Select
End Sub
Private 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 Then
Cmd_bianhao.Caption = "取消编号"
Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _
True, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
ElseIf Flg_bh = False Then
Cmd_bianhao.Caption = "增加编号"
Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
End If
End Sub
'3-公共过程-段落------------------------------------------------------------------
'4-公共过程-表格属性更改------------------------------------------------------------------
Sub biao() '选中word所有表格
Dim T As Table
ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
For Each T In ActiveDocument.Tables
T.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges wdEditorEveryone
ActiveDocument.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 = False
End With
Next i
End Sub
Sub YeBianJu()
'表格版式改为--------无,同时居中
QianRu_mid
'页边距2,2,2,2，页眉边距0.0
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With 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 = wdLayoutModeLineGrid
End With
End Sub
Sub YEBIANJU1()
'页边距2,2,2,2，页眉边距0.0
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
On Error Resume Next
With 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 = wdLayoutModeLineGrid
End With
End Sub
Public Sub T_jz()
'文字在单元格居中
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End Sub
Public 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 = True
End With
Selection.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 Object
my_H = InputBox("请输入图片高度，必须是数字，默认500", "图片尺寸", 500)
my_W = InputBox("请输入图片宽度，必须是数字，默认500", "图片尺寸", 500)
For Each my_Shape In ActiveDocument.InlineShapes
With my_Shape
.LockAspectRatio = msoFalse
.height = my_H
.width = my_W
.Select
Application.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next
End 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 Tables
Dim 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 = False
This_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.Tables
If InStr(MyName, "目录") < 1 Then
'不更改目录文档
For i = 1 To mydoc.Tables.Count
If my_Stop = True Then: Exit Sub '停止程序
On Error Resume Next
my_tbls(i).Cell(1, 1).Range.Text = Comb_SGDW.Text
my_tbls(i).Cell(1, 3).Range.Text = T_GCMC.Text
Next i
If mydoc.Name <> This_doc_name Then
mydoc.Save
mydoc.Close
T_DOC_OK.Text = "更改完毕---" & MyName & vbCrLf & "----------" & vbCrLf & T_DOC_OK.Text
End If
End If
Delay (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 Tables
Dim 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 = False
This_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 #1
ReDim 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.Tables
If InStr(MyName, "目录") < 1 And my_tbls.Count >= 1 Then
'不更改目录文档
SGDW.sz_Filename(UBound(SGDW.sz_Filename)) = MyName
ReDim 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.Count
If 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)) = S1
GCMC.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 Then
TJ_SGDW.SZ_Count(i12) = TJ_SGDW.SZ_Count(i12) + 1
ElseIf i12 = UBound(TJ_SGDW.SZ_Name) And TJ_SGDW.SZ_Name(i12) <> S1 Then
ReDim 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)) = S1
TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count)) = 1
N_err = N_err + 1
End If
Next i12
SGDW.SZ_Count(i11) = SGDW.SZ_Count(i11) + 1
TJ_SGDW.SZ_Count(i11) = TJ_SGDW.SZ_Count(i11) + 1
Exit For
ElseIf i11 = UBound(SGDW.SZ_Name) And SGDW.SZ_Name(i11) <> S1 Then
ReDim 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)) = S1
SGDW.SZ_Count(UBound(SGDW.SZ_Count)) = 1
If 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 Then
TJ_SGDW.SZ_Count(i12) = TJ_SGDW.SZ_Count(i12) + 1
ElseIf i12 = UBound(TJ_SGDW.SZ_Name) And TJ_SGDW.SZ_Name(i12) <> S1 Then
ReDim 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)) = S1
TJ_SGDW.SZ_Count(UBound(TJ_SGDW.SZ_Count)) = 1
End If
Next i12
End If
Next i11
For i11 = LBound(GCMC.SZ_Name) To UBound(GCMC.SZ_Name)
If GCMC.SZ_Name(i11) = S2 Then
GCMC.SZ_Count(i11) = GCMC.SZ_Count(i11) + 1
TJ_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 Then
TJ_GCMC.SZ_Count(i12) = TJ_GCMC.SZ_Count(i12) + 1
ElseIf i12 = UBound(TJ_GCMC.SZ_Name) And TJ_GCMC.SZ_Name(i12) <> S2 Then
ReDim 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)) = S2
TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count)) = 1
End If
Next i12
Exit For
ElseIf i11 = UBound(GCMC.SZ_Name) And GCMC.SZ_Name(i11) <> S2 Then
ReDim 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)) = S2
GCMC.SZ_Count(UBound(GCMC.SZ_Count)) = 1
If 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 Then
TJ_GCMC.SZ_Count(i12) = TJ_GCMC.SZ_Count(i12) + 1
ElseIf i12 = UBound(TJ_GCMC.SZ_Name) And TJ_GCMC.SZ_Name(i12) <> S2 Then
ReDim 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)) = S2
TJ_GCMC.SZ_Count(UBound(TJ_GCMC.SZ_Count)) = 1
N_err = N_err + 1
End If
Next i12
End If
Next i11
Next i
If mydoc.Name <> This_doc_name Then
mydoc.Save
mydoc.Close
End If
End 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 i11
For 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 i21
Write #1, "--------------------------------------------------------------"
Next i12
'写入完毕，文件名数组加1
ReDim Preserve SGDW.sz_Filename(UBound(SGDW.sz_Filename) + 1)
T_DOC_OK.Text = "完成--" & MyName & vbCrLf & T_DOC_OK
Delay (1000)
MyName = Dir
Loop
Write #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) & "----数量为：" & i22
Write #1, "统计结束--------------------------------------------------------------"
Write #1, vbCrLf & vbCrLf & vbCrLf & "分析结果：--------------------------------------------------------------"
Write #1, S1
Write #1, S2
Write #1, "分析结束--------------------------------------------------------------"
T_DOC_OK.Text = "检查结果见文件：" & MyPath & "检查结果.txt" & vbCrLf & T_DOC_OK.Text
T_DOC_OK.Text = _
"统计结果：----------------------------------------------------" & vbCrLf & _
S1 & vbCrLf & _
S2 & vbCrLf & _
"--------------------------------------------------------------" & vbCrLf & _
vbCrLf & vbCrLf & _
T_DOC_OK.Text
i = MsgBox("表头内容检查完毕！错误数量大可能值：" & N_err - 1 & vbCrLf & "是否打开检查文件？", vbYesNo)
If i = 6 Then
Close #1
Shell "notepad.exe " + MyPath + "\检查结果.txt", 1
Else: Close #1
End If
S1 = ""
S2 = ""
End Sub
Public Sub Chushi_AIAODIDO() '初始化过程
With AIAODIDO_COM
.AddItem "AI", 0
.AddItem "AO", 1
.AddItem "DI", 2
.AddItem "DO", 3
.AddItem "RTD", 4
.ListIndex = 0
End 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 Sub
Public 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_Range
For i = LBound(Sz_Range) To UBound(Sz_Range)
.AddItem Sz_Range(i), i
Next i
.ListIndex = 0
End 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_Last
Select Case Comb_zt_types.ListIndex
Case Is = 0
.Text = zt_S
Case Is = 1
.Text = zt_S1
Case Is = 2
.Text = "-KG;-KGW"
Case Is = 3
.Text = "-KG;-KDW"
Case Is = 4
.Text = "-KG;-GDW"
Case Else
.Text = zt_S1
End 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.Text
Case "AI"
Bit_1.Text = 8
Comb_AIAO_Range.Enabled = True
Case "AO"
Bit_1.Text = 4
Comb_AIAO_Range.Enabled = True
Case "DI"
Bit_1.Text = 32
Comb_AIAO_Range.Enabled = False
Case "DO"
Bit_1.Text = 32
Comb_AIAO_Range.Enabled = False
Case "RTD"
Bit_1.Text = 16
Comb_AIAO_Range.Enabled = True
End Select
'-------------------------------------
Select Case AIAODIDO_COM.Text
Case Is = "AI"
'基础化I/O组件模拟量创建AIAODIDO
T_str_Row.Text = 5
T_str_Col.Text = 2
T_end_Row.Text = 36
T_end_Col.Text = 2
Case Is = "AO"
'基础化I/O组件模拟量创建AIAODIDO
T_str_Row.Text = 5
T_str_Col.Text = 2
T_end_Row.Text = 36
T_end_Col.Text = 2
Case Is = "DI"
'基础化I/O组件模拟量创建AIAODIDO
T_str_Row.Text = 4
T_str_Col.Text = 2
T_end_Row.Text = 35
T_end_Col.Text = 2
Case Is = "DO"
'基础化I/O组件模拟量创建AIAODIDO
T_str_Row.Text = 4
T_str_Col.Text = 2
T_end_Row.Text = 35
T_end_Col.Text = 2
Case Is = "RTD"
'基础化热电阻模块变送器 组件模拟量创建AIAODIDO
T_str_Row.Text = 5
T_str_Col.Text = 2
T_end_Row.Text = 36
T_end_Col.Text = 2
End Select
'-------------------------------------
End Sub
Private 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 <> "" Then
With AIAODIDO_COM
For X = Num_st To Num_st + Num - 1
For Y = Bit_st To Bit_st + Bit_num - 1
'在文本框中写入数据
S = .Text & X & T_fenge.Text & Y
If Comb_AIAO_Range.Enabled = True Then 'AI/AO/RTD等带量程的数据
S = S & ";" & Comb_AIAO_Range.Text
End If
T_AD.Text = T_AD.Text & S & vbCrLf
Next Y
Next X
End With
Else
MsgBox "请在文本框输入数字！"
End If
End 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 If
If k = 1 Then
Set mytbls = ActiveDocument.Tables
n = 0
For i = 1 To mytbls.Count
n = n + 1
On Error Resume Next
j = InStr(1, mytbls(n).Cell(2, 2).Range.Text, S_name)
If j < 1 Then
mytbls(n).Delete
n = n - 1
End If
Next 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 Table
Dim oCell As Cell
Dim WidthOfoCell(5000) As Single
Dim HeightOfoCell(5000) As Single
Set my_tables = ActiveDocument.Tables
Str_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 + 1
oCell.Select
If Selection.Range.Cells.Count = 1 Then
If Selection.Information(wdStartOfRangeRowNumber) >= end_Row And Selection.Information(wdStartOfRangeColumnNumber) >= end_Col Then
Exit For
GoTo p1
End If
If Selection.Information(wdStartOfRangeRowNumber) >= str_Row Then
WidthOfoCell(i) = oCell.width
HeightOfoCell(i) = Selection.Rows.height
End If
End If
Next
p1:
'根据行列采集数据，采集完毕跳转P1
'开始更改其他页面中每个单元格的宽度和高度，保持和参考页单元格的尺寸一致
For n = Str_Page To End_Page
i = 0 '初始化i
If n <> CanKao_Page Then
'不更改参考页,否则后续更改无效
my_tables(n).Select
If 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 p3
End If
For Each oCell In Word.Selection.Cells
i = i + 1
If i > 5000 Then
MsgBox "表格单元格数量超过5000，数量过多，无法继续执行"
GoTo p3
End If
oCell.Select
If Selection.Range.Cells.Count = 1 Then
If Selection.Information(wdStartOfRangeRowNumber) >= end_Row And Selection.Information(wdStartOfRangeColumnNumber) >= end_Col Then
Exit For
GoTo P2
End If
If Selection.Information(wdStartOfRangeRowNumber) >= str_Row Then
Selection.Cells.width = WidthOfoCell(i)
Selection.Rows.height = HeightOfoCell(i)
End If
End If
Next
End If
P2:
Next n
p3:
End Sub
'15-公共过程-将仪表报告其他表格与第一个表格尺寸统一=================================================================================================
'16-公共过程-初始化页码，针对第一页页码不是1的情况进行处理=================================================================================================
Sub Sub_ReSet_Page_No()
'第一页页码改为1，页眉页码格式更改，将第一页设置为1
MoveToDocStart
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
With Selection.HeaderFooter.PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = False
.StartingNumber = 0
End With
ActiveWindow.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.Count
If Rows_Cols > 1 Then
MsgBox "【倒数第三行必须是合并的】，【发现表格不是单体报告】，可能存在过多行，不宜进行自动调整，请手动调整，否则会出现不可逆混乱", , "严重警告！！！"
Else
If Flg_n = 1 Then
'是否只对第一页操作
If Flg_m = 6 Then
n = 1
End If
For i = 1 To n
With ActiveDocument
'获得当前表格的总行数
M = .Tables(i).Rows.Count
'更改第一行行高
.Tables(i).Cell(1, 1).Select
Selection.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 = 0
If M >= 3 Then
For j = 1 To M
'计算除了倒数第三行之外其他行的行高，方便以后对倒数第三行行高重新定义，使页面总行高固定为25.5cm
If j <> M - 2 Then
i_H = i_H + PointsToCentimeters(.Tables(i).Cell(j, 1).height)
.Tables(i).Cell(j, 1).Select
End If
i_w = 0
'更改每行中最后一列的列宽，使每行的总列宽等于W(17.5)
W_n = .Tables(i).Rows(j).Cells.Count
If W_n >= 2 Then
For k = 1 To W_n - 1
i_w = i_w + .Tables(i).Cell(j, k).width
Next k
End If
.Tables(i).Cell(j, W_n).width = CentimetersToPoints(17.5) - i_w
Next j
'更改倒数第三行行高，内容行，最高那行;防止更改多列行，必须是合并的整行(一开始已经排除这种情况了)
.Tables(i).Rows(M - 2).height = CentimetersToPoints(H - i_H)
ElseIf M = 2 Then
.Tables(i).Rows(M).height = CentimetersToPoints(H - 3)
Else
MsgBox "表格行数必须大于2"
End If
End With
Next i
For j = 1 To 2
For i = 1 To n
'第二个单元格可能存在多行单独处理
ActiveDocument.Tables(i).Cell(1, 2).Select
Selection.MoveLeft
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Size = 18
Next i
Next j
End If
End If
End 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 Then
H1 = 1
ElseIf H1 < 0.6 Then
H1 = 0.6
End If
.Rows.height = CentimetersToPoints(H1)
End With
End 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 Variant
MoveToDocEnd
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_P
If i_end_Row > i_my_tbls(i).Rows.Count - 2 Then
i_end_Row = i_my_tbls(i).Rows.Count - 2
End If
For j = i_str_Row To i_end_Row
If 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 <> "" Then
GoTo Tiao_moniliang
End If
End 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_Col
i_my_tbls(i).Cell(j, k).Select
'计算误差
Randomize
i_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 If
End With
Next k
End If
Tiao_moniliang:
Next j
Next 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 Variant
Dim 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_P
For j = i_str_Row To i_end_Row
For k = i_str_Col To i_end_Col
On Error Resume Next
i_s = i_s + Get_Val(i_Tables(i).Cell(j, k).Range.Text) + vbTab
Next k
Next j
i_sz_S(i) = Mid(i_s, 1, Len(i_s) - 1)
i_s = ""
Next i
fun_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 String
Set mydoc = Word.ActiveDocument
MyDocName = mydoc.Name
'加载word所在文件夹路径
MyPath = mydoc.Path & "\"
MyName = Dir(MyPath & "*.doc*")
Do While MyName <> ""
myNamelist(i) = MyName
MyName = Dir
i = i + 1
Loop
'创建pdf文件夹
pdf_Path = mydoc.Path & "\pdf\"
If Dir(pdf_Path, vbDirectory) = "" Then
VBA.MkDir pdf_Path
End If
n = 0
'将word文档全部打开
For i = LBound(myNamelist) To UBound(myNamelist)
If myNamelist(i) <> "" Then
n = n + 1
MyName = myNamelist(i)
Set myDoc1(i) = GetObject(MyPath & MyName)
T_DOC_OK.Text = MyName & "--读取完毕！" & vbCrLf & T_DOC_OK.Text
Delay (50)
Else
Exit For
End If
Delay (50)
Next i
T_DOC_OK.Text = "--------------------" & vbCrLf & T_DOC_OK.Text
'将打开的n个word文档转换成pdf
For i = 0 To n - 1
myDoc1(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:=False
Delay (200)
MyName = myDoc1(i).Name
T_DOC_OK.Text = MyName & "-转换pdf完成！" & vbCrLf & T_DOC_OK.Text
If MyName <> MyDocName Then
myDoc1(i).Close wdDoNotSaveChanges
End If
If i >= n - 1 Then
T_DOC_OK.Text = "【转换完成！】" & vbCrLf & vbCrLf & T_DOC_OK.Text
Exit For
End If
Next i
End 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 > 0
doc_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).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.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 Sub
Public Sub Create_Tables_duohuilu()
'创建多回路表格
Dim ii%, jj%
Dim doc_Mulu As Document
YeBianJu '优化页边距
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
'表格内容文字居中
.Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.Rows.Alignment = wdAlignRowCenter
'先操作列，在操作行，否则会混乱。
'合并第8列，2，3行。
.Cell(Row:=2, Column:=7).Select
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
'合并第7列，2，3行。
.Cell(Row:=2, Column:=6).Select
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
'列的合并很特殊
'合并第2列，2，3行。
.Cell(Row:=2, Column:=2).Select
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
'合并第1列，2，3行。
.Cell(Row:=2, Column:=1).Select
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Cells.Merge
ActiveDocument.Range(.Cell(1, 1).Range.start, .Cell(1, 2).Range.End).Cells.Merge
ActiveDocument.Range(.Cell(1, 2).Range.start, .Cell(1, 5).Range.End).Cells.Merge
ActiveDocument.Range(.Cell(1, 3).Range.start, .Cell(1, 6).Range.End).Cells.Merge
ActiveDocument.Range(.Cell(2, 3).Range.start, .Cell(2, 4).Range.End).Cells.Merge
ActiveDocument.Range(.Cell(2, 7).Range.start, .Cell(2, 8).Range.End).Cells.Merge
ActiveDocument.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 Sub
Public 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 Table
Dim 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 = False
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)
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.Count
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col + 1
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
'设定小数点
S_P = Set_P(Points)
Randomize
For i = str_P To end_P
If 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_Row
With my_tbls(i)
.Cell(j, k).Select
Delay (10)
Select Case j
Case 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 k
Case Is <= str_Row + 2
'第1遍正反行程
str_Col = str_Col + 1
end_Col = end_Col + 1
For k = str_Col To end_Col
If k = str_Col Or k = end_Col Then
Flg_i = 0
Else
Flg_i = 1
End If
tem_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 k
str_Col = str_Col - 1
end_Col = end_Col - 1
Case Is <= str_Row + 4
'第2遍正反行程
str_Col = str_Col + 1
end_Col = end_Col + 1
For k = str_Col To end_Col
If k = str_Col Or k = end_Col Then
Flg_i = 0
Else
Flg_i = 1
End If
tem_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 k
str_Col = str_Col - 1
end_Col = end_Col - 1
Case Is <= str_Row + 5
'正反行程误差的较大值
For k = str_Col To end_Col
Up1 = 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 k
Case Else
MsgBox "超出行数"
End Select
End With
Next j
Next i
End 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 Variant
Dim my_tbls As Tables, my_table As Table
Set my_tbls = ActiveDocument.Tables
str_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 = 5
If InStr(TEM_S, "DI") Then str_Row = 4
If InStr(TEM_S, "DO") Then str_Row = 4
str_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 '初始化页码格式，将第一页页码设置为1
If T_AD.Text <> "" Then
SZ_S = Split(Left(T_AD.Text, Len(T_AD.Text) - 2), vbCrLf)
End If
tem_i = 0: i_sz_S = 0: n = 1: i = 0: k = 0
If IsEmpty(SZ_S) = True Then: GoTo p1 '空值退出
i_Rows = str_Row
Do While i_sz_S <= UBound(SZ_S)
With my_tbls(n)
If Len(.Cell(i_Rows, 2).Range.Text) > 2 Then
GoTo p_NewRows '非空行跳转下一行
Else
Select 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 k
Case 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 k
Case 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 Else
If InStr(SZ_S(i_sz_S), "RTD") Then
Array_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 If
End Select
i_sz_S = i_sz_S + 1
p_NewRows:
i = i + 1
i_Rows = str_Row + i
End If
'增加表格
If i_Rows > my_tbls(n).Rows.Count - 2 And n = my_tbls.Count And i_sz_S < UBound(SZ_S) Then
i = 0: i_Rows = str_Row
If InStr(1, ActiveDocument.Name, "数字量") > 0 Then '数字量9列模拟量10列
sub_New_tbl my_tbls, n, str_Row, 1, end_Row, 9
Else
sub_New_tbl my_tbls, n, str_Row, 1, end_Row, 10
End If
n = n + 1
ElseIf i_Rows > end_Row And n < my_tbls.Count Then
i = 0: i_Rows = str_Row
n = n + 1
End If
End With
Delay (1)
Loop
Set my_tbls = ActiveDocument.Tables
If InStr(1, ActiveDocument.Name, "模拟量") > 0 Then '开始更新内部数据
'基础化I/O组件模拟量测试
T_str_Row.Text = 5
T_str_Col.Text = 4
T_end_Row.Text = 36
T_end_Col.Text = 10
T_col_BZ.Text = 3 '量程所在列
T_Point.Text = 2
T_P_ShuJu.Text = 2
T_jingdu.Text = 0.1
T_jiancedian.Enabled = False
sub_AIAO_ShuJu my_tbls, 1, my_tbls.Count, 5, 36, 4, 10 '填写AIAO数据
End If
p1:
End Sub
Private Sub cmd_ChuangJianWenDang_Click()
Dim ExcelPath$
Dim DataArray() As Variant
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim SheetName As String
Dim FieldName As String, SZ_FieldIndex() As Variant, iFieldIndex%
Dim BoxWidth As Double, BoxHeight As Double
Dim Txt_FountSize As Double
Dim 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 Long
Dim NoOfPage%, BookMarkName$, BuChang%
ExcelPath = T_ExcelPath.Text
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(1)
' 确定字段数据范围
Dim LastCol As Long
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'文本框宽度13mm，高度40mm
'xy,起始坐标
'每行每列的间隔
BoxWidth = T_BoxWidth.Text
BoxHeight = T_BoxHeight.Text
ZBJX = T_ZBJX.Text
SBJY = T_SBJY.Text
Zbjx1 = T_ZBJX1.Text
Sbjy1 = T_SBJy1.Text
StrX = T_StrX.Text
StrY = T_StrY.Text
JianGeX = T_JianGeX.Text
JianGeY = T_JianGeY.Text
StrRow = T_StrRow.Text
EndRow = T_EndRow.Text
SheetName = combo_sheetsName.Text
'根据字段内容，确定要打印的字段所在的列号
ReDim SZ_FieldIndex(1 To listZiDuan.ListCount)
DataArray = ReadExcel2SZ(ExcelPath, SheetName, 1, 1, 1, LastCol)
iFieldIndex = 1
For j = 1 To listZiDuan.ListCount
' 查找字段在数组中的列索引
For i = 1 To UBound(DataArray, 2)
If DataArray(1, i) = listZiDuan.List(j - 1) Then
SZ_FieldIndex(iFieldIndex) = i
iFieldIndex = iFieldIndex + 1
End If
Next i
Next
'获取每行对应字段的内容，输入数组
ReDim dataarry(1 To EndRow)
DataArray = ReadExcel2SZBOX(ExcelPath, SheetName, StrRow, EndRow, SZ_FieldIndex)
MoveToDocStart '光标移动到文档开始
'创建文本框
NoOfPage = T_NoOfPage.Text
Dim myPage%
myPage = 1
For i = LBound(DataArray) To UBound(DataArray)
j = i - 6 * (myPage - 1)
'一组间距9mm，两组之间间距8mm，需要做补偿
jj = j
Select Case jj
Case 1 To 5
'BuChang = -1
J1 = 1
J2 = 0
Jx = jj - 1
Jy = 0
'MsgBox Jx
Case 6 To 10
'BuChang = -1
J1 = 0
J2 = 1
Jx = jj - 1 - 5
Jy = 0
'MsgBox Jx
Case 11 To 15
'BuChang = -3
J1 = 1
J2 = 0
Jx = jj - 1 - 10
Jy = 1
Case 16 To 20
'BuChang = -3
J1 = 0
J2 = 1
Jx = jj - 1 - 15
Jy = 1
Case 21 To 25
'BuChang = -8
J1 = 1
J2 = 0
Jx = jj - 1 - 20
Jy = 2
Case 26 To 30
'BuChang = -9
J1 = 0
J2 = 1
Jx = jj - 1 - 25
Jy = 2
End 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) + BuChang
X1 = J1 * ZBJX + J2 * Zbjx1 + Jx * (T_JianGeX.Text)
Y1 = J1 * SBJY + J2 * Sbjy1 + Jy * (T_JianGeY.Text)
X2 = X1 + BoxWidth
Y2 = Y1
Call 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) Then
Delay1 (1000)
MoveToDocEnd1 '将光标移动到当前页面底部
Delay1 (1000)
Selection.InsertBreak Type:=wdPageBreak
Delay1 (1000)
MoveToDocStart1 '将光标移动到下一页的开头
Delay1 (1000)
myPage = myPage + 1
Delay1 (1000) '毫秒
End If
Next i
End Sub
Sub MoveToDocEnd1()
Selection.EndKey Unit:=wdStory
End Sub
Sub MoveToDocStart1()
Selection.HomeKey Unit:=wdStory
End Sub
'===========================================================================================================
Public Function del_StrEnter(ByVal iStr As String)
'去除换行符
Dim str As String
str = 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 Sub
Public 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 Variant
Dim ExcelPath$
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim DataArray() As Variant
Dim i As Long, j As Long
ExcelPath = iPath
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(I_Sheet)
' 确定数据范围
Dim lastRow As Long, LastCol As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If lastRow > 0 And LastCol > 0 Then
ReDim DataArray(1 To lastRow, 1 To LastCol)
' 读取数据到数组
For i = iStrRow To iEndRow
For j = iStrCol To iEndCol
DataArray(i, j) = ws.Cells(i, j).Value
Next j
Next i
Else
Debug.Print "No data found in the worksheet."
End If
' 关闭Excel文件
wb.Close SaveChanges:=False
ReadExcel2SZ = DataArray
End 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 Worksheet
Dim tem_Str As String
Dim DataArray() As Variant
Dim i As Long, j As Long
ExcelPath = iPath
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(I_SheetName)
ReDim DataArray(1 To iEndRow - iStrRow + 1)
' 读取数据到数组
For i = iStrRow To iEndRow
tem_Str = ""
For j = LBound(iSz_FieldIndex) To UBound(iSz_FieldIndex)
tem_Str = tem_Str & ws.Cells(i, iSz_FieldIndex(j)).Value & vbCrLf
Next j
tem_Str = Left(tem_Str, Len(tem_Str) - 2) '去掉最后一个回车
DataArray(i - iStrRow + 1) = tem_Str
Next i
' 关闭Excel文件
wb.Close SaveChanges:=False
ReadExcel2SZBOX = DataArray
End Function
Public 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 Variant
Dim txtBox As Shape
Dim txtFrame As TextFrame
Dim txtRange As Range
Dim fontSize As Integer
Dim pt2mm As Double
pt2mm = 0.352778 'vba单位是pt，1pt=0.352778mm
height = height / pt2mm
width = width / pt2mm
xCoord = xCoord / pt2mm
yCoord = 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 With
With txtBox.TextFrame
.MarginLeft = CentimetersToPoints(0.2) ' 左边距
.MarginTop = CentimetersToPoints(0.5) ' 上边距
.MarginRight = CentimetersToPoints(0.1) ' 右边距
.MarginBottom = CentimetersToPoints(0.1) ' 下边距
End With
' 设置文本框文本
Set txtFrame = txtBox.TextFrame
Set txtRange = txtFrame.TextRange
txtFrame.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 = wdLineSpaceExactly
txtRange.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 Double
CentimetersToPoints = cm * 28.3464567 ' 1厘米=28.3464567点
End Function
Private 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_End
If i <= 57 Or i >= 65 Then '排除特殊字符，保留0-9，A-F
s_New = s_Stic & Chr(i) & T_wh_hz.Text
T_INS.Text = T_INS.Text & s_New & vbCrLf
End If
Next i
End Sub
Private Sub Cmd_clr_zt_Click()
T_Equ.Text = ""
End Sub
Private Sub cmd_NewPage_Click()
Dim i%
For i = 1 To T_NewPages.Text
Selection.InsertBreak
'ThisDocument.Content.InsertAfter Chr(12)
Next i
MoveToDocStart '光标移动到文档开始
MoveToCurrentLineStart
End Sub
Private Sub cmd_DaXiao_Click()
'改变窗口大小
With cmd_DaXiao
Select Case .Caption
Case Is = "最小化"
.Caption = "最大化"
Frm_WORD.height = 50
Frm_WORD.width = 160
Case Is = "最大化"
.Caption = "最小化"
Frm_WORD.height = 400
Frm_WORD.width = 500
End Select
End With
End Sub
Private Sub Cmd_Doc2Pdf_Click()
Dim a%, pdf_Path$
a = MsgBox("是否转换所有word文件：【是】转换所有word；【否】只转换该word", vbYesNoCancel)
If a = 2 Then
ElseIf a = 6 Then
Doc2Pdf
ElseIf a = 7 Then
With ActiveDocument
'创建pdf文件夹
pdf_Path = .Path & "\pdf\"
If Dir(pdf_Path, vbDirectory) = "" Then
VBA.MkDir pdf_Path
End 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:=False
T_DOC_OK.Text = .Name & "转换pdf完成" & vbCrLf & T_DOC_OK.Text
End With
End If
End Sub
Private Sub cmd_end_P_Click()
T_end_P.Text = ActiveDocument.Tables.Count
End Sub
Private Sub cmd_Excel_Click()
sub_Find_Excel '如果没有excel打开则运行一个新的工作簿。
If Findexcel = True Then
Frm_WORD.Hide
Frm_Excel.Show 0
Else
MsgBox "请手动打开一个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.Workbook
Set Objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
E_name = "EXCEL"
Findexcel = False
For Each Obj In Objs
If InStr(1, Obj.Description, E_name) > 0 Then
Findexcel = True
Exit For
End If
Next
End Sub
Private 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 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)
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 Sub
Private Sub cmd_help_FYF_Click()
MsgBox "未防止死循环；支持最大页数5000页左右的word表格整理，如果页数过多，清自行将word分割后，分别整理"
End Sub
Private 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 Integer
Dim doc_Mulu As Document
Dim 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 String
docPath = InputBox("请粘贴文件夹目录：", "生成目录文件夹地址", Application.ActiveDocument.Path & "\")
If Right(docPath, 1) <> "\" Then: docPath = docPath & "\"
'光标移动到最后一行
MoveToDocEnd
'增加回车
'Selection.TypeText (Chr(13))
'创建目录表格
Set doc_Mulu = ActiveDocument
Creat_Tables doc_Mulu
docName = Dir(docPath & "*.doc*")
TEM_S = docName
L = 0
Do While TEM_S <> ""
Set mydoc = GetObject(docPath & TEM_S)
Set my_tbls = mydoc.Tables
n_Pages = my_tbls.Count
flg_XuHao = False
flg_Name = False
flg_Page = False
L = 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 Next
Xuhao(L, 1, 1) = i
End If
If Xuhao(L, 1, 1) = 0 And IsNumeric(Mid(TEM_S, i, 1)) = True Then
'第一次：数字和非数字的分割点
Xuhao(L, 1, 1) = i
ElseIf 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 + 1
flg_XuHao = True
End If
If 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 + 1
flg_Name = True
ElseIf i = Len(TEM_S) And Xuhao(L, 3, 1) = 0 Then
'名称结束位置
Xuhao(L, 2, 2) = i
MsgBox "[" & TEM_S & "]" & "文件名缺少页码，文件名最后必须增加页数，例如：****1页.doc"
Xuhao(L, 3, 1) = i
flg_Name = True
End If
If 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) = i
flg_Page = True
ElseIf i = Len(TEM_S) And Xuhao(L, 3, 1) > 0 And Xuhao(L, 3, 2) = 0 Then
'页码结束位置
Xuhao(L, 3, 2) = i
flg_Page = True
End If
Next i
If 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 Then
SZ_S(L, 3) = n_Pages
End If
End If
'页数与内部表格内容不符
If n_Pages = Cint1(SZ_S(L, 3)) Then
SZ_S(L, 4) = ""
Else
SZ_S(L, 4) = "表格数：" & n_Pages
End If
If mydoc.Name <> doc_Mulu.Name Then
mydoc.Save
mydoc.Close
End If
TEM_S = Dir
Loop
'准备写入目录数据
For L = LBound(SZ_S, 1) To UBound(SZ_S, 1)
If L >= doc_Mulu.Tables(1).Rows.Count Then
doc_Mulu.Tables(1).Rows.Add
End If
If SZ_S(L, 2) <> "" Then
With 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).Select
Selection.SelectRow
Selection.Rows.height = CentimetersToPoints(0.6)
End With
Else
Exit For
End 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_all
End If
End With
'优化目录表格尺寸
sub_MuLu_youhua
End Sub
Private Sub Cmd_Creat_TXT_Click()
Open T_path_Record.Text For Output As #1
Close #1
End Sub
Private Sub cmd_ReadWorkBook_Click()
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim exlPath$, n%, i%
Label400.Caption = ""
combo_sheetsName.Clear
exlPath = T_ExcelPath.Text
' 打开Excel文件
Set wb = Workbooks.Open(exlPath)
n = wb.Sheets.Count
'MsgBox n
For i = 1 To n
combo_sheetsName.AddItem wb.Sheets(i).Name
Next i
combo_sheetsName.ListIndex = 0
wb.Close SaveChanges:=False
Label400.Caption = "读取成功!"
End Sub
Private 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 #1
Write #1, S
Close #1
End Sub
Private Sub Cmd_Reset_Page_No_Click()
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
End Sub
Private Sub cmd_str_P_Click()
T_str_P.Text = 1
End Sub
Private Sub cmd_t_clear_Click()
T_GCMC.Text = ""
End Sub
Private Sub cmd_T_clear1_Click()
T_DOC_OK.Text = ""
End Sub
Private Sub cmd_table_Nor_h_w_Click()
T_Table_Height = 25.5
T_Table_Width = 17.5
End Sub
Private Sub Cmd_Tianxie1_Click()
'将txt中内容写入word的指定行，按规律
'控制word刷新
Application.ScreenUpdating = False
Dim 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.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
If T_INS.Text <> "" Then
SZ_S = Split(T_INS.Text, vbCrLf)
End If
If T_INS2.Text <> "" Then
SZ_S2 = Split(T_INS2.Text, vbCrLf)
End If
If T_INS3.Text <> "" Then
SZ_S3 = Split(T_INS3.Text, vbCrLf)
End If
If T_INS4.Text <> "" Then
SZ_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 = 0
k = str_Col
j = str_Row
i = str_P
'前缀；后缀；或者直接赋值
If IsEmpty(SZ_S) = False Then
If Chk_fugai1.Value = True Then
Do While i_sz_S <= UBound(SZ_S)
'my_tbls(i).Cell(j, k).Select
If Chk_fugai.Value = True 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)
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 With
If j + 1 > 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
my_tbls(i).Cell(j, k).Select
Else
j = j + 1
End If
i_sz_S = i_sz_S + 1
Loop
Else
'不覆盖数据
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_fugai1.Value = True 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)
If TEM_S <> "" Then
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 With
Else
i_sz_S = i_sz_S - 1
End If
If j + 1 > 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
my_tbls(i).Cell(j, k).Select
End If
j = j + 1
Next ii
i_sz_S = i_sz_S + 1
Loop
End If
End If
ElseIf chk_4_col.Value = False Then
'只填写一列
i_sz_S = 0
k = str_Col
j = str_Row
i = str_P
'前缀；后缀；或者直接赋值
If IsEmpty(SZ_S) = False Then
If 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).Select
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
If j + 1 > 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
my_tbls(i).Cell(j, k).Select
Else
j = j + 1
End If
Next ii
i_sz_S = i_sz_S + 1
Loop
Else
'跳过数据行
'无法重复填写。。。代码困难
If i > ActiveDocument.Tables.Count Then '增加一页新表格
j = str_Row
sub_New_tbl my_tbls, i - 1, str_Row, str_Col, end_Row, end_Col
End If
Do While i_sz_S <= UBound(SZ_S)
If j + 1 > 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
Delay (1)
TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)
If Len(TEM_S) <> 0 Then
j = j + 1
Else
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
i_sz_S = i_sz_S + 1
my_tbls(i).Cell(1, 1).Select
End If
Loop
End If
End If
End If
Lab_state.Caption = "填写完成！"
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private 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.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)
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
Lab_state.Caption = "拼命填写中..."
i_sz_S = 0
k = str_Col
j = str_Row
i = str_P
'前缀；后缀；或者直接赋值
Do While N_cishu < T_TX_ChongFu.Text
Randomize
my_tbls(i).Cell(j, k).Select
If Chk_fugai1.Value = True Then
my_tbls(i).Cell(j, k).Range.Text = ""
End If
Delay (5)
TEM_S = Get_Val(my_tbls(i).Cell(j, k).Range.Text)
If Chk_suiji.Value = True Then
i_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)
Else
i_s = T_INS.Text
End If
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
If j + 2 > my_tbls(i).Rows.Count 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
Else
j = j + 1
End If
N_cishu = N_cishu + 1
If 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 Sub
Private 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 Sub
Private 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 Sub
Private Sub Cmd_Word_biaotou_jiancha_Click()
'控制word刷新
Application.ScreenUpdating = False
Sub_Word_Bath_jiancha
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private Sub Cmd_write_duohuilu_Click()
'控制word刷新
Application.ScreenUpdating = False
Dim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%
Dim zt_Last As Variant, zt_First As Variant
Dim zt_S$
Dim Arry_QT As Variant, Arry_YC As Variant, Arry_YX As Variant, Arry_GZ As Variant
Dim Arry_KG As Variant, Arry_KGW As Variant, Arry_KDW As Variant, Arry_GDW As Variant
Dim Arry_Equ As Variant
Dim SZ_S As Variant, SZ_S_i%, Flg_new_page As Boolean
Dim 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 Tables
Dim my_table As Table
my_Stop = False
Set my_tbls = ActiveDocument.Tables
Sub_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 Then
MsgBox "缺少表格我将自动创建表格模板"
Create_Tables_duohuilu
Comb_zt_types.ListIndex = 1
ElseIf ActiveDocument.Tables(1).Rows.Count <> 40 Then
ii = MsgBox("[表格格式：必须为表头：3行，数据36行，最后备注一行]" & vbCrLf & "是否【删除】所有表格！！！创建【多回路报告表格】？", vbYesNoCancel)
If ii = 6 Then
'删除所有表格
Do While ActiveDocument.Tables.Count > 0
ActiveDocument.Tables(1).Delete
Loop
Create_Tables_duohuilu
Comb_zt_types.ListIndex = 1
End If
Exit Sub
End If
'判断前缀和后缀
If InStr(T_zt_First.Text, ";") > 0 Then
zt_First = Split(T_zt_First.Text, ";")
End If
If InStr(T_zt_Last.Text, ";") > 0 Then
zt_Last = Split(T_zt_Last.Text, ";")
End If
If T_Equ.Text = "" Then
T_Equ.Text = "P001" & vbCrLf & "P002" & vbCrLf
End If
If Right(T_Equ.Text, 1) <> vbCrLf Then
T_Equ.Text = T_Equ.Text & vbCrLf
End If
Arry_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 = 1
end_Col = 10
'获得页数和行数，准备写入
i = 1: k = 0: i_Equ = 0: SZ_S_i = 0: i_Row = str_Row
i = Selection.Information(wdActiveEndPageNumber)
'多回路测试报告
Do
If my_Stop = True Then: Exit Sub '停止程序
'行数是36的整数倍的时候会出现bug，36 76这两个数要单独处理
If i_Row = (36 * 2 + 4) Then
i_Row1 = 4
i_Row = i_Row + 1
GoTo Tiao_kaiguanliang1
Else:
i_Row1 = (i_Row - 4) Mod 36 + 4
End If
'根据行数来计算填写数据的列数。
i_Col1 = 2 + ((i_Row - 4) \ 36) * 5
If i_Col1 > 7 Then
i_Col1 = 7
End If
'检查到表格中有数据就跳过本行
my_tbls(i).Cell(i_Row1, i_Col1).Select
TEM_S = Get_Val(my_tbls(i).Cell(i_Row1, i_Col1).Range.Text)
If TEM_S <> "" Then
i_Row = i_Row + 1
'跳转下一页判断
GoTo Tiao_kaiguanliang1
End If
'每行按列，写入表格数据
If i_Row1 <= 39 - UBound(SZ_S) Then '不能超过数据行数,至少要保证填写整数个设备
If i_Row1 < 4 + UBound(SZ_S) + 1 Then
If i = 1 And i_Col1 = 2 Then
i_num = 0
ElseIf i = 1 And i_Col1 = 7 Then
'寻找非空的序号，真是困难,本页上一列寻找
For ii = 0 To UBound(SZ_S) + 1
TEM_S = Get_Val(my_tbls(i).Cell(39 - ii, 1).Range.Text)
If TEM_S <> "" Then
i_num = Get_Val(TEM_S)
Exit For
End If
Next ii
ElseIf i > 1 And i_Col1 = 2 Then
'寻找非空的序号，真是困难，上一页寻找
For ii = 0 To UBound(SZ_S) + 1
my_tbls(i - 1).Cell(39 - ii, 6).Select
TEM_S = Get_Val(my_tbls(i - 1).Cell(39 - ii, 6).Range.Text)
If TEM_S <> "" Then
i_num = Get_Val(TEM_S)
Exit For
End If
Next ii
ElseIf i > 1 And i_Col1 = 7 Then
'寻找非空的序号，真是困难,本页上一列寻找
For ii = 0 To UBound(SZ_S) + 1
TEM_S = Get_Val(my_tbls(i).Cell(39 - ii, 1).Range.Text)
If TEM_S <> "" Then
i_num = Get_Val(TEM_S)
Exit For
End If
Next ii
End If
Else
i_num = Get_Val(my_tbls(i).Cell(i_Row1 - 1, i_Col1 - 1).Range.Text)
End If
For 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 = "-远程"
'YC
For 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_i
Case Is = "-运行"
'YX
For 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_i
Case Is = "-故障"
'GZ
For 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_i
Case Is = "-QT"
'QT
For 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_i
End Select
Next SZ_S_i
Else:
GoTo Tiao_kaiguanliang1: '如果该设备未写入完毕，那就跳到下一列或者新建word页，继续填写，这时候设备号不再加1，跳过i_equ=i_equ+1
End If
i_Equ = i_Equ + 1
i_Row = i_Row + UBound(SZ_S) '注意设备增加1个，行数要增加好几行，寻找非空行的时候，只需要增加1行，跳过该指令
Tiao_kaiguanliang1: '非空行跳过,跳——开关量，判断
If i_Row = end_Row - UBound(SZ_S) And i_Col = 2 Then
i_Row = 40
End If
If 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 = True
ElseIf i = my_tbls.Count And SZ_S_i <> 0 Then '某设备的回路尚未填写完毕
Flg_new_page = True
End If
If Flg_new_page = True Then
sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Col '插入新表格，并清空指定区域内容
i_Col1 = 0
Flg_new_page = False '重置判断
End If
If i_Equ < UBound(Arry_Equ) Or i_Row >= (end_Row - 3) * 2 + 4 Then '设备尚未填写完毕，或者某台设备的回路尚未填写完毕
i = i + 1 '页码加1
i_Row = str_Row
ElseIf i_Equ = UBound(Arry_Equ) And SZ_S_i <= UBound(SZ_S) Then
i = i + 1 '页码加1
i_Row = str_Row
End If
End If
Loop Until i_Equ > UBound(Arry_Equ) Or Arry_Equ(i_Equ) = ""
FP1:
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private 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 Sub
Private Sub Cmd_Yibiao_Tongyi_Click()
'统一仪表尺寸，将仪表报告其他页面表格尺寸与第一页统一，默认第一页，也可以更改参考页。
Dim i%
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
i = MsgBox("是否将所有表格尺寸与参考页表格尺寸统一？", vbOKCancel, "统一表格尺寸")
If i = 1 Then
Sub_Yibiao_Tongyi
End If
End Sub
Private Sub cmd_ZengJia_Click()
T_StrRow.Text = CInt(T_StrRow.Text) + CInt(T_NoOfPage.Text)
End Sub
Private Sub cmd_zt_start_Click()
'控制word刷新
Application.ScreenUpdating = False
Dim str_P%, end_P%, str_Row%, end_Row%, str_Col%, end_Col%, n%
Dim zt_Last As Variant, zt_First As Variant
Dim zt_S$
Dim Arry_QT As Variant, Arry_YC As Variant, Arry_YX As Variant, Arry_GZ As Variant
Dim Arry_KG As Variant, Arry_KGW As Variant, Arry_KDW As Variant, Arry_GDW As Variant
Dim Arry_Equ As Variant
Dim SZ_S As Variant, SZ_S_i%, Flg_new_page As Boolean
Dim 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 Tables
Dim my_table As Table
my_Stop = False
Set my_tbls = ActiveDocument.Tables
Sub_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 Then
zt_First = Split(T_zt_First.Text, ";")
Else '没有分号
ReDim zt_First(0)
zt_First(0) = T_zt_First.Text
End If
If InStr(T_zt_Last.Text, ";") > 0 Then
zt_Last = Split(T_zt_Last.Text, ";")
Else '没有分号
ReDim zt_Last(0)
zt_Last(0) = T_zt_Last.Text
End If
SZ_S = zt_Last
If T_Equ.Text = "" Then
T_Equ.Text = "P001" & vbCrLf & "P002"
End If
Arry_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_Row
i = Selection.Information(wdActiveEndPageNumber)
Do While i_Equ <= UBound(Arry_Equ)
If my_Stop = True Then: Exit Sub '停止程序
'检查到表格中有数据就跳过本行
my_tbls(i).Cell(i_Row, 2).Select
TEM_S = Get_Val(my_tbls(i).Cell(i_Row, 2).Range.Text)
If TEM_S <> "" Then
GoTo Tiao_kaiguanliang
End 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"
'QT
For 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_i
Case Is = "-远程"
'YC
For 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_i
Case Is = "-运行"
'YX
For 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_i
Case Is = "-故障"
'GZ
For 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_i
Case Is = "-KG"
'GZ
For 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_i
Case Is = "-KGW"
'GZ
For 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_i
Case Is = "-KDW"
'GZ
For 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_i
Case Is = "-GDW"
'GZ
For 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_i
End Select
If SZ_S_i >= UBound(SZ_S) Or SZ_S(SZ_S_i) = "" Then
i_Equ = i_Equ + 1
SZ_S_i = 0 '某设备单条填写完毕，准备填写下一条
Else
SZ_S_i = SZ_S_i + 1
End If
Tiao_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 = True
ElseIf i = my_tbls.Count And SZ_S_i <> 0 Then '某设备的回路尚未填写完毕
Flg_new_page = True
End If
If Flg_new_page = True Then
sub_New_tbl my_tbls, i, str_Row, str_Col, end_Row, end_Col '插入新表格，并清空指定区域内容
Flg_new_page = False '重置判断
End If
If i_Equ < UBound(Arry_Equ) Then '设备尚未填写完毕，或者某台设备的回路尚未填写完毕
i = i + 1 '页码加1
i_Row = str_Row
ElseIf i_Equ = UBound(Arry_Equ) And SZ_S_i <= UBound(SZ_S) Then
i = i + 1 '页码加1
i_Row = str_Row
End If
End If
Delay (1)
Loop
tem_i = 0
FP1:
'控制word刷新
Application.ScreenUpdating = True
End Sub
Private Sub Comb_DYMC_Click()
T_GGNR.Text = Get_Val(Comb_DYMC.Text)
End Sub
Private Sub cmdJiaRuBiaoQian_Click()
LbZhengMian.Caption = LbZhengMian.Caption & Combo_ZiDuan.Text & vbCrLf
LbFanMian.Caption = LbFanMian.Caption & Combo_ZiDuan.Text & vbCrLf
listZiDuan.AddItem Combo_ZiDuan
End Sub
Private Sub cmdQingKongBiaoQian_Click()
LbZhengMian.Caption = ""
LbFanMian.Caption = ""
listZiDuan.Clear
End Sub
Private 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, S
If InStr(1, S, S1) > 0 Then
Selection.Text = S
Exit Do
End If
Loop
List_KeyWord.Clear
Do While Not EOF(1)
Input #1, S
If InStr(1, S, S1) > 0 Then
List_KeyWord.AddItem S
End If
Loop
Close #1
End Sub
Private Sub Comb_zt_types_Change()
Ref_zt_Types
T_str_Row.Text = 4
T_str_Col.Text = 2
T_end_Row.Text = 35
T_end_Col.Text = 9
End Sub
Private 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 Sub
Public Sub Del_FenYeFu()
'删除所有分页符
Const wdReplaceAll = 2
Dim oRng As Range
With ActiveWindow.ActivePane.View.Zoom
.PageRows = 1
End With
Set 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.Find
Do While .Execute(findtext:=TEM_S) = True
find_No = find_No + 1
Loop
End With
If find_No >= 2 Then '找到大于2条相同记录，说明至少有2个表格。只有1个表格情况会死循环，排除这个情况
'【删除表格之间多余内容】删除多余换行符和空格和分页符等不属于表格的内容
tem_Tims = 0
Selection.HomeKey Unit:=wdStory '光标移动到首行
Selection.Find.ClearFormatting
With Selection.Find
.Text = TEM_S
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
tem_Line = Selection.Information(wdFirstCharacterLineNumber)
L = 0
Do Until Selection.Information(wdActiveEndAdjustedPageNumber) >= Selection.Information(wdNumberOfPagesInDocument)
L = L + 1
If L > 5000 Then: Exit Do
'防止查重
'删除非表格内容数据
Selection.MoveUp Unit:=wdLine, Count:=1
j = 0
Do While Selection.Information(Word.WdInformation.wdWithInTable) = False
Delay (10)
Selection.Delete
Selection.MoveUp Unit:=wdLine, Count:=1
j = j + 1
If j > 100 Then: Exit Do
Loop
tem_Tims = tem_Tims + 1
Selection.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 Then
Selection.Find.Execute
Else
tem_Line = Selection.Information(wdFirstCharacterLineNumber)
End If
'破死循环,超过找到真正表格数量
If tem_Tims >= find_No + 2 Then
Exit Do
End If
Loop
'最后一页单独增加一个分页符
If Selection.Information(wdActiveEndAdjustedPageNumber) >= Selection.Information(wdNumberOfPagesInDocument) Then
'删除非表格内容数据
Selection.MoveUp Unit:=wdLine, Count:=1
j = 0
Do While Selection.Information(Word.WdInformation.wdWithInTable) = False
Delay (10)
Selection.Delete
Selection.MoveUp Unit:=wdLine, Count:=1
j = j + 1
If j > 100 Then: Exit Do
Loop
Selection.Find.Execute
Selection.InsertBreak Type:=wdPageBreak
'删除第一页之前多余的一个分页符
Selection.HomeKey Unit:=wdStory '光标移动到首行
Selection.Delete
End If
End If
'首行增加回车
Selection.HomeKey Unit:=wdStory '光标移动到首行
On Error Resume Next
Selection.SplitTable
'移动到最后一行
MoveToDocEnd
'再次删除非表格内容数据
Selection.MoveUp Unit:=wdLine, Count:=1
j = 0
Do While Selection.Information(Word.WdInformation.wdWithInTable) = False
Delay (10)
Selection.Delete
Selection.MoveUp Unit:=wdLine, Count:=1
j = j + 1
If j > 100 Then: Exit Do
Loop
sub_ShouHangYouHua '优化首页首行显示，删除不必要的分页符和换行
End Sub
Private Sub Cmd_Tong_Yi_Table_H_W_Click()
YeBianJu '先将表格居中
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
YEBIANJU1 '统一页边距，不然更改表格尺寸没意义
sub_Tong_Yi_Table_H_W '更改表格尺寸适合A4纸打印
End Sub
Private Sub CMD_Cell_counts_Click()
On Error Resume Next
T_jishu.Text = Cell_counts
End Sub
Private Sub sub_ShouHangYouHua()
'移动到首行删除首行的分页符增加一个回车
'优化首页首行显示，删除不必要的分页符和换行
Dim j%
MoveToDocStart
'再次删除非表格内容数据
Selection.MoveUp Unit:=wdLine, Count:=1
j = 0
Do While Selection.Information(Word.WdInformation.wdWithInTable) = False
Delay (10)
Selection.Delete
'Selection.MoveUp Unit:=wdLine, Count:=1
j = j + 1
If j > 100 Then: Exit Do
Loop
MoveToDocStart
Selection.SplitTable
End Sub
Private Sub combo_sheetsName_Change()
End Sub
Private Sub Combox_FangXiang_Change()
End Sub
Private 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 Sub
Private 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 Table
Set my_tbls = ActiveDocument.Tables
str_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.Tables
n = myTable.Count
n1 = 34
For i = str_P To end_P
n = myTable(i).Rows.Count
For j = 0 To 1
myTable(i).Rows(n - j).Delete
Next j
n = myTable(i).Rows.Count
myTable(i).Rows(n).Select
Selection.InsertRowsBelow 1
Selection.Text = "技术负责人： 调校人： " & T_riqi.Text
Next i
End Sub
Private Sub CommandButton2_Click()
Dim S$, P_Txt$
P_Txt = T_path_Record.Text
Shell "notepad.exe " + P_Txt, 1
End Sub
Private 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 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)
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 i
TXT_Path = ActiveDocument.Path & "\" & "数据导出_" & i_s & ".txt"
'创建txt文档
Open TXT_Path For Output As #1
Close #1
Delay 100
'写入数据
Open TXT_Path For Append As #1
For 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, 1
End Sub
Private Sub CommandButton6_Click()
End Sub
Private 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 String
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim i As Long, j As Long
ExcelPath = T_ExcelPath.Text
SheetName = combo_sheetsName.Text
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(SheetName)
' 确定数据范围
Dim lastRow As Long, LastCol As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
wb.Close SaveChanges:=False
StrRow = 1
EndRow = 1
StrCol = 1
EndCol = LastCol
SZ_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 j
Next i
Combo_ZiDuan.ListIndex = 0
End Sub
Private Sub CommandButton5_Click()
End Sub
Private Sub delete_All_Click()
DeletePageContent '删除当前页所有文本框
End Sub
Sub DeletePageContent()
Dim currentPage As Range
Set currentPage = Selection.Range
'选择并删除当前页上的所有内容
currentPage.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=1
currentPage.WholeStory
currentPage.Delete
'清空本页内容
Selection.TypeText Text:=""
End Sub
Private Sub Lab_CanKao_P_Click()
ActiveDocument.Tables(T_CanKao_P.Text).Cell(1, 1).Select
End Sub
Private Sub Lab_end_P_Click()
ActiveDocument.Tables(T_end_P.Text).Cell(1, 1).Select
End Sub
Private Sub Lab_state_Click()
End Sub
Private Sub Lab_str_P_Click()
ActiveDocument.Tables(T_str_P.Text).Cell(1, 1).Select
End Sub
Private Sub Label103_Click()
End Sub
Private Sub Label80_Click()
If Cmb_sty.Text = "热电阻" Then
T_jiancedian.Text = "0,100"
ElseIf Cmb_sty.Text = "温度变送器" Then
T_jiancedian.Text = "25,50,100"
End If
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
MsgBox ListBox1.Selected
End Sub
Private Sub Label99_Click()
End Sub
Private Sub List_KeyWord_Click()
Selection.Text = List_KeyWord.Text
End Sub
Private Sub listZiDuan_Click()
MsgBox listZiDuan.List(0)
End Sub
Private Sub MultiPage1_Change()
'MsgBox MultiPage1.Value
Select Case MultiPage1.Value
Case Is = 6
T_Doc_Path.Text = ActiveDocument.Path
Case Is = 5
'分析是开关量回路还是多回路
On Error Resume Next
If ActiveDocument.Tables.Count >= 1 Then
If InStr(0, ActiveDocument.Tables(1).Cell(1, 2).Range.Text, "多回路") > 0 Then
'发现多回路报告
Comb_zt_types.ListIndex = 1
End If
End If
Case Is = 9
Frm_WORD.width = 1000
Frm_WORD.height = 600
Case Else
Frm_WORD.width = 600
Frm_WORD.height = 400
End Select
End Sub
Private Sub OBut_style_01_Click()
If OBut_style_01.Value = -1 Then
Cmb_sty_01.Enabled = True
Cmb_sty.Enabled = False
End If
End Sub
Private Sub OBut_style_Click()
If OBut_style.Value = -1 Then
Cmb_sty_01.Enabled = False
Cmb_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 Then
On Error Resume Next
AITD = CDbl1(T_AITD.Text)
AIKS = CDbl1(T_AIKS.Text)
AIDS = CDbl1(T_AIDS.Text)
If DSS.Value = -1 Then
AIKS = KSjs(AIDS, AITD)
T_AIKS.Text = AIKS
Else
AIDS = DSjs(AITD, AIKS)
T_AIDS.Text = AIDS
End If
End If
End Sub
Private Sub T_AOTD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AOTD.Text) = True Then
On Error Resume Next
AOTD = CDbl1(T_AOTD.Text)
AOKS = CDbl1(T_AOKS.Text)
AODS = CDbl1(T_AODS.Text)
If DSS.Value = -1 Then
AOKS = KSjs(AODS, AOTD)
T_AOKS.Text = AOKS
Else
AODS = DSjs(AOTD, AOKS)
T_AODS.Text = AODS
End If
End If
End Sub
Private Sub T_Box_Height_Change()
End Sub
Private Sub T_BoxWidth_Change()
End Sub
Private Sub T_DITD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DITD.Text) = True Then
On Error Resume Next
DITD = CDbl1(T_DITD.Text)
DIKS = CDbl1(T_DIKS.Text)
DIDS = CDbl1(T_DIDS.Text)
If DSS.Value = -1 Then
DIKS = KSjs(DIDS, DITD)
T_DIKS.Text = DIKS
Else
DIDS = DSjs(DITD, DIKS)
T_DIDS.Text = DIDS
End If
End If
End Sub
Private Sub T_DOC_OK_Change()
End Sub
Private Sub T_Doc_Path_Change()
End Sub
Private Sub T_DOTD_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DOTD.Text) = True Then
On Error Resume Next
DOTD = CDbl1(T_DOTD.Text)
DOKS = CDbl1(T_DOKS.Text)
DODS = CDbl1(T_DODS.Text)
If DSS.Value = -1 Then
DOKS = KSjs(DODS, DOTD)
T_DOKS.Text = DOKS
Else
DODS = DSjs(DOTD, DOKS)
T_DODS.Text = DODS
End If
End If
End Sub
Private Sub T_AIKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AIKS.Text) = True Then
On Error Resume Next
AITD = CDbl1(T_AITD.Text)
AIKS = CDbl1(T_AIKS.Text)
AIDS = CDbl1(T_AIDS.Text)
If DSS.Value = -1 Then
AITD = TDjs(AIDS, AIKS)
T_AITD.Text = AITD
Else
AIDS = DSjs(AIKS, AIKS)
T_AIDS.Text = AIDS
End If
End If
End Sub
Private Sub T_AOKS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AOKS.Text) = True Then
On Error Resume Next
AOTD = CDbl1(T_AOTD.Text)
AOKS = CDbl1(T_AOKS.Text)
AODS = CDbl1(T_AODS.Text)
If DSS.Value = -1 Then
AOTD = TDjs(AODS, AOKS)
T_AOTD.Text = AOTD
Else
AODS = DSjs(AOKS, AOKS)
T_AODS.Text = AODS
End 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 Then
On Error Resume Next
DITD = CDbl1(T_DITD.Text)
DIKS = CDbl1(T_DIKS.Text)
DIDS = CDbl1(T_DIDS.Text)
If DSS.Value = -1 Then
DITD = TDjs(DIDS, DIKS)
T_DITD.Text = DITD
Else
DIDS = DSjs(DIKS, DIKS)
T_DIDS.Text = DIDS
End 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 Then
On Error Resume Next
DOTD = CDbl1(T_DOTD.Text)
DOKS = CDbl1(T_DOKS.Text)
DODS = CDbl1(T_DODS.Text)
If DSS.Value = -1 Then
DOTD = TDjs(DODS, DOKS)
T_DOTD.Text = DOTD
Else
DODS = DSjs(DOKS, DOKS)
T_DODS.Text = DODS
End 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 Then
On Error Resume Next
AITD = CDbl1(T_AITD.Text)
AIKS = CDbl1(T_AIKS.Text)
AIDS = CDbl1(T_AIDS.Text)
If KSS.Value = -1 Then
AITD = TDjs(AIDS, AIKS)
T_AITD.Text = AITD
Else
AIKS = KSjs(AIDS, AITD)
T_AIKS.Text = AIKS
End If
End If
End Sub
Private Sub T_AODS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_AODS.Text) = True Then
On Error Resume Next
AOTD = CDbl1(T_AOTD.Text)
AOKS = CDbl1(T_AOKS.Text)
AODS = CDbl1(T_AODS.Text)
If KSS.Value = -1 Then
AOTD = TDjs(AODS, AOKS)
T_AOTD.Text = AOTD
Else
AOKS = KSjs(AODS, AOTD)
T_AOKS.Text = AOKS
End If
End If
End Sub
Private Sub T_DIDS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DIDS.Text) = True Then
On Error Resume Next
DITD = CDbl1(T_DITD.Text)
DIKS = CDbl1(T_DIKS.Text)
DIDS = CDbl1(T_DIDS.Text)
If KSS.Value = -1 Then
DITD = TDjs(DIDS, DIKS)
T_DITD.Text = DITD
Else
DIKS = KSjs(DIDS, DITD)
T_DIKS.Text = DIKS
End If
End If
End Sub
Private Sub T_DODS_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If IsNumeric(T_DODS.Text) = True Then
On Error Resume Next
DOTD = CDbl1(T_DOTD.Text)
DOKS = CDbl1(T_DOKS.Text)
DODS = CDbl1(T_DODS.Text)
If KSS.Value = -1 Then
DOTD = TDjs(DODS, DOKS)
T_DOTD.Text = DOTD
Else
DOKS = KSjs(DODS, DOTD)
T_DOKS.Text = DOKS
End If
End 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.Text
Select Case Cmb_sty.ListIndex
Case 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_S
T_str_Row.Text = 9
T_str_Col.Text = 1
T_end_Row.Text = 11
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 1
T_P_ShuJu.Text = 3
T_jiancedian.Enabled = True
T_jiancedian.Text = "0,50,100"
Case Is = 2
'温度变送器
T_str_Row.Text = 11
T_str_Col.Text = 1
T_end_Row.Text = 13
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 1
T_P_ShuJu.Text = 3
T_jiancedian.Enabled = True
T_jiancedian.Text = "25,50,100"
Case Is = 3
'压力变送器
T_str_Row.Text = 11
T_str_Col.Text = 1
T_end_Row.Text = 15
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 4
T_LC_Col.Text = 2
T_Point.Text = 2
T_P_ShuJu.Text = 3
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_Tips.Text = "只需输入量程0-100kpa，精度：0.05%；其他不用输入"
Case Is = 4
'温度计
T_str_Row.Text = 3
T_str_Col.Text = 8
T_end_Row.Text = 40
T_end_Col.Text = 8
T_Point.Text = 1
T_HD_k.Text = 2
T_jingdu.Text = 1.5
T_jiancedian.Enabled = False
Case Is = 5
'压力表
T_str_Row.Text = 3
T_str_Col.Text = 8
T_end_Row.Text = 40
T_end_Col.Text = 8
T_Point.Text = 4
T_HD_k.Text = 2
T_jingdu.Text = 1.5
T_Tips.Text = "压力表数据列必须为9列，否则出错，例如：序号-名称-编号-型号-量程-精度-允许误差-最大误差-调校结果"
T_jiancedian.Enabled = False
Case Is = 6
'调节阀
T_str_Row.Text = 19
T_str_Col = 2
T_end_Row = 24
T_end_Col = 6
T_VA_bz_Row.Text = T_str_Row.Text
T_xc_Row.Text = 4
T_xc_Col.Text = 2
T_jingdu.Text = 0.5
T_jiancedian.Enabled = False
T_P_ShuJu.Text = 2
Case Is = 7
'模拟量回路测试
T_str_Row.Text = 5
T_str_Col.Text = 4
T_end_Row.Text = 36
T_end_Col.Text = 10
T_col_BZ.Text = 3 '量程所在列
T_Point.Text = 1
T_jingdu.Text = 0.1
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_P_ShuJu.Text = 2
Case Is = 8
'基础化I/O组件模拟量测试
T_str_Row.Text = 5
T_str_Col.Text = 4
T_end_Row.Text = 36
T_end_Col.Text = 10
T_col_BZ.Text = 3 '量程所在列
T_Point.Text = 2
T_P_ShuJu.Text = 2
T_jingdu.Text = 0.1
T_jiancedian.Enabled = False
Case Is = 9
'安全栅
T_str_Row.Text = 4
T_str_Col.Text = 8
T_end_Row.Text = 35
T_end_Col.Text = 12
T_col_BZ.Text = 5 '精度所在列
T_Point.Text = 2
T_jingdu.Text = 0.1
T_point_wucha.Enabled = True
T_jiancedian.Enabled = False
Case Is = 10
'数显表
T_str_Row.Text = 10
T_str_Col.Text = 2
T_end_Row.Text = 14
T_end_Col.Text = 8
T_jingdu.Text = 0.5
T_LC_Row.Text = 5
T_LC_Col.Text = 2
T_Point.Text = 2
T_P_ShuJu.Text = 3
T_jdxs.Text = 0.4
T_jiancedian.Enabled = False
T_Tips.Text = "数显表数据"
Case Else
T_point_wucha.Enabled = False
T_jiancedian.Enabled = False
End Select
End Sub
'2--指令-表格数据批量更改-------------------------------------------------------
Private Sub Cmd_acitve_me_Click()
MsgBox "所有内容仅供个人学习使用，严禁传播。", , "声明："
End Sub
Private Sub Cmd_biaogejuzhong_Click()
YeBianJu '更改页边距后自动居中。
End Sub
Private 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.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)
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.Count
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
T_str_P.Text = 1
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
For i = str_P To end_P
For j = str_Row To end_Row
For k = str_Col To end_Col
If Chk_BGFZ_ZT.Value = False Then
TEM_S = Get_Val(my_tbls(CanKao_P).Cell(j, k).Range.Text)
my_tbls(i).Cell(j, k).Select
Delay (10)
If Chk_fugai.Value = -1 Then
Selection.Text = ""
End If
my_tbls(i).Cell(j, k).Range.Text = TEM_S
Else
my_tbls(CanKao_P).Cell(j, k).Range.Copy
Delay (2)
my_tbls(i).Cell(j, k).Range.Select
my_tbls(i).Cell(j, k).Range.Paste
End If
'更改行高
If Chk_BGFZ_HG.Value = True Then
my_tbls(i).Cell(j, k).height = my_tbls(str_P).Cell(j, k).height
End If
Next k
Next 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 Sub
Private Sub Cmd_get_col_BZ_Click()
'获取标准值所在数据列
T_col_BZ.Text = Selection.Information(wdEndOfRangeColumnNumber)
End Sub
Private Sub Cmd_get_Row_Click()
'获取标准值所在数据行
T_VA_bz_Row.Text = Selection.Information(wdEndOfRangeRowNumber)
End Sub
Private 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 Sub
Private Sub cmd_insert_date_Click()
Ins_data
End Sub
Private Sub cmd_IO_CLEAR_Click()
T_AD.Text = ""
End Sub
Private Sub Cmd_pilianggaitu_Click()
'mac_TuPianDaXiao
'适合96dpi的图片
Dim img As InlineShape
' 根据你的发现，直接使用特定比例来设置宽度以近似5cm（仅适用于96dpi）
Dim targetWidthMultiplier As Single
Dim Width_1cm As Double
Width_1cm = 28.318584 '1厘米宽度对应的像素值
If IsNumeric(T_PIC_Width.Text) = False Or T_PIC_Width.Text = "" Then '防止输入错误
T_PIC_Width.Text = 5
End If
targetWidthMultiplier = T_PIC_Width.Text * Width_1cm ' 文本框输入厘米数转换成word对应的数值
' 遍历文档中的所有内嵌图片
For Each img In ActiveDocument.InlineShapes ' 等比例调整图片尺寸，首先获取原始尺寸，然后应用特定比例
With img
.LockAspectRatio = True ' 保持宽高比锁定
If .width = targetWidthMultiplier <> targetWidthMultiplier Then
.width = targetWidthMultiplier
End If
End With
Next img
MsgBox "文档中的图片已全部调整为大约" & T_PIC_Width & "厘米宽度。"
End Sub
Private Sub Cmd_quanlujing_Click()
'标题栏显示完整路径
On Error Resume Next
ActiveWindow.Caption = ActiveDocument.FullName
End Sub
Private Sub cmd_Red_Click()
ziti_Red
End Sub
Private 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 = False
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)
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.Count
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
S_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 = "压力变送器" Then
For i = str_P To end_P
If 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行填写数据
Randomize
Delay (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) '标准电流值
Randomize
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
flg_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) '上行值
Randomize
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
flg_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 k
Next j
For j = str_Row To end_Row '11-15行填写数据
For k = str_Col To end_Col
my_tbls(i).Cell(j, k).Range.Text = SZ_YaLi(j, k)
Next k
Next j
Erase SZ_YaLi '清空静态数组
my_tbls(i).Cell(1, 1).Select '动态更新页面
If i = end_P Then: MsgBox "更新完毕！"
Next i
ElseIf t_Style = "数显表" Then
For i = str_P To end_P
If 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_Col
Randomize
S_P = Cint1(T_Point.Text)
S_P1 = Cint1(T_P_ShuJu.Text) '数据小数位数
'my_tbls(i).Cell(j, k).Select
Delay (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 = 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 - str_Row) / 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 - str_Row) / 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 + 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 Select
my_tbls(i).Cell(j, k).Range.Text = TEM_S
Next k
Next j
If i = end_P Then: MsgBox "更新完毕！"
Next i
ElseIf t_Style = "热电阻" Then
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;-50-250;-100~450;-196~600;-196~600;"
Randomize
For i = str_P To end_P
If 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.15
tem_Range = "-100~450℃"
Case Is = "B级", "B"
Jingdu = 0.3
tem_Range = "-196~600℃"
Case Is = "C级", "C"
Jingdu = 0.6
tem_Range = "-196~600℃"
Case Is = "AA级", "AA"
Jingdu = 0.3
tem_Range = "-50~250℃"
Case Else
Jingdu = 0.15
tem_Range = "-100~450℃"
End Select
'获得量程,为计算百分比做准备
TEM_S = my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text
If Get_Val(TEM_S) = "" Then '如果量程忘记填写，重新赋值量程
my_tbls(i).Cell(Lc_Row, Lc_Col).Range.Text = tem_Range
TEM_S = Get_Range(tem_Range)
Else
TEM_S = Get_Range(TEM_S)
End If
MyRange = 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 - 2
For j = str_Row To end_Row
Dim 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).Select
Delay (10)
Select Case k
Case Is = 1 '量程百分比
If U_Range = L_Range Then
MsgBox "量程下限和上限相等，除数为0，请检查量程，尽量改成这样的形式：0-100单位"
End If
TEM_S = (tem_S_jcd - U_Range) / (U_Range - L_Range) * 100
TEM_S = fun_XiaoShu(TEM_S, S_P)
Case Is = 2 '当前检测点位
TEM_S = tem_S_jcd
TEM_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 = 4
tem_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_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 = 6
tem_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_Wucha
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
my_tbls(i).Cell(j, k).Range.Text = TEM_S
Next k
Next j
If i = end_P Then: MsgBox "更新完毕！"
Next i
ElseIf t_Style = "温度变送器" Then
Randomize
'准备检测点数值，准备布署数据
T_Range = Split(T_jiancedian.Text, ",") '人为定义检测点，但是要考虑规范要求
For i = str_P To end_P
If 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 - 2
For j = str_Row To end_Row '根据检测点位，逐行填写数据
Randomize
Delay (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) '标准电流值
Randomize
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
flg_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) '上行值
Randomize
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
flg_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 j
For j = str_Row To end_Row '11-15行填写数据
For k = str_Col To end_Col
my_tbls(i).Cell(j, k).Range.Text = SZ_YaLi(j, k)
Next k
Next j
Erase SZ_YaLi '清空静态数组
my_tbls(i).Cell(1, 1).Select
If 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) '数据小数位数
Randomize
For i = str_P To end_P
For j = str_Row To my_tbls(i).Rows.Count - 2
If my_Stop = True Then: Exit Sub '停止程序
If Len(my_tbls(i).Cell(j, 2).Range.Text) > 2 Then
TEM_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_range
TEM_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).Select
my_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 Next
my_tbls(i).Cell(j, 9).Range.Text = "合格"
End If
Next j
If i = end_P Then: MsgBox "更新完毕！"
Next i
ElseIf t_Style = "模拟量回路测试" Or Cmb_sty.Text = "基础化I/O组件模拟量测试" Then
sub_AIAO_ShuJu my_tbls, str_P, end_P, str_Row, end_Row, str_Col, end_Col
ElseIf t_Style = "安全栅" Then
For i = str_P To end_P
If end_Row > my_tbls(i).Rows.Count - 2 Then: end_Row = my_tbls(i).Rows.Count - 2
For j = str_Row To end_Row
If 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_S
GoTo Tiao_anquanshan
End If
End If
TEM_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
'计算误差
Randomize
YXWC = (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 Then
my_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 Then
Jingdu = 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 If
If k = end_Col Then
my_tbls(i).Cell(j, k).Range.Text = "合格"
End If
Next k
End If
Tiao_anquanshan:
Next j
If i = end_P Then: MsgBox "更新完毕！"
Next i
End If
'启用word刷新
Application.ScreenUpdating = True
End Sub
Private Sub Cmd_ref_VA_Click()
'根据原始内容和精度更改数据,调节阀
'控制word刷新
Application.ScreenUpdating = False
Dim 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 Table
Dim 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 Variant
my_Stop = False
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)
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.Count
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col + 1
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
'设定小数点
S_P = Set_P(Points)
Randomize
For i = str_P To end_P
my_tbls(i).Cell(1, 1).Select
If 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).Select
Select Case j
Case Is = str_Row
'更正单位
tem_Unit = .Cell(4, 1).Range.Text
tem_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 k
Case Is <= str_Row + 2
'第1遍正反行程
For k = str_Col To end_Col
If k = str_Col Or k = end_Col Then
Flg_i = 0
Else
Flg_i = 1
End If
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
tem_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_Wucha
Sz1(j - str_Row, k - str_Col) = Format(TEM_S, S_P)
' .Cell(j, k).Range.Text = Format(TEM_S, S_P)
Next k
Case Is <= str_Row + 4, Is > str_Row + 2
'第2遍正反行程
For k = str_Col To end_Col
If k = str_Col Or k = end_Col Then
Flg_i = 0
Else
Flg_i = 1
End If
flg_Zero = Rnd - 0.5
If flg_Zero = 0 Then: flg_Zero = flg_Zero + 1
tem_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_Wucha
Sz1(j - str_Row, k - str_Col) = Format(TEM_S, S_P)
' .Cell(j, k).Range.Text = Format(TEM_S, S_P)
Next k
Case Else
MsgBox "超出行数"
End Select
Next j
End With
'正反行程误差的较大值
'正反行程误差的较大值
For k = str_Col To end_Col
Up1 = 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_Row
For k = str_Col To end_Col
If Sz1(j - str_Row, k - str_Col) <> "" Then
If 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 If
End If
Next k
Next j
End With
Next i
'控制word刷新
Application.ScreenUpdating = True
End Sub
Public Function Max(ByVal a#, ByVal b#) As Double
'获得2个数中较大值
If a >= b Then
Max = a
Else
Max = b
End If
End Function
Public 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 Then
R_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 -1
If InStr(1, "0123456789.", Mid(R_S, i, 1)) > 0 Then
R_S = Left(R_S, i)
L_R_S = Len(R_S)
Exit For
End If
Next i
'从量程左侧开始获取量程
For i = 1 To L_R_S
i1_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 - 1
PL = 1
ElseIf 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 = i
URH_1 = i + 1
PL = 1
PH1 = 1
ElseIf PL = 0 And i = L_R_S Then '下限是0，只有上限的量程
URL = 0
URH = Left(R_S, i)
PL = 1
PH = 1
Exit For
End If
If 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 + 1
PH1 = 1
End If
If PL = 1 And PH1 = 1 And PH = 0 And InStr(1, "-.0123456789", i3_R_S) < 1 Then
'已经发现量程下限和上限起始值，发现非数字值，发现单位第一个字母；后发现量程上限终止值
i_URH = i + 1
URH = Mid(R_S, URH_1 + 1, i_URH - URH_1)
PH = 1
End If
If PL = 1 And PH = 0 And i = L_R_S Then
'没有单位的量程
i_URH = i
URH = Mid(R_S, URH_1 + 1, i_URH - URH_1)
PH = 1
'MsgBox "无单位"
End If
If i >= L_R_S And PH = 0 And PL = 0 Then
'没有量程
URL = 0
URH = 0
PH = 1
PH1 = 1
PL = 1
Exit For
End If
Next i
Get_Range = URL & ";" & URH
Else
Get_Range = "0;0"
PL = 1
PH = 1
PH1 = 1
End If
End 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 Range
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)
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.Count
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
T_str_P.Text = 1
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
If Chk_HG_YE.Value = True Then
For 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.Select
Gaiziti T_ziti.Text, Cint1(T_zihao.Text), Cint1(T_JJ.Text)
Next i
Else
Gaiziti T_ziti.Text, Cint1(T_zihao.Text), Cint1(T_JJ.Text)
End If
'Selection.HomeKey Unit:=wdStory
End Sub
Private Sub lab_ref_VA_Click()
Cmd_ref_VA.Enabled = True
End Sub
Private 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 Sub
Private Sub Lb_zihao_Click()
Gaiziti T_ziti.Text, Cint1(Lb_zihao.Caption), Cint1(T_JJ.Text)
End Sub
Private Sub Lbl_flg_cmd_Click()
Cmd_Ref_Date.Enabled = True
End Sub
Private Sub T_end_Col_Change()
end_Col = Cint1(T_end_Col.Text)
End Sub
Private Sub T_end_P_Change()
Dim my_tbls As Tables
Set my_tbls = ActiveDocument.Tables
If Cint1(T_end_P.Text) > my_tbls.Count Then
MsgBox "页数超出word中表格的实际页数，已经更正为word的表格总页数:" & my_tbls.Count & "页"
T_end_P.Text = my_tbls.Count
End If
End Sub
Private 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 Sub
Private Sub T_ExcelPath_Change()
End Sub
Private 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 Sub
Private Sub T_INS2_Change()
L_T_INS2.Caption = T_INS2.LineCount
End Sub
Private Sub T_INS3_Change()
L_T_INS3.Caption = T_INS3.LineCount
End Sub
Private Sub T_INS4_Change()
L_T_INS4.Caption = T_INS4.LineCount
End Sub
Private 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 Then
MsgBox "检测点只能输入【数值】和【.】和【英文半角逗号】"
End If
Next i
End Sub
Private Sub T_NewPages_Change()
End Sub
Private Sub T_PIC_Width_Change()
End Sub
Private Sub T_StartX_Change()
End Sub
Private Sub T_str_Col_Change()
str_Col = Cint1(T_str_Col.Text)
End Sub
Private Sub T_str_Row_Change()
str_Row = Cint1(T_str_Row.Text)
End Sub
Private Sub T_StrRow_Change()
T_EndRow.Text = CInt(T_StrRow.Text) + CInt(T_NoOfPage.Text) - 1
End Sub
Private Sub T_StrY_Change()
End Sub
Private 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 Sub
Private Sub T_yw_LdP_Change()
yw_S_js
End Sub
Private Sub T_ZBJX_Change()
End Sub
Private 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 Then
T_hanggao.Text = i + 1
ElseIf KeyCode = 40 Then
T_hanggao.Text = i - 1
ElseIf KeyCode < 58 And KeyCode > 47 Then
Hg = 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.Tables
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
If Chk_HG_YE.Value = False Then
Hg = CInt(T_hanggao.Text)
Hanggao Hg, K1
Else
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)
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.Count
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
T_str_P.Text = 1
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
For i = str_P To end_P
For j = str_Row To end_Row
For k = str_Col To end_Col
'my_tbls(i).Cell(j, k).Select
my_tbls(i).Cell(j, k).height = my_tbls(str_P).Cell(j, k).height
Next k
Next j
Next 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 Sub
Private Sub L6_Click()
Hg = 6
Hanggao Hg, K1
End Sub
Private Sub L8_Click()
Hg = 8
Hanggao Hg, K1
End Sub
Private Sub L10_Click()
Hg = 10
Hanggao Hg, K1
End Sub
Private Sub L12_Click()
Hg = 12
Hanggao Hg, K1
End Sub
Private 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 Then
With Selection.ParagraphFormat
.LineSpacing = T_JJ.Text
End With
End If
End Sub
Private Sub T_JJ_Change()
Dim i As Double
i = Cint1(T_JJ.Text)
If i > 0.7 Then
With Selection.ParagraphFormat
.LineSpacing = T_JJ.Text
End 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.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)
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.Count
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
For i = str_P To end_P
For j = str_Row To end_Row
For k = str_Col To end_Col
TEM_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 Then
tem_Ss = T_QianZhui.Text & TEM_S & T_HouZhui.Text & (str_DZ + i_DZ)
Else
tem_Ss = T_QianZhui.Text & TEM_S & T_HouZhui.Text
End If
my_tbls(i).Cell(j, k).Range.Text = tem_Ss
tem_Ss = ""
i_DZ = i_DZ + 1
Next k
Next 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 Variant
Dim my_tbls As Tables
Dim my_table As Table
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)
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.Count
Sub_ReSet_Page_No '初始化页码格式，将第一页页码设置为1
Lab_state.Caption = "拼命填写中..."
If T_INS.Text <> "" Then
SZ_S = Split(T_INS.Text, vbCrLf)
End If
If CanKao_P > n Or CanKao_P < 1 Then
MsgBox "参考页超过表格数量，确认后会自动更正"
CanKao_P = n
T_CanKao_P.Text = CanKao_P
End If
If end_P > n Then
MsgBox "结束页超过表格数量，确认后会自动更正"
end_P = n
T_end_P.Text = end_P
End If
If end_Row < str_Row Then
end_Row = str_Row
T_end_Row.Text = end_Row
End If
If end_Col < str_Col Then
end_Col = str_Col
T_end_Col = end_Col
End If
If end_P < str_P Then
end_P = str_P
T_end_P.Text = end_P
End If
'前缀；后缀；或者直接赋值
If IsEmpty(SZ_S) = False Then
For j = str_Row To end_Row
For k = str_Col To end_Col
For i = str_P To end_P
With 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) Then
If Chk_qianzhui1.Value = -1 Then
.Range.Text = SZ_S(i - str_P) & Replace(.Range.Text, Chr(13), "")
End If
If CHK_houzhui1.Value = -1 Then
.Range.Text = Replace(.Range.Text, Chr(13), "") & SZ_S(i - str_P)
End If
If CHK_houzhui1.Value <> -1 And Chk_qianzhui1.Value <> -1 Then
.Range.Text = SZ_S(i - str_P)
End If
End If
End If
End With
' If I = end_P Then: MsgBox "填写完成！"
If i = end_P Then: Lab_state.Caption = "填写完成！"
Next i
Next 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 Sub
Private Sub T_yw_h_Change()
yw_S_js
End Sub
Private Sub cmd_yw_dp_Copy_Click()
Selection.Text = T_yw_dP.Text
End Sub
Private Sub cmd_yw_Ldp_Copy_Click()
Selection.Text = T_yw_LdP.Text
End Sub
Private 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 Sub
Private 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 Sub
Private Sub TextBox1_Change()
End Sub
Private 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), i
Cmb_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 Long
Dim IStyle As Long
hWndForm = 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-操作-液位计算*********************************************************
扫一扫
891
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
