ذخیره فایل [بایگانی]

atefeh

جمعه 20 تیر 1382, 10:32 صبح

با سلام.
من میخواهم در برنامه ام یک صفحه ای را از روی یک سایت Save کنم.کسی میداند چطورمی شود با دادن آدرس سایت و شاخه مورد نظر این صفحه را ذخیره کنم؟
البته من میتوانم این صفحه را ابتدا در یک Load ، frmBrowser کنم اما نمیدانم چطور میشه ذخیره اش کرد؟

Vahid_Nasiri

جمعه 20 تیر 1382, 12:15 عصر

به صورت زیر :

Sub save_mess(Url, user_name, pass_word, file_name)

On Error Resume Next
Dim t1, tf, res

t1 = Time
objXMLHTTP.Open "GET", Url, False, user_name, pass_word

objXMLHTTP.send ""

writeToFile objXMLHTTP.responseText, file_name
tf = Time

res = Abs(Second(t1) - Second(tf))

'Debug.Print res

DoEvents

lblTime.Caption = getTotalTime(res * Abs(k - Abs(Val(txtFrom.Text) - Val(txtTo.Text))))

'Debug.Print Abs(k - Abs(Val(txtFrom.Text) - Val(txtTo.Text)))

End Sub

سپس این مورد را فراموش نکنید:

Dim objXMLHTTP As New XMLHTTP

در قسمت Ref ها هم باید MS XML 2.6 را تیک بزنید

سعید قدیری مقدم

شنبه 21 تیر 1382, 08:38 صبح

سلام بر دوستان عزیز - با وجود اینکه آقای نصیری کد کاملی رو برای این موضوع نوشتن می خواستم برای تکمیل این کد :oops: یک روش ساده تر برای ذخیره کردن صفحه های html که داخل frmbrowser بار شدند بنویسم
شما یک button روی فرم قرار بدین و با فرض اینکه نام browser شما brwWebBrowser باشد کد زیر را در button بنویسید

Private Sub Command1_Click()

On Error Resume Next
brwWebBrowser.Offline = True
brwWebBrowser.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
brwWebBrowser.Offline = False

End Sub

با کلیک کردن button پنچره ذخیره سازی صفحه مورد نظر ظاهر شده و شما میتونید صفحه خودتون رو داخل هارد دیسک یا فلاپی ذخیره کنید

atefeh

شنبه 21 تیر 1382, 10:43 صبح

خیلی ممنون از راهنمایی تون.فقط یک مشکلی دارم.تابع WriteToFile برایش شناخته شده نیست و خطا میگیرد!

Vahid_Nasiri

شنبه 21 تیر 1382, 17:27 عصر

درسته! چون اون رو من خودم نوشتم!
به این صورت : :oops:

Option Explicit

'Copyright (C) 2002 - Vahid_Nasiri@Yahoo.com

Dim objXMLHTTP As New XMLHTTP
Dim k As Long

Sub start_saving()

'Kill App.Path + "\" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + ".htm"
'If Err.Number = 53 Then Resume Next

Dim i As Long

k = 0

write_header App.Path + "\" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + ".htm"

For i = Val(txtFrom.Text) To Val(txtTo.Text)

frm1.Caption = "Processing Message No: " + Str(i)

'save_mess "http://localhost/gethtmlsource.asp", "", "", _
App.Path + "\" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + ".htm"

save_mess "http://groups.yahoo.com/group/" & txtName.Text & "/message/" & i, _
txtID.Text, txtPass.Text, _
App.Path + "\" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + ".htm"

UpdateStatus picProgress, (k / (Abs(Val(txtFrom.Text) - Val(txtTo.Text) + 1)))
k = k + 1

Next

write_footer App.Path + "\" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + ".htm"

picProgress.Cls

End Sub

Sub save_mess(Url, user_name, pass_word, file_name)

On Error Resume Next
Dim t1, tf, res

t1 = Time
objXMLHTTP.Open "GET", Url, False, user_name, pass_word

objXMLHTTP.send ""

writeToFile objXMLHTTP.responseText, file_name
tf = Time

res = Abs(Second(t1) - Second(tf))

'Debug.Print res

DoEvents

lblTime.Caption = getTotalTime(res * Abs(k - Abs(Val(txtFrom.Text) - Val(txtTo.Text))))

'Debug.Print Abs(k - Abs(Val(txtFrom.Text) - Val(txtTo.Text)))

End Sub

Sub write_header(FileName)

Dim fileno
fileno = FreeFile
Open FileName For Append As #fileno

Print #fileno, "<html>" + vbCrLf
Print #fileno, "<head>" + vbCrLf
Print #fileno, "<title>" + "messages_" & txtFrom.Text & "_to_" & txtTo.Text + "</title>" + vbCrLf
Print #fileno, "</head>" + vbCrLf

Print #fileno, "<style>"
Print #fileno, "BODY {"
Print #fileno, " SCROLLBAR-FACE-COLOR: #FF9900;"
Print #fileno, " SCROLLBAR-HIGHLIGHT-COLOR: #FF9900;"
Print #fileno, " SCROLLBAR-SHADOW-COLOR: #FF9900;"
Print #fileno, " SCROLLBAR-3DLIGHT-COLOR: #ffcc66;"
Print #fileno, " SCROLLBAR-ARROW-COLOR: #FFFFFF;"
Print #fileno, " SCROLLBAR-TRACK-COLOR: #ffcc66;"
Print #fileno, " SCROLLBAR-DARKSHADOW-COLOR: #FF9900;"
Print #fileno, " }"
Print #fileno, "</style>"

