Word, HTML

word- HTML, . .

Word

Shapes ( ) InlineShapes ( ). . . , .

, .. , .

 

. , .

HTML

HTML , . , . , , .

, InlineShapes. , , , , .

InlineShapes, . _001.jpg, , 001 , jpg . InlineShapes gif.

, HTML , Word. , , , 100% :

For Each Shape In EmbeddedImages

EmbeddedCount = EmbeddedCount + 1

Set NewShape = Shape.ConvertToShape

NewShape.ScaleHeight 1, True

NewShape.ScaleWidth 1, True

Next

, , . , IMG. , .

Shape.LinkFormat.SavePictureWithDocument. InlineShapes .

InlineShape , - , . . Shape , :

Set NewHyperLink = Document.Hyperlinks.Add(Shape, NewHyperLinkAddress, Target:="_blank")

 

Word- HTML

HTML .

Word:

Set Word = CreateObject("Word.Application")

Word doc-:

Set Document = Word.Documents.Open(FileName:=FileName, ConfirmConversions _

:=False, ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _

PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _

WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:="")

:

With Document.WebOptions

.RelyOnCSS = True

.OptimizeForBrowser = True

.OrganizeInFolder = False ' , htm-

.UseLongFileNames = True

.RelyOnVML = False

.AllowPNG = False

.ScreenSize = msoScreenSize800x600_

.PixelsPerInch = 96

.Encoding = msoEncodingCyrillic_

End With

HTM-:

Document.SaveAs FileName:=DstFileName, FileFormat:= _

wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles _

:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _

:=False, SaveNativePictureFormat:=True, SaveFormsData:=False, _

SaveAsAOCELetter:=False

HTML HTML-, HTML , , .

OLE-, , , , OLE- Word:

Sub KillAllWordProcesses()

Set Locator = CreateObject("WbemScripting.SWbemLocator")

Set Services = Locator.ConnectServer(".")

Set Items = Services.ExecQuery("SELECT * FROM Win32_Process WHERE NAME LIKE '%WINWORD.EXE%'")

For Each Item In Items

'Debug.Print Item.Name

'Debug.Print Item.CommandLine

'Debug.Print Item.ExecutablePath

'Debug.Print Item.Caption

'Debug.Print "---------------"

If InStr(1, UCase(Item.CommandLine), UCase("/Automation -Embedding")) <> 0 Then

Item.Terminate

End If

Next

 

End Sub

Word HTM

. .

Sub ConvertDoc2HTMFile(FileName, Optional Word = 0)

' DOC HTM-

If Word = 0 Then

KillAllWordProcesses

Set Word = CreateObject("Word.Application")

End If

wdOpenFormatAuto = 0

msoScreenSize800x600_ = 3

msoEncodingCyrillic_ = 1251

wdFormatFilteredHTML = 10

msoLinkedPicture_ = 11

msoPicture_ = 13

wdInlineShapePicture = 3

wdInlineShapeHorizontalLine = 6

wdInlineShapeLinkedPicture_ = 4

Set fs = CreateObject("Scripting.FileSystemObject")

Set File = fs.GetFile(FileName)

FileShortName = File.Name

FilePath = Left(File.Path, Len(File.Path) - Len(File.Name) - 1)

FileNamePart = Replace(FileShortName, ".doc", "")

FileNamePart = Replace(FileNamePart, ".docx", "")

DstFileName = Replace(FileName, ".doc", ".htm")

DstFileName = Replace(DstFileName, ".docx", ".htm")

If FileName = DstFileName Then

Exit Sub '

End If

Set Document = Word.Documents.Open(FileName:=FileName, ConfirmConversions _

:=False, ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _

PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _

WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:="")

With Document.WebOptions

.RelyOnCSS = True

.OptimizeForBrowser = True

.OrganizeInFolder = False

.UseLongFileNames = True

.RelyOnVML = False

.AllowPNG = False

.ScreenSize = msoScreenSize800x600_

.PixelsPerInch = 96

.Encoding = msoEncodingCyrillic_

End With

Set Images = New Collection

For Each Shape In Document.InLineShapes

Images.Add Shape

Next

For Each Shape In Document.Shapes

Images.Add Shape

Next

'Images

EmbeddedCount = 0

Set ForDeleteImages = New Collection

Set EmbeddedImages = New Collection

For Each Shape In Images

ForDelete = True

Work = False

Linked = False

InlineLinked = False

Embedded = False

If TypeName(Shape) = "InlineShape" And Shape.Type = wdInlineShapePicture Or _

TypeName(Shape) = "Shape" And Shape.Type = msoPicture_ Then

EmbeddedCount = EmbeddedCount + 1

EmbeddedImages.Add Shape

Work = True

Embedded = True

ElseIf TypeName(Shape) = "Shape" And Shape.Type = msoLinkedPicture_ Then

Linked = True

Work = True

ElseIf TypeName(Shape) = "InlineShape" And Shape.Type = wdInlineShapeLinkedPicture_ Then

'For better saving convert to shape

Linked = True

Work = True

InlineLinked = True

'Shape.ConvertToShape

ElseIf TypeName(Shape) = "InlineShape" Then

Shape.Delete 'Delete, because cannot save correctly

ForDelete = False

Work = False

Else

Work = False

End If

'

If Work Then

HyperlinkAddress = ""

On Error Resume Next

HyperlinkAddress = Shape.Hyperlink.Address

On Error GoTo 0

If HyperlinkAddress = "" Then

If Linked Then

SrcFileFullName = Shape.LinkFormat.SourceName & ""

'On Error Resume Next

'Set LinkFile = fs.GetFile(SrcFileFullName)

NewHyperLinkAddress = SrcFileFullName 'LinkFile.Name

If InlineLinked Then

'Shape.Range.Paragraphs.First

'Set NewHyperLink =
Document.Hyperlinks.Add(Document.Selection, NewHyperLinkAddress, Target:="_blank")

'Set NewShape = Shape.ConvertToShape

'Set NewHyperLink = Document.Hyperlinks.Add(NewShape, NewHyperLinkAddress,

Target:="_blank")

'Set NewHyperLink = Document.Hyperlinks.Add(Shape, NewHyperLinkAddress, Target:="_blank")

Else

Shape.LinkFormat.SavePictureWithDocument = True

Set NewHyperLink = Document.Hyperlinks.Add(Shape, NewHyperLinkAddress, Target:="_blank")

End If

On Error GoTo 0

ElseIf Embedded Then

ForDelete = False

If EmbeddedCount = 78 Then

X = 1

End If

NewHyperLinkAddress = FileNamePart & "__image" & Format(EmbeddedCount, "###000") & ".jpg"

Set NewHyperLink = Document.Hyperlinks.Add(Shape, NewHyperLinkAddress, Target:="_blank")

End If

End If

End If

If ForDelete Then

ForDeleteImages.Add Shape

End If

Next

Document.SaveAs FileName:=DstFileName, FileFormat:= _

wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles _

:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _

:=False, SaveNativePictureFormat:=True, SaveFormsData:=False, _

SaveAsAOCELetter:=False

If EmbeddedImages.Count() > 0 Then

EmbeddedCount = 0

NewFileNameForPictures = FilePath & "\" & FileNamePart & "_.htm"

On Error Resume Next

'

For Each Shape In ForDeleteImages

Shape.Delete

Next

For Each Shape In EmbeddedImages

EmbeddedCount = EmbeddedCount + 1

Set NewShape = Shape.ConvertToShape

NewShape.ScaleHeight 1, True

NewShape.ScaleWidth 1, True

Next

On Error GoTo 0

Document.SaveAs FileName:=NewFileNameForPictures, FileFormat:= _

wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles _

:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _

:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _

SaveAsAOCELetter:=False

Document.Close False

Set fs = CreateObject("Scripting.FileSystemObject")

Set File = fs.GetFile(NewFileNameForPictures)

File.Delete

End If

 

On Error Resume Next

Document.Close False

On Error GoTo 0

 

End Sub