伍胥之 离线

级别: 军区司令员

显示用户信息

楼主发表于: 2010-03-19

正序阅读 ┊ 只看楼主 ┊ 小中大

[ZT]我和电脑亲密接触的心路历程

管理提醒: 本帖被卡拉设置为精华(2010-06-13)

原题：[ZT]The Progamming career of a non-programmer
(卡拉注：可以译为“一个非程序员的编程生涯”）

[ 此帖被伍胥之在01-20-2011 21:41重新编辑 ]

评价一下你浏览此帖子的感受

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

100楼发表于: 2021-07-18

只看该作者 ┊ 小中大

Dim bContinue As Boolean

Dim regEX As New RegExp
Dim paraCounter As Long  '全局段落计数，仅在主程序中可读写，其它过程函数应为只读

Dim LastTitle0String As String, LastTitle0No As Long
Dim LastTitle1String As String, LastTitle1No As Long
Dim LastTitle2String As String, LastTitle2No As Long
Dim LastTitle3String As String, LastTitle3No As Long
Dim LastTitle4String As String, LastTitle4No As Long
Dim LastTitle5String As String, LastTitle5No As Long
Dim LastTabelString As String, LastTableNo As Long
Dim LastFigureString As String, LastFigureNo As Long

Dim strSeperator As String

Sub ConvertWidth(fTEXT As String, rText As String)
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        Selection.Find.Wrap = wdFindContinue
        Me.txtStatus.Text = "转换全角数字字母" & fTEXT & "形式为半角" & rText
        DoEvents
        Selection.Find.Execute findtext:=fTEXT, replacewith:=rText, Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue, MatchCase:=True
End Sub

Sub ClearDomain()
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Wrap = wdFindContinue
            Me.txtStatus.Text = "清除所有域代码"
            DoEvents
            .Execute findtext:="^d", replacewith:="", Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue, MatchWildcards:=False
        End With
End Sub

Private Sub cmdCheck_Click()
    bContinue = True
    Dim NoSeries1(1 To 16) As String
    Dim NoSeries2(1 To 16) As String
    Dim NoSeries5(1 To 16) As String
    Dim NoSeriesRM(1 To 16) As String
    Dim paraTotal As Long, ParaText As String
    Dim ttString As String, ttNo As String

    Dim ShapeCounter As Long, ShapeHeight As Long, ShapeWidth As Long

    Me.txtStatus.Visible = True
    Me.lbParaType.Visible = True
    Me.cmdCheck.Enabled = False




    Dim ParaType As String, rText As String

    Selection.WholeStory
    Selection.NoProofing = True

    tm1 = Now

        ActiveWindow.View.Type = wdNormalView

    NoSeries1(1) = "一"
    NoSeries1(2) = "二"
    NoSeries1(3) = "三"
    NoSeries1(4) = "四"
    NoSeries1(5) = "五"
    NoSeries1(6) = "六"
    NoSeries1(7) = "七"
    NoSeries1(8) = "八"
    NoSeries1(9) = "九"
    NoSeries1(10) = "十"
    NoSeries1(11) = "十一"
    NoSeries1(12) = "十二"
    NoSeries1(13) = "十三"
    NoSeries1(14) = "十四"
    NoSeries1(15) = "十五"
    NoSeries1(16) = "十六"

    NoSeries2(1) = "㈠"
    NoSeries2(2) = "㈡"
    NoSeries2(3) = "㈢"
    NoSeries2(4) = "㈣"
    NoSeries2(5) = "㈤"
    NoSeries2(6) = "㈥"
    NoSeries2(7) = "㈦"
    NoSeries2(8) = "㈧"
    NoSeries2(9) = "㈨"
    NoSeries2(10) = "㈩"

    NoSeries5(1) = "①"
    NoSeries5(1) = "②"
    NoSeries5(3) = "③"
    NoSeries5(4) = "④"
    NoSeries5(5) = "⑤"
    NoSeries5(6) = "⑥"
    NoSeries5(7) = "⑦"
    NoSeries5(8) = "⑧"
    NoSeries5(9) = "⑨"
    NoSeries5(10) = "⑩"


    NoSeriesRM(1) = "I"
    NoSeriesRM(2) = "II"
    NoSeriesRM(3) = "III"
    NoSeriesRM(4) = "IV"
    NoSeriesRM(5) = "V"
    NoSeriesRM(6) = "VI"
    NoSeriesRM(7) = "VII"
    NoSeriesRM(8) = "VIII"
    NoSeriesRM(9) = "IX"
    NoSeriesRM(10) = "X"
    NoSeriesRM(11) = "XI"
    NoSeriesRM(12) = "XII"
    NoSeriesRM(13) = "XIII"
    NoSeriesRM(14) = "XIV"
    NoSeriesRM(15) = "XV"
    NoSeriesRM(16) = "XVI"

    i = MsgBox("为了你的数据安全，请使用单独保存的文件副本进行本操作。" & vbCrLf & "确定继续进行吗？", vbYesNo)

    If i = vbNo Then
        Exit Sub
    End If

    If Me.chkSuper.Value Then
        Me.txtStatus.Text = "检查修改所有的上标格式"

        CheckSuperScript

    End If

    If Me.chkStyle.Value Then
        Me.txtStatus.Text = "设置样式，请稍候...."
        DoEvents
        CeateOrModifyStyle
    End If



    ClearDomain



    If Me.chkLIST.Value Then
        Me.txtStatus.Text = "将所有自动列表标题转化为人工标题形式"

        ConvertListToOrdinary
    End If


    Dim pType As String, trimpTEXT As String
    If Me.chkNum.Value = True Then
        Me.txtStatus.Text = "转换全角数字形式为半角"
        ConvertWidth "１", "1"
        DoEvents
        ConvertWidth "２", "2"
        DoEvents
        ConvertWidth "３", "3"
        DoEvents
        ConvertWidth "４", "4"
        DoEvents
        ConvertWidth "５", "5"
        DoEvents
        ConvertWidth "６", "6"
        DoEvents
        ConvertWidth "７", "7"
        DoEvents
        ConvertWidth "８", "8"
        DoEvents
        ConvertWidth "９", "9"
        DoEvents
        ConvertWidth "０", "0"
        DoEvents
        ConvertWidth "ａ", "a"
        DoEvents
        ConvertWidth "ｂ", "b"
        DoEvents
        ConvertWidth "ｃ", "c"
        DoEvents
        ConvertWidth "ｄ", "d"
        DoEvents
        ConvertWidth "ｅ", "e"
        DoEvents
        ConvertWidth "ｆ", "f"
        DoEvents
        ConvertWidth "ｇ", "g"
        DoEvents
        ConvertWidth "ｈ", "h"
        DoEvents
        ConvertWidth "ｉ", "i"
        DoEvents
        ConvertWidth "ｊ", "j"
        DoEvents
        ConvertWidth "ｋ", "k"
        DoEvents
        ConvertWidth "ｌ", "l"
        DoEvents
        ConvertWidth "ｍ", "m"
        DoEvents
        ConvertWidth "ｎ", "n"
        ConvertWidth "ｏ", "o"
        ConvertWidth "ｐ", "p"
        ConvertWidth "ｑ", "q"
        ConvertWidth "ｒ", "r"
        ConvertWidth "ｓ", "s"
        ConvertWidth "ｔ", "t"
        ConvertWidth "ｕ", "u"
        ConvertWidth "ｖ", "v"
        ConvertWidth "ｗ", "w"
        ConvertWidth "ｘ", "x"
        ConvertWidth "ｙ", "y"
        ConvertWidth "ｚ", "z"
        ConvertWidth "Ａ", "A"
        ConvertWidth "Ｂ", "B"
        ConvertWidth "Ｃ", "C"
        ConvertWidth "Ｄ", "D"
        ConvertWidth "Ｅ", "E"
        ConvertWidth "Ｆ", "F"
        ConvertWidth "Ｇ", "G"
        ConvertWidth "Ｈ", "H"
        ConvertWidth "Ｉ", "I"
        ConvertWidth "Ｊ", "J"
        ConvertWidth "Ｋ", "K"
        ConvertWidth "Ｌ", "L"
        ConvertWidth "Ｍ", "M"
        ConvertWidth "Ｎ", "N"
        ConvertWidth "Ｏ", "O"
        ConvertWidth "Ｐ", "P"
        ConvertWidth "Ｑ", "Q"
        ConvertWidth "Ｒ", "R"
        ConvertWidth "Ｓ", "S"
        ConvertWidth "Ｔ", "T"
        ConvertWidth "Ｕ", "U"
        ConvertWidth "Ｖ", "V"
        ConvertWidth "Ｗ", "W"
        ConvertWidth "Ｘ", "X"
        ConvertWidth "Ｙ", "Y"
        ConvertWidth "Ｚ", "Z"
        ConvertWidth "^l", "^p"
        ConvertWidth "（", "("
        ConvertWidth "）", ")"

    End If

    With ActiveDocument
        Dim tbl As Table
        For Each tbl In .Tables
            tbl.Rows.Alignment = wdAlignRowCenter
            tbl.Range.Font.NameFarEast = "楷体"
            tbl.Range.Font.NameAscii = "Times New Roman"
            tbl.Range.Font.Size = 10.5
        Next
        Set tbl = Nothing
    End With


    With ActiveDocument

        For i = 1 To .TablesOfContents.Count
            .TablesOfContents(i).Delete
        Next



        paraTotal = .Paragraphs.Count
        paraCounter = 1

        LastTitle0No = 0
        LastTitle1No = 0
        LastTitle2No = 0
        LastTitle3No = 0
        LastTitle4No = 0
        LastTableNo = 0
        LastFigureNo = 0

        Dim Sec As Long

        Sec = InputBox("正文从第一节开始？", "节设置", 6)
        If Sec = 0 Then
            Exit Sub
        End If

        k = 0
        Do While (paraCounter < paraTotal) And bContinue
            k = k + 1
            If .Paragraphs(paraCounter).Range.Information(wdActiveEndSectionNumber) >= Sec Then
                Exit Do
            End If
            paraCounter = paraCounter + 1
            If k Mod 20 = 0 Then
                Me.lbCounter.Caption = paraCounter
                DoEvents
            End If
        Loop


        Do While (paraCounter < paraTotal) And bContinue

            ParaText = Trim(.Paragraphs(paraCounter).Range.Text)
            ShapeHeight = 0
            ShapeWidth = 0

            CheckPara .Paragraphs(paraCounter).Range, ParaType, rText, ttString, ttNo, ShapeCounter, ShapeHeight, ShapeWidth

            Select Case ParaType
                Case "【】表格内容"
                    .Paragraphs(paraCounter).Style = "QLNU表格内容"
                Case "章"
                    LastTitle0No = LastTitle0No + 1
                    '新一章开始，复位其下属标题编号
                    LastTitle1No = 0
                    LastTitle2No = 0
                    LastTitle3No = 0
                    LastTitle4No = 0

                    k = Val(ttNo)
                    If k = 0 Then '非数字编号章节
                        If ttNo <> NoSeries1(LastTitle0No) Then
                            rText = "第" & NoSeries1(LastTitle0No) & ttString
                            Me.ErrMsg.AddItem "章节编号错误：" & ParaText
                        End If
                    Else
                        If Val(ttNo) <> LastTitle0No Then
                            rText = "第" & LastTitle0No & ttString
                            Me.ErrMsg.AddItem "章节编号错误：" & ParaText
                        End If

                    End If

                    '章段落设置
                    '字体大小：三号16磅小三号15磅四号14磅小四号12磅五号10.5磅小五号9磅
                    .Paragraphs(paraCounter).Style = "QLNU章节"
                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    tc = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="TC  """ & tc & """ \l 1 ", PreserveFormatting:=False
                Case "一级标题"
                    LastTitle1No = LastTitle1No + 1
                    '新一级标题开始，复位其下属标题编号
                    LastTitle2No = 0
                    LastTitle3No = 0
                    LastTitle4No = 0

                    If ttNo <> NoSeries1(LastTitle1No) Then
                            rText = NoSeries1(LastTitle1No) & "、" & ttString
                            Me.ErrMsg.AddItem "一级标题编号错误：" & ParaText
                    End If


                    '一级标题段落设置  格式：一、标题内容
                    .Paragraphs(paraCounter).Range.Text = rText
                    .Paragraphs(paraCounter).Style = "QLNU一级标题"
                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    tc = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="TC  """ & tc & """ \l 1 ", PreserveFormatting:=False
                Case "二级标题"
                    LastTitle2No = LastTitle2No + 1
                    '新二级标题开始，复位其下属标题编号
                    LastTitle3No = 0
                    LastTitle4No = 0

                    If ttNo <> NoSeries1(LastTitle2No) Then
                            rText = "(" & NoSeries1(LastTitle2No) & ")" & ttString
                            ErrMsg.AddItem "二级标题编号错误：" & ParaText
                    End If

                    '二级标题段落设置格式：(一)、标题内容
                    .Paragraphs(paraCounter).Range.Text = rText
                    .Paragraphs(paraCounter).Style = "QLNU二级标题"

                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    tc = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="TC  """ & tc & """ \l 2 ", PreserveFormatting:=False

                Case "三级标题"
                    LastTitle3No = LastTitle3No + 1
                    '新三级标题开始，复位其下属标题编号
                    LastTitle4No = 0

                    If Val(ttNo) <> LastTitle3No Then
                            rText = LastTitle3No & ". " & ttString
                            Me.ErrMsg.AddItem "三级标题编号错误：" & ParaText

                    End If
                    '三级标题段落设置格式：1. 标题内容
                    .Paragraphs(paraCounter).Range.Text = rText
                    .Paragraphs(paraCounter).Style = "QLNU三级标题"
                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    tc = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="TC  """ & tc & """ \l 3 ", PreserveFormatting:=False
                Case "四级标题"
                    LastTitle4No = LastTitle4No + 1

                    If Val(ttNo) <> LastTitle4No Then
                            rText = "(" & LastTitle4No & "). " & ttString
                            ErrMsg.AddItem "四级标题编号错误：" & ParaText

                    End If
                    '四级标题段落设置格式：(1). 标题内容
                    .Paragraphs(paraCounter).Range.Text = rText
                    .Paragraphs(paraCounter).Style = "QLNU四级标题"
                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    tc = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="TC  """ & tc & """ \l 4 ", PreserveFormatting:=False

                Case "表格标题"
                    LastTableNo = LastTableNo + 1

                    If ttNo <> CStr(LastTableNo) Then
                            rText = "表" & LastTableNo & ". " & ttString
                            ErrMsg.AddItem "表格编号错误：" & ParaText

                    End If

                    '表格名称段落设置格式：表1. 表格名称
                    .Paragraphs(paraCounter).Style = "QLNU表格标题"
                    xe = Replace(rText, vbCr, "")
                    .Paragraphs(paraCounter).Range.Select
                    Selection.MoveEnd wdCharacter, -1   '选择范围包括行尾的换行符。
                    Selection.Range.Text = xe
                    Selection.EndKey
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="XE  " & """" & xe & """", PreserveFormatting:=False

                Case "表格首行"
                    .Paragraphs(paraCounter).Style = "QLNU表格首行"
                Case "图片标题"
                    LastFigureNo = LastFigureNo + 1

                    If ttNo <> CStr(LastFigureNo) Then
                            rText = "图" & LastFigureNo & ". " & ttString
                            ErrMsg.AddItem "表格编号错误：" & ParaText

                    End If
                    '图片名称段落设置格式：图1. 图名称
                    .Paragraphs(paraCounter).Range.Text = rText
                    .Paragraphs(paraCounter).Style = "QLNU图片标题"
                    .Paragraphs(paraCounter).Range.Select
                    Selection.EndKey unit:=wdLine
                    xe = Replace(rText, vbCr, "")
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="XE  " & """" & xe & """", PreserveFormatting:=False
                Case "正文"
                     '正文名称段落设置
                    .Paragraphs(paraCounter).Style = "QLNU正文"
               Case "文献条目"
                    With .Paragraphs(paraCounter)
                        '.Range.Select
                        'Selection.ClearFormatting
                        '.Range.Find.Execute findtext:=rText, replacewith:=strSeperator   'Replacetext 传回了编号及分隔符部分，而StrSeperator传回了正确的格式与分隔符如“[15] ”
                        .Style = "QLNU参考文献"
                    End With
               Case "图表注解"
                    With .Paragraphs(paraCounter)
                        .Range.Font.NameFarEast = "楷体"
                        .Range.Font.NameAscii = "Times New Roman"
                        .Range.Font.Size = 9 '小5号字

                        .Alignment = wdAlignParagraphCenter
                        .LeftIndent = 0
                        .RightIndent = 0
                        .FirstLineIndent = 0
                        .LineSpacing = 12
                        .LineSpacingRule = wdLineSpaceExactly
                        .LineUnitAfter = 0
                        .LineUnitBefore = 0
                        .OutlineLevel = wdOutlineLevelBodyText
                        .PageBreakBefore = False
                        .RightIndent = 0
                        .WordWrap = True
                        .LineUnitAfter = 0.5

                    End With
                Case Else
                    '不作处理
            End Select

            '含有inlineshape的段落处理
            If ShapeHeight > 30 Then
                .Paragraphs(paraCounter).LineSpacingRule = wdLineSpaceSingle  '对有图片的段落设置为单倍行距
            End If

            If (ShapeWidth + ShapeHeight) > 150 Then
                .Paragraphs(paraCounter).Style = "QLNU图片段落"
            End If

            '段落计数器递
            paraCounter = paraCounter + 1
            Me.lbCounter.Caption = "当前检测段落：" & paraCounter
            Me.txtStatus.Text = ParaText
            DoEvents
        Loop
    End With

    msg = ""

    For i = 0 To Me.ErrMsg.ListCount - 1
        msg = msg & vbCrLf & vbCrLf & Me.ErrMsg.List(i)
    Next



    Me.txtStatus.Text = "格式化完成！" & vbCrLf & "开始时间：" & tm1 & vbCrLf & "结束时间：" & Now & vbCrLf & msg
    Me.cmdCheck.Enabled = True
    Me.txtStatus.Visible = True
    Me.lbParaType.Visible = False

    bContinue = False
End Sub

Sub CheckPara(ByRef ChKRange As Range, ParaType As String, ReplaceTEXT As String, TitleString As String, TitleNo As String, shpCounter As Long, MaxShpHeight As Long, TotalShpWidth As Long)
    Dim pTEXT As String

    pTEXT = ChKRange.Text

    ParaType = "其它"
    TitleString = pTEXT
    TitleNo = "N/A"

    shpCounter = ChKRange.InlineShapes.Count
    If shpCounter <> 0 Then
        MaxShpHeight = 0: TotalShpWidth = 0
        For i = 1 To shpCounter
            k = ChKRange.InlineShapes(i).Height
            l = ChKRange.InlineShapes(i).Width
            If k > MaxShpHeight Then
                MaxShpHeight = k
            End If
            TotalShpWidth = TotalShpWidth + l
        Next
        If MaxShpHeight > 60 Or TotalShpWidth > 150 Then
            Exit Sub
        End If
    End If

    '空行
    If Len(pTEXT) <= 2 Then
        Exit Sub
    End If


    '是否为表格中的文字
    If ActiveDocument.Paragraphs(paraCounter).Range.Information(wdWithInTable) Then
        ParaType = "表格内容"
        k = ActiveDocument.Paragraphs(paraCounter).Range.Information(wdEndOfRangeRowNumber)
        If k = 1 Then
            ParaType = "表格首行"
        End If
        Exit Sub
    End If

    '例外情况：脚注
    If ActiveDocument.Paragraphs(paraCounter).Range.Information(wdInFootnote) Then
        ParaType = "脚注"
        Exit Sub
    End If

    '例外情况：尾注
    If ActiveDocument.Paragraphs(paraCounter).Range.Information(wdInEndnote) Then
        ParaType = "尾注"
        Exit Sub
    End If

    If ActiveDocument.Paragraphs(paraCounter).Range.Information(wdInHeaderFooter) Then
        ParaType = "页眉页脚"
        Exit Sub
    End If


    With regEX
        .Global = True

        .Pattern = "^第([1-9]|１|２|３|４|５|６|７|８|一|二|三|四|五|六|七|八|九|十)章(、|\.|\s|。|．)+(.{1,30})$"
        If regEX.Test(pTEXT) Then
            ReplaceTEXT = regEX.Replace(pTEXT, "第$1章 $3")
            TitleString = regEX.Replace(pTEXT, "$3")
            TitleNo = regEX.Replace(pTEXT, "$1")
            ParaType = "章"
            Exit Sub
        End If

        .Pattern = "^(十一|十二|十三|十四|十五|十六|一|二|三|四|五|六|七|八|九|十)(、|\.|\s|。|．)+(.{1,40})$"
        If regEX.Test(pTEXT) Then
            ParaType = "一级标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = regEX.Replace(pTEXT, "$1、$3")
            TitleString = regEX.Replace(pTEXT, "$3")
            TitleNo = regEX.Replace(pTEXT, "$1")
            Exit Sub
        End If

        '全角或半角括号中的数字
        .Pattern = "(^$|（)(十一|十二|十三|十四|十五|十六|一|二|三|四|五|六|七|八|九|十)($|）)(、|\.|\s|。|．)*(.{1,40})$"
        If regEX.Test(pTEXT) Then
            ParaType = "二级标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = regEX.Replace(pTEXT, "($2)$5")
            TitleString = regEX.Replace(pTEXT, "$5")
            TitleNo = regEX.Replace(pTEXT, "$2")
            Exit Sub
        End If

        '阿拉伯数字  1. 2.
        .Pattern = "^([1-9]|１|２|３|４|５|６|７|８|９|０){1,2}(、|\.|\s|。|．)+(.{1,80})$"
        If regEX.Test(pTEXT) Then
            ParaType = "三级标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = regEX.Replace(pTEXT, "$1. $3") '未进行全半角转换，如需要可分成两步分别检测
            TitleString = regEX.Replace(pTEXT, "$3")
            TitleNo = regEX.Replace(pTEXT, "$1")
            Exit Sub
        End If

        '全角或半角括号中的阿拉伯数字
        .Pattern = "^(^$|（)([0-9]|０|１|２|３|４|５|６|７|８|９){1,2}($|）)(、|\.|\s|。|．)*(.{1,80})$"
        If regEX.Test(pTEXT) Then
            ParaType = "四级标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = regEX.Replace(pTEXT, "($2) $5")
            TitleString = regEX.Replace(pTEXT, "$5")
            TitleNo = regEX.Replace(pTEXT, "$2")
            Exit Sub
        End If

        '表格名称
        .Pattern = "^表(\d{1,2}-{0,1}\d{0,1})([、|\.|。|．｜\s]{1,9})(.{1,120})$"
        If regEX.Test(pTEXT) Then
            ParaType = "表格标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = Trim(regEX.Replace(pTEXT, "表$1. $3"))
            TitleString = Trim(regEX.Replace(pTEXT, "$3"))
            TitleNo = Trim(regEX.Replace(pTEXT, "$1"))
            strSeperator = Trim(regEX.Replace(pTEXT, "$2")) '不知道为什么，但是发现传回的replacetext在修改Paragraph对象的Range.Text后，表格标题就会落入第一个单元格中，所以，只能用Paragraph.Range.Find.Execute方法替换
            Exit Sub
        End If

        '图片名称
        .Pattern = "^图(\d{1,2}-{0,1}\d{0,1})(、|\.|\s|。|．)+(.{1,120})$"
        If regEX.Test(pTEXT) Then
            ParaType = "图片标题"
            regEX.Execute (pTEXT)
            ReplaceTEXT = regEX.Replace(pTEXT, "图$1. $3")
            TitleString = regEX.Replace(pTEXT, "$3")
            TitleNo = regEX.Replace(pTEXT, "$1")
            Exit Sub
        End If

        '参考文献
        .Pattern = "^([\[|［])(\d+)([］|\]])([、|\.|\s|。|．]{0,1})"  '[数字]、
        If regEX.Test(pTEXT) Then
            ParaType = "文献条目"
            'ReplaceTEXT = regEX.Replace(pTEXT, "$1$2$3$4")
            'TitleNo = regEX.Replace(pTEXT, "[$2] ")
            Exit Sub
        End If

        prfx = Left(pTEXT, 2)
        If prfx = "注：" Or prfx = "注:" Then
            ParaType = "图表注解"
            Exit Sub
        End If


        ParaType = "正文"

    End With
End Sub

Sub ConvertListToOrdinary()
    Dim st As Paragraph
    With ActiveDocument
        For i = .Paragraphs.Count To 1 Step -1
            Set st = .Paragraphs(i)
            lst = st.Range.ListFormat.ListString
            If lst <> "" Then
                st.Range.ListFormat.RemoveNumbers
                st.Range.InsertBefore lst & " "
            End If
        Next
    End With
    Set st = Nothing
End Sub

Private Sub UserForm_Activate()
    Me.lbTotal.Caption = "当前文章段落总数：" & ActiveDocument.Paragraphs.Count & " 共" & ActiveDocument.Sections.Count & "节"
    Me.lbTotal.Font.Bold = True
    Me.txtStatus.Visible = False
    Me.cmdCheck.Enabled = True

End Sub

Sub CheckSuperScript()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "[【\[［〖](*)[】\]〗］]"
        .Replacement.Text = "[\1]"
        .Replacement.Font.Superscript = True
        '.Replacement.Font.Color = wdColorBlue
        .Forward = True
        .Wrap = wdFindContinue
        .FORMAT = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    bContinue = False
    Set regEX = Nothing
End Sub

Sub CeateOrModifyStyle()
'
'
Dim stl As Style

    Options.Pagination = False

    On Error Resume Next
    For Each stl In ActiveDocument.Styles
        stl.Delete
    Next
    On Error GoTo 0

    Set stl = Nothing

    DoEvents
    On Error Resume Next

    ActiveDocument.Styles.Add Name:="BaseStyle", Type:=wdStyleTypeParagraph

    ActiveDocument.Styles.Add Name:="QLNU论文题目", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU中文摘要", Type:=wdStyleTypeParagraph

    ActiveDocument.Styles.Add Name:="QLNU英文标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU英文摘要", Type:=wdStyleTypeParagraph

    ActiveDocument.Styles.Add Name:="QLNU目录项", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU章节标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU一级标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU二级标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU三级标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU四级标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU正文", Type:=wdStyleTypeParagraph

    ActiveDocument.Styles.Add Name:="QLNU表格标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU表格首行", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU表格内容", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU图片标题", Type:=wdStyleTypeParagraph
    ActiveDocument.Styles.Add Name:="QLNU图片段落", Type:=wdStyleTypeParagraph

    ActiveDocument.Styles.Add Name:="QLNU参考文献", Type:=wdStyleTypeParagraph
    On Error GoTo 0
    DoEvents

    'BaseStyle
    ActiveDocument.Styles("BaseStyle").AutomaticallyUpdate = False
    With ActiveDocument.Styles("BaseStyle").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "宋体"
        .Size = 10.5
        .Bold = wdUndefined
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Subscript = wdUndefined

        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False

        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Scaling = 100
        .Kerning = 1
        .Animation = wdAnimationNone
        .DisableCharacterSpaceGrid = False
        .EmphasisMark = wdEmphasisMarkNone
    End With
    With ActiveDocument.Styles("BaseStyle").ParagraphFormat
        .LeftIndent = 0
        .RightIndent = 0
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphJustify

        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False

        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .AutoAdjustRightIndent = True
        .DisableLineHeightGrid = True

        .FarEastLineBreakControl = True
        .WordWrap = True
        .Hyphenation = False

        .HangingPunctuation = True
        .HalfWidthPunctuationOnTopOfLine = True
        .AddSpaceBetweenFarEastAndAlpha = True
        .AddSpaceBetweenFarEastAndDigit = True
        .BaseLineAlignment = wdBaselineAlignBaseline
    End With
    ActiveDocument.Styles("BaseStyle").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("BaseStyle").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("BaseStyle").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("BaseStyle").NoProofing = False

    '一级标题题样式
    ActiveDocument.Styles("QLNU一级标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU一级标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU一级标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU一级标题").Font
        .NameFarEast = "黑体"
        .NameAscii = "Arial Black"
        .NameOther = "黑体"
        .Name = "黑体"
        .Size = 16              '三号
        .Bold = True
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU一级标题").ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter

        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .OutlineLevel = wdOutlineLevelBodyText

        .LineUnitBefore = 0.5
        .LineUnitAfter = 0.5
    End With
    ActiveDocument.Styles("QLNU一级标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU一级标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU一级标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU一级标题").NoProofing = True
    DoEvents

    '二级
    ActiveDocument.Styles("QLNU二级标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU二级标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU二级标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU二级标题").Font
        .NameFarEast = "黑体"
        .NameAscii = "Arial Narrow"
        .NameOther = "黑体"
        .Name = "黑体"
        .Size = 15        '小三号
        .Bold = False
        .Outline = False
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU二级标题").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft

        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = False
        .OutlineLevel = wdOutlineLevelBodyText

        .LineUnitBefore = 0.5
        .LineUnitAfter = 0.5

    End With
    ActiveDocument.Styles("QLNU二级标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU二级标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU二级标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU二级标题").NoProofing = True
    DoEvents

    '三级标题样式
    ActiveDocument.Styles("QLNU三级标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU三级标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU三级标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU三级标题").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "黑体"
        .Name = "黑体"
        .Size = 14               '四号
        .Bold = False
        .Outline = False
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU三级标题").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft

        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = False
        .OutlineLevel = wdOutlineLevelBodyText

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 2

        .LineUnitBefore = 0.5
        .LineUnitAfter = 0
    End With
    ActiveDocument.Styles("QLNU三级标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU三级标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU三级标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU三级标题").NoProofing = True
    DoEvents

    '四级标题样式
    ActiveDocument.Styles("QLNU四级标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU四级标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU四级标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU四级标题").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "宋体"
        .Name = "宋体"
        .Size = 12               '小四号
        .Bold = True
        .Outline = False
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU四级标题").ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft

        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = False
        .OutlineLevel = wdOutlineLevelBodyText

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 2

        .LineUnitBefore = 0
        .LineUnitAfter = 0

    End With
    ActiveDocument.Styles("QLNU四级标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU四级标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU四级标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU四级标题").NoProofing = True
    DoEvents

    '正文校式
    ActiveDocument.Styles("QLNU正文").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU正文").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU正文").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU正文").Font

        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "宋体"
        .Name = "宋体"

        .Size = 12               '小四号

        .Bold = wdUndefined
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined

        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False

        .DisableCharacterSpaceGrid = True
    End With
    With ActiveDocument.Styles("QLNU正文").ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceExactly
        .LineSpacing = 20
        .Alignment = wdAlignParagraphLeft

        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .Hyphenation = False

        .OutlineLevel = wdOutlineLevelBodyText


        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 2

        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .SpaceBefore = 0
        .SpaceAfter = 0

        .DisableLineHeightGrid = True
    End With
    ActiveDocument.Styles("QLNU正文").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU正文").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU正文").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU正文").NoProofing = True
    DoEvents

    '图片段落样式
    ActiveDocument.Styles("QLNU图片段落").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU图片段落").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU图片段落").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU图片段落").Font
        .Size = 12               '小四号
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU图片段落").ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .OutlineLevel = wdOutlineLevelBodyText

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
    ActiveDocument.Styles("QLNU图片段落").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU图片段落").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU图片段落").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU图片段落").NoProofing = True
    DoEvents


    '第X章
    ActiveDocument.Styles("QLNU章节标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU章节标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU章节标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU章节标题").Font
        .NameFarEast = "黑体"
        .NameAscii = "Arial Black"
        .NameOther = "Arial Black"
        .Name = "黑体"
        .Size = 16
        .Bold = True
        .UnderlineColor = wdColorAutomatic
        .Outline = False
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Scaling = 100
        .DisableCharacterSpaceGrid = True
    End With
    With ActiveDocument.Styles("QLNU章节标题").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = True
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 1
        .LineUnitAfter = 0.5

        .AutoAdjustRightIndent = False
        .DisableLineHeightGrid = True
        .FarEastLineBreakControl = True
        .WordWrap = True
    End With
    ActiveDocument.Styles("QLNU章节标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU章节标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU章节标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU章节标题").NoProofing = True
    DoEvents

    '表格标题
    ActiveDocument.Styles("QLNU表格标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU表格标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU表格标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU表格标题").Font
        .NameFarEast = "楷体"
        .NameAscii = "Arial"
        .Name = "楷体"
        .Size = 10.5
        .Bold = True
        .Underline = wdUnderlineNone
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Color = wdColorAutomatic
    End With
    With ActiveDocument.Styles("QLNU表格标题").ParagraphFormat

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .KeepTogether = True
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 1
        .LineUnitAfter = 0

    End With
    ActiveDocument.Styles("QLNU表格标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU表格标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU表格标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU表格标题").NoProofing = True
    DoEvents

    '表格首行
    ActiveDocument.Styles("QLNU表格首行").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU表格首行").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU表格首行").Font
        .NameFarEast = "楷体"
        .NameAscii = "Times New Roman"
        .Name = "楷体"
        .Size = 9
        .Bold = True
        .Underline = wdUnderlineNone
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU表格首行").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)


        .CharacterUnitLeftIndent = -0.5
        .CharacterUnitRightIndent = -0.5
        .CharacterUnitFirstLineIndent = -0.5

        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .SpaceBefore = 0
        .SpaceAfter = 0

    End With
    ActiveDocument.Styles("QLNU表格首行").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU表格首行").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU表格首行").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU表格首行").NoProofing = True
    DoEvents

    '表格内容
    ActiveDocument.Styles("QLNU表格内容").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU表格内容").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU表格内容").Font
        .NameFarEast = "楷体"
        .NameAscii = "Times New Roman"
        .Name = "楷体"
        .Size = 9
        .Bold = False
        .Underline = wdUnderlineNone
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU表格内容").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = -0.5
        .CharacterUnitRightIndent = -0.5
        .CharacterUnitFirstLineIndent = -0.5
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .SpaceBefore = 0
        .SpaceAfter = 0
    End With
    ActiveDocument.Styles("QLNU表格首行").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU表格首行").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU表格首行").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU表格首行").NoProofing = True
    DoEvents

    '图片标题
    ActiveDocument.Styles("QLNU图片标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU图片标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU图片标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU图片标题").Font
        .NameFarEast = "楷体"
        .NameAscii = "Times New Roman"
        .Name = "楷体"
        .Size = 10.5
        .Bold = True
        .Underline = wdUnderlineNone
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Outline = False
        .Shadow = False
        .Color = wdColorAutomatic
    End With
    With ActiveDocument.Styles("QLNU图片标题").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter

        .KeepWithNext = wdUndefined
        .KeepTogether = True
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
    ActiveDocument.Styles("QLNU图片标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU图片标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU图片标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU图片标题").NoProofing = True
    DoEvents

    '目录项
    ActiveDocument.Styles("QLNU目录项").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU目录项").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU目录项").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU目录项").Font
        .NameFarEast = "黑体"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
        .Name = "黑体"
        .Size = 10.5
        .Bold = False
        .Italic = wdUndefined
        .Underline = wdUnderlineNone
        .Color = wdColorAutomatic
        .Superscript = wdUndefined
        .Subscript = wdUndefined
    End With
    With ActiveDocument.Styles("QLNU目录项").ParagraphFormat

        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphLeft

        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
    ActiveDocument.Styles("QLNU目录项").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU目录项").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU目录项").ParagraphFormat.TabStops.Add Position:=PicasToPoints(44.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderMiddleDot
    ActiveDocument.Styles("QLNU目录项").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU目录项").NoProofing = True
    DoEvents

    '参考文献
    ActiveDocument.Styles("QLNU参考文献").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU参考文献").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU参考文献").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU参考文献").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
        .Name = "Times New Roman"
        .Size = 12
        .Bold = False
        .Italic = wdUndefined
        .Subscript = wdUndefined
        .Superscript = wdUndefined
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .Color = wdColorAutomatic
        .Engrave = False
    End With
    With ActiveDocument.Styles("QLNU参考文献").ParagraphFormat

        .LineSpacingRule = wdLineSpaceExactly
        .LineSpacing = 16
        .Alignment = wdAlignParagraphLeft
        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = -2

        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .SpaceBefore = 0
        .SpaceAfter = 0

    End With
    ActiveDocument.Styles("QLNU参考文献").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU参考文献").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU参考文献").LanguageID = wdEnglishUS
    ActiveDocument.Styles("QLNU参考文献").NoProofing = True
    ActiveDocument.Styles("QLNU参考文献").LanguageID = wdSimplifiedChinese
    DoEvents

    '
    ActiveDocument.Styles("QLNU论文题目").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU论文题目").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU论文题目").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU论文题目").Font
        .NameFarEast = "黑体"
        .NameAscii = "Arial Black"
        .NameOther = "Arial Black"
        .Name = "Arial Black"
        .Size = 16
        .Bold = False
        .Italic = wdUndefined
        .Superscript = wdUndefined
        .Subscript = wdUndefined
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .Color = wdColorAutomatic

    End With
    With ActiveDocument.Styles("QLNU论文题目").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = True
        .NoLineNumber = False
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 1
        .LineUnitAfter = 1

        .BaseLineAlignment = wdBaselineAlignAuto
    End With
    ActiveDocument.Styles("QLNU论文题目").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU论文题目").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU论文题目").LanguageID = wdEnglishUS
    ActiveDocument.Styles("QLNU论文题目").NoProofing = True
    ActiveDocument.Styles("QLNU论文题目").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU论文题目").NoProofing = True
    DoEvents

    '中文摘要
    ActiveDocument.Styles("QLNU中文摘要").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU中文摘要").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU中文摘要").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU中文摘要").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
        .Name = "Times New Roman"
        .Size = 12
        .Bold = wdUndefined
        .Superscript = wdUndefined
        .Subscript = wdUndefined
        .Italic = wdUndefined
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .Color = wdColorAutomatic
    End With
    With ActiveDocument.Styles("QLNU中文摘要").ParagraphFormat
        .LineSpacingRule = wdLineSpaceExactly
        .LineSpacing = 20
        .Alignment = wdAlignParagraphLeft

        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = True
        .PageBreakBefore = False
        .NoLineNumber = False
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 2
        .LineUnitBefore = 0
        .LineUnitAfter = 0

    End With
    ActiveDocument.Styles("QLNU中文摘要").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU中文摘要").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU中文摘要").LanguageID = wdEnglishUS
    ActiveDocument.Styles("QLNU中文摘要").NoProofing = True
    ActiveDocument.Styles("QLNU中文摘要").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU中文摘要").NoProofing = True
    ActiveDocument.Styles("QLNU中文摘要").Frame.Delete
    DoEvents

    ActiveDocument.Styles("QLNU英文标题").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU英文标题").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU英文标题").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU英文标题").Font
        .NameFarEast = "黑体"
        .NameAscii = "Arial Narrow"
        .Name = "Arial Narrow"
        .Size = 16
        .Bold = True
        .Bold = wdUndefined
        .Superscript = wdUndefined
        .Subscript = wdUndefined
        .Italic = wdUndefined

        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
    End With
    With ActiveDocument.Styles("QLNU英文标题").ParagraphFormat
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .WidowControl = True
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 1
        .LineUnitAfter = 1

    End With
    ActiveDocument.Styles("QLNU英文标题").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU英文标题").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU英文标题").LanguageID = wdEnglishUS
    ActiveDocument.Styles("QLNU英文标题").NoProofing = True
    ActiveDocument.Styles("QLNU英文标题").LanguageID = wdSimplifiedChinese
    ActiveDocument.Styles("QLNU英文标题").NoProofing = True
    ActiveDocument.Styles("QLNU英文标题").Frame.Delete
    DoEvents

    ActiveDocument.Styles("QLNU英文摘要").BaseStyle = ActiveDocument.Styles("BaseStyle")
    ActiveDocument.Styles("QLNU英文摘要").NextParagraphStyle = "BaseStyle"
    ActiveDocument.Styles("QLNU英文摘要").AutomaticallyUpdate = False
    With ActiveDocument.Styles("QLNU英文摘要").Font
        .NameFarEast = "宋体"
        .NameAscii = "Arial"
        .NameOther = "Arial"
        .Name = "Arial"
        .Size = 12
        .Bold = wdUndefined
        .Italic = wdUndefined
        .Superscript = wdUndefined
        .Subscript = wdUndefined
    End With

    With ActiveDocument.Styles("QLNU英文摘要").ParagraphFormat

        .LineSpacingRule = wdLineSpaceExactly
        .LineSpacing = 20

        .Alignment = wdAlignParagraphJustify

        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False

        .OutlineLevel = wdOutlineLevelBodyText

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .FirstLineIndent = CentimetersToPoints(0)

        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 2

        .LineUnitBefore = 0
        .LineUnitAfter = 1

    End With
    ActiveDocument.Styles("QLNU英文摘要").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("QLNU英文摘要").ParagraphFormat.TabStops.ClearAll
    ActiveDocument.Styles("QLNU英文摘要").LanguageID = wdEnglishUS
    ActiveDocument.Styles("QLNU英文摘要").NoProofing = False
    DoEvents

    Options.Pagination = True
    Me.txtStatus.Text = "样式修改完成，重新进行分页，请稍候....."
    DoEvents
    ActiveDocument.Repaginate

End Sub

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

99楼发表于: 2021-07-18

只看该作者 ┊ 小中大

继续填个坑：

用VBA控制WORD自己修订学生毕业文的格式。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

98楼发表于: 2021-01-02

只看该作者 ┊ 小中大

继续填 BotNET 或Pynthon? 有没有XDJMs接龙啊？

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

97楼发表于: 2015-09-06

只看该作者 ┊ 小中大

下一次练手，也是VB，不过只是用CCD测量济钢中板车间轧机出来的板的宽度。

这一次，我自己做了一个二进制的尺子，用CCD在一个盒子里读尺。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

96楼发表于: 2015-09-06

只看该作者 ┊ 小中大

这个地方现在已经变化很大了。以前紧靠山东农科院的实验田

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

95楼发表于: 2015-09-06

只看该作者 ┊ 小中大

从这里里分离出来的。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

94楼发表于: 2015-09-06

只看该作者 ┊ 小中大

拍下的火车
第6车皮

第9车皮

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

93楼发表于: 2015-09-06

只看该作者 ┊ 小中大

一共这么多文件。

这是我用VB写出的最大的程序，也是用API最多的。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

92楼发表于: 2015-09-06

只看该作者 ┊ 小中大

这才是我当年写出的一个比较烂的程序

Main2.bas

Attribute VB_Name = "SubMain"
Option Explicit

'采集文件与临时文件
Public Const TmpFile As String = "d:\30-0600.dat"
'已有数据：30-0600.dat /30日早6点进车与6：30出车头

Public fStatus As Long, hFile As Long, bytesRW As Long, lptrFile As Long
Public hBCFile As Long  '记录采集参数的文件
Public Const TmpBMP As String = "d:\1.bmp"
Public hTmpFile As Long

'采集窗口参数常量
Public Const FrameH As Long = 280&
Public Const FrameW As Long = 768&
Public Const pFrameSize As Long = FrameW * FrameH

'标志区范围，用于识别车辆
Public Const PilarC As Integer = 260   '识别标志立柱中线坐标X
Public Const mkW As Integer = 28  '识别标志立柱宽度
Public Const mkH As Integer = 80 ''识别标志立柱高度(上白中黑下白)
Public Const mkY As Integer = 4 ''识别标志立柱Y坐标(40-79白, 80-119黑,120-159白)
Public Const mkX As Integer = PilarC - mkW / 2 '识别标志立柱X坐标
'车缝检测位置常数
Public Const sSize As Long = 32&
Public Const sPos As Long = 310&
Public Const sPosL As Long = 200&
Public Const sPosR As Long = 500&
'车缝检测框位置
Public Slice(1 To sSize, 1 To FrameH) As Byte
Public SliceL(1 To sSize, 1 To FrameH) As Byte
Public SliceR(1 To sSize, 1 To FrameH) As Byte
Public avSL As Integer, avSLR As Integer, avSLL As Integer

Public MKpilar(1 To mkW * mkH) As Byte   '一维数组用于亮度对比度分析，比使用二维数组更便于VB编译优化
'该数组用于亮度对比度调节、车辆通过识别与车皮间隔识别
Public BsLine(1 To 4 * FrameW) As Byte, bsAV As Integer  '图像的前4行。用于确定标志区的亮度与对比度范围
Public PilarW As Long, PilarH As Long, PilarX As Long, PilarY As Long
Public LeftBK(1 To 1024, 0 To 1) As Byte, RightBK(1 To 1024, 0 To 1) As Byte
'前后帧左右上角128列*8行像素块，根据平均值差绝对值判断进车方向

'一次连续采集的帧数
Public tFrames As Long

'在采集卡申请的缓存中，是按帧为单位的，每一帧包含奇偶场两场的数据
'而该卡的硬件设置是按场采集，只需要读第一场的数据即可。
'所以要设置的缓存帧的大小是frameW*frameH*2，而一场的数据量为pFrameSize

Public pFRAME(1 To FrameW, 1 To FrameH) As Byte
Public pBuffer(1 To FrameW * FrameH * 2) As Byte
Public pWorkSpace(1 To FrameW * FrameH) As Long
Public Const pBufferSize As Long = FrameW * FrameH * 2
Public pGray(0 To 255) As Long '整幅图像的灰度直方图

Public hBoard As Long   '采集卡标识
Public mBufferAddr As Long  '缓存地址
Public BufferSize As Long  '缓存大小(字节)
Public iCurrentCard As Long
Public CapStatus As Long
Public iFrames As Long
Public currentBr As Byte, currentContr As Byte

Public hMEM As Long, mStatus As Long
Public Const hMemSize As Long = pFrameSize * 4
Public hMemWork As Long
Public Const hMemWorkSize As Long = pFrameSize * 5

'串口接收轨道衡数据
Public WeightFromCom As String
Public bReceiveComplete As Boolean

Public Type GrayBMPHeader
  Tag As Integer
  FileLength As Long    '文件大小
  Reserve1 As Long
  DataOffset As Long    '图像数据偏移量
  BMPHeaderSize As Long  '文件头长
                        'length of the bitmap info header used to describe the bitmap colors, compression,…
                        'the following sizes are possible:
                        '28h - windows 3.1x, 95, nt, …
                        '0ch - os/2 1.x
                        'f0h - os/2 2.x

  ImageWidth As Long           '图像宽（像素数）
  ImageHeight As Long          '图像高(像素数)
  PlaneNumber As Integer  '图像层数
  bpp As Integer    'bits per pixels    '1 - monochrome bitmap
                                        '4 - 16 color bitmap
                                        '8 - 256 color bitmap
                                        '16 - 16bit (high color) bitmap
                                        '24 - 24bit (true color) bitmap
                                        '32 - 32bit (true color) bitmap
  Compression As Long '压缩方法     '0 - none (also identified by bi_rgb)
                                    '1 - rle 8-bit / pixel (also identified by bi_rle4)
                                    '2 - rle 4-bit / pixel (also identified by bi_rle8)
                                    '3 - bitfields (also identified by bi_bitfields)
  IMAGESIZE As Long  '图像数据字节数
  hResolution  As Long  '水平分辩率  像素数/米
  vResolution  As Long  '垂直分辩率
  ColorsinBMP As Long   '图中所用的颜色。对256色图像总为0x100
  ImportantColors As Long
  Pallate(0 To 255) As Long  '图像每个值对应的实际显示颜色,项数对应PallateNumber所指调色板项数
End Type

Public BMPHeader As GrayBMPHeader, BMP1 As GrayBMPHeader
Public sRECT As RECT

Public conn As ADODB.Connection
Public rsTrain As ADODB.Recordset
Public rsOperater As ADODB.Recordset
Public rsGoods As ADODB.Recordset
Public rsGood2 As ADODB.Recordset
Public rsSender As ADODB.Recordset
Public rsReceover As ADODB.Recordset
Public rsTrainTMP As ADODB.Recordset

'打开采集卡
'设置参数
'设置为实时单帧采集到缓存方式
'由另一线程查询采集状态，如果完成采集，传送至用户数组分析或保存

Sub Main()
  Dim i As Integer, status As Long

   InitBMPinfo
   '生成BMP文件头---该文件头是固定将pFRAME数组写成BMP文件
    BMPHeader.Tag = &H4D42
    BMPHeader.ImageWidth = FrameW
    BMPHeader.ImageHeight = FrameH
    BMPHeader.BMPHeaderSize = &H28
    BMPHeader.PlaneNumber = 1
    BMPHeader.bpp = 8
    BMPHeader.Compression = 0
    BMPHeader.hResolution = &H1274   'Windows pBrush.exe的默认值,PhotoED.exe默值为0
    BMPHeader.vResolution = &H1274
    BMPHeader.ColorsinBMP = 256
    BMPHeader.ImportantColors = BMPHeader.ColorsinBMP
    BMPHeader.DataOffset = Len(BMPHeader)
    For i = 0 To 255
      BMPHeader.Pallate(i) = RGB(i, i, i)
    Next i
    BMPHeader.IMAGESIZE = FrameH * FrameW
    BMPHeader.FileLength = Len(BMPHeader) + BMPHeader.IMAGESIZE

    MoveMemory BMP1, BMPHeader, Len(BMPHeader)

    BMP1.ImageWidth = FrameW
    BMP1.ImageHeight = FrameH * 2
    BMP1.IMAGESIZE = BMP1.ImageWidth * BMP1.ImageHeight
    BMP1.FileLength = Len(BMP1) + BMP1.IMAGESIZE

  '确定标志位置,为pilarX, pilarY确定初始值
   PilarW = mkW
   PilarH = mkH  '此两项为固定值
   PilarX = GetSetting(App.EXEName, "Mark", "MarkX", mkX)
   PilarY = GetSetting(App.EXEName, "Mark", "MarkY", mkY)  '此两项需要在程序初始化时检查并进行调整


  '连续采集记录文件
  ' 建立一个缓冲区为页对齐方式的文件
  If Dir(TmpFile) <> "" Then
    hFile = CreateFile(TmpFile, GENERIC_READ Or GENERIC_WRITE, _
     0&, 0&, OPEN_ALWAYS, FILE_FLAG_NO_BUFFERING, 0&)
    ' 在95/98中，如果打开文件时没有声明overlapped方式，在读定文件时就不能使用overlapped参数项
    ' 而必须用setfilepointer函数调节与操作系统保留的文件指针。
  Else
    hFile = CreateFile(TmpFile, GENERIC_READ Or GENERIC_WRITE, _
     0&, 0&, CREATE_ALWAYS, FILE_FLAG_NO_BUFFERING, 0&)
  End If
  If hFile = 0 Then
    MsgBox TmpFile & ": File Open Error", vbOKOnly
    Exit Sub
  End If
  '采集参数记录文件
hBCFile = FreeFile()
Open TmpFile + ".BC" For Binary Access Read Write As #hBCFile

hMEM = VirtualAlloc(ByVal 0&, hMemSize, MEM_COMMIT, PAGE_READWRITE)  ’分配系统内容
If hMEM = 0 Then
    fStatus = GetLastError
    MsgBox "内存分配错误: 错误代码 - " & Str(fStatus) & vbCrLf _
     & "请向技术人员报告该错误代码。", vbOKOnly
    CloseHandle hFile
    Exit Sub
End If

hMemWork = VirtualAlloc(ByVal 0&, hMemWorkSize, MEM_COMMIT, PAGE_READWRITE)
If hMemWork = 0 Then
    fStatus = GetLastError
    MsgBox "内存分配错误: 错误代码 - " & Str(fStatus) & vbCrLf _
     & "请向技术人员报告该错误代码。", vbOKOnly
     '释放已成功分配的内存
    mStatus = VirtualFree(ByVal hMEM, hMemSize, MEM_DECOMMIT)
    mStatus = VirtualFree(ByVal hMEM, 0&, MEM_RELEASE)

    CloseHandle hFile
    Exit Sub
End If

' Test writing
'WriteFile hFile, ByVal hMEM, ByVal 4096&, bytesRW, ByVal 0&

   '初始化采集卡参数
   iCurrentCard = -1
   hBoard = okOpenBoard(iCurrentCard)
   Debug.Print hBoard
   If hBoard = 0 Then
      ExitGrabber
      End
   End If
   okGetBufferSize hBoard, mBufferAddr, BufferSize
   If mBufferAddr = 0 Then
     MsgBox "缓存不存在！"
     ExitGrabber
   End If
   Debug.Print Hex(mBufferAddr), Hex(BufferSize)


   currentBr = 128: currentContr = 128
   '设置视频输入参数
   okSetVideoParam hBoard, VIDEO_SOURCECHAN, 1 'Video2
      ' lParam=0,1.. Comp.Video; 0x100,101...to Y/C(S-Video), 0x200,0x201 to RGB Chan.Input
   okSetVideoParam hBoard, VIDEO_BRIGHTNESS, currentBr '亮度
   okSetVideoParam hBoard, VIDEO_CONTRAST, currentContr '对比度  ---初始设置条件下如果图像亮度达不到基本要求则控制灯光
   okSetVideoParam hBoard, VIDEO_RGBFORMAT, FORM_GRAY8 '8位灰度模式
   okSetVideoParam hBoard, VIDEO_TVSTANDARD, 0 'PAL制式
   okSetVideoParam hBoard, VIDEO_SIGNALTYPE, &H10000 '逐行（低字）同步开槽（高字）
   okSetVideoParam hBoard, VIDEO_RECTSHIFT, 144 + &H2C0000 '有效区起始位置:高字Y偏移，低字X偏移 (144/44经验值)
   okSetVideoParam hBoard, VIDEO_AVAILRECTSIZE, FrameW + FrameH * 2 * &H10000 '有效区大小：低字X高字Y (768/576采集卡最大值)
   okSetVideoParam hBoard, VIDEO_FREQSEG, 0 ' 低频部分信号

   '设置采集参数
   okSetCaptureParam hBoard, CAPTURE_INTERVAL, 0  '逐帧
   okSetCaptureParam hBoard, CAPTURE_CLIPMODE, 2 '裁剪方式
   okSetCaptureParam hBoard, CAPTURE_BUFRGBFORMAT, FORM_GRAY8  '8位灰度
   okSetCaptureParam hBoard, CAPTURE_HARDMIRROR, 0 '不作镜像变换
   okSetCaptureParam hBoard, CAPTURE_FRMRGBFORMAT, FORM_GRAY8 '帧存格式
   okSetCaptureParam hBoard, CAPTURE_SAMPLEFIELD, 0 ' 逐场采集
   okSetCaptureParam hBoard, CAPTURE_HORZPIXELS, 944  '水平像素数 PAL制式固定值
   okSetCaptureParam hBoard, CAPTURE_VERTLINES, 625 '垂直线数
   okSetCaptureParam hBoard, CAPTURE_SEQCAPWAIT, 0 '不等结束立即返回
   'okSetCaptureParam hBoard, CAPTURE_BUFBLOCKSIZE, FrameW + FrameH * 2 * &H10000
   'Buffer Block Size不用设置，而用okSetTargetRect函数进行动态调节


   okCloseBoard hBoard
   Sleep 50
   hBoard = okOpenBoard(iCurrentCard)   '关闭后重新打开使新的设置值生效

   '设置数据传送方式
   'okSetConvertParam hBoard, CONVERT_FIELDEXTEND, FIELD_COPYEXTEND '逐行并扩展行
   '该设置对本程序无意义，因为程序直接用CopyMemory方法读缓存，而扩展行方式是在用采集卡内置函数读RECT过程中实现的。

   sRECT.Right = -1   '用于获得当前设置值
   iFrames = okSetTargetRect(hBoard, BUFFER, sRECT)
   Debug.Print sRECT.Left, sRECT.Right, sRECT.Top, sRECT.Bottom
   Debug.Print okSetCaptureParam(hBoard, CAPTURE_BUFBLOCKSIZE, -1)  'FrameW + FrameH * &H10000
   sRECT.Left = 0
   sRECT.Top = 0
   sRECT.Right = sRECT.Left + FrameW
   sRECT.Bottom = sRECT.Top + FrameH * 2
   iFrames = okSetTargetRect(hBoard, BUFFER, sRECT)

   sRECT.Right = -1   '检查新设置值
   iFrames = okSetTargetRect(hBoard, BUFFER, sRECT)
   Debug.Print sRECT.Left, sRECT.Right, sRECT.Top, sRECT.Bottom
   Debug.Print Hex(okSetCaptureParam(hBoard, CAPTURE_BUFBLOCKSIZE, -1))

   If TESTSignal = False Then
      'ExitGrabber
   End If



   '设为实时采集状态
   'iFrames = okCaptureActive(hBoard, BUFFER, 0&)


   '单帧采集
   'okWaitSignalEvent hBoard, EVENT_FRAMEHEADER, -1
   'iFrames = okCaptureSingle(hBoard, BUFFER, 0&)
   okCaptureTo hBoard, BUFFER, 0, 1 'single
   'Do While okGetCaptureStatus(hBoard, False) <> 0
   '   Sleep 20
   'Loop
   okGetCaptureStatus hBoard, True
   MoveMemory pFRAME(1, 1), ByVal mBufferAddr, pFrameSize
   '写入768*576测试图象
   ArrayToBMP TmpBMP

   '打开数据库
   Set conn = New ADODB.Connection
   conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Persist Security Info=False;Data Source=" & "c:\train\train.mdb" & _
      "; Mode=Read|Write"
   conn.Open

   frmRecord.Picture1.Picture = LoadPicture(TmpBMP)
   frmRecord.Visible = True
   frmQuery.Visible = True
   Load frmReceiveFromComm

   '调试参数
   If InStr(UCase(Command()), "/CAPTURE") > 0 Then
     SignalBox.Visible = True
   End If
   If InStr(UCase(Command()), "/COMM") > 0 Then
     frmReceiveFromComm.Visible = True
   End If

End Sub

Sub ExitGrabber()
  '关闭数据库
  '关闭采集卡
  mStatus = VirtualFree(ByVal hMEM, hMemSize, MEM_DECOMMIT)
  mStatus = VirtualFree(ByVal hMEM, 0&, MEM_RELEASE)
  mStatus = VirtualFree(ByVal hMemWork, hMemWorkSize, MEM_DECOMMIT)
  mStatus = VirtualFree(ByVal hMemWork, 0&, MEM_RELEASE)
  okStopCapture hBoard
  okCloseBoard hBoard
  CloseHandle hFile
  Close #hBCFile
  conn.Close
  End
End Sub

Function ArrayToBMP(ByVal File As String)
Dim BytesWrite As Long

hTmpFile = CreateFile(File, GENERIC_READ Or GENERIC_WRITE, 0&, 0&, _
  CREATE_ALWAYS, 0&, 0&)

If hTmpFile = 0 Then
   ArrayToBMP = False
   Exit Function
End If

SetFilePointer hTmpFile, 0&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMPHeader, 2&, BytesWrite, ByVal 0&
SetFilePointer hTmpFile, 2&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMPHeader.FileLength, Len(BMPHeader) - 2, BytesWrite, ByVal 0&

SetFilePointer hTmpFile, Len(BMPHeader), 0&, FILE_BEGIN
WriteFile hTmpFile, pFRAME(1, 1), pFrameSize, BytesWrite, ByVal 0&

If BytesWrite < pFrameSize Then
  ArrayToBMP = False
End If

CloseHandle hTmpFile

End Function

Function ArrayToBMP1(ByVal File As String)

Dim BytesWrite As Long

hTmpFile = CreateFile(File, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0&, _
  CREATE_ALWAYS, 0&, 0&)

If hTmpFile = 0 Then
   ArrayToBMP1 = False
   Exit Function
End If

SetFilePointer hTmpFile, 0&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMP1, 2&, BytesWrite, ByVal 0&

SetFilePointer hTmpFile, 2&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMP1.FileLength, Len(BMP1) - 2, BytesWrite, ByVal 0&

SetFilePointer hTmpFile, Len(BMP1), 0&, FILE_BEGIN
WriteFile hTmpFile, pBuffer(1), pBufferSize, BytesWrite, ByVal 0&

If BytesWrite < pBufferSize Then
  ArrayToBMP1 = False
End If

CloseHandle hTmpFile

End Function

'使用该过程建立的文件要求在用后关闭
Public Function ArrayToBMP2(File As String) As Boolean

Dim BytesWrite As Long

ArrayToBMP2 = True

hTmpFile = CreateFile(File, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0&, _
  CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY, 0&)

If hTmpFile = 0 Then
   ArrayToBMP2 = False
   Exit Function
End If

SetFilePointer hTmpFile, 0&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMPHeader, 2, BytesWrite, ByVal 0&

SetFilePointer hTmpFile, 2&, 0&, FILE_BEGIN
WriteFile hTmpFile, BMPHeader.FileLength, Len(BMPHeader) - 2, BytesWrite, ByVal 0&

SetFilePointer hTmpFile, Len(BMPHeader), 0&, FILE_BEGIN
WriteFile hTmpFile, pFRAME(1, 1), pFrameSize, BytesWrite, ByVal 0&

If BytesWrite < pFrameSize Then
  ArrayToBMP2 = False
End If

CloseHandle hTmpFile

End Function

Private Function TESTSignal() As Boolean
Dim extsign As Long, videotype As Long, scanlines As Long, fieldfrq As Long

extsign = okGetSignalParam(hBoard, SIGNAL_VIDEOEXIST)

If extsign = 1 Then
   TESTSignal = True
Else
    If extsign = 0 Then
        MsgBox "无视频输入信号，检查摄像机电源！", vbOKOnly
        TESTSignal = False
        Exit Function
    End If
End If

'测试视频输入类型
'video type
okWaitSignalEvent hBoard, EVENT_ODDFIELD, 40
videotype = okGetSignalParam(hBoard, SIGNAL_VIDEOTYPE)
If videotype = 1 Then
        '"隔行信号(Interlaced)"
Else
   If videotype = 0 Then
       '"逐行信号(Non-interlaced)"
   Else
     If videotype = -1 Then
       ' "不支持"
     End If
   End If
End If

'测试垂直扫描线数
'video scanlines
scanlines = -1
scanlines = okGetSignalParam(hBoard, SIGNAL_SCANLINES)
    If scanlines = -1 Then
        ' "不支持"
    Else
        'Trim(Str(ScanLines)) + " 行数/幅"
    End If

'测试帧频
'video field frequency
    fieldfrq = okGetSignalParam(hBoard, SIGNAL_FIELDFREQ)
    If fieldfrq = -1 Then
        'lblSignal(8) = "不支持"
    Else
        'lblSignal(8) = Trim(Str(FieldFRQ)) + " 场数/秒"
    End If
End Function

Sub PicIdentify()
'本程序完成从文件中按顺序读出一幅图像并完成图像识别
'根据固定位置判断透过车皮连接处接收的对面的立柱影像。出现立柱后该帧前1-2帧与后1-2帧分别为车号信息与车皮信息
'判定标准：如果在立柱位置上有明显的模式反差，则视为车皮之间的间隔
'方法：对立柱标志区进行平均值二值化，面积为32*40，亮区（255）与暗区（0）的亮度平均值理论差大于200倍，实际差值应不小于100倍

  Dim fPTR As Long, cFrame As Long
  Dim i As Long, j As Integer, pTotal As Long, pAV As Integer


cFrame = 0

Do While cFrame < tFrames

  fStatus = SetFilePointer(hFile, cFrame * pFrameSize, 0&, FILE_BEGIN)
  fStatus = ReadFile(hFile, ByVal hMEM, ByVal pFrameSize, bytesRW, ByVal 0&)
  MoveMemory pFRAME(1, 1), ByVal hMEM, pFrameSize

  frmRecord.RText.Text = Str(cFrame)
  frmRecord.RText.Refresh

  If CheckMark = True Then
   ArrayToBMP TmpBMP
   frmRecord.Picture1.Picture = LoadPicture(TmpBMP)
   frmRecord.RText.Text = "第" & Str(cFrame) & "帧"

   DrawSlice

   'i = MsgBox("检测到立柱：第" & Str(cFrame) & "帧", vbYesNo)
   'If i = vbNo Then
   '  Exit Do
   'End If
   'cFrame = cFrame + 1

  End If
  DoEvents
  cFrame = cFrame + 1
Loop
End Sub

Function CheckMark(Optional iBlk As Integer = 30, Optional iWhite As Integer = 230) As Boolean

'如标志区模式反差存在则为TRUE，否则返回FALSE

Dim i As Integer, j As Integer, mTotal As Long, mAV As Single, mTop As Long, mBot As Long
CheckMark = True

'复制标志区
For i = 1 To mkH
   MoveMemory MKpilar((i - 1) * PilarW + 1), pFRAME(PilarX, PilarY + i), PilarW
Next i

For j = 1 To PilarW * PilarH / 2
   mTop = mTop + MKpilar(j)
Next j

For j = PilarW * PilarH / 2 + 1 To PilarW * PilarH
   mBot = mBot + MKpilar(j)
Next j

mTop = mTop / PilarW / PilarH * 2
mBot = mBot / PilarW / PilarH * 2

mAV = (mTop + mBot) / 2 + (mBot - mTop) / 4 '标志区平均亮度

'平均值极值化
  For j = 1 To PilarH * PilarW
    MKpilar(j) = IIf(MKpilar(j) > mAV, 255, 0)
  Next j

mTop = 0: mBot = 0
For j = 1 To PilarH * PilarW / 2
  mTop = mTop + MKpilar(j)
Next j

For j = PilarH * PilarW / 2 + 1 To PilarH * PilarW
  mBot = mBot + MKpilar(j)
Next j

  mTop = mTop / PilarH / PilarW * 3
  mBot = mBot / PilarH / PilarW * 3


If mBot > iWhite And mTop < iBlk Then
  CheckMark = True
Else
  CheckMark = False
End If
End Function

Sub Capture1Frame()
   okCaptureTo hBoard, BUFFER, 0, 1 'single
   okGetCaptureStatus hBoard, True
   MoveMemory pFRAME(1, 1), ByVal mBufferAddr, pFrameSize
End Sub

Sub CopyMark(iBlk As Integer, iWhite As Integer)
'复制标志区并返回标志区暗区与亮区的亮度平均值
Dim i As Integer, j As Integer, mTotal As Long, mAV As Single, mTop As Long, mBot As Long, mMid As Single, bsTotal As Long

'复制标志区
For i = 1 To mkH
   MoveMemory MKpilar((i - 1) * PilarW + 1), pFRAME(PilarX, PilarY + i), PilarW
Next i

For j = 1 To mkW * mkH / 2
   mTotal = mTotal + MKpilar(j)
Next j

iBlk = mTotal / (mkW * mkH / 2)  '标志区上部白区平均亮度

mTotal = 0
For j = mkW * mkH / 2 + 1 To mkW * mkH
   mTotal = mTotal + MKpilar(j)
Next j

iWhite = mTotal / (mkW * mkH / 2) '标志区下部黑区平均亮度

'背景亮度
  MoveMemory BsLine(1), pFRAME(1, 1), 4 * FrameW
  For i = 1 To 4 * FrameW
    bsTotal = bsTotal + BsLine(i)
  Next i
  bsAV = bsTotal / FrameW / 4

End Sub

Sub AdjIMGbright(Optional bInit As Boolean = True)

  '自动调节亮度与对比度,此时处于无车辆状态（白天特别高，而夜间特别暗）
  '图像平均亮度白天不高于200（当车辆通过时可能会下降到100左右）,不低于100
  '            夜间不高于80（过高时通常是由于雪花噪声引起）,但立柱不低于30

  Dim bsTotal As Long, i As Integer, iBlack As Integer, iBright As Integer

  '按标准亮度与对比度采集一帧，确定背景亮度
  currentContr = 128   '初始对比度
  currentBr = 128   '初始亮度
  okSetVideoParam hBoard, VIDEO_BRIGHTNESS, currentBr '亮度
  okSetVideoParam hBoard, VIDEO_CONTRAST, currentContr '对比度
  DoEvents
  Capture1Frame
  '获得图像上缘4行象素
  MoveMemory BsLine(1), pFRAME(1, 1), 4 * FrameW
  CopyMark iBlack, iBright   '图像标志区亮度
  For i = 1 To 4 * FrameW
    bsTotal = bsTotal + BsLine(i)
  Next i
  bsAV = bsTotal / FrameW / 4    '图像上缘基线亮度

  Select Case bsAV
     Case 0 To 60    '夜间通过灯光照明,完全没有背景
       currentBr = 150
       currentContr = 60
     Case 61 To 80   '有可见背景
       currentBr = 140
       currentContr = 70
     Case 81 To 100  '有清晰背景
       currentBr = 128
       currentContr = 80
     Case 100 To 150  '有明亮背景
       currentBr = 140                '5:30-6:00钟实测数据
       currentContr = 50
     Case 151 To 180
       currentBr = 130
       currentContr = 60
     Case 181 To 220  '背景全为白色
       currentBr = 110
       currentContr = 130
     Case 221 To 255  '背景全为白色
       currentBr = 100
       currentContr = 100
  End Select

  Select Case (iBlack + iBright) / 2   '图像反射光强度修正
        Case 100 To 150
          currentBr = currentBr - 10
        Case 151 To 255
          currentBr = currentBr - 20
  End Select

  okSetVideoParam hBoard, VIDEO_BRIGHTNESS, currentBr '亮度
  okSetVideoParam hBoard, VIDEO_CONTRAST, currentContr '对比度
End Sub

Sub CopyCorner(rowID As Integer, diffL As Integer, diffR As Integer)
    Dim i As Integer, j As Integer, L1 As Long, L2 As Long, R1 As Long, R2 As Long

    For i = 1 To 8
      MoveMemory LeftBK((i - 1) * 128 + 1, rowID), pFRAME(1, i), 128&
      MoveMemory RightBK((i - 1) * 128 + 1, rowID), pFRAME(640, i), 128&
    Next i

    For j = 1 To 1024
      L1 = L1 + LeftBK(j, 0)
      L2 = L2 + LeftBK(j, 1)
      R1 = R1 + RightBK(j, 0)
      R2 = R2 + RightBK(j, 1)
    Next j
    diffL = Abs(L1 - L2) / 1024
    diffR = Abs(R1 - R2) / 1024
End Sub

Function CheckSlice() As Boolean
  CopySlice avSL, avSLR, avSLL
  If Abs(avSL - avSLL) > (Abs(avSLL - avSLR) + 5) * 4 Then
    CheckSlice = True
  Else
    CheckSlice = False
  End If
End Function

Sub CopySlice(avSL As Integer, avSLR As Integer, avSLL As Integer)
  Dim i As Long, j As Long, total As Long, totalL As Long, totalR As Long
  For i = 1 To FrameH
    MoveMemory Slice(1, i), pFRAME(sPos, i), sSize
    MoveMemory SliceL(1, i), pFRAME(sPosL, i), sSize
    MoveMemory SliceR(1, i), pFRAME(sPosR, i), sSize
  Next i
  For i = 1 To FrameH
    For j = 1 To sSize
       total = total + Slice(j, i)
       totalL = totalL + SliceL(j, i)
       totalR = totalR + SliceR(j, i)
    Next j
  Next i
  avSL = total / FrameH / sSize
  avSLR = totalR / FrameH / sSize
  avSLL = totalL / FrameH / sSize
End Sub

Sub DrawSlice()
   frmRecord.Picture1.Line (sPosL, 0)-(sPosL + sSize, FrameH), RGB(255, 0, 0), B
   frmRecord.Picture1.Line (sPos, 0)-(sPos + sSize, FrameH), RGB(0, 255, 0), B
   frmRecord.Picture1.Line (sPosR, 0)-(sPosR + sSize, FrameH), RGB(0, 0, 255), B
   frmRecord.RText.Text = Str(avSLL) & "/" & Str(avSL) & "/" & Str(avSLR)
End Sub
Sub DrawMark(pic As Control)
   Dim i As Long, j As Long
   pic.Line (PilarX, FrameH - PilarY)-(PilarX + PilarW, FrameH - PilarY - PilarH / 2), RGB(255, 0, 0), B
   pic.Line (PilarX, FrameH - PilarY - PilarH / 2 - 1)-(PilarX + PilarW, FrameH - PilarY - PilarH), RGB(0, 0, 255), B
   For i = 1 To PilarH
     For j = 1 To PilarW
       pic.PSet (PilarX + PilarW + 10 + j, FrameH - PilarY - i), RGB(MKpilar((i - 1) * PilarW + j), 0, 0)
     Next j
   Next i
End Sub

Function avIMG() As Integer
  Dim i As Long, j As Long, totalIMG As Long
  MoveMemory pBuffer(1), pFRAME(1, 1), pFrameSize
  For i = 1 To pFrameSize
    totalIMG = totalIMG + pBuffer(i)
  Next i
  avIMG = totalIMG / pFrameSize
End Function

Function avRegion(barCol As Integer, barWidth As Integer) As Integer
  Dim i As Long, j As Long, totalIMG As Long
  For i = 1 To FrameH
     MoveMemory pBuffer((i - 1) * barWidth + 1), pFRAME(barCol, i), barWidth
  Next i
  For i = 1 To FrameH * barWidth
    totalIMG = totalIMG + pBuffer(i)
  Next i
  avRegion = totalIMG / pFrameSize
End Function

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

91楼发表于: 2015-09-06

只看该作者 ┊ 小中大

'VB 6.0 版
'这不是我写的，它更强悍了。因为可以直接读写物理扇区(CHS)，而不是逻辑扇区。

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long '//declare has changed
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long '//declare has changed
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
'如果用绝对扇区写，那么文件的建立打开都不能用VB的 open 语句了。

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3

Private Const INVALID_HANDLE_VALUE = -1

'//file seek
Private Const FILE_BEGIN = 0
Private Const FILE_CURRENT = 1
Private Const FILE_END = 2

Private Const ERROR_SUCCESS = 0&

'//device io control
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long

Private Const IOCTL_DISK_GET_DRIVE_GEOMETRY As Long = &H70000   '458752
Private Const IOCTL_STORAGE_GET_MEDIA_TYPES_EX  As Long = &H2D0C04
Private Const IOCTL_DISK_FORMAT_TRACKS As Long = &H7C018
Private Const FSCTL_LOCK_VOLUME As Long = &H90018
Private Const FSCTL_UNLOCK_VOLUME As Long = &H9001C
Private Const FSCTL_DISMOUNT_VOLUME As Long = &H90020
Private Const FSCTL_GET_VOLUME_BITMAP = &H9006F

'//type
Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type

Private Enum MEDIA_TYPE
    Unknown
    F5_1Pt2_512
    F3_1Pt44_512
    F3_2Pt88_512
    F3_20Pt8_512
    F3_720_512
    F5_360_512
    F5_320_512
    F5_320_1024
    F5_180_512
    F5_160_512
    RemovableMedia
    FixedMedia
End Enum

Private Type DISK_GEOMETRY
    Cylinders           As LARGE_INTEGER
    MediaType           As MEDIA_TYPE
    TracksPerCylinder   As Long
    SectorsPerTrack     As Long
    BytesPerSector      As Long
End Type

'//private vars
Private hDisk           As Long             'disk handle
Private lpGeometry      As DISK_GEOMETRY    'disk info
Private lBufferSize     As Long             'the buffer size of read/write

Public Function OpenDisk(ByVal FileName As String) As Boolean
'// 打开磁盘
    hDisk = CreateFile(FileName, _
                        GENERIC_READ Or GENERIC_WRITE, _
                        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                        ByVal 0&, _
                        OPEN_EXISTING, _
                        0, _
                        0)
    OpenDisk = Not (hDisk = INVALID_HANDLE_VALUE)
End Function

Public Function CloseDisk() As Boolean
'//关闭磁盘
    CloseDisk = CloseHandle(hDisk)
End Function

Public Function GetDiskGeometry() As Boolean
'//获取磁盘参数
    Dim dwOutBytes      As Long
    Dim bResult         As Boolean

    bResult = DeviceIoControl(hDisk, _
                                IOCTL_DISK_GET_DRIVE_GEOMETRY, _
                                ByVal 0&, 0, _
                                lpGeometry, Len(lpGeometry), _
                                dwOutBytes, _
                                ByVal 0&)

    If bResult Then lBufferSize = lpGeometry.BytesPerSector * lpGeometry.SectorsPerTrack
    GetDiskGeometry = bResult
End Function

Public Sub GetDiskInfo(MediaType As Long, _
                        Cylinders As Long, _
                        TracksPerCylinder As Long, _
                        SectorsPerTrack As Long, _
                        BytesPerSector As Long)
'//返回磁盘的参数
    MediaType = lpGeometry.MediaType
    Cylinders = lpGeometry.Cylinders.lowpart
    TracksPerCylinder = lpGeometry.TracksPerCylinder
    SectorsPerTrack = lpGeometry.SectorsPerTrack
    BytesPerSector = lpGeometry.BytesPerSector

End Sub

Public Property Get BufferSize() As Long
'//返回每次读/写的缓冲大小
    BufferSize = lBufferSize
End Property

Public Function LockVolume() As Boolean
'// 将卷锁定
    Dim dwOutBytes  As Long
    Dim bResult     As Boolean

    bResult = DeviceIoControl(hDisk, _
                                FSCTL_LOCK_VOLUME, _
                                ByVal 0&, 0, _
                                ByVal 0&, 0, _
                                dwOutBytes, _
                                ByVal 0&)
    LockVolume = bResult
End Function

Public Function UnlockVolume() As Boolean
'// 将卷解锁
    Dim dwOutBytes As Long
    Dim bResult As Boolean

    bResult = DeviceIoControl(hDisk, _
                                FSCTL_UNLOCK_VOLUME, _
                                ByVal 0&, 0, _
                                ByVal 0&, 0, _
                                dwOutBytes, _
                                ByVal 0&)
    UnlockVolume = bResult
End Function

Public Function DismountVolume() As Boolean
'// 将卷卸下,使系统重新辨识磁盘，等效于重新插盘
    Dim dwOutBytes As Long
    Dim bResult As Boolean

    bResult = DeviceIoControl(hDisk, _
                                FSCTL_DISMOUNT_VOLUME, _
                                ByVal 0&, 0, _
                                ByVal 0&, 0, _
                                dwOutBytes, _
                                ByVal 0&)
    DismountVolume = bResult
End Function

Public Function ReadDisk(ByVal Cylinders As Long, _
                    ByVal Tracks As Long, _
                    db() As Byte) As Boolean
'//按柱面和磁道来读取磁盘数据
    Dim iPos    As Long
    Dim lRead   As Long

    iPos = Cylinders * Tracks * lBufferSize

    If SeekAbsolute(0, iPos) Then
        ReadDisk = ReadBytes(lBufferSize, db(), lRead)
    End If
End Function

Public Function WriteDisk(ByVal Cylinders As Long, _
                     ByVal Tracks As Long, _
                     db() As Byte) As Boolean
'//按柱面和磁道来写磁盘数据
    Dim iPos    As Long
    Dim lRead   As Long

    iPos = Cylinders * Tracks * lBufferSize

    If SeekAbsolute(0, iPos) Then
        WriteDisk = WriteBytes(lBufferSize, db())
    End If
End Function

'/////////////////////////////////////////////////////////////////////////////////////
'//file system

Private Function SeekAbsolute(ByVal HighPos As Long, ByVal LowPos As Long) As Boolean
'//seek file
    '//Notice: when you set LowPos=5, the read/write will begin with the 6th(LowPos+1) byte
    LowPos = SetFilePointer(hDisk, LowPos, HighPos, FILE_BEGIN)
    If LowPos = -1 Then
        SeekAbsolute = (Err.LastDllError = ERROR_SUCCESS)
    Else
        SeekAbsolute = True
    End If

End Function

Private Function ReadBytes(ByVal ByteCount As Long, ByRef DataBytes() As Byte, ByRef ActuallyReadByte As Long) As Boolean
'//read data to array
    Dim RetVal    As Long
    RetVal = ReadFile(hDisk, DataBytes(0), ByteCount, ActuallyReadByte, 0)
    'ActuallyReadByte =>> if the bytesRead=0 mean EOF
    ReadBytes = Not (RetVal = 0)

End Function

Private Function WriteBytes(ByVal ByteCount As Long, ByRef DataBytes() As Byte) As Boolean
'//write data from array
    Dim RetVal As Long
    Dim BytesToWrite As Long
    Dim BytesWritten As Long

    RetVal = WriteFile(hDisk, DataBytes(0), ByteCount, BytesWritten, 0)

    WriteBytes = Not (RetVal = 0)
End Function

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

90楼发表于: 2015-09-05

只看该作者 ┊ 小中大

//从指定扇区号dwSector开始，写dwLength长度的数据
BOOL WriteDisk( HANDLE hpartition, DWORD dwSector, DWORD dwLength, char* lpBuffer){
DWORD dwCB;
LARGE_INTEGER  offset;
offset.QuadPart  =  UInt32x32To64(dwSector ,  512);
SetFilePointer(hpartition,  offset.LowPart,  &offset.HighPart,  FILE_BEGIN);
if(!WriteFile(hpartition, lpBuffer, dwLength * 512, &dwCB, NULL)){
DWORD error = GetLastError();
MessageBox(NULL,"写入文件失败!",NULL,IDOK);
return FALSE;
}
return TRUE;
}

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

89楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第46楼清水于03-03-2011 14:50发表的 : t<sNc8x
~o@\ n
介个真的看不懂。 1TNz&=e
你说你老啦，喜欢怀旧了，才想起来填坑。 8?7kIin
提醒我也想想，是不是也老啦，是不是也有坑没填呢。 efjO8J[uk-

你肯定有许多坑没有填，但是我挖的坑更多，但同是我也在你的某个坑里等你填埋呢！

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

88楼发表于: 2015-09-05

只看该作者 ┊ 小中大

Re:回 38楼(伍胥之) 的帖子

引用
引用第39楼suehan234于01-22-2011 08:00发表的回 38楼(伍胥之) 的帖子 : f=ac I|w
佩服，玩也玩得这么专业！ ;8P_av}C

只是票友而已，算不上专业的。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

87楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第25楼猪小秘于01-20-2011 20:51发表的 : v f`9*xF
伍SIR，再次抱拳佩服 P##Z[$IJ3

小秘倒是好久不见了呢！宝贝几岁了？很健康活泼吧？

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

86楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第21楼阿散于06-14-2010 22:33发表的 : }W$8M>l
引用第19楼伍胥之于06-14-2010 12:33发表的 : i\Yl
f=o4I2Y[
lEHwZ<je
我平生唯一参加的计算机考试就是职称考试，任选4个模块。 #{x5L^v>]
jYWw.g<
我连一级也没有考过。 I!0JG`&
. -#aZF2z

引用
9? 2
矬子里拔将军... WSLy}@`Vx
你们那里的俗语是吧? hK(tPl$
y"vX~LR
我们这里说"矮子里拔长脚"..应该是同一个意思... lkA^\+Ct
H`-=?t
有趣....各地有表达意思一样却方式不同的俗语.... _gW{gLYyJ
/7gi/uh~-(
s~J=<)T*6
你的文章写的有脸皮,没屁眼的, [ ?iqqG.
让看客大为不满... h4(JUio
|3;(~a)%
你等着,,估计你以后接到的午夜凶铃就多了... WmNYO,>

我到现在也没有接到你的午夜凶铃呢！

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

85楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第17楼阿散于06-13-2010 22:29发表的 : \}JrFc%O
每个人的故事对其他人都是故事, /r^[a,Q#x
自己的故事也是其中之一. P~RhUKfd
跳出来看, /v#)f-N%zs
不过是众人中的一个人的故事. 8o|P&q(v*
>w.'KR0L
所以,接着听故事. ffE# ^|
}ptMjT{9
女人们有兴趣的就等老伍开个新帖或者跟贴, k4{:9zL1#?
听他痛说恋爱革命历史.... *HE^1IEl
5G(E&>~
杂家接着听他自学程序员历史, ,l HLH
高级程序员考了吗? )(m0cP{7

这个恋爱革命史还是等你痛改前非换个新ID来讲吧！

我什么程度员也没有考过，连大学生的计算机应用等级证明都没有。

我唯一考过的计算机科目是职称评审时要求有证书，所以我用了半小时考了word, powerpoint,和internet基础。都是小儿科的东东。如果没有用VBA写个Word的宏，我都觉得对不起微软了。

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

84楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第16楼阿平于06-13-2010 22:25发表的 : bzZ>ly H
哦, 打倒忽悠大家的家伙. 3l1cyPv

阿平姐，这可不是忽悠，我可是认真交待经历呢！

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

83楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第10楼卡拉于06-13-2010 21:49发表的 : .)tSg
老伍，对不住，我把你原来的英文标题改了，太不吸引人眼球了，有些人还当是英文的都不会去点击。我通篇读了一下，改成了现在的标题。如果你不喜欢，可以改回来。 XMIbUbUk-

其实标题没有什么，卡总既然改了就不必再改回了。

主要是当初写的时候真是顶着锅盖写的。

阿散说得对。我就是把一堆鸡毛蒜皮的小事，用了一个big title.

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

伍胥之 离线

级别: 军区司令员

显示用户信息

82楼发表于: 2015-09-05

只看该作者 ┊ 小中大

引用
引用第6楼沧桑于06-13-2010 14:39发表的 : [lzN !!B!
老伍在写交代材料啊，而且写在一个ZT的贴下，哈哈。 op2 Of<{h

这不是怕您见笑嘛！现在露馅了，只得继续招供了。

可以从宽不？

杺栫杣杊椌柮栬，䒴蓉艿芖。

回复引用

举报顶端

http://bachinese.com/forum
访问内容超出本站范围，不能确定是否安全
继续访问	取消访问

快速回复
	限 100 字节进入高级模式加粗字体颜色背景颜色插入链接图片验证问题: 3 * 6 = ? 正确答案:18 按"Ctrl+Enter"直接提交	上一个下一个


密码
	找回密码