form1.frm

来自「Word2003 Demo including setting font, in」· FRM 代码 · 共 238 行

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Word API Demo"
   ClientHeight    =   4350
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7575
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4350
   ScaleWidth      =   7575
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   2280
      Top             =   3360
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.ComboBox Combo2 
      Height          =   315
      Left            =   6120
      TabIndex        =   12
      Top             =   1200
      Width           =   1095
   End
   Begin VB.ComboBox Combo1 
      Height          =   315
      Left            =   2760
      TabIndex        =   10
      Top             =   1200
      Width           =   1695
   End
   Begin VB.CommandButton Command3 
      Caption         =   "Save"
      Height          =   255
      Left            =   6600
      TabIndex        =   8
      Top             =   2640
      Width           =   615
   End
   Begin VB.TextBox Text3 
      Height          =   285
      Left            =   1560
      TabIndex        =   7
      Top             =   2640
      Width           =   4935
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Open"
      Height          =   255
      Left            =   6600
      TabIndex        =   4
      Top             =   1920
      Width           =   615
   End
   Begin VB.TextBox Text2 
      Height          =   285
      Left            =   1560
      TabIndex        =   3
      Top             =   1920
      Width           =   4935
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   1560
      TabIndex        =   1
      Top             =   480
      Width           =   5655
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Create && Print"
      Height          =   495
      Left            =   2880
      TabIndex        =   0
      Top             =   3360
      Width           =   1695
   End
   Begin VB.Label Label5 
      Caption         =   "Font Size"
      Height          =   255
      Left            =   5040
      TabIndex        =   11
      Top             =   1200
      Width           =   855
   End
   Begin VB.Label Label4 
      Caption         =   "Font Name"
      Height          =   255
      Left            =   1560
      TabIndex        =   9
      Top             =   1200
      Width           =   975
   End
   Begin VB.Label Label3 
      Caption         =   "Output"
      Height          =   255
      Left            =   360
      TabIndex        =   6
      Top             =   2640
      Width           =   615
   End
   Begin VB.Label Label2 
      Caption         =   "Image"
      Height          =   255
      Left            =   360
      TabIndex        =   5
      Top             =   1920
      Width           =   735
   End
   Begin VB.Label Label1 
      Caption         =   "Text"
      Height          =   255
      Left            =   360
      TabIndex        =   2
      Top             =   480
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Author- Gang Gang Huang

Private Const STR_INSERTTEXT = "@<Gang Gang Huang>@"
Private Const STR_MSG = "Word API Demo"
Private STR_INSERTIMAGE As String
Private STR_OUTPUTDOC As String

Private Sub Command1_Click()
    On Error GoTo errhadle
    Dim AppWord As Object
    Dim wordDoc As Object
    Me.Command1.Enabled = False
    If Check Then
        Set AppWord = CreateObject("Word.Application")
        AppWord.Visible = False
        Set wordDoc = AppWord.Documents.Add
        Call wordDoc.Range(0, 0).Select
        'Set font name & size
        AppWord.selection.Font.Name = CStr(Me.Combo1)
        AppWord.selection.Font.Size = CInt(Me.Combo2)
        'Insert text
        Call AppWord.selection.TypeText(CStr(Me.Text1))
        Call AppWord.selection.TypeParagraph
        'Insert picture
        Call AppWord.selection.InlineShapes.AddPicture(CStr(Me.Text2), False, True)
        wordDoc.SaveAs CStr(Me.Text3), True
        'Print document
        wordDoc.printout (False)
        wordDoc.Close
        AppWord.Quit
        Set AppWord = Nothing
    End If
exitpoint:
    Me.Command1.Enabled = True
    Exit Sub
errhadle:
    MsgBox Err.Description, vbExclamation + vbOKOnly, STR_MSG
    Resume exitpoint
End Sub

Private Sub Command2_Click()
    Me.CommonDialog1.Filter = "TIFF File|*.tif"
    Me.CommonDialog1.ShowOpen
    If Trim(Me.CommonDialog1.FileName) <> "" Then
        Me.Text2 = Me.CommonDialog1.FileName
    End If
End Sub

Private Sub Command3_Click()
    Me.CommonDialog1.Filter = "MS Wrod|*.doc"
    Me.CommonDialog1.ShowSave
    If Trim(Me.CommonDialog1.FileName) <> "" Then
        Me.Text3 = Me.CommonDialog1.FileName
    End If
End Sub

Private Sub Form_Load()
    Me.Text1 = STR_INSERTTEXT
    STR_INSERTIMAGE = App.Path & "\" & "Sample.tif"
    STR_OUTPUTDOC = App.Path & "\" & "Output.doc"
    Me.Text2 = STR_INSERTIMAGE
    Me.Text3 = STR_OUTPUTDOC
    
    Me.Combo1.AddItem "Arial"
    Me.Combo1.AddItem "Book Antiqua"
    Me.Combo1.AddItem "Courier New"
    Me.Combo1.AddItem "Microsoft Sans Serif"
    Me.Combo1.AddItem "Times New Roman"
    Me.Combo1.AddItem "Verdana"
    
    Me.Combo2.AddItem "8"
    Me.Combo2.AddItem "9"
    Me.Combo2.AddItem "10"
    Me.Combo2.AddItem "12"
    Me.Combo2.AddItem "14"
    Me.Combo2.AddItem "16"
    
    Me.Combo1.ListIndex = 0
    Me.Combo2.ListIndex = 2
    
    Call Me.Move((Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2)
End Sub

Private Function Check() As Boolean
    Check = False
    Dim l_objFso As Object
    If Trim(Me.Text1) = "" Then
        MsgBox "Insert text can't be empty", vbOKOnly, STR_MSG
        Exit Function
    End If
    If Trim(Me.Text2) = "" Then
        MsgBox "Insert image file path can't be empty", vbOKOnly, STR_MSG
        Exit Function
    End If
    Set l_objFso = CreateObject("Scripting.FileSystemObject")
    If Not l_objFso.FileExists(Me.Text2) Then
        MsgBox "Insert image file does't exist", vbOKOnly, STR_MSG
        Exit Function
    End If
        If Trim(Me.Text3) = "" Then
        MsgBox "Output file name can't be empty", vbOKOnly, STR_MSG
        Exit Function
    End If
    If l_objFso.FileExists(Me.Text3) Then
        MsgBox "Output file exist already", vbOKOnly, STR_MSG
        Exit Function
    End If
    Check = True
    Set l_objFso = Nothing
End Function