form1.frm

IBM Lotus 123 操作程序例子

VERSION 5.00
Begin VB.Form form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command9 
      Caption         =   "WordPro代刚"
      Height          =   405
      Left            =   2760
      TabIndex        =   8
      Top             =   1140
      Width           =   1905
   End
   Begin VB.CommandButton Command8 
      Caption         =   "WordProヘ魁まノ"
      Height          =   435
      Left            =   2760
      TabIndex        =   7
      Top             =   420
      Width           =   1905
   End
   Begin VB.CommandButton Command7 
      Caption         =   "Word Pro 类结构"
      Height          =   465
      Left            =   0
      TabIndex        =   6
      Top             =   2280
      Width           =   2325
   End
   Begin VB.CommandButton Command6 
      Caption         =   "使用PDF段落"
      Height          =   405
      Left            =   0
      TabIndex        =   5
      Top             =   1860
      Width           =   2325
   End
   Begin VB.CommandButton Command5 
      Caption         =   "使用Word Pro段落"
      Height          =   405
      Left            =   0
      TabIndex        =   4
      Top             =   1440
      Width           =   2325
   End
   Begin VB.CommandButton Command4 
      Caption         =   "利用本地邮件系统发送邮件"
      Height          =   495
      Left            =   0
      TabIndex        =   3
      Top             =   930
      Width           =   2310
   End
   Begin VB.CommandButton Command3 
      Caption         =   "读入Lotus 1-2-3文件数据"
      Height          =   480
      Left            =   0
      TabIndex        =   2
      Top             =   450
      Width           =   2310
   End
   Begin VB.CommandButton Command2 
      Caption         =   "写数据到Lotus 1-2-3"
      Height          =   450
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   2310
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   390
      Left            =   2730
      TabIndex        =   0
      Top             =   15
      Width           =   1905
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' WIN 32 API function declarations
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

' Win32 Constant Declarations and other constants
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

' Win32 Type Declarations
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Private m_strError As String

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Function GetLastError() As String
   GetLastError = m_strError
   m_strError = ""
End Function

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Function ConvertFile(strSourceFileName As String, strDestinationFileName As String) As String
   On Error GoTo ErrorHandler
   
   Dim msExcel As Excel.Application
   Set msExcel = GetObject(Class:="Excel.Application")
   
   msExcel.Visible = True
   msExcel.Workbooks.Open strSourceFileName, UpdateLinks:=False ', ReadOnly:=True
   msExcel.ActiveWorkbook.PrintOut ActivePrinter:="Distiller Assistant v3.01"
   
   ' Wait for the file to be distilled
   While IsFileDistilledYet(msExcel.ActiveWorkbook.Name, strDestinationFileName) <> True
      Sleep 1000
   Wend
   
   msExcel.ActiveWorkbook.Close False
   
   ' Should check and quit excel when done
   Set msExcel = Nothing
   ConvertFile = True
   Exit Function
   
   '////////////////////////////////////////////////////
ErrorHandler:
   ' Create Excel for the first time if it is not active
   If Err.Number = 429 Then
      Set msExcel = CreateObject("Excel.Application")
      Err.Clear ' Clear Err object in case error occurred.
      Resume
   End If
   
   ' All other errors handled here
   If IsCriticalError Then
      ConvertFile = False
      Exit Function
   Else
      Resume
   End If
End Function

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Private Function IsCriticalError() As Boolean
   Dim strErrorMessage As String
   Select Case Err.Number ' Evaluate error number.
      Case Else
         strErrorMessage = "Please contact [e-mail] and inform them that" & Chr$(13) & _
            "the error message reported by the operating system was " & Chr$(13) & _
            Chr$(34) + Trim(Str(Err.Number)) & " " & Err.Description + Chr$(34)
         MsgBox strErrorMessage, , "Conversion error" + Str(Err.Number)
         IsCriticalError = True
         Exit Function
   End Select
   IsCriticalError = False
