mod1.bas

自动排版程序

'            MyRange.InsertAfter "市  场  动  态" & Chr(13)
'            MyRange.Font.Name = "黑体"
'            MyRange.Font.Size = 14
'            MyRange.Font.Bold = True
'            MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
'        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'        MyRange.ParagraphFormat.LineSpacing = 26
'        MyRange.Start = MyRange.End
'
'
'    For i = 0 To intT - 1
'        If strClass(i) = "市场动态" Then
'            MyRange.Start = MyRange.End
'            MyRange.InsertAfter "※"
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphLeft
'
'            MyRange.Start = MyRange.End
'            strXX = strContents(i)
'            MyRange.InsertAfter " " & Trim(strXX) & "              " & Trim(strSource(i)) & Chr(13)
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphJustify
'       '建立悬挂缩进
'            MyRange.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.3)
'            MyRange.ParagraphFormat.LeftIndent = InchesToPoints(0.3)
'
'            MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'            MyRange.ParagraphFormat.LineSpacing = 26
'
'
'         End If
'    DoEvents
'    Next i
    
'***************************综合报道的内容***********************

            MyRange.Start = MyRange.End
            MyRange.InsertAfter "综  合  报  道" & Chr(13)
            MyRange.Font.Name = "黑体"
            MyRange.Font.Size = 14
            MyRange.Font.Bold = True
            MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        MyRange.ParagraphFormat.LineSpacing = 26
        MyRange.Start = MyRange.End

    
    For i = 0 To intT - 1
        If strClass(i) = "综合报道" Then
            MyRange.Start = MyRange.End
            MyRange.InsertAfter "※"
            MyRange.Font.Name = "仿宋_GB2312"
            MyRange.Font.Size = 14
            MyRange.Paragraphs.Alignment = wdAlignParagraphLeft
        
            MyRange.Start = MyRange.End
            strXX = strContents(i)
            MyRange.InsertAfter " " & Trim(strXX) & "   " & Trim(strSource(i)) & Chr(13)
            MyRange.Font.Name = "仿宋_GB2312"
            MyRange.Font.Size = 14
            MyRange.Paragraphs.Alignment = wdAlignParagraphJustify
       '建立悬挂缩进
            MyRange.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.3)
            MyRange.ParagraphFormat.LeftIndent = InchesToPoints(0.3)
                   
            MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
            MyRange.ParagraphFormat.LineSpacing = 26

         End If
    DoEvents
    Next i
    
'************************国际采撷*****************
'    MyRange.Start = MyRange.End
'    MyRange.InsertAfter "   国际采撷" & Chr(13)
'    MyRange.Font.Name = "隶书"
'    MyRange.Font.Size = 14
'    MyRange.Font.Italic = True
'    MyRange.Font.ColorIndex = wdBlack
'
'    MyRange.Paragraphs.Alignment = wdAlignParagraphLeft
'    MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'    MyRange.ParagraphFormat.LineSpacing = 18
'    MyRange.Start = MyRange.End
'***************************跨国集团的内容***********************
'
'            MyRange.Start = MyRange.End
'            MyRange.InsertAfter "跨  国  集  团" & Chr(13)
'            MyRange.Font.Name = "黑体"
'            MyRange.Font.Size = 14
'            MyRange.Font.Bold = True
'            MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
'        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'        MyRange.ParagraphFormat.LineSpacing = 26
'        MyRange.Start = MyRange.End
'
'
'
'    For i = 0 To intT - 1
'        If strClass(i) = "跨国集团" Then
'            MyRange.Start = MyRange.End
'            MyRange.InsertAfter "※"
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphLeft
'
'            MyRange.Start = MyRange.End
'            strXX = strContents(i)
'            MyRange.InsertAfter " " & Trim(strXX) & "              " & Trim(strSource(i)) & Chr(13)
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphJustify
       '建立悬挂缩进
'            MyRange.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.3)
'            MyRange.ParagraphFormat.LeftIndent = InchesToPoints(0.3)
'
'            MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'            MyRange.ParagraphFormat.LineSpacing = 26
'
'         End If
'    DoEvents
'    Next i
    
