?
Solved

URGENT:  MSWord - Opening a Template File and then saving it as a predefined filename

Posted on 2006-05-22
24
Medium Priority
?
454 Views
Last Modified: 2008-01-09
Hi all

I use the following functions .... which are part of a class - to manipulate some word documents
'******************************************************************************************
'*** This function opens a word template document ... it is usually opened as Document1 Document2 and so on ....
'*** wrdDoc is defined as Private wrdDoc as Word.Document
'*** wrdApp is defined as Private wrdApp as Word.Application
Public Function OpenNewDoc(Optional Docname As String, Optional ro As Boolean = False, Optional atrfl As Boolean = False, Optional bVisible As Boolean = True)
    Dim iTries As Integer
    iTries = 0
10:
    On Error GoTo Error_Handler:
    Set wrdDoc = New Word.Document
    Set wrdDoc = wrdApp.Documents.Add(Docname, Visible:=True)
    wrdApp.Visible = bVisible
Exit_Handler:
  Exit Function
Error_Handler:
    Call ClsErrorHandler("OpenNewDoc")
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Function

'** End First Function

Now after I have opened the new document - I use a function to replace predefined text in the document ... then I use the following function to save the document, by a newly created filename.


Public Function SaveDocAsAndClose(FileNum As Long, Author As String, Optional AutoPath As String, _
                                  Optional strFileName As String = "", Optional bPrint As Boolean = False, _
                                  Optional bClose As Boolean = False) As String
    Dim iTries As Integer
    Dim strDocName$
    Dim strfile$
   
    iTries = 0
10:
   On Error GoTo Error_Handler:
 
    ' now lets work out a file name
    'start with the filenumber and then then username and then the dattime group
   
       strfile = CStr(FileNum) & "_" & Author & "_" & Format$(Now, "_yyyymmdd_hhnnss")
       ' ok now do we have a specific path ?
       If AutoPath = "" Then
           'save to my documents dir
           AutoPath = GetMyDocsFolder
       End If
       'see if there is a backslash on the end
       If mID(AutoPath, Len(AutoPath), 1) <> "\" Then
           ' add a backslash
           AutoPath = AutoPath & "\"
       End If
       
       strfile = AutoPath & strfile
       
       ' Save the document, close it
       strDocName = strfile & ".doc"
   
    If wrdDoc Is Nothing Then
     MsgBox "No document"
     Exit Function
    End If
   
    wrdDoc.SaveAs strDocName, AddToRecentFiles:=False
   
   
    If bPrint Then
     ' make sure we update our fields
         wrdApp.Options.UpdateFieldsAtPrint = True
        ' ******************************************************
        ' *** NEED TO CATCH THE PRINTER ERROR IF ONE IS THROWN
         On Error GoTo Error_Handler:
         wrdDoc.PrintOut Background:=True
         wrdDoc.Save
         wrdDoc.Saved = True
    End If
   
    If bClose Then
         wrdDoc.Saved = True
         wrdDoc.Close
    End If
    RaiseEvent DocumentSaved(strDocName)
    SaveDocAsAndClose = strDocName
       
Exit_Handler:

  Exit Function
   
Error_Handler:
    m_ProcedureName = "SaveDocAsAndClose"
   
    Select Case Err.Number
      Case 5142
       ' current printer unavailable
       MsgBox Err.Number & " " & Err.description
       
    End Select
   
    Call ClsErrorHandler("SaveDocAsAndClose")
   
'    If iTries < 3 Then
'        iTries = iTries + 1
'        Call MakeValidObject
'        GoTo 10:
'    Else
        Resume Exit_Handler
'    End If
End Function

On EVERY OCCASSION if I run the functions in the VB IDE, they work without fail, no errors are thrown and the document is saved perfectly. HOWEVER outside the IDE (ie the compiled exe), wrdDoc is ALWAYS nothing - thus no document to save.

Does anyone have any ideas on why ?

Does anyone have any ideas on how to resolve the problem ?


MTIA

Darrin
0
Comment
Question by:dwe0608
  • 11
  • 9
21 Comments
 
LVL 44

Expert Comment

by:bruintje
ID: 16732593
Hello dwe0608,

without seeing where wrdApp is created i can only mention that you create 2 instance of wrdDoc

not sure how word is going to handle this but i thinkyou would be better off with deleting this line
Set wrdDoc = New Word.Document

and only using
Set wrdDoc = wrdApp.Documents.Add(Docname, Visible:=True)

with the change you set wrdApp to visible is the opened template derived document visible there or not?

hope this helps a bit
bruintje
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16733153
What happens in your clsErrorHandler procedure? Is it being called?
Do you know if the document is successfully created and disappears at some point?

I suggest that you use logging to pin the problem down.
App.LogEventdoesn't work in the IDE, so you could use a sub like this

Sub WriteLog(strText As String, strLogFile As String)
    Dim f As Integer
    Dim strTextLine As String
   
    strTextLine = Time & " " & strText
