L
LF
Is there a way to initiate a MS-Word macro from access? If not, I'd
appreciate help with converting the VBA below to an Access 2K3 function that
would control the MS-Word functionality.
Sub CSVdelimitTable()
'prompt user warning and save copy of file with a .CSV extension
Dim theResponse, theFileName
'theResponse = MsgBox("Pleace click Cancel if current file contains
anything other than a single table." And Chr(13) And Chr(10) And Chr(13) And
Chr(10) And "Click OK to save a copy of the file in the form of comma
seperated values which is openable by Excel and database importable.",
vbOKCancel, "CSV Warning!")
If theResponse = vbOK Then
'theFileName = ActiveDocument.Name
'theFileName = Mid(theFileName, 1, Len(theFileName) - 4)
'theFileName = theFileName + ".CSV"
'ChangeFileOpenDirectory ActiveDocument.Path
'ActiveDocument.SaveAs FileName:=theFileName, FileFormat:=wdFormatDocument
'Else
Exit Sub
End If
'set view to Page Layout in order to access header/footer
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or
ActiveWindow.ActivePane.View.Type _
= wdMasterView Then
ActiveWindow.ActivePane.View.Type = wdPageView
End If
'remove header and footer to avoid them being saved as delimited rows
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'search/replace all table paragraph returns with intermediate values
Selection.Tables(1).Select
With Selection.Find
.Text = "^p"
.Replacement.Text = "$$EMBEDDED_RETURN$$"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'search/replace all table tabs with intermediate values
With Selection.Find
.Text = "^t"
.Replacement.Text = "$$EMBEDDED_TAB$$"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'double quote all table quotes
With Selection.Find
.Text = """"
.Replacement.Text = """"""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'convert table cells to text
Selection.Rows.ConvertToText Separator:=wdSeparateByTabs
'insert quote text qualifiers and a comma between each field value
With Selection.Find
.Text = "^t"
.Replacement.Text = ""","""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'insert quote text qualifiers at end of each record
With Selection.Find
.Text = "^p"
.Replacement.Text = """^p"""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'insert a quote text qualifier before the first word
Selection.HomeKey Unit:=wdLine
Selection.TypeText Text:=""""
're-establish embedded returns
With Selection.Find
.Text = "$$EMBEDDED_RETURN$$"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
're-establish embedded tabs
With Selection.Find
.Text = "$$EMBEDDED_TAB$$"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'delete last line to avoid corruption of last row
Selection.EndKey Unit:=wdStory, Extend:=wdMove
Selection.TypeBackspace
Selection.TypeBackspace
'return cursor to top of document and save file as Text Only filetype
Selection.HomeKey Unit:=wdStory
ActiveDocument.SaveAs FileFormat:=wdFormatText
End Sub
appreciate help with converting the VBA below to an Access 2K3 function that
would control the MS-Word functionality.
Sub CSVdelimitTable()
'prompt user warning and save copy of file with a .CSV extension
Dim theResponse, theFileName
'theResponse = MsgBox("Pleace click Cancel if current file contains
anything other than a single table." And Chr(13) And Chr(10) And Chr(13) And
Chr(10) And "Click OK to save a copy of the file in the form of comma
seperated values which is openable by Excel and database importable.",
vbOKCancel, "CSV Warning!")
If theResponse = vbOK Then
'theFileName = ActiveDocument.Name
'theFileName = Mid(theFileName, 1, Len(theFileName) - 4)
'theFileName = theFileName + ".CSV"
'ChangeFileOpenDirectory ActiveDocument.Path
'ActiveDocument.SaveAs FileName:=theFileName, FileFormat:=wdFormatDocument
'Else
Exit Sub
End If
'set view to Page Layout in order to access header/footer
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or
ActiveWindow.ActivePane.View.Type _
= wdMasterView Then
ActiveWindow.ActivePane.View.Type = wdPageView
End If
'remove header and footer to avoid them being saved as delimited rows
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'search/replace all table paragraph returns with intermediate values
Selection.Tables(1).Select
With Selection.Find
.Text = "^p"
.Replacement.Text = "$$EMBEDDED_RETURN$$"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'search/replace all table tabs with intermediate values
With Selection.Find
.Text = "^t"
.Replacement.Text = "$$EMBEDDED_TAB$$"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'double quote all table quotes
With Selection.Find
.Text = """"
.Replacement.Text = """"""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'convert table cells to text
Selection.Rows.ConvertToText Separator:=wdSeparateByTabs
'insert quote text qualifiers and a comma between each field value
With Selection.Find
.Text = "^t"
.Replacement.Text = ""","""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'insert quote text qualifiers at end of each record
With Selection.Find
.Text = "^p"
.Replacement.Text = """^p"""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'insert a quote text qualifier before the first word
Selection.HomeKey Unit:=wdLine
Selection.TypeText Text:=""""
're-establish embedded returns
With Selection.Find
.Text = "$$EMBEDDED_RETURN$$"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
're-establish embedded tabs
With Selection.Find
.Text = "$$EMBEDDED_TAB$$"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'delete last line to avoid corruption of last row
Selection.EndKey Unit:=wdStory, Extend:=wdMove
Selection.TypeBackspace
Selection.TypeBackspace
'return cursor to top of document and save file as Text Only filetype
Selection.HomeKey Unit:=wdStory
ActiveDocument.SaveAs FileFormat:=wdFormatText
End Sub