June 2022

S M T W T F S
   1234
567891011
12131415161718
19202122 232425
2627282930  

Style Credit

Expand Cut Tags

No cut tags
Sunday, December 17th, 2006 08:00 pm
Ура, заработало!
Спасибо всем за моральную и физическую поддержку.

кому интересно - текст макроса под катом



Sub convert()
'
Dim mystring As String

' select table and move to the new document to make sure what we want to export
Selection.Tables(1).Select
Selection.Copy
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)

Dim myindex As Integer
Dim mydocrange As Range
Dim newrange As Range
Dim newdoc As Document
Dim myheaderrow As Row
Dim mytable As Table

Dim filename As String
Set mytable = ActiveDocument.Tables(1)
Set myheaderrow = mytable.Rows(1)
For Each aRow In mytable.Rows
Set myCell = aRow.Cells(1)
Set newdoc = Documents.Add

Set mydocrange = newdoc.Range(Start:=0, End:=0)
Dim i As Integer

If aRow.Index <> 1 Then ' we dont want to save headers
For Each aCell In aRow.Cells
aCell.Select
Selection.Copy
With mydocrange
.Paste
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
End With
' add some info from headers
i = aCell.ColumnIndex
myheaderrow.Cells(i).Select
Selection.Copy
With mydocrange
.Paste
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
End With


Next aCell
' newfiletext = newfiletext + "*/"


Set newrange = newdoc.Words(1)

With newdoc
filename = newrange.Text

For Each aTable In newdoc.Tables
For Each aCell In aTable.Range.Cells
aCell.Range.InsertBefore "/*"
aCell.Range.InsertAfter "*/"
Next aCell
Next aTable

.SaveAs filename:=filename, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, Encoding:=1251, InsertLineBreaks:=False, AllowSubstitutions:=False _
, LineEnding:=wdCRLF

MsgBox (filename)

End With
' Else
' newdoc.Close
End If

' here we should save the file
Next aRow


End Sub


Но и гадость же эта ваша заливная рыба, в смысле интерфейс у ворд бейсика жутко неудобный...
Monday, December 18th, 2006 02:50 am (UTC)
Не, это не для простого (не-программистского) ума :(((
Monday, December 18th, 2006 03:11 am (UTC)
Ну, за вижуал бейсик!
Monday, December 18th, 2006 03:30 am (UTC)
:)
Рада, что заработало. А интерфейс - это дело привычки.. :)
Monday, December 18th, 2006 11:36 am (UTC)
я бы в Excel сначала таблицу засунула - там объектная модель при обращении с табличными данными, imho, проще.