frmacctoword.frm

主要是利用VB来实现word的排版预览功能

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   6120
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   6120
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton CmdDlg 
      Caption         =   "..."
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   5280
      TabIndex        =   9
      Top             =   2040
      Width           =   495
   End
   Begin VB.TextBox Text4 
      Height          =   375
      Left            =   360
      TabIndex        =   8
      Text            =   "Text4"
      Top             =   2040
      Width           =   4815
   End
   Begin VB.CommandButton Command2 
      Caption         =   "添加"
      Height          =   495
      Left            =   360
      TabIndex        =   4
      Top             =   2520
      Width           =   1455
   End
   Begin VB.TextBox Text3 
      Height          =   375
      Left            =   1320
      TabIndex        =   3
      Text            =   "Text3"
      Top             =   1440
      Width           =   2655
   End
   Begin VB.TextBox Text2 
      Height          =   375
      Left            =   1320
      TabIndex        =   2
      Text            =   "Text2"
      Top             =   840
      Width           =   1575
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   1320
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   240
      Width           =   1575
   End
   Begin VB.CommandButton cmdToWord 
      Caption         =   "导入Word"
      Height          =   495
      Left            =   4200
      TabIndex        =   0
      Top             =   2520
      Width           =   1575
   End
   Begin VB.Label Label3 
      Caption         =   "家庭住址"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   240
      TabIndex        =   7
      Top             =   1560
      Width           =   975
   End
   Begin VB.Label Label2 
      Caption         =   "性别"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   720
      TabIndex        =   6
      Top             =   960
      Width           =   495
   End
   Begin VB.Label Label1 
      Caption         =   "姓名"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   720
      TabIndex        =   5
      Top             =   360
      Width           =   615
   End
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   1695
      Left            =   4320
      Top             =   120
      Width           =   1455
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Cn As New ADODB.Connection
Dim Rec As New ADODB.Recordset
Dim objWord As Object

Private Sub cmdToWord_Click()
Dim connstr As String
Dim FileDB As String
Dim temp As String
temp = App.Path + "\photo"
FileDB = App.Path + "\dbpic.mdb"

connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileDB & ";Persist Security Info=False"
Cn.Open connstr
Rec.Open "pic", Cn, adOpenDynamic, adLockOptimistic

Stream2File temp, Rec.Fields("照片")
Image1.Picture = LoadPicture(temp)     '把照片显示在控件上

'创建objWord对象
Set objWord = CreateObject("Word.Application")
objWord.Visible = True '让WORD 可见
'新建一个Word文档
objWord.Documents.Add Template:=App.Path & "\word.dot"
'调用宏
addrBook
Kill temp     '删除临时文件，防止二次使用出错
Rec.Close
Cn.Close
Set objWord = Nothing
End Sub
'功能:把文件输入到流中，本题中不使用
Public Sub File2Stream(strFile As String, ByRef adofld As ADODB.Field)
Dim strContent As New ADODB.Stream
With strContent
     .Mode = adModeReadWrite    '可读写模式
     .Type = adTypeBinary       '二进制格式
     .Open
     .LoadFromFile strFile    '把文件导入流
End With
adofld.Value = strContent.Read()
strContent.Close
End Sub
'功能:把流中数据输入到文件
Public Sub Stream2File(strFile As String, ByRef adofld As ADODB.Field)
Dim strContent As New ADODB.Stream
With strContent
     .Mode = adModeReadWrite    '可读写模式
     .Type = adTypeBinary       '二进制格式
     .Open
End With
strContent.Write (adofld.Value)
strContent.SaveToFile strFile
strContent.Close
End Sub
'由宏编写，可根据题目自行更改
Sub addrBook()
With objWord
    .Selection.MoveDown Unit:=wdLine, Count:=1
    .Selection.MoveRight Unit:=wdCharacter, Count:=5
    If Not IsNull(Rec.Fields("姓名").Value) Then
       .Selection.TypeText Text:=Rec.Fields("姓名").Value
    End If
    .Selection.MoveRight Unit:=wdCharacter, Count:=6
    If Not IsNull(Rec.Fields("性别").Value) Then
       .Selection.TypeText Text:=Rec.Fields("性别").Value
    End If
    .Selection.MoveRight Unit:=wdCharacter, Count:=1
    If Not IsNull(Rec.Fields("照片").Value) Then
      Dim stmPhoto As New ADODB.Stream
      stmPhoto.Open
      stmPhoto.Type = adTypeBinary
      stmPhoto.Write Rec.Fields("照片").Value
      stmPhoto.SaveToFile App.Path & "\photo", adSaveCreateOverWrite
      .Selection.InlineShapes.AddPicture FileName:=App.Path & "\photo", LinkToFile:=False, _
        SaveWithDocument:=True
    End If
     .Selection.MoveRight Unit:=wdCharacter, Count:=7
    If Not IsNull(Rec.Fields("家庭住址").Value) Then
       .Selection.TypeText Text:=Rec.Fields("家庭住址").Value
    End If
End With
End Sub