Мой вариант такой (работает очень долго):
- Код: Выделить всё
Dim w1 As Word.Application, w2 As Word.Document
Dim shp As Word.Shape
Dim rsBlancP As Recordset
Dim rsShp As Recordset, rsLbl As Recordset
Dim rsTxt As Recordset, rsTbl As Recordset
Dim rsTblReq As Recordset, rsTblReq1 As Object
Dim strRez As String, NullMe As String
Dim n_col As Integer, n_pp As Long
Set rsBlancP = dbsCurrent.OpenRecordset("SELECT * FROM PRINT_BLANCS WHERE ((FILE_NAME='" & valBlanc & "') AND (ID=" & BlancID & "))")
If rsBlancP.EOF = False Then
Set w1 = CreateObject("Word.Application")
w1.documents.Add Template:=(PathBlanc + valBlanc)
Set w2 = w1.ActiveDocument
Set rsLbl = dbsCurrent.OpenRecordset("SELECT * FROM PRINT_TEXT")
If rsLbl.EOF = False Then
rsLbl.MoveFirst
Do While Not rsLbl.EOF
If rsLbl![N_FIELDS] = 0 Then w2.ActiveWindow.Selection.Find.ClearFormatting
w2.ActiveWindow.Selection.Find.Replacement.ClearFormatting
w2.ActiveWindow.Selection.Find.text = rsLbl![TXT_TITLE]
w2.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll, ReplaceWith:=SelectReq(rsLbl![REQ_NUM]), Wrap:=wdFindContinue
For Each shp In w2.Shapes
shp.Select
w2.ActiveWindow.Selection.Find.ClearFormatting
w2.ActiveWindow.Selection.Find.Replacement.ClearFormatting
w2.ActiveWindow.Selection.Find.text = rsLbl![TXT_TITLE]
w2.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll, ReplaceWith:=SelectReq(rsLbl![REQ_NUM]), Wrap:=wdFindContinue
With shp.TextFrame
If .HasText Then
.TextRange.Select
w2.ActiveWindow.Selection.Find.ClearFormatting
w2.ActiveWindow.Selection.Find.Replacement.ClearFormatting
w2.ActiveWindow.Selection.Find.text = rsLbl![TXT_TITLE]
w2.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll, ReplaceWith:=SelectReq(rsLbl![REQ_NUM]), Wrap:=wdFindContinue
End If
End With
Next
Else
NullMe = SelectReq(rsLbl![REQ_NUM])
If valADO = False Then
Set rsTblReq = dbsCurrent.OpenRecordset(NullMe)
If rsTblReq.EOF = True Then
rsLbl.close
Set w2 = Nothing
w1.Visible = True
Set w1 = Nothing
rsBlancP.close
Exit Sub
End If 'If rsTblReq.EOF = True
w1.WordBasic.StartOfDocument
w1.WordBasic.EditFind Find:=CStr(rsLbl![TXT_TITLE])
Do While w1.WordBasic.EditFindFound()
With w1.WordBasic
.Insert tblHider
w2.ActiveWindow.Selection.TypeParagraph
rsTblReq.MoveFirst
n_pp = 1
Do While Not rsTblReq.EOF
NullMe = n_pp
For n_col = 0 To (rsTbl![N_FIELDS] - 1)
If IsNull(rsTblReq.Fields(n_col)) = False Then
NullMe = NullMe + ";" + CStr(rsTblReq.Fields(n_col))
Else
NullMe = NullMe + ";" + ""
End If
Next n_col
.Insert NullMe
w2.ActiveWindow.Selection.TypeParagraph
n_pp = n_pp + 1
rsTblReq.MoveNext
Loop 'rsTblReq
.ParaUp rsTblReq.RecordCount + 1, 1
w2.ActiveWindow.Selection.ConvertToTable Separator:=wdSeparateByCommas, NumColumns:=rsTbl![N_FIELDS] + 1, NumRows:=rsTblReq.RecordCount + 1, Format:=wdTableFormatGrid1, ApplyBorders:=True, ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:=True, ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False, AutoFit:=False, AutoFitBehavior:=wdAutoFitFixed
w2.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
w2.ActiveWindow.Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
и т.д.
Но он работает долго...
Есть словарь меток, хранящийся в БД Access 2000. Этот словарь прогоняется, ищутся соответствия на бланке и заменяется соответствующим текстовым результатом запроса.
Подскажите какой-нить более быстрый алгоритм. Очень актуальный вопрос для меня!