'***************************发展趋势的内容***********************
'
'            MyRange.Start = MyRange.End
'            MyRange.InsertAfter "发  展  趋  势" & Chr(13)
'            MyRange.Font.Name = "黑体"
'            MyRange.Font.Size = 14
'            MyRange.Font.Bold = True
'            MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
'        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'        MyRange.ParagraphFormat.LineSpacing = 26
'        MyRange.Start = MyRange.End
'
'
'    For i = 0 To intT - 1
'        If strClass(i) = "发展趋势" Then
'            MyRange.Start = MyRange.End
'            MyRange.InsertAfter "※"
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphLeft
'
'            MyRange.Start = MyRange.End
'            strXX = strContents(i)
'            MyRange.InsertAfter " " & Trim(strXX) & "              " & Trim(strSource(i)) & Chr(13)
'            MyRange.Font.Name = "楷体_GB2312"
'            MyRange.Font.Size = 14
'            MyRange.Paragraphs.Alignment = wdAlignParagraphJustify
       '建立悬挂缩进
'            MyRange.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.3)
'            MyRange.ParagraphFormat.LeftIndent = InchesToPoints(0.3)
'
'            MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
'            MyRange.ParagraphFormat.LineSpacing = 26
'
'         End If
'    DoEvents
'    Next i
'***********************综信采撷的内容***************************
   '加框的标头
    MyRange.InsertAfter Chr(13)
    
        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        MyRange.ParagraphFormat.LineSpacing = 26
        MyRange.Start = MyRange.End
    
    MyRange.InsertAfter "综信采撷"
    MyRange.Font.Name = "隶书"
    MyRange.Font.Size = 14
    MyRange.Font.Bold = True
    MyRange.Font.ColorIndex = wdBlue
    MyRange.Select
    MyRange.Borders.OutsideLineStyle = wdLineStyleDouble '###############
    MyRange.Borders.OutsideColorIndex = wdViolet
    MyRange.Borders.OutsideLineWidth = wdLineWidth050pt
    MyRange.Paragraphs.Alignment = wdAlignParagraphLeft

    MyRange.InsertAfter Chr(13)
    MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    MyRange.ParagraphFormat.LineSpacing = 26
 '内容
    
    For i = 0 To intT - 1
        If strClass(i) = "综信采撷" Then
            MyRange.Start = MyRange.End
            strBT = strTitles(i)
            MyRange.InsertAfter strBT & Chr(13)
            MyRange.Font.Name = "黑体"
            MyRange.Font.Size = 14
            MyRange.Font.Bold = True
            MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        MyRange.ParagraphFormat.LineSpacing = 26
            
            MyRange.Start = MyRange.End
            strXX = strContents(i)
            MyRange.InsertAfter "    " & strXX & "    " & Trim(strSource(i)) & Chr(13)
            MyRange.Font.Name = "仿宋_GB2312"
            MyRange.Font.Size = 14
            MyRange.Paragraphs.Alignment = wdAlignParagraphJustify
           
        End If
        MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        MyRange.ParagraphFormat.LineSpacing = 26
    DoEvents
    Next i
    MyRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    MyRange.ParagraphFormat.LineSpacing = 26




'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
    
'***********************报尾*****************8
    MyRange.Start = MyRange.End
    MyRange.InsertAfter Chr(13)
    For i = 1 To 28
        MyRange.InsertAfter "─"
    Next i
    MyRange.InsertAfter Chr(13)
    MyRange.InsertAfter "联系电话：[phone]  传真：[phone]" & Chr(13)
    MyRange.InsertAfter "E-mail: [e-mail]    信息联络部" & Chr(13)
    MyRange.Font.Name = "楷体_GB2312"
    MyRange.Font.Size = 14
    MyRange.Paragraphs.Alignment = wdAlignParagraphCenter
    MyRange.Font.Bold = True
    MyRange.Font.ColorIndex = wdBlue
    
    MyWord.Activate
    MyDocument.Select
    '页码
  '  With MyDocument.Sections(1).Footers(wdHeaderFooterEvenPages)
  
  '  End With
    
    '数字字体改为TIMES NEW ROMAN

'    SendKeys "%o", True
'    SendKeys "f", True
'    SendKeys "%f", True
'    SendKeys "times new roman", True
'    SendKeys "{ENTER}", True
'    SendKeys "{ENTER}", True
    
'    SendKeys "%i", True
'    SendKeys "u", True
'    SendKeys "%a{up}", True
'    SendKeys "{ENTER}", True
'    SendKeys "%s", True
''    SendKeys "%f", True
 '   SendKeys "%a", True
'    SendKeys "{up}", True
'    SendKeys "{ENTER}", True
'    SendKeys "{ENTER}", True
    
    
    
'    SendKeys "{ENTER}", True
    
'    MyRange.InsertAfter " "
    
    
    
    
    
'    MyDocument.Activate
'    MyWord.Visible = True
    
    Set MyRange = Nothing
    Set MyDocument = Nothing
    Set MyWord = Nothing
   
End Sub