'name the file for the day
    strLogFile = App.Path & "\" & Format$(Now, "yy") & Right$("00" & Format$(Now, "y"), 3) & ".log"

    f = FreeFile
    Open strLogFile For Append As f
        Print #f, strTextLine
    Close f
End Sub
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16733379
HEY GUYS


bruintje  - I threw that extra initialisation part in because I thought the variable might not have been initialising properly - and to tell the truth - it makes no difference that is noteable ...

GrahamSkan, First - as I said, maybe not clearly enough, no - as I said no error is thrown ... nothing is logged in my error file ...

My error log is as follows:

Public Sub ClsErrorHandler(m_ProcedureName As String, Optional strCustomError As String = "", Optional bShowMsgBox As Boolean = False, Optional bIsFatal As Boolean = False)
    'Generic Error handling routine

Dim handleErr As String
Dim textfile As String

    'Raise the event according the procedure passed. Will write all errors
     'to an error log. Errors on the form will only be visible if
     'the event is active and a debug.print statement or message box
     'is inserted
   
    'Log the errors to an error log
    textfile = App.Path & "\ErrogLog.txt"
    handleErr = "Error: " & Err.Number & " " & Err.description & " " & Err.Source & " Custom: " & strCustomError

    Open textfile For Append As #1 'write error to textfile
        Write #1, Now; handleErr; m_ProcedureName
    Close #1
   
   
    If bShowMsgBox Then
        Dim iResult As VbMsgBoxResult
        Dim msgboxQ$
        Dim msgboxI As VbMsgBoxStyle
       
        If bIsFatal Then
            msgboxQ = handleErr & vbCrLf & vbCrLf & vbCrLf & "Continue ?"
            msgboxI = vbYesNo + vbCritical
        Else
            msgboxQ = handleErr & vbCrLf & vbCrLf & vbCrLf & "The program will now end."
            msgboxI = vbCritical
        End If
       
        iResult = MsgBoxEx(msgboxQ, msgboxI)
        If iResult = vbNo Then
            MsgBox "Program will now end.", vbOKOnly
            Unload MDIForm1
        Else
            MsgBox iResult
        End If
       
     End If
   
    Err.Clear

End Sub


To assist you with helping me, the following is the class code:

'****************************************************************************
' Start ClsWord

Option Explicit


Private m_ProcedureName As String 'Name of current procedure: for error handling

Private m_Strsubject As String 'Subject of E-mail message
Private m_StrTo As String 'Recipient address
Private m_StrToAdd As String 'Text to add to Word doc
Private m_VarMsgBody As Variant 'Body of e-mail message

Private WithEvents wrdApp As Word.Application 'MS Word object
Private wrdDoc As Word.Document 'MS Word Document
Private wrdSelection As Word.Selection 'MS Word Selection
Private strDocName As String 'MS Word document name


'Raised if merge document saved successfully
Public Event DocumentSaved(sFileName As String)
'Raised if merge document saved Unsuccessfully
Public Event DocumentNotSaved(ErrNum As Integer, msgWhy As String)
'Raised if document was e-mailed successfully
Public Event MessageSent(strTo As String, strSubject As String, strMsg As String, strAttachment As String, msgID As String)
'Raised if document was e-mailed Unsuccessfully
Public Event MessageNotSent(ErrNum As Integer, msgWhy As String)



Private Sub MakeValidObject()
 '   Set wrdApp = New Word.Application
    On Error Resume Next
    Set wrdApp = GetObject(, "Word.Application")
       
    ' if error then Word wasn't open
    If Err.Number <> 0 Then
        ' open Word
        Set wrdApp = CreateObject("Word.Application")
    End If
    Err.Clear
   
   
    On Error GoTo 0    'Set to false if you don't want to see the word doc
    wrdApp.Visible = False


End Sub

Private Sub Class_Initialize()
 Call MakeValidObject
End Sub


Private Sub wrdApp_Quit()
   'Respond to the Quit event of Word
   'MsgBoxEx "Word Quit!", vbOKOnly
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Sub

Private Sub Class_Terminate()

On Error Resume Next

    wrdApp.NormalTemplate.Saved = True
   
    wrdApp.Quit
   
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing

End Sub

Public Function Wrd_Terminate()


    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing

End Function
Public Function Show(Optional bVal As Boolean = True, Optional bActivate As Boolean = True)
 wrdApp.Visible = bVal
 If bActivate Then wrdApp.Activate
 
End Function
Public Function OpenNewDoc(Optional docname As String, Optional ro As Boolean = False, Optional atrfl As Boolean = False, Optional bVisible As Boolean = True)
 
    Dim iTries As Integer
    iTries = 0
10:
    On Error GoTo Error_Handler::
'    If Len(docname) > 0 Then
'        Set wrdDoc = wrdApp.Documents.Open(docname, ReadOnly:=ro, addtorecentfiles:=atrfl)
'    Else
        Set wrdDoc = wrdApp.Documents.Add(docname, Visible:=True)
       
        'wrdDoc.Select
        'Set wrdSelection = wrdApp.Selection
'    End If

 wrdApp.Visible = bVisible

Exit_Handler:

  Exit Function
   
