病程续打程序（word vba）

因为工作需要，自己写的用于医疗病历的病历续打程序，无模板限制，在word中使用，也可用于任意文件的定位续打

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub 病程续打()
'
' 病程续打 3.1版本

'版本信息
'3.1版完全实现与模板无关打印,自动调用当前文件设置
'3.0版实现多模板续打
'2.1版增加提示信息,防止误续打
'2.0版实现多页续打
'1.0版实现单页续打

' 条件判断
'------------------------------------------

    Dim dl As Range, yema As Byte
    Set dl = Selection.Range
    yema = Selection.Information(wdActiveEndPageNumber)

    Dim boxsbj As Long, boxzbj As Long, boxkd As Long
    boxsbj = Selection.Information(wdVerticalPositionRelativeToPage)
    boxzbj = Selection.Information(wdHorizontalPositionRelativeToPage)

    Dim ymzbj As Long, ymybj As Long, ymsbj As Long, ymxbj As Long
    Dim ymym As Long, ymyj As Long, ymkd As Long, ymgd As Long, ymhwg As Long
    ymsbj = ActiveDocument.PageSetup.TopMargin
    ymxbj = ActiveDocument.PageSetup.BottomMargin
    ymzbj = ActiveDocument.PageSetup.LeftMargin
    ymybj = ActiveDocument.PageSetup.RightMargin
    ymym = ActiveDocument.PageSetup.HeaderDistance
    ymyj = ActiveDocument.PageSetup.FooterDistance
    ymkd = ActiveDocument.PageSetup.PageWidth
    ymgd = ActiveDocument.PageSetup.PageHeight
    ymhwg = ActiveDocument.PageSetup.LinesPage


    If Selection.Paragraphs.Count < 3 Then
   dlxz = MsgBox("未完整选择病程记录,如果确需打印请选择是", vbYesNo)
    If dlxz = vbNo Then
   Exit Sub
   End If
   End If

   Selection.Copy

    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    If Selection.Information(wdActiveEndPageNumber) <> yema Then
    MsgBox "选择内容不在同一页上,请重新选择"
    Exit Sub
    End If

   If Selection.Information(wdFirstCharacterLineNumber) = 1 Then
    shxz = MsgBox("所选内容是本页第一部分,将直接打印当前页.", vbYesNo)
    If shxz = vbNo Then
    Exit Sub
    Else
       Application.PrintOut FileName:="", Range:=wdPrintCurrentPage, Item:= _
        wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
    Exit Sub
    End If
   End If

'新建文档
'---------------------------------
     Documents.add DocumentType:=wdNewBlankDocument

'页面设置
'--------------------
    With ActiveDocument.PageSetup
        .TopMargin = ymsbj
        .BottomMargin = ymxbj
        .LeftMargin = ymzbj
        .RightMargin = ymybj
        .HeaderDistance = ymym
        .FooterDistance = ymyj
        .PageWidth = ymkd
        .PageHeight = ymgd
        .LinesPage = ymhwg
        .LayoutMode = wdLayoutModeLineGrid
    End With

'插入文本框
'------------
    boxkd = ActiveDocument.PageSetup.PageWidth - ActiveDocument.PageSetup.LeftMargin - ActiveDocument.PageSetup.RightMargin
    ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, boxzbj, boxsbj, boxkd, 124.65).Select
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.TextFrame.MarginLeft = 0
    Selection.ShapeRange.TextFrame.MarginRight = 0
    Selection.ShapeRange.TextFrame.MarginTop = 0
    Selection.ShapeRange.TextFrame.MarginBottom = 0
    Selection.ShapeRange.Left = wdShapeLeft

'粘贴
'----------
    Selection.ShapeRange.TextFrame.TextRange.Select
    Selection.Collapse
    Selection.Paste

'自动调整文本框高度
'------------------
    Selection.ShapeRange.TextFrame.AutoSize = True

'打印当前页
'--------------
    Application.PrintOut FileName:="", Range:=wdPrintCurrentPage, Item:= _
        wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
'关闭临时文档
'-------------
    ActiveDocument.Close (wdDoNotSaveChanges)


End Sub

' 病程续打 3.1版本