, 25 2018 . 15:02
+
, !
:
Sub imprtMl(mail As Long)
Dim Fname, FnameTmp, sql, list As String
Dim rs_ml, rs_pl, rs_auth As DAO.Recordset
Dim objWord As Object 'Word.Application
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
If objWord Is Nothing Then
MsgBox "MS Word is not installed on your computer"
End If
End If
objWord.Visible = True
sql = "Select * from pln_mail "
Set rs_ml = CurrentDb.OpenRecordset(pln_sql)
Set rs_pl = CurrentDb.OpenRecordset("list_for_mail")
Set rs_auth = CurrentDb.OpenRecordset("Property Auth")
rs_pl.FindFirst "pln_main.ml = " & mail
rs_ml.FindFirst "ID = " & mail
rs_auth.FindFirst "id = " & rs_ml!reg
Do While rs_pl.NoMatch = False
list = list & rs_pl!IDobj & rs_pl!type_obj & rs_pl!shortname & _
rs_pl!yr & rs_pl!type_work & rs_pl!type_kpp & _
rs_pl!namemn & rs_pl!KM & rs_pl!type_line & vbCrLf
rs_pl.FindNext "pln_main.ml = " & mail
Loop
FnameTmp = "\\CPS01-FSDFS-01\Files\Documents\Ml_Remarks_01.docx"
Fname = "C:\Users\Desktop\testdoc.docx"
objWord.Open FnameTmp
objWord.Documents.Add (FnameTmp)
objWord.ActiveDocument.SaveAs Fname
With objWord.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = objWord.wdFindContinue
.Forward = True
.Text = "%SPEC%"
Do While .Execute = True
.Parent.HomeKey Unit:=objWord.wdLine
.Parent.MoveDown Unit:=objWord.wdLine, Count:=2, Extend:=objWord.wdMove
Loop
.InsertAfter rs_auth!ToSpec
End With
'/////////// //////////
Set rs_pl = Nothing
Set rs_ml = Nothing
Set rs_auth = Nothing
End Sub
:
1.
2. -
3.
////// ///////////
4.
5. PROFIT
!
PS: sql ,
____
vk.com/taenfox
http://www.sql.ru/forum/1299575/pismo-v-word-zamena-teksta