Error_Handler:
    Call ClsErrorHandler("OpenNewDoc")
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
   
End Function


Public Sub printDoc()
    'print out the word doc
    wrdDoc.PrintOut
   
End Sub
Public Sub SendDoc(ByVal strTo As String, ByVal strSubject As String, _
    varMsgBody As Variant, Optional strDocName As String = "")
    Dim objOutLook As Outlook.Application
    Dim ObjMailItem As Outlook.MailItem

    Dim iTries As Integer
    iTries = 0
10:
 '   On Error GoTo Error_Handler::
 
   
    'Mail the word document to recipient specified

    Set objOutLook = GetObject(, "Outlook.Application")
       
    ' if error then Word wasn't open
    If Err.Number <> 0 Then
        ' open Word
        Set objOutLook = CreateObject("Outlook.Application")
    End If
    Err.Clear

On Error GoTo Exit_Handler:
       
    m_Strsubject = strSubject
    m_StrTo = strTo
    m_VarMsgBody = varMsgBody

    'Check to see if the e-mail address is correct by checking the format
    If checkEmailAddress = False Then
     m_ProcedureName = "SendDoc"
     Call ClsErrorHandler
     Exit Sub
    End If
   
        'Set objOutLook = New Outlook.Application
        Set ObjMailItem = objOutLook.CreateItem(olMailItem)
       
    'create e-mail and insert attachment
        With ObjMailItem
            .Recipients.Add m_StrTo
            .Subject = m_Strsubject
            .Body = m_VarMsgBody & vbCrLf & vbCrLf
            .Attachments.Add strDocName
        End With
       
        ObjMailItem.Send
       
        RaiseEvent MessageSent(m_StrTo, m_Strsubject, CStr(m_VarMsgBody), strDocName, 0)
       
Exit_Handler:

  Exit Sub
   
Error_Handler:

    Call ClsErrorHandler("SendDoc")
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Sub
Public Function SaveDocAsAndClose(FileNum As Long, Author As String, Optional autoPath As String, Optional strFileName As String = "", Optional bPrint As Boolean = False, Optional bClose As Boolean = False) As String
    Dim iTries As Integer
    iTries = 0
10:
'    On Error GoTo Error_Handler::
 
    ' now lets work out a file name
    'start with the filenumber and then then username and then the dattime group
   
       Dim strfile$
       strfile = CStr(FileNum) & "_" & Author & "_" & Format$(Now, "_yyyymmdd_hhnnss")
       ' ok now do we have a specific path ?
       If autoPath = "" Then
           'save to my documents dir
           autoPath = GetMyDocsFolder
       End If
    '   If Not DriveExist(autoPath) Then GoTo Err_Handler
        'see if there is a backslash on the end
        If mID(autoPath, Len(autoPath), 1) <> "\" Then
           ' add a backslash
           autoPath = autoPath & "\"
        End If
       
        strfile = autoPath & strfile
       
       ' Save the document, close it
       strDocName = strfile & ".doc"
    '***********************************************************************************
    ' NO ERROR THROWN IN THE IDE
    ' NUT AS A COMPILED EX - THROWN AN ERR THAT THE VARIABLE WAS NOT INITITIALSED
    '***********************************************************************************
    wrdDoc.SaveAs strDocName, AddToRecentFiles:=False
   
    If bPrint Then
     ' make sure we update our fields
     wrdApp.Options.UpdateFieldsAtPrint = True

     wrdDoc.PrintOut Background:=True
     wrdDoc.Save
     wrdDoc.Saved = True
     
     
'     wrdDoc.Close

    End If
   
    If bClose Then
         wrdDoc.Saved = True
         wrdDoc.Close
    End If
    RaiseEvent DocumentSaved(strDocName)
    SaveDocAsAndClose = strDocName
       
Exit_Handler:

  Exit Function
   
Error_Handler:
    m_ProcedureName = "SaveDocAsAndClose"
    Call ClsErrorHandler
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Function
Public Function closeDoc(strFileName As String, Optional autosave As Boolean = False)
    Dim iTries As Integer
    iTries = 0
10:
    On Error GoTo Error_Handler::
 
'        wrdDoc.Close SaveChanges:=autosave


Exit_Handler:

  Exit Function
   
Error_Handler:
    m_ProcedureName = "closeDoc"
    Call ClsErrorHandler
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Function

Public Sub DeleteDoc(PathAndDocName As String)
   
   

   'Delete a file
   If FileExist(PathAndDocName) Then
'    Kill PathAndDocName
   End If
       
End Sub
Public Sub InsertCurrentDate()
    'Inserts the current date with the deafult font

    wrdSelection.InsertDateTime _
    DateTimeFormat:="dddd, MMMM dd, yyyy", InsertAsField:=False
   
End Sub



Private Function checkEmailAddress() As Boolean
On Error Resume Next
     Dim i%
    'parses e-mail address to see if is correct
    i = InStr(m_StrTo, "@")
    checkEmailAddress = (InStr(i + 1, m_StrTo, ".") > 0)
   
End Function

Private Function FileExist(FileName As String) As Boolean
On Error Resume Next

    FileExist = (Dir$(UCase((FileName))) <> "")

End Function

Private Function DriveExist(Path As String) As Boolean
On Error Resume Next

    DriveExist = (Dir(UCase((Path))) <> "")

End Function
' Convert a Word-compatible format to an other format.
' Parameters:
'  - sFileName is the file to convert
'  - wdFormat is the destination file's format
'  - sNewFileName is the destination file. If not specified the the routine
' will use the sFileName's path & name
'
' NOTE: requires the Microsoft Word type library
'
' Example: convert from DOC to HTML
'   ConvertWordDocument("C:\Documents\MyWordFile.doc", wdFormatHTML)

Function ConvertWordDocument(ByVal sFileName As String, _
    Optional ByVal wdFormat As WdSaveFormat = wdFormatText, _
    Optional ByVal sNewFileName As String) As Boolean
   
    Dim iPointer As MousePointerConstants
    Dim sExtension As String
'    Dim wrdApp As New Word.Application

    On Error GoTo ERR_HANDLER:
    iPointer = Screen.MousePointer

    ' open the file
    wrdApp.Documents.Open sFileName, False, False, False, , , , , , _
        wdOpenFormatAuto

    ' the destination filename if sFileName is sNewFileName is missing
    If Len(sNewFileName) = 0 Then
        sNewFileName = sFileName
        ' remove the actual extension ad add the one specified by sExtension
        If InStr(sNewFileName, ".") > 0 Then sNewFileName = Left$(sNewFileName, _
            InStr(sNewFileName, ".") - 1)
        ' set the extension for the selected destination format
        sExtension = Switch(wdFormat = wdFormatDocument, ".doc", _
                            wdFormat = wdFormatDOSText, ".txt", _
                            wdFormat = wdFormatDOSTextLineBreaks, ".txt", _
                            wdFormat = wdFormatRTF, ".rtf", _
                            wdFormat = wdFormatTemplate, ".dot", _
                            wdFormat = wdFormatTextLineBreaks, ".txt", _
                            wdFormat = wdFormatUnicodeText, ".txt")
       
        ' add the extension to the file name
        sFileName = sFileName & sExtension
    End If

    ' save the file
    wrdApp.ActiveDocument.SaveAs sNewFileName, wdFormat, , , False

    ConvertWordDocument = True

Exit_Err_Handler:
   Exit Function
   
ERR_HANDLER:
    m_ProcedureName = "ConvertWordDocument"
    Resume Exit_Err_Handler
End Function









Public Function ReplaceField(strField As String, strReplacementText As String, Optional GoToHome As Boolean = False) As Boolean
  On Error GoTo ErrorOcurred
 
  strReplacementText = RepText$(strReplacementText, vbCrLf, chr(13))
 
  With wrdApp.Selection.Find
    .Text = "[" & Trim(strField) & "]"
    .Replacement.Text = Trim(strReplacementText)
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
  ReplaceField = True
  GoTo Success
ErrorOcurred:
  ReplaceField = False
Success:
  '
End Function



If yu have  plsy - and its pretty obvious - you can see what I am talking about .

HOPEFULLY


MTIA

Darrom
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16733556
You don't have to confine logging to Error handling.

You can add trace information, for example, at the top and bottom of each procedure

Sub MyProc(Parameter1, Parameter2)
Dim a '...
WriteLog "Entering Procedure: MyProc" & ",  Parameter1: " & Parameter1 & ",  Parameter2: " & Parameter2 & ", wdrDoc? " & IIf(wrdDoc Is Nothing, "Missing", wrdDoc.Name)
'...
WriteLog "Exiting Procedure: MyProc" wdrDoc? " & IIf(wrdDoc Is Nothing, "Missing", wrdDoc.Name)
End Sub
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16773979
GrahamSkan - MT - The param logging has been implemented - and is does the same as my error logging -in the IDE no error is thrown - but in the compiled exe wrdDoc is always nothing

Can you gave my class a whirl and see if you can see the solution ... ?
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16774858
If you are getting nothing from the trace log, then I haven't explained it properly.
However, I'll make this my lesson in using classes in VB. Does all the code go into a class module?
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16774885
yes, all the code except the error handler which goes into a module

MTIA

Darrin
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775010
Thanks. I've added the code into the two modules.

I've had to do some changes to get it to com[pile
I've added references to the Word and Outlook Object libraries.

I've changed this line in the SendDoc procedure
      Call ClsErrorHandler
to this
     Call ClsErrorHandler("SendDoc")

I've replaced the call to a missing function in SaveDocAsAndClose
           'autoPath = GetMyDocsFolder
           autoPath = wrdApp.Options.DefaultFilePath(wdDocumentsPath)
   and changed this code in the same function
        m_ProcedureName = "SaveDocAsAndClose"
        Call ClsErrorHandler
   to
         m_ProcedureName = "SaveDocAsAndClose"
         ClsErrorHandler m_ProcedureName

The same thing in closeDoc .

In ReplaceField
  strReplacementText = RepText$(strReplacementText, vbCrLf, Chr(13))
has been changed to
  strReplacementText = Replace$(strReplacementText, vbCrLf, Chr(13))

In ClsErrorHandler        
   iResult = MsgBoxEx(msgboxQ, msgboxI)
has been Changed to
  iResult = MsgBox(msgboxQ, msgboxI)

and this line has been commented out
            Unload MDIForm1

Now, if I start with a full compile (Crtl+F5), it doesn't report any errors. How do I use it?
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16775015
sorry about that - the function to return the user document path is below - place it in a bas file on its own:

Option Explicit

Private Declare Function SHGetSpecialFolderPath _
   Lib "shell32.dll" _
   Alias "SHGetSpecialFolderPathA" _
   (ByVal hwnd As Long, _
   ByVal lpszPath As String, _
   ByVal nFolder As Integer, _
   ByVal fCreate As Boolean) As Boolean

Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_INTERNET = &H1
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16
Private Const CSIDL_COMMON_PROGRAMS = &H17
Private Const CSIDL_COMMON_STARTUP = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
Private Const CSIDL_APPDATA = &H1A
Private Const CSIDL_PRINTHOOD = &H1B
Private Const CSIDL_ALTSTARTUP = &H1D
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E
Private Const CSIDL_COMMON_FAVORITES = &H1F
Private Const CSIDL_INTERNET_CACHE = &H20
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22

Private m_strSpecialPath

Public Function GetMyDocsFolder() As String
    Dim blnReturn   As Long
    Dim strBuffer   As String
    strBuffer = space(255)
    blnReturn = SHGetSpecialFolderPath(0, _
      strBuffer, _
      CSIDL_PERSONAL, _
      False)
   
    strBuffer = Left(strBuffer, InStr(strBuffer, chr(0)) - 1)
   
    GetMyDocsFolder = strBuffer

End Function


0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775034
The Word option that I have used would do a similar job, though it is Word-orientated, so that is no longer a show-stopper.

What do I run to make the code do anything?
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16775067
(hopefully, you will enjoy this)

to call the class I do it as follows

Create a new word document - insert the following text into it exactly as formatted


[@surname]

[@title]

[@TotalFees]

Save the document in a directory under the app.path as \Templates\AuthorityToAct.rtf - this is the dcument that we are going to merge with

In a form :

Option Explicit
Dim cls as clsWrd
dim szFields as Collection
Dim szDta as collection

IN the onload event of the form

Set cls = new clsWrd
Set szFields = New Collection
Set szData = new Collection

 szData.add "Smith"
 szData.add "Mr"
 szData.add "1000.89765"

 sFields.add "@surname"
 szFields.add "@Title"
 szFields.add "@TotalFees"
place a command button on the form and in the click event place the following code:
 Dim i
 With clsWrd
  .OpenNewDoc App.Path & "\Templates\AuthorityToAct.rtf", False, False, False

  For i = 1 To szFields.Count
    DoEvents
      .ReplaceField szFields(i), ReturnFormattedData(szFields(i), szData(i))
      ' Debug.Print szFields(i) & " - " & szData(i)
      DoEvents
   Next i
 
   Dim szAttachment$
  ' here we add our document to the database for the matter
  szAttachment = .SaveDocAsAndClose(650987, "DWE", , , False, False)

  Msgbox szattachment

You wll also need this function

Public Function ReturnFormattedData(szFieldName As String, szData As String) As String
 Dim str$
 
    Select Case szFieldName
     Case "@Title"
      str = szData
      ReturnFormattedData = ProperCase(str)
     Case "@Surname"
      str = szData
      ReturnFormattedData =  ProperCase(str)
     Case "@TotalFees"
      str = szData
      ReturnFormattedData = Format(str, "Currency")

     
     Case Else ' no formatting
      str = szData
      ReturnFormattedData = Format$(szData)
     
   End Select
 
End Function



I am sorry, I whacked this together after your initial reply here ... so there might be some tweaking to do and THIS keyboard misses a key everynow and then ...
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16775101
==>The Word option that I have used would do a similar job, though it is Word-orientated, so that is no longer a show-stopper.
infact it is eause it allows me to get the default path of word to save the document, be it on a server or whereever .... go her to collect the aditional points, you have earnt them

http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21865978.html
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16775104
man, I hate this keyboard
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775234
Fortunately for your plan, Patrick's reply was a bit hasty, otherwise you would have had to accept his answer. I wouldn't have commented.
Actually, the question was a bit unnecessary, and a moderator might feel justifed in stepping in . Thanks for the thought.
0
 
LVL 1

Author Comment

by:dwe0608
ID: 16775342
Dude, we fix this problem nd I will post those sorts of quesntions til we each a suiable amount of points commensate with the effrts here ....Patricks answer was wrong - it told me hw to SET the directory - not retrieve it
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775388
OK. Back from a late lunch.  I am now getting a compile error on

Dim cls As clsWrd

Member already exists in a object model from which this object module derives.

cls is a method of a form object, so I'll try another name.
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775400
Now I get an error :

User-defined type not defined on the same Dim.

Changing to Class1
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775461
OK. I now get a MsgBox report:

c:\documents and settings\...\650987_DWE__20060527_134137.doc

And there is now a document with the data plugged in.
I'll now compile and run it as an exe.
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 16775508
The bad news is that it runs OK. as an exe.
0
 
LVL 76

Accepted Solution

by:
GrahamSkan earned 2000 total points
ID: 16775830
For a start, let's see if you can run the exact code that works for me. Something that you or I did might have removed the critical bit.

************** Module ****************

Option Explicit

Public Sub ClsErrorHandler(m_ProcedureName As String, Optional strCustomError As String = "", Optional bShowMsgBox As Boolean = False, Optional bIsFatal As Boolean = False)
    'Generic Error handling routine
Dim handleErr As String
Dim textfile As String

    'Raise the event according the procedure passed. Will write all errors
     'to an error log. Errors on the form will only be visible if
     'the event is active and a debug.print statement or message box
     'is inserted
   
    'Log the errors to an error log
    textfile = App.Path & "\ErrogLog.txt"
    handleErr = "Error: " & Err.Number & " " & Err.Description & " " & Err.Source & " Custom: " & strCustomError
    Open textfile For Append As #1 'write error to textfile
        Write #1, Now; handleErr; m_ProcedureName
    Close #1
    If bShowMsgBox Then
        Dim iResult As VbMsgBoxResult
        Dim msgboxQ$
        Dim msgboxI As VbMsgBoxStyle
        If bIsFatal Then
            msgboxQ = handleErr & vbCrLf & vbCrLf & vbCrLf & "Continue ?"
            msgboxI = vbYesNo + vbCritical
        Else
            msgboxQ = handleErr & vbCrLf & vbCrLf & vbCrLf & "The program will now end."
            msgboxI = vbCritical
        End If
        iResult = MsgBox(msgboxQ, msgboxI)
        If iResult = vbNo Then
            MsgBox "Program will now end.", vbOKOnly
            'Unload MDIForm1
        Else
            MsgBox iResult
        End If
     End If
    Err.Clear
End Sub

Public Function ReturnFormattedData(szFieldName As String, szData As String) As String
    Dim str$
    Select Case szFieldName
        Case "@Title"
            str = szData
            ReturnFormattedData = ProperCase(str)
        Case "@Surname"
            str = szData
            ReturnFormattedData = ProperCase(str)
        Case "@TotalFees"
            str = szData
            ReturnFormattedData = Format(str, "Currency")
        Case Else ' no formatting
            str = szData
            ReturnFormattedData = Format$(szData)
    End Select
End Function

Public Function ProperCase(strText As String) As String
    ProperCase = UCase$(Left$(strText, 1)) & LCase$(Mid$(strText, 2))
End Function

************* Class ***************

Option Explicit

Private m_ProcedureName As String 'Name of current procedure: for error handling
Private m_Strsubject As String 'Subject of E-mail message
Private m_StrTo As String 'Recipient address
Private m_StrToAdd As String 'Text to add to Word doc
Private m_VarMsgBody As Variant 'Body of e-mail message

Private WithEvents wrdApp As Word.Application 'MS Word object
Private wrdDoc As Word.Document 'MS Word Document
Private wrdSelection As Word.Selection 'MS Word Selection
Private strDocName As String 'MS Word document name

'Raised if merge document saved successfully
Public Event DocumentSaved(sFileName As String)
'Raised if merge document saved Unsuccessfully
Public Event DocumentNotSaved(ErrNum As Integer, msgWhy As String)
'Raised if document was e-mailed successfully
Public Event MessageSent(strTo As String, strSubject As String, strMsg As String, strAttachment As String, msgID As String)
'Raised if document was e-mailed Unsuccessfully
Public Event MessageNotSent(ErrNum As Integer, msgWhy As String)

Private Sub MakeValidObject()
 '   Set wrdApp = New Word.Application
    On Error Resume Next
    Set wrdApp = GetObject(, "Word.Application")
       
    ' if error then Word wasn't open
    If Err.Number <> 0 Then
        ' open Word
        Set wrdApp = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0    'Set to false if you don't want to see the word doc
    wrdApp.Visible = False
End Sub

Private Sub Class_Initialize()
 Call MakeValidObject
End Sub

Private Sub wrdApp_Quit()
   'Respond to the Quit event of Word
   'MsgBoxEx "Word Quit!", vbOKOnly
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Sub

Private Sub Class_Terminate()

On Error Resume Next
    wrdApp.NormalTemplate.Saved = True
    wrdApp.Quit
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Sub

Public Function Wrd_Terminate()
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Function
Public Function Show(Optional bVal As Boolean = True, Optional bActivate As Boolean = True)
 wrdApp.Visible = bVal
 If bActivate Then wrdApp.Activate
End Function
Public Function OpenNewDoc(Optional docname As String, Optional ro As Boolean = False, Optional atrfl As Boolean = False, Optional bVisible As Boolean = True)
    Dim iTries As Integer
    iTries = 0
10:
    On Error GoTo Error_Handler::
'    If Len(docname) > 0 Then
'        Set wrdDoc = wrdApp.Documents.Open(docname, ReadOnly:=ro, addtorecentfiles:=atrfl)
'    Else
        Set wrdDoc = wrdApp.Documents.Add(docname, Visible:=True)
       
        'wrdDoc.Select
        'Set wrdSelection = wrdApp.Selection
'    End If

 wrdApp.Visible = bVisible

Exit_Handler:

  Exit Function
   
Error_Handler:
    Call ClsErrorHandler("OpenNewDoc")
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
   
End Function

Public Sub printDoc()
    'print out the word doc
    wrdDoc.PrintOut
   
End Sub
Public Sub SendDoc(ByVal strTo As String, ByVal strSubject As String, _
    varMsgBody As Variant, Optional strDocName As String = "")
    Dim objOutLook As Outlook.Application
    Dim ObjMailItem As Outlook.MailItem
    Dim iTries As Integer
    iTries = 0
10:
 '   On Error GoTo Error_Handler::
    'Mail the word document to recipient specified

    Set objOutLook = GetObject(, "Outlook.Application")
       
    ' if error then Word wasn't open
    If Err.Number <> 0 Then
        ' open Word
        Set objOutLook = CreateObject("Outlook.Application")
    End If
    Err.Clear

On Error GoTo Exit_Handler:
       
    m_Strsubject = strSubject
    m_StrTo = strTo
    m_VarMsgBody = varMsgBody

    'Check to see if the e-mail address is correct by checking the format
    If checkEmailAddress = False Then
     m_ProcedureName = "SendDoc"
     Call ClsErrorHandler("SendDoc")
     Exit Sub
    End If
   
        'Set objOutLook = New Outlook.Application
        Set ObjMailItem = objOutLook.CreateItem(olMailItem)
       
    'create e-mail and insert attachment
        With ObjMailItem
            .Recipients.Add m_StrTo
            .Subject = m_Strsubject
            .Body = m_VarMsgBody & vbCrLf & vbCrLf
            .Attachments.Add strDocName
        End With
       
        ObjMailItem.Send
       
        RaiseEvent MessageSent(m_StrTo, m_Strsubject, CStr(m_VarMsgBody), strDocName, 0)
       
Exit_Handler:

  Exit Sub
   
Error_Handler:

    Call ClsErrorHandler("SendDoc")
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Sub
Public Function SaveDocAsAndClose(FileNum As Long, Author As String, Optional autoPath As String, Optional strFileName As String = "", Optional bPrint As Boolean = False, Optional bClose As Boolean = False) As String
    Dim iTries As Integer
    iTries = 0
10:
'    On Error GoTo Error_Handler::
 
    ' now lets work out a file name
    'start with the filenumber and then then username and then the dattime group
   
       Dim strfile$
       strfile = CStr(FileNum) & "_" & Author & "_" & Format$(Now, "_yyyymmdd_hhnnss")
       ' ok now do we have a specific path ?
       If autoPath = "" Then
           'save to my documents dir
           'autoPath = GetMyDocsFolder
           autoPath = wrdApp.Options.DefaultFilePath(wdDocumentsPath)
       End If
    '   If Not DriveExist(autoPath) Then GoTo Err_Handler
        'see if there is a backslash on the end
        If Mid(autoPath, Len(autoPath), 1) <> "\" Then
           ' add a backslash
           autoPath = autoPath & "\"
        End If
       
        strfile = autoPath & strfile
       
       ' Save the document, close it
       strDocName = strfile & ".doc"
    '***********************************************************************************
    ' NO ERROR THROWN IN THE IDE
    ' NUT AS A COMPILED EX - THROWN AN ERR THAT THE VARIABLE WAS NOT INITITIALSED
    '***********************************************************************************
    wrdDoc.SaveAs strDocName, AddToRecentFiles:=False
   
    If bPrint Then
     ' make sure we update our fields
     wrdApp.Options.UpdateFieldsAtPrint = True

     wrdDoc.PrintOut Background:=True
     wrdDoc.Save
     wrdDoc.Saved = True
'     wrdDoc.Close
    End If
    If bClose Then
         wrdDoc.Saved = True
         wrdDoc.Close
    End If
    RaiseEvent DocumentSaved(strDocName)
    SaveDocAsAndClose = strDocName
Exit_Handler:
  Exit Function
Error_Handler:
    m_ProcedureName = "SaveDocAsAndClose"
   ClsErrorHandler m_ProcedureName
   
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Function
Public Function closeDoc(strFileName As String, Optional autosave As Boolean = False)
    Dim iTries As Integer
    iTries = 0
10:
    On Error GoTo Error_Handler::
'        wrdDoc.Close SaveChanges:=autosave
Exit_Handler:
  Exit Function
Error_Handler:
    m_ProcedureName = "closeDoc"
    ClsErrorHandler m_ProcedureName
    If iTries < 3 Then
        iTries = iTries + 1
        Call MakeValidObject
        GoTo 10:
    Else
        Resume Exit_Handler
    End If
End Function

