Public Sub AllReportsCyrillec()
Dim obj As AccessObject, dbs As Object
Dim k%
Dim ctl As Control
k = 0
'шрифт который меняем
Const arialcyr = "Arial Cyr"
Const newarialcyr = "Arial"
Set dbs = Application.CurrentProject
' Search for open AccessObject objects in AllReports collection.
For Each obj In dbs.AllReports
k = k + 1
' Print name of obj.
'debug.print k, obj.name
debug.print obj.name
If InStr(1, obj.name, "Etiketka") > 0 Then GoTo 111 'обработка исключений (этот отчет не трогать!)
DoCmd.OpenReport obj.name, acViewDesign, , , acHidden
With Reports(obj.name)
For Each ctl In Reports(obj.name).Controls
If ctl.Properties(2) = 100 Or ctl.Properties(2) = 109 Then
'debug.print "" & ctl.name
'debug.print "" & ctl.Properties(2)
On Error Resume Next
'debug.print ""; ctl.Properties("FontName")
If arialcyr = ctl.Properties("FontName") Then
ctl.Properties("FontName") = newarialcyr 'шрифт НА который меняем
'debug.print "заменили"
End If
End If
Next
End With
DoCmd.Close acReport, obj.name, acSaveYes
111:
Next obj
MsgBox Now(), , "Всего отчетов в базе " & k
End Sub
|