درسته! چون اون رو من خودم نوشتم!
به این صورت : :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
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول