كود تحويل من HTM إلى Word

[عنـ الشوق ـاد]

كود تحويل من HTM إلى Word

Private Sub Cleanup()
Set IE = Nothing
Set Word = Nothing
Set Response = Nothing
Set Session = Nothing
Set Server = Nothing
Set ASP = Nothing
Set Stream = Nothing
End Sub


Public Sub Download(ByRef pstrURL As Variant)
Dim lstrPath As String
Dim lstrFileName As String
Dim ldblStart As Double
mblnDone = False
ldblStart = Timer
Call IE.Navigate2(pstrURL)


While IE.Busy And Not mblnDone


DoEvents


If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 1, "HTML2Word.dll", "Connect Timeout - Busy"
End If
Wend


While Not (IE.Document.ReadyState = "complete" Or mblnDone)


DoEvents


If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 2, "HTML2Word.dll", "Connect Timeout - Not Complete"
End If
Wend
Call IE.Document.Body.createTextRange.execCommand("Copy")


DoEvents
lstrFileName = Session.SessionID & ".doc"
lstrPath = App.Path & "\~" & Hex(Timer) & "_" & lstrFileName


DoEvents
On Error Resume Next
Word.Content.Paste


If Err Then
Call Cleanup
Dim lstrMsg
lstrMsg = Err.Description
On Error Goto 0
Err.Raise vbObjectError + 3, "HTML2Word.dll", "Can Not paste - " & lstrMsg
End If
On Error Goto 0
Word.SaveAs lstrPath
Word.Close
Response.ContentType = "application/octet-stream"
Response.AddHeader "content-disposition", "attatchment; filename=" & lstrFileName
Stream.Open
Stream.LoadFromFile lstrPath
Response.BinaryWrite Stream.ReadText
Stream.Close
Response.Flush
Response.End
FileSystem.Kill lstrPath
End Sub


Public Sub OnEndPage()
Call Cleanup
End Sub


Private Sub IE_StatusTextChange(ByVal Text As String)
If Text = "Done" Then mblnDone = True


DoEvents
End Sub

Private ASP As ASPTypeLibrary.ScriptingContext
Private Response As ASPTypeLibrary.Response
Private Session As ASPTypeLibrary.Session
Private Server As ASPTypeLibrary.Server
Private WithEvents IE As SHDocVw.InternetExplorer
Private Word As Word.Document
Private Stream As ADODB.Stream
Private mblnDone


Public Sub OnStartPage(ByRef ASPLink As ASPTypeLibrary.ScriptingContext)
Set ASP = ASPLink
Set Response = ASPLink.Response
Set Session = ASPLink.Session
Set Server = ASPLink.Server
Set IE = New SHDocVw.InternetExplorer
Set Word = New Word.Document
Set Stream = New ADODB.Stream
Response.Clear
End Sub


Private Sub Cleanup()
Set IE = Nothing
Set Word = Nothing
Set Response = Nothing
Set Session = Nothing
Set Server = Nothing
Set ASP = Nothing
Set Stream = Nothing
End Sub


Public Sub Download(ByRef pstrURL As Variant)
Dim lstrPath As String
Dim lstrFileName As String
Dim ldblStart As Double
mblnDone = False
ldblStart = Timer
Call IE.Navigate2(pstrURL)


While IE.Busy And Not mblnDone


DoEvents


If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 1, "HTML2Word.dll", "Connect Timeout - Busy"
End If
Wend


While Not (IE.Document.ReadyState = "complete" Or mblnDone)


DoEvents


If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 2, "HTML2Word.dll", "Connect Timeout - Not Complete"
End If
Wend
Call IE.Document.Body.createTextRange.execCommand("Copy")


DoEvents
lstrFileName = Session.SessionID & ".doc"
lstrPath = App.Path & "\~" & Hex(Timer) & "_" & lstrFileName


DoEvents
On Error Resume Next
Word.Content.Paste


If Err Then
Call Cleanup
Dim lstrMsg
lstrMsg = Err.Description
On Error Goto 0
Err.Raise vbObjectError + 3, "HTML2Word.dll", "Can Not paste - " & lstrMsg
End If
On Error Goto 0
Word.SaveAs lstrPath
Word.Close
Response.ContentType = "application/octet-stream"
Response.AddHeader "content-disposition", "attatchment; filename=" & lstrFileName
Stream.Open
Stream.LoadFromFile lstrPath
Response.BinaryWrite Stream.ReadText
Stream.Close
Response.Flush
Response.End
FileSystem.Kill lstrPath
End Sub


Public Sub OnEndPage()
Call Cleanup
End Sub


Private Sub IE_StatusTextChange(ByVal Text As String)
If Text = "Done" Then mblnDone = True


DoEvents
End Sub[/right]
[right]
[/right][/right]

[الـــدانـــة]

اللــــه يعطيــــك العافيـــة أخــــوي عنـــاد
جهـــــــود تشكــــــــر عليهــــــا
دمت ودام عطائـــــك