Print #fileno, "<body>" + vbCrLf

Close #fileno

End Sub

Sub write_footer(FileName)

Dim fileno
fileno = FreeFile
Open FileName For Append As #fileno

Print #fileno, "</body>" + vbCrLf
Print #fileno, "</html>" + vbCrLf

Close #fileno

End Sub

Sub writeToFile(ByVal description As String, FileName)

Dim fileno
fileno = FreeFile
Open FileName For Append As #fileno

Print #fileno, "<p>&</p>"

Print #fileno, "<table border=""1"" cellpadding=""0"" cellspacing=""0"" style=""border-collapse: collapse; font-family: Tahoma; font-size: 10pt"" bordercolor=""#FF0000"" width=""100%"" id=""AutoNumber1"" bgcolor=""#99CCFF"">"
Print #fileno, "<tr>"

Print #fileno, "<td width=""100%"">" + description + "</td>"

Print #fileno, "</tr>"
Print #fileno, "</table>"
Print #fileno, "<p>&</p>"

Close #fileno

End Sub

Private Sub cmdStart_Click()
cmdStart.Enabled = False
start_saving
cmdStart.Enabled = True
End Sub

Private Sub Form_Load()
'MsgBox getTotalTime(125 * 60)
End Sub

Private Sub Form_Unload(Cancel As Integer)

Set objXMLHTTP = Nothing

End Sub

Sub UpdateStatus(pic As PictureBox, ByVal sngPercent As Single, _
Optional ByVal fBorderCase As Boolean = False)
Dim strPercent As String
Dim intX As Integer
Dim intY As Integer
Dim intWidth As Integer
Dim intHeight As Integer

'For this to work well, we need a white background and any color foreground (blue)
Const colBackground = &HFFFFFF ' white
Const colForeground = &H800000 ' dark blue
pic.AutoRedraw = True
pic.ForeColor = colForeground
pic.BackColor = colBackground
pic.FontBold = True
'
'Format percentage and get attributes of text
'
Dim intPercent
intPercent = Int(100 * sngPercent + 0.5)

'Never allow the percentage to be 0 or 100 unless it is exactly that value. This
'prevents, for instance, the status bar from reaching 100% until we are entirely done.
If intPercent = 0 Then
If Not fBorderCase Then
intPercent = 1
End If
ElseIf intPercent = 100 Then
If Not fBorderCase Then
intPercent = 99
End If
End If

strPercent = Format$(intPercent) & "%"
intWidth = pic.TextWidth(strPercent)
intHeight = pic.TextHeight(strPercent)

'
'Now set intX and intY to the starting location for printing the percentage
'
intX = pic.Width / 2 - intWidth / 2
intY = pic.Height / 2 - intHeight / 2

'
'Need to draw a filled box with the pics background color to wipe out previous
'percentage display (if any)
'
pic.DrawMode = 13 ' Copy Pen
pic.Line (intX, intY)-Step(intWidth, intHeight), pic.BackColor, BF

'
'Back to the center print position and print the text
'
pic.CurrentX = intX
pic.CurrentY = intY
pic.Print strPercent

'
'Now fill in the box with the ribbon color to the desired percentage
'If percentage is 0, fill the whole box with the background color to clear it
'Use the "Not XOR" pen so that we change the color of the text to white
'wherever we touch it, and change the color of the background to blue
'wherever we touch it.
'
pic.DrawMode = 10 ' Not XOR Pen
If sngPercent > 0 Then
pic.Line (0, 0)-(pic.Width * sngPercent, pic.Height), pic.ForeColor, BF
Else
pic.Line (0, 0)-(pic.Width, pic.Height), pic.BackColor, BF
End If

pic.Refresh
End Sub

Function getTotalTime(m_time_seconds)

On Error Resume Next

Debug.Print vbCrLf

Dim i, m_time_minutes

m_time_minutes = m_time_seconds / 60
Debug.Print "m_time_minutes:" + Str(m_time_minutes)

Dim x As Single, m_hour As Single, m_min As Single, f_min

x = m_time_minutes / 60
Debug.Print "(m_time_minutes / 60):" + Str(x)

m_hour = Int(x)
Debug.Print "m_hour:" + Str(m_hour)

m_min = x - Int(x)
Debug.Print "m_min:" + Str(m_min)

m_min = Round(m_min * 15 / 0.25)
Debug.Print "m_min_new:" + Str(m_min)

Dim ts
ts = Abs(m_time_seconds - ((m_hour * 60) * 60) - (m_min * 60))

getTotalTime = CStr(m_hour) + ":" + Str(m_min) + ":" + Str(ts)

End Function

atefeh

یک شنبه 22 تیر 1382, 08:06 صبح

خیلی متشکرم. می بخشید اما میشه بگویید این txtFrom.Text چی است؟

Vahid_Nasiri

یک شنبه 22 تیر 1382, 15:50 عصر

عمدا نمی خواهم خود برنامه را زیپ کنم و اینجا بگذارم! :oops:

من این برنامه را برای سیو کردن پیغامهای گروه های یاهو برای خودم!! :oops: درست کرده ام ..... برای مثال از پیغام 500 تا 1500 را در یک فایل برای من ذخیره کند تا بعدا سر فرصت بتونم اونها را بخونم........