PPT交班小程序_VBA

科室手术交班使用的是PPT，需要按照预定格式填入交班内容，为了省事，使用VBA来导入病历中的内容到PPT中。

PPT设计如下（底部的文字为使用方式说明，不在本程序中）：

具体说明如下：

1. 用带底纹的文本框制作预定格式的母版；
2. 在母版的基础上添加文本框并根据需要命名；
3. 使用如下程序将内容分别导入第2步的文本框中的。

Dim intcurrentslideindex As Integer
Dim objapp As PowerPoint.Application

Sub 自动填写交班记录()

    '激活窗口
    Set objapp = Application
    objapp.Activate
    
    '代码更新2023-4-14。加入下述代码可省去手动复制，直接点击按钮运行，然后选择保存的输钱小姐文件即可
    'ActivePresentation.Slides(1).Duplicate
    
    '选择幻灯片中所有形状和文本框
    ActiveWindow.Selection.SlideRange.Shapes.SelectAll
    
    
    Dim strhtmlFilePath As String
    Dim strhtmlcontent, strhtmlcontent1 As String
    Dim objtextbox As Shape
    Dim objhtmlfile As Object
    Dim objfso As Object

    '打开文件对话框，选择html文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "HTML Files", "*.htm; *.html"
        If .Show = True Then
        '获取html文件绝对路径
            strhtmlFilePath = .SelectedItems(1)
        Else
        '用户没有选择文件，退出子程序
            Exit Sub
        End If
    End With
    
    '创建文件操作对象和html文件对象
    Set objfso = CreateObject("scripting.filesystemobject")
    Set objhtmlfile = objfso.opentextfile(strhtmlFilePath)
    
    '读取html文件内容
    strhtmlcontent = objhtmlfile.readall()
    'strhtmlcontent1 = objhtmlfile.readline()，这个代码的意思是读取第一行，需要注意光标的位置
    
    objhtmlfile.Close
    
    '将相应内容分别填入相应的文本框，需要注意的是这一操作仅在之前选中的文本框中进行
    For Each objtextbox In ActiveWindow.Selection.ShapeRange
        If objtextbox.Type = msoTextBox Then
            Select Case objtextbox.Name
            Case "datebox"
                Start1 = InStr(strhtmlcontent, "术前小结/手术日期_术前小结")
                Last = InStr(Start1, strhtmlcontent, "</TD>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "bedbox"
                Start1 = InStr(strhtmlcontent, "residence.now.bed")
                Last = InStr(Start1, strhtmlcontent, "</TD>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "idbox"
                Start1 = InStr(strhtmlcontent, "residence.event")
                Last = InStr(Start1, strhtmlcontent, "</TD>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "namebox"
                Start1 = InStr(strhtmlcontent, "服务对象标识/病人姓名")
                Last = InStr(Start1, strhtmlcontent, "</customtag:de_y>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "genderbox"
                Start1 = InStr(strhtmlcontent, "人口学/性别")
                Last = InStr(Start1, strhtmlcontent, "</customtag:ded_y>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "agebox"
                Start1 = InStr(strhtmlcontent, "人口学/年龄")
                Last = InStr(Start1, strhtmlcontent, "</customtag:de_y>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "complaint"
                Start1 = InStr(strhtmlcontent, "主诉/主诉描述")
                Last = InStr(Start1, strhtmlcontent, "</customtag:de_y>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = "以" & "“" & Mid(strhtmlcontent, Start, Last - Start) & "”" & "为主诉入院"
            Case "diagnosisbox"
                Start1 = InStr(strhtmlcontent, "诊断/入院初步诊断")
                Last = InStr(Start1, strhtmlcontent, "</customtag:de_y>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                
                 '提取的诊断中有空格符——"&nbsp"——，通过while循环删除
                Dim a, b, c, d As String
                a = Mid(strhtmlcontent, Start, Last - Start)
                b = "&nbsp"
                Do While InStr(b, "&nbsp") <> 0 'instr中若不包含某字符，则取0，0以后的数字表示仍包含所查找的字符
        
                    b = Replace(a, "&nbsp", "") '通过replace函数来删除特定字符
                Loop
                    
                '如果诊断做过修改，html文件中会增加修改的标记，故通过下述循环删除这一标记用于交班
                Do While InStr(b, "<SPAN ") <> 0
                        Start1 = InStr(b, "<SPAN ")
                        Last = InStr(Start1, b, ">")
                        str1 = Mid(b, Start1, Last - Start1 + 1)
                        c = Replace(b, str1, "")
                        d = c
                        c = Replace(d, "</SPAN>", "")
                        b = c
                Loop
                    
                objtextbox.TextFrame.TextRange.Text = b
                
            Case "operationbox"
                Start1 = InStr(strhtmlcontent, "术前小结/手术名称_术前小结")
                Last = InStr(Start1, strhtmlcontent, "</TD>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                
                '提取的诊断中有空格符——"&nbsp"——，通过while循环删除
                a = Mid(strhtmlcontent, Start, Last - Start)
                b = "&nbsp"
                Do While InStr(b, "&nbsp") <> 0 'instr中若不包含某字符，则取0，0以后的数字表示仍包含所查找的字符
        
                    b = Replace(a, "&nbsp", "") '通过replace函数来删除特定字符
                Loop
                
                objtextbox.TextFrame.TextRange.Text = b
            Case "aneasthesiabox"
                Start1 = InStr(strhtmlcontent, "术前小结/麻醉名称_术前小结")
                Last = InStr(Start1, strhtmlcontent, "</TD>")
                str1 = Mid(strhtmlcontent, Start1, Last - Start1)
                Start = Start1 + InStr(str1, ">")
                objtextbox.TextFrame.TextRange.Text = Mid(strhtmlcontent, Start, Last - Start)
            Case "operatorbox"
                objtextbox.TextFrame.TextRange.Text = ""
            End Select
        End If
    Next objtextbox
    
    '完成后删除之前导出的html文件
    Kill strhtmlFilePath
    
    '保存ppt
    objapp.ActivePresentation.Save
    
End Sub