End Function

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Function IsFileDistilledYet(strFileName As String, strOrigFileName) As Boolean
   Dim FindData As WIN32_FIND_DATA
   Dim strOutputFileName As String
   Dim strDestFileName As String
   Dim strFindFileName As String
   Dim StrLen As Integer
   
   strOutputFileName = LCase("c:\" + Left(strFileName, Len(strFileName) - 3) + "pdf")
   
   ' Check to see that the file has been created
   FindFirstFile strOutputFileName, FindData
   StrLen = InStr(FindData.cFileName, Chr(0))
   strFindFileName = LCase("c:\" + Left(FindData.cFileName, StrLen - 1))
   
   If strOutputFileName = strFindFileName Then
      IsFileDistilledYet = True
      ' Build the destination filename from the orginal source document filename
      strDestFileName = Left(strOrigFileName, Len(strOrigFileName) - 3) + "pdf"
      ' Move the distilled file to it's original location
      MoveFile strFindFileName, strDestFileName ' SHOULD CHECK FOR ERRORS HERE
   Else
      IsFileDistilledYet = False
   End If
   
End Function

'///////////////////////////////////////////////////
'///////////////////////////////////////////////////

Private Sub Command1_Click()
   Dim strFileToConvert As String
   Dim strDestinationFile As String
   Dim strFolder As String
   
   ' Set the source folder
   strFolder = "c:\temp\"
   
   ' Grab the first file to convert
   strFileToConvert = Dir(strFolder + "*.xls")
   
   ' Loop through all excel files
   While strFileToConvert <> ""
      ' Create the destination filename
      strDestinationFile = Left(strFileToConvert, Len(strFileToConvert) - 4)
      strDestinationFile = strDestinationFile + ".pdf"
      
      ' Attempt to convert the file to PDF
      If (ConvertFile(strFolder + strFileToConvert, strFolder + strDestinationFile) = False) Then
         ' Hmmm, looks like something went wrong - let's prompt the user to see if they wish to quit
         If (MsgBox("There has been a problem converting the file " + strFileToConvert, vbYesNo) = vbYes) Then
            ' Finish up - let's get out of here
            Exit Sub
         End If
      End If
      
      ' Grab the next file
      strFileToConvert = Dir
   Wend
   
End Sub


Private Sub Command2_Click()
    Dim LotusApp As lotus123.Application
    Dim LotusDoc As lotus123.Document
    Dim LotusSheet As lotus123.Sheet
    Dim objX As lotus123.Range
    
    Set LotusDoc = CreateObject("Lotus123.Workbook")
    
    Set LotusApp = LotusDoc.Application
    Set LotusSheet = LotusDoc.CurrentSheet
    
    LotusDoc.Close
    
    Set LotusDoc = LotusApp.NewDocument("temp.123")
    
    Dim i As Integer
    Dim j As Integer
    
    For i = 1 To 10
        For j = 1 To 10
            LotusDoc.Ranges("A:" & NumToChr(i) & CStr(j)).Contents = NumToChr(i) & "," & CStr(j)
        Next
    Next
    
    LotusDoc.Ranges("A:B3").Contents = "B3"
'    Set LotusDoc.Ranges("A:B3").Font.FontColor = LotusApp.Colors("Red")
    
    Set objX = LotusDoc.Ranges("A:A1")
    objX.Contents = "A"
    
    LotusApp.Visible = True
    LotusDoc.Activate
    
'    LotusDoc.SaveAs FileName:="c:\temp\Test.123"
'    LotusDoc.Close
'    LotusApp.Quit
'    Set LotusApp = Nothing
'
'    Shell ("e:\lotus\123\123w.exe c:\temp\test.123")
    
    
'    ' Example: BackColor, Background, Bold, Colors, Contents, Font, Fontcolor,
'' and Pattern properties
'' Declare the variables.
'    Dim testapp As lotus123.Application
'    Dim testfont As Font
'    Dim y As Color
'    Dim z As Color
'    Dim range1 As lotus123.Ranges
'    Set testapp = LotusDoc.Application
'' Declare and name a range.
'    Set range1 = [A:A2..A:A10]
'' Set the variable testfont as the font for the A1 cell and make
'' the font bold. Set the variables y and z to the colors red and white.
'    Set testfont = [A1].Font
'
'testfont.Bold = True
'    Set y = testapp.Colors("White")
'    Set z = testapp.Colors("Red")
'' Set the colors for the first column and the background pattern for
'' the named range. Set the contents of cell A1 to read "label here".
'    Set testfont.FontColor = y
'    Set range1.Background.BackColor = z
'    range1.Background.Pattern = 125
'    [A1].Contents = "label here"
End Sub

Function NumToChr(ByVal intASCCode As Integer) As String
' Purpose : 将数字转换成大写字母 1 to A,26 to Z,27 to AA
' 只能处理两位字符，即1 to 26^2
' 作者：丁振华 2002-04-16


    Dim intFirst As Integer
    Dim intLast As Integer
    
    If intASCCode > 26 Then
        intFirst = (intASCCode - 1) \ 26       ' ??俱
        intLast = (intASCCode - 1) Mod 26    ' 取余
        NumToChr = Chr(intFirst + 65 - 1) & Chr(intLast + 65)
    Else
        NumToChr = Chr(intASCCode + 65 - 1)
    End If
    
End Function

Private Sub Command3_Click()
    Dim LotusApp As lotus123.Application
    Dim LotusDoc As lotus123.Document
    
    Set LotusDoc = CreateObject("Lotus123.Workbook")
    Set LotusApp = LotusDoc.Application
    
'    LotusDoc.Close False
    
    Set LotusDoc = LotusApp.OpenDocument(FileName:="test.123", Location:="C:\Temp")
    
    LotusApp.Visible = True
    LotusDoc.Activate
        
    MsgBox LotusDoc.Ranges("A:A10").Contents
    

    
End Sub

Private Sub Command4_Click()
    Dim LotusApp As lotus123.Application
    Dim LotusDoc As lotus123.Document

    Set LotusDoc = CreateObject("Lotus123.Workbook")
    Set LotusApp = LotusDoc.Application

'    LotusDoc.Close False

'    Set LotusDoc = LotusApp.OpenDocument(FileName:="test.123", Location:="C:\Temp")

    LotusApp.UserLogin "王家波", "123"

    LotusApp.SendMail tolist:="丁振?/HOPE.COM", IndivMessages:="Test", Subject:="Subject", Body:="Body Text"
    
End Sub

Private Sub Command5_Click()
    
'    Dim MyWord As Object
'    Dim NewDoc As Object
    Dim Myword As Wordpro.Application
    Dim NewDoc As Wordpro.Document
    Dim NewDocC As TextDocument
    Dim WPWordApp As Wordpro.WPApplication
    Dim NewObj As Worksheet
    Dim astr As String
    
    On Error Resume Next
    
    Set Myword = GetObject(, "WordPro.Application")
    
    If Err.Number <> 0 Then
        Err.Clear
        Set Myword = CreateObject("WordPro.Application")
    End If
    
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbInformation
        Exit Sub
    End If
    
    On Error GoTo ErrHandle
    On Error GoTo 0
    
    '打开原有的文件
    Call Myword.OpenDocument(DocName:="TESTORDER.lwp", Location:="C:\Temp")
    
    Set WPWordApp = Myword.Application
    Set NewDocC = Myword.ActiveDocument
    WPWordApp.Visible = True
    NewDocC.Activate
        
    Dim strTemp As String
    
    Call WPWordApp.GoToBookmark("TEST001")
    
    WPWordApp.SelectParagraph
    WPWordApp.CopySelection
    strTemp = Clipboard.GetText
    MsgBox strTemp
    
'    往文件中添加新内容
'    WPWordApp.BeginChange
'    WPWordApp.Type ("Some sample [TAB] text.")
'    WPWordApp.Type ("[Enter]")
'    WPWordApp.Type ("[TAB]")
'    WPWordApp.Type ("More sample [TAB] text.")
'    WPWordApp.Type ("[Enter]")
'    WPWordApp.Type ("[TAB]")
'    WPWordApp.EndChange
    'NewDocC.EndChange
    'NewDoc.EndChange
'    WPWordApp.CopySelection
'    Set NewDoc = MyWord.ActiveDocument
'    NewDoc.Paragraphs(1).Range.Text = "Ok,This is my first samples"
'    NewDoc.Description = "fasfjadkljfkl;jfaklasjasfjfjalajafjafjljfajfweoijweiofjwlchciane"
'
'    '给新建文件命名
'    NewDoc.FullName = "TestOrder.lwp"

ErrHandle:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbInformation
    End If
End Sub

Private Sub Command6_Click()
    Dim MyPDF As Object
    Dim MyPDFFile As Object
    Set MyPDF = CreateObject("PDF.Application")
    Set MyPDFFile = MyPDF.ActiveDocument
    Call MyPDF.OpenDocument(FileName:="Readme.pdf", Location:="C:\Temp")
    Call MyPDF.GoToBookmark("Other Help Resources")
    
    MyPDF.Visible = True
    
    
End Sub

Private Sub Command7_Click()