Public Sub DeleteDoc(PathAndDocName As String)
   'Delete a file
   If FileExist(PathAndDocName) Then
'    Kill PathAndDocName
   End If
End Sub
Public Sub InsertCurrentDate()
    'Inserts the current date with the deafult font
    wrdSelection.InsertDateTime _
    DateTimeFormat:="dddd, MMMM dd, yyyy", InsertAsField:=False
End Sub

Private Function checkEmailAddress() As Boolean
On Error Resume Next
     Dim i%
    'parses e-mail address to see if is correct
    i = InStr(m_StrTo, "@")
    checkEmailAddress = (InStr(i + 1, m_StrTo, ".") > 0)
   
End Function

Private Function FileExist(FileName As String) As Boolean
On Error Resume Next

    FileExist = (Dir$(UCase((FileName))) <> "")

End Function

Private Function DriveExist(Path As String) As Boolean
On Error Resume Next

    DriveExist = (Dir(UCase((Path))) <> "")

End Function
' Convert a Word-compatible format to an other format.
' Parameters:
'  - sFileName is the file to convert
'  - wdFormat is the destination file's format
'  - sNewFileName is the destination file. If not specified the the routine
' will use the sFileName's path & name
'
' NOTE: requires the Microsoft Word type library
'
' Example: convert from DOC to HTML
'   ConvertWordDocument("C:\Documents\MyWordFile.doc", wdFormatHTML)

Function ConvertWordDocument(ByVal sFileName As String, _
    Optional ByVal wdFormat As WdSaveFormat = wdFormatText, _
    Optional ByVal sNewFileName As String) As Boolean
   
    Dim iPointer As MousePointerConstants
    Dim sExtension As String
'    Dim wrdApp As New Word.Application

    On Error GoTo ERR_HANDLER:
    iPointer = Screen.MousePointer

    ' open the file
    wrdApp.Documents.Open sFileName, False, False, False, , , , , , _
        wdOpenFormatAuto

    ' the destination filename if sFileName is sNewFileName is missing
    If Len(sNewFileName) = 0 Then
        sNewFileName = sFileName
        ' remove the actual extension ad add the one specified by sExtension
        If InStr(sNewFileName, ".") > 0 Then sNewFileName = Left$(sNewFileName, _
            InStr(sNewFileName, ".") - 1)
        ' set the extension for the selected destination format
        sExtension = Switch(wdFormat = wdFormatDocument, ".doc", _
                            wdFormat = wdFormatDOSText, ".txt", _
                            wdFormat = wdFormatDOSTextLineBreaks, ".txt", _
                            wdFormat = wdFormatRTF, ".rtf", _
                            wdFormat = wdFormatTemplate, ".dot", _
                            wdFormat = wdFormatTextLineBreaks, ".txt", _
                            wdFormat = wdFormatUnicodeText, ".txt")
       
        ' add the extension to the file name
        sFileName = sFileName & sExtension
    End If
    ' save the file
    wrdApp.ActiveDocument.SaveAs sNewFileName, wdFormat, , , False
    ConvertWordDocument = True

Exit_Err_Handler:
   Exit Function
   
ERR_HANDLER:
    m_ProcedureName = "ConvertWordDocument"
    Resume Exit_Err_Handler
End Function

Public Function ReplaceField(strField As String, strReplacementText As String, Optional GoToHome As Boolean = False) As Boolean
  On Error GoTo ErrorOcurred
 
  strReplacementText = Replace$(strReplacementText, vbCrLf, Chr(13))
  With wrdApp.Selection.Find
    .Text = "[" & Trim(strField) & "]"
    .Replacement.Text = Trim(strReplacementText)
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
  ReplaceField = True
  GoTo Success
ErrorOcurred:
  ReplaceField = False
Success:
  '
End Function

*********** Form *************

Option Explicit
Dim objOne As Class1
Dim szFields As Collection
Dim szData As Collection


Private Sub Command1_Click()
'place a command button on the form and in the click event place the following code:
 Dim i
 With objOne
  .OpenNewDoc App.Path & "\Templates\AuthorityToAct.rtf", False, False, False

  For i = 1 To szFields.Count
    DoEvents
      .ReplaceField szFields(i), ReturnFormattedData(szFields(i), szData(i))
      ' Debug.Print szFields(i) & " - " & szData(i)
      DoEvents
   Next i
 
   Dim szAttachment$
  ' here we add our document to the database for the matter
  szAttachment = .SaveDocAsAndClose(650987, "DWE", , , False, False)

  MsgBox szAttachment
End With
End Sub

 Private Sub Form_Load()
'IN the onload event of the form

Set objOne = New Class1
Set szFields = New Collection
Set szData = New Collection

 szData.Add "Smith"
 szData.Add "Mr"
 szData.Add "1000.89765"

 szFields.Add "@surname"
 szFields.Add "@Title"
 szFields.Add "@TotalFees"
End Sub

0
 
LVL 1

Author Comment

by:dwe0608
ID: 16777587
ok ... will rebuild into an exe from my end based on your code and come back to you ...
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses
Course of the Month13 days, 8 hours left to enroll

750 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question