Public Sub MoveDown(parNum As Integer)
Dim temp As String
    temp = strTitles(parNum + 1)
    strTitles(parNum + 1) = strTitles(parNum)
    strTitles(parNum) = temp
    
    temp = strSource(parNum + 1)
    strSource(parNum + 1) = strSource(parNum)
    strSource(parNum) = temp
    
    temp = strContents(parNum + 1)
    strContents(parNum + 1) = strContents(parNum)
    strContents(parNum) = temp
    
    temp = strClass(parNum + 1)
    strClass(parNum + 1) = strClass(parNum)
    strClass(parNum) = temp

End Sub

Public Sub MoveUp(parNum As Integer)
Dim temp As String
    temp = strTitles(parNum - 1)
    strTitles(parNum - 1) = strTitles(parNum)
    strTitles(parNum) = temp
    
    temp = strSource(parNum - 1)
    strSource(parNum - 1) = strSource(parNum)
    strSource(parNum) = temp
    
    temp = strContents(parNum - 1)
    strContents(parNum - 1) = strContents(parNum)
    strContents(parNum) = temp
    
    temp = strClass(parNum - 1)
    strClass(parNum - 1) = strClass(parNum)
    strClass(parNum) = temp

End Sub

Public Sub DelOne(parNum As Integer)
Dim i As Integer
    For i = parNum To intT - 2
        strTitles(i) = strTitles(i + 1)
        strSource(i) = strSource(i + 1)
        strContents(i) = strContents(i + 1)
        strClass(i) = strClass(i + 1)
    Next i
    intT = intT - 1
    intS = intT
    intC = intT
    intCl = intT
    

End Sub

Public Sub OutFile(filename As String)
Dim i As Integer
Dim fileNum As Integer
On Error GoTo ErrHandle
    
    fileNum = FreeFile
    Open filename For Output As #fileNum
        Write #fileNum, CStr(intT)
        For i = 0 To intT - 1
            Write #fileNum, Exchange(strTitles(i), Chr(34), "abcdefghijk")
            Write #fileNum, Exchange(strSource(i), Chr(34), "abcdefghijk")
            Write #fileNum, Exchange(strContents(i), Chr(34), "abcdefghijk")
            Write #fileNum, Exchange(strClass(i), Chr(34), "abcdefghijk")
        Next i
    Close #fileNum
    Exit Sub
ErrHandle:
    MsgBox "发生错误" & Chr(13) & Err.Description
End Sub

Public Sub InFile(filename As String)
Dim temp As String
Dim i As Integer
Dim StaPos
Dim fileNum As Integer
On Error GoTo ErrHandle
    fileNum = FreeFile
    Open filename For Input As #fileNum
        Input #fileNum, temp
        StaPos = intT
        intT = CInt(temp) + intT
        ReDim Preserve strTitles(intT)
        ReDim Preserve strSource(intT)
        ReDim Preserve strContents(intT)
        ReDim Preserve strClass(intT)
        
        For i = StaPos To intT - 1
            Input #fileNum, strTitles(i)
            Input #fileNum, strSource(i)
            Input #fileNum, strContents(i)
            Input #fileNum, strClass(i)
            strTitles(i) = Exchange(strTitles(i), "abcdefghijk", Chr(34))
            strSource(i) = Exchange(strSource(i), "abcdefghijk", Chr(34))
            strContents(i) = Exchange(strContents(i), "abcdefghijk", Chr(34))
            strClass(i) = Exchange(strClass(i), "abcdefghijk", Chr(34))
            Form1.lstTitles.AddItem strTitles(i) & "----" & strClass(i)
        Next i
    Close #fileNum
    intS = intT
    intC = intT
    intCl = intT
    
    Exit Sub
ErrHandle:
    MsgBox "发生错误" & Chr(13) & Err.Description
End Sub

Public Function Exchange(ByVal strSour As String, strOld As String, strNew) As String
Dim temp As String
Dim i As Integer
Dim n As Integer
n = 0
For i = 1 To Len(strSour)
        n = InStr(i, strSour, strOld)
        If n > 0 Then
            strSour = Mid(strSour, 1, n - 1) & strNew & Mid(strSour, n + Len(strOld), Len(strSour) - i)
        End If
Next i
        Exchange = strSour
    
        
End Function

Public Function CheckFile(filename As String)
Dim myfilesysobj As Object
Set myfilesysobj = CreateObject("Scripting.FileSystemObject")
        
        If myfilesysobj.fileexists(filename) Then
            If MsgBox("是否覆盖" & filename & "文件？", vbExclamation + vbYesNo, "保存") = vbYes Then
                CheckFile = True
            Else
                CheckFile = False
            End If
        Else
            CheckFile = True
            
        End If

End Function