Rabu, 13 November 2013
Senin, 10 Mei 2010
send sms vb6
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
Call Send_SMS(CPNumber.Text, SMSText.Text)
End Sub
Private Sub Form_Load()
On Error GoTo commErr
With MSComm1
.CommPort = 3
.Handshaking = comNone
.Settings = "9600,n,8,1"
If .PortOpen = False Then
.PortOpen = True
.DTREnable = True
.RTSEnable = True
.RThreshold = 1
.InputLen = 1
.Output = "AT" & vbCrLf
Sleep 500
.Output = "ATE0" & vbCrLf
Sleep 500
Else
MsgBox "Port Already Open"
End If
MsgBox "Connected"
Exit Sub
commErr:
If Err.Number = 8005 Then
MsgBox "Port is busy"
ElseIf Err.Number = 8002 Then
MsgBox "Invalid Port"
Exit Sub
End If
End With
End Sub
Private Function Send_SMS(ByVal Number As String, ByVal Text As String)
With MSComm1
.Output = "AT+CMGS=" & Chr(34) & Trim(Number) & Chr(34) & vbCrLf
Sleep 1000
.Output = Trim(Text) & Chr(26) & vbCrLf
Sleep 2000
If InStr(.Input, "OK") Then
MsgBox "Message Send"
Else
MsgBox "Message Not Send"
End If
End With
End Function
Private Sub Form_Unload(Cancel As Integer)
With MSComm1
If .PortOpen = True Then
.PortOpen = False
Sleep 500
End If
End
End With
End Sub
Private Sub Command1_Click()
Call Send_SMS(CPNumber.Text, SMSText.Text)
End Sub
Private Sub Form_Load()
On Error GoTo commErr
With MSComm1
.CommPort = 3
.Handshaking = comNone
.Settings = "9600,n,8,1"
If .PortOpen = False Then
.PortOpen = True
.DTREnable = True
.RTSEnable = True
.RThreshold = 1
.InputLen = 1
.Output = "AT" & vbCrLf
Sleep 500
.Output = "ATE0" & vbCrLf
Sleep 500
Else
MsgBox "Port Already Open"
End If
MsgBox "Connected"
Exit Sub
commErr:
If Err.Number = 8005 Then
MsgBox "Port is busy"
ElseIf Err.Number = 8002 Then
MsgBox "Invalid Port"
Exit Sub
End If
End With
End Sub
Private Function Send_SMS(ByVal Number As String, ByVal Text As String)
With MSComm1
.Output = "AT+CMGS=" & Chr(34) & Trim(Number) & Chr(34) & vbCrLf
Sleep 1000
.Output = Trim(Text) & Chr(26) & vbCrLf
Sleep 2000
If InStr(.Input, "OK") Then
MsgBox "Message Send"
Else
MsgBox "Message Not Send"
End If
End With
End Function
Private Sub Form_Unload(Cancel As Integer)
With MSComm1
If .PortOpen = True Then
.PortOpen = False
Sleep 500
End If
End
End With
End Sub
send email pake vb
Private Sub SendMail_Click()
Dim AOL As Long, MDI As Long, tool As Long, Toolbar As Long
Dim ToolIcon As Long, OpenSend As Long, DoIt As Long
Dim Rich As Long, EditTo As Long, EditCC As Long
Dim EditSubject As Long, SendButton As Long
Dim Combo As Long, fCombo As Long, ErrorWindow As Long
Dim Button1 As Long, Button2 As Long
AOL& = FindWindow("AOL Frame25", vbNullString)
MDI& = FindWindowEx(AOL&, 0&, "MDICLIENT", vbNullString)
tool& = FindWindowEx(AOL&, 0&, "AOL Toolbar", vbNullString)
Toolbar& = FindWindowEx(tool&, 0&, "_AOL_Toolbar", vbNullString)
ToolIcon& = FindWindowEx(Toolbar&, 0&, "_AOL_Icon", vbNullString)
ToolIcon& = FindWindowEx(Toolbar&, ToolIcon&, "_AOL_Icon", vbNullString)
Call PostMessage(ToolIcon&, WM_LBUTTONDOWN, 0&, 0&)
Call PostMessage(ToolIcon&, WM_LBUTTONUP, 0&, 0&)
DoEvents
Do
DoEvents
OpenSend& = FindWindowEx(MDI&, 0&, "AOL Child", "Write Mail")
EditTo& = FindWindowEx(OpenSend&, 0&, "_AOL_Edit", vbNullString)
EditCC& = FindWindowEx(OpenSend&, EditTo&, "_AOL_Edit", vbNullString)
EditSubject& = FindWindowEx(OpenSend&, EditCC&, "_AOL_Edit", vbNullString)
Rich& = FindWindowEx(OpenSend&, 0&, "RICHCNTL", vbNullString)
Combo& = FindWindowEx(OpenSend&, 0&, "_AOL_Combobox", vbNullString)
fCombo& = FindWindowEx(OpenSend&, 0&, "_AOL_Fontcombo", vbNullString)
Button1& = FindWindowEx(OpenSend&, 0&, "_AOL_Icon", vbNullString)
Button2& = FindWindowEx(OpenSend&, Button1&, "_AOL_Icon", vbNullString)
SendButton& = FindWindowEx(OpenSend&, 0&, "_AOL_Icon", vbNullString)
For DoIt& = 1 To 13
SendButton& = FindWindowEx(OpenSend&, SendButton&, "_AOL_Icon", vbNullString)
Next DoIt&
Loop Until OpenSend& <> 0& And EditTo& <> 0& And EditCC& <> 0& And EditSubject& <> 0& And Rich& <> 0& And SendButton& <> 0& And Combo& <> 0& And fCombo& <> 0& & SendButton& <> Button1& And SendButton& <> Button2&
Call SendMessageByString(EditTo&, WM_SETTEXT, 0, Person)
DoEvents
Call SendMessageByString(EditSubject&, WM_SETTEXT, 0, Subject)
DoEvents
Call SendMessageByString(Rich&, WM_SETTEXT, 0, Message)
DoEvents
Pause 0.2
Call SendMessage(SendButton&, WM_LBUTTONDOWN, 0&, 0&)
Call SendMessage(SendButton&, WM_LBUTTONUP, 0&, 0&)
End Sub
Dim AOL As Long, MDI As Long, tool As Long, Toolbar As Long
Dim ToolIcon As Long, OpenSend As Long, DoIt As Long
Dim Rich As Long, EditTo As Long, EditCC As Long
Dim EditSubject As Long, SendButton As Long
Dim Combo As Long, fCombo As Long, ErrorWindow As Long
Dim Button1 As Long, Button2 As Long
AOL& = FindWindow("AOL Frame25", vbNullString)
MDI& = FindWindowEx(AOL&, 0&, "MDICLIENT", vbNullString)
tool& = FindWindowEx(AOL&, 0&, "AOL Toolbar", vbNullString)
Toolbar& = FindWindowEx(tool&, 0&, "_AOL_Toolbar", vbNullString)
ToolIcon& = FindWindowEx(Toolbar&, 0&, "_AOL_Icon", vbNullString)
ToolIcon& = FindWindowEx(Toolbar&, ToolIcon&, "_AOL_Icon", vbNullString)
Call PostMessage(ToolIcon&, WM_LBUTTONDOWN, 0&, 0&)
Call PostMessage(ToolIcon&, WM_LBUTTONUP, 0&, 0&)
DoEvents
Do
DoEvents
OpenSend& = FindWindowEx(MDI&, 0&, "AOL Child", "Write Mail")
EditTo& = FindWindowEx(OpenSend&, 0&, "_AOL_Edit", vbNullString)
EditCC& = FindWindowEx(OpenSend&, EditTo&, "_AOL_Edit", vbNullString)
EditSubject& = FindWindowEx(OpenSend&, EditCC&, "_AOL_Edit", vbNullString)
Rich& = FindWindowEx(OpenSend&, 0&, "RICHCNTL", vbNullString)
Combo& = FindWindowEx(OpenSend&, 0&, "_AOL_Combobox", vbNullString)
fCombo& = FindWindowEx(OpenSend&, 0&, "_AOL_Fontcombo", vbNullString)
Button1& = FindWindowEx(OpenSend&, 0&, "_AOL_Icon", vbNullString)
Button2& = FindWindowEx(OpenSend&, Button1&, "_AOL_Icon", vbNullString)
SendButton& = FindWindowEx(OpenSend&, 0&, "_AOL_Icon", vbNullString)
For DoIt& = 1 To 13
SendButton& = FindWindowEx(OpenSend&, SendButton&, "_AOL_Icon", vbNullString)
Next DoIt&
Loop Until OpenSend& <> 0& And EditTo& <> 0& And EditCC& <> 0& And EditSubject& <> 0& And Rich& <> 0& And SendButton& <> 0& And Combo& <> 0& And fCombo& <> 0& & SendButton& <> Button1& And SendButton& <> Button2&
Call SendMessageByString(EditTo&, WM_SETTEXT, 0, Person)
DoEvents
Call SendMessageByString(EditSubject&, WM_SETTEXT, 0, Subject)
DoEvents
Call SendMessageByString(Rich&, WM_SETTEXT, 0, Message)
DoEvents
Pause 0.2
Call SendMessage(SendButton&, WM_LBUTTONDOWN, 0&, 0&)
Call SendMessage(SendButton&, WM_LBUTTONUP, 0&, 0&)
End Sub
kirim email dengan vb dengan attacment
Dim objBase64 As New Base64
Dim bTrans As Boolean
Dim m_iStage As Integer
Dim Sock As Integer
Dim RC As Integer
Dim Bytes As Integer
Dim ResponseCode As Integer
Dim path As String
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Const OFN_EXPLORER = &H80000 ' new look commdlg
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'This is for the WaitforResponse Routine
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'Dec's for the X disabling
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Const MF_BYPOSITION = &H400&
Const MF_REMOVE = &H1000&
'For MIME processing
Dim Mime As Boolean
'For Filehandling
Dim arrRecipients As Variant
Dim CurrentE As Integer
'***************************************************************
Private Sub Attachment_Click()
path = SaveDialog(Me, "*.*", "Attach File", App.path)
If path = "" Then Exit Sub
AttachmentList.AddItem path
Mime = True
AttachmentList.ListIndex = AttachmentList.ListCount - 1
End Sub
Private Sub AttachmentList_Click()
fSize = Int((FileLen(AttachmentList) / 1024) * 100 + 0.5) / 100
AttachmentList.ToolTipText = AttachmentList & " (" & fSize & " KB)"
End Sub
Private Sub AttachmentList_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For I = 1 To Data.Files.Count
If (GetAttr(Data.Files.Item(I)) And vbDirectory) = 0 Then AttachmentList.AddItem Data.Files.Item(I): Mime = True: AttachmentList.ListIndex = AttachmentList.ListCount - 1
Next I
End Sub
'***************************************************************
'Routine for arraving Data
'***************************************************************
Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048
On Error Resume Next
'A Socket is open
If Sock > 0 Then
'Receive up to 2048 chars
Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
If Bytes > 0 Then
ServerResponse = Mid$(MsgBuffer, 1, Bytes)
DataArrival = DataArrival & ServerResponse & vbCrLf
'Scrolls down the Textbox
DataArrival.SelStart = Len(DataArrival)
If bTrans Then
'Checks if the Response code is correct
If ResponseCode = Left$(MsgBuffer, 3) Then
m_iStage = m_iStage + 1
Transmit m_iStage
Else
'If the Response Code is not right reset the connection
closesocket (Sock)
Call EndWinsock
Sock = 0
Process = "The Server responds with an unexpected Response Code!"
Exit Sub
End If
End If
ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
closesocket (Sock)
Call EndWinsock
Sock = 0
End If
End If
Refresh
End Sub
Private Sub delattach_Click()
If AttachmentList.ListCount = 0 Or AttachmentList.ListIndex = -1 Then Exit Sub
tmpIndex = AttachmentList.ListIndex
AttachmentList.RemoveItem (AttachmentList.ListIndex)
If AttachmentList.ListCount = 0 Then Mime = False: Attachment.ToolTipText = "Drag & Drop your attachments here" Else If AttachmentList.ListIndex = 0 Then AttachmentList.ListIndex = tmpIndex Else AttachmentList.ListIndex = tmpIndex - 1
End Sub
Sub DisableX(frm As Form)
Dim hMenu As Long
Dim nCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
nCount = GetMenuItemCount(hMenu)
'Get rid of the Close menu and its separator
Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or MF_BYPOSITION)
'Make sure the screen updates
'our change
DrawMenuBar frm.hWnd
End Sub
Private Sub Exit_Click()
On Error Resume Next
Call Startrek
closesocket Sock
Call EndWinsock
End
End Sub
Private Sub Form_Load()
Call DisableX(Me)
End Sub
Function IsConnected2Internet() As Boolean
On Error Resume Next
'IsConnected = InternetGetConnectedState(0&, 0&) 'Doesn't work with older versions of Wininit.dll
If MyIP = "127.0.0.1" Or MyIP = "" Then IsConnected2Internet = False Else IsConnected2Internet = True
End Function
Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Form1.hWnd
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter & "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next A
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.flags = OFN_HIDEREADONLY Or OFN_CREATEPROMPT
A = GetSaveFileName(ofn)
If (A) Then
SaveDialog = Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1)
Else
SaveDialog = ""
End If
End Function
'***************************************************************
'Routine for sending a MIME Attachment
'***************************************************************
Private Sub SendMimeAttachment()
Dim FileIn As Long
Dim temp As Variant
Dim s As Variant
Dim TempArray() As Byte
Dim Encoded() As Byte
Dim strFile As String
Dim strFile1 As String * 32768
For IAT = 0 To AttachmentList.ListCount - 1
path = AttachmentList.List(IAT)
Mimefilename = Trim$(Right$(path, Len(path) - InStrRev(path, "\")))
'Gets the next free filenumber
FileIn = FreeFile
'Preparing the Mime Header
temp = vbCrLf & "--NextMimePart" & vbCrLf
temp = temp & "Content-Type: application/octet-stream; name=Mimefilename" & vbCrLf
temp = temp & "Content-Transfer-Encoding: base64" & vbCrLf
temp = temp & "Content-Disposition: attachment; filename=" & Chr$(34) & Mimefilename & Chr$(34) & vbCrLf
WinsockSendData (temp & vbCrLf)
'Open Base64 Input File
Open path For Binary Access Read As FileIn
If GetSetting(App.Title, "Settings", "Too big", "") <> "True" Then
If LOF(FileIn) > 2097152 Then
fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100
Setu = MsgBox("The current file is " & fSize & " MB of size, extracting from it could take a few minutes, Click Yes to go ahead, No to skip it or Cancel if you don't want to get this message again", vbYesNoCancel)
If Setu = vbYes Then GoTo Cont
If Setu = vbNo Then Close (FileIn): GoTo Anoth Else SaveSetting App.Title, "Settings", "Too big", "True"
End If
End If
Cont:
frm2.Visible = True
Process = "Loading """ & AttachmentList.List(IAT) & """"
Do While Not EOF(FileIn)
If LOF(FileIn) = 0 Then GoTo Anoth
Get FileIn, , strFile1
strFile = strFile & Mid$(strFile1, 1, Len(strFile1) - (Loc(FileIn) - LOF(FileIn)))
strFile1 = ""
DoEvents
frm2.Width = (3300 / 100) * (Len(strFile) * 50 / LOF(FileIn))
lblpcent = Int(Len(strFile) * 50 / LOF(FileIn)) & "%"
If Cancelflag Then Close FileIn: Exit Sub
Loop
Close FileIn
If strFile = "" Then Exit Sub
objBase64.Str2ByteArray strFile, TempArray
objBase64.EncodeB64 TempArray, Encoded
objBase64.Span 76, Encoded, TempArray
strFile = ""
s = StrConv(TempArray, vbUnicode)
For I = 1 To Len(s) Step 8192
ss = Trim$(Mid$(s, I, 8192))
tmpServerSpeed = 150 'milliseconds
Start = timeGetTime
Do
DoEvents
Loop Until timeGetTime >= Start + tmpServerSpeed * 20
WinsockSendData (ss)
frm2.Width = 1650 + (3300 / 100) * ((I + Len(ss)) * 50 / Len(s))
lblpcent = 50 + Int((I + Len(ss)) * 50 / Len(s)) & "%"
Process = "Sending " & Mimefilename & "... " & I + Len(ss) & " Bytes from " & Len(s)
DoEvents
Next I
'Send the last part of the MIME Body
Anoth:
s = ""
Next IAT
WinsockSendData (vbCrLf & "--NextMimePart--" & vbCrLf)
WinsockSendData (vbCrLf & "." & vbCrLf)
End Sub
'***************************************************************
'Routine for connecting to the server
'***************************************************************
Private Sub SendMimeConnect_Click()
' Little Error check
If Tobox = "" Or InStr(Tobox, "@") = 0 Then
MsgBox "To: Is not correct!"
Exit Sub
End If
'Check for internet connection
If IsConnected = False Then
If MsgBox("No Internet connection has been detected, check for Update anyway?", vbYesNo) = vbNo Then Exit Sub
End If
'Connect to server, port 25 (SMTP)
Sock = ConnectSock(MailServer, 25, DataArrival.hWnd)
'If an error occured close the connection and
'send an error message to the text window
If Sock = SOCKET_ERROR Then
Process = "Cannot Connect to " & MailServer & GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
Process = "Connected to " & MailServer
bTrans = True
m_iStage = 0
DataArrival = ""
ResponseCode = 220
Call WaitForResponse
End Sub
'***************************************************************
'Routine for sending a MIME txt
'***************************************************************
Sub SendMimetxt(txtFrom, txtTo, txtSubjekt, txtMail)
Dim strToSend As String
Dim strDataToSend As String
If Mime Then
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf
'Do not change this Headers
strDataToSend = strDataToSend & "Mime-Version: 1.0" & vbCrLf
strDataToSend = strDataToSend & "Content-Type: multipart/mixed; boundary=NextMimePart" & vbCrLf
strDataToSend = strDataToSend & "Content-Transfer-Encoding: 7bit" & vbCrLf
strDataToSend = strDataToSend & "This is a multi-part message in MIME format." & vbCrLf & vbCrLf
strDataToSend = strDataToSend & "--NextMimePart" & vbCrLf & vbCrLf
'Header plus Message
strDataToSend = strDataToSend & Trim$(Mailtxt)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
'Send the Mime Header and the Message
'send message body in steps in case it is too large
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
'Call Attachment Routine
SendMimeAttachment
Else
'Send the E-Mail without Attachment
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf & vbCrLf
strDataToSend = strDataToSend & Trim$(txtMail)
'The following line is necessary in order to be able to send
'a dot on a single line without confusing the server
'(Very Important, otherwise the email might get truncated)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
'send message body in steps in case it is too large
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
'Send Data and finish it!
WinsockSendData (vbCrLf & "." & vbCrLf)
End If
End Sub
Sub Startrek()
On Error Resume Next
Dim Rate As Integer
Dim Rate2 As Integer
If WindowState <> 0 Then Exit Sub 'Windowstate = 0
Caption = "End Transmission"
GotoVal = (Height / 12)
Rate = 50 'Initial value
For Gointo = 1 To GotoVal
Spd = Timer
Rate2 = Rate / 2
Height = Height - Rate
Top = Top + Rate2 '(Screen.Height - Height) \ 2
DoEvents
Width = Width - Rate
Left = Left + Rate2 '(Screen.Width - Width) \ 2
DoEvents
If Width <= 2000 Then Exit For
Rate = (Timer - Spd) * 10000
Next Gointo
WindowState = 1 'Minimize before disappearing
End Sub
Private Sub Tobox_Change()
arrRecipients = Split(Tobox, ",")
End Sub
'***************************************************************
'Sends the E-Mail
'***************************************************************
Private Sub Transmit(iStage As Integer)
Dim Helo As String
Dim pos As Integer
Select Case m_iStage
Case 1
Helo = Frombox
pos = Len(Helo) - InStr(Helo, "@")
Helo = Right$(Helo, pos)
ResponseCode = 250
WinsockSendData ("HELO " & Helo & vbCrLf)
Call WaitForResponse
Case 2
ResponseCode = 250
WinsockSendData ("MAIL FROM: <" & Trim$(Frombox) & ">" & vbCrLf)
Call WaitForResponse
Case 3
ResponseCode = 250
WinsockSendData ("RCPT TO: <" & Trim$(arrRecipients(CurrentE)) & ">" & vbCrLf)
Call WaitForResponse
Case 4
ResponseCode = 354
WinsockSendData ("DATA" & vbCrLf)
Call WaitForResponse
Case 5
' Calls the routine to send the Header
ResponseCode = 250
Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt)
Call WaitForResponse
'Finish the E-Mail sending process
Case 6
ResponseCode = 221
WinsockSendData ("QUIT" & vbCrLf)
Call WaitForResponse
Process = "email terkirim uy!"
frm2.Width = 3300
lblpcent = "100%"
DataArrival = ""
m_iStage = 0
If arrRecipients(CurrentE + 1) <> "" Then
CurrentE = CurrentE + 1
SendMimeConnect_Click
Else
bTrans = False
CurrentE = 0
End If
End Select
End Sub
'**************************************************************
'NEW! Waits until time out, while waiting for response
'**************************************************************
Private Sub WaitForResponse()
Dim Start As Long
Dim Tmr As Long
'Works with an Api Declaration because it's more presice
Start = timeGetTime
While Bytes > 0
Tmr = timeGetTime - Start
DoEvents
If Tmr > 20000 Then
Process = "SMTP service error, timed out while waiting for response"
End If
Wend
End Sub
Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer
Dim MsgBuffer As String * 8192
MsgBuffer = DatatoSend
RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)
If RC = SOCKET_ERROR Then
Process = "Cannot Send Request." & Str$(WSAGetLastError()) & _
GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
End Sub
Dim bTrans As Boolean
Dim m_iStage As Integer
Dim Sock As Integer
Dim RC As Integer
Dim Bytes As Integer
Dim ResponseCode As Integer
Dim path As String
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Const OFN_EXPLORER = &H80000 ' new look commdlg
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'This is for the WaitforResponse Routine
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'Dec's for the X disabling
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Const MF_BYPOSITION = &H400&
Const MF_REMOVE = &H1000&
'For MIME processing
Dim Mime As Boolean
'For Filehandling
Dim arrRecipients As Variant
Dim CurrentE As Integer
'***************************************************************
Private Sub Attachment_Click()
path = SaveDialog(Me, "*.*", "Attach File", App.path)
If path = "" Then Exit Sub
AttachmentList.AddItem path
Mime = True
AttachmentList.ListIndex = AttachmentList.ListCount - 1
End Sub
Private Sub AttachmentList_Click()
fSize = Int((FileLen(AttachmentList) / 1024) * 100 + 0.5) / 100
AttachmentList.ToolTipText = AttachmentList & " (" & fSize & " KB)"
End Sub
Private Sub AttachmentList_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For I = 1 To Data.Files.Count
If (GetAttr(Data.Files.Item(I)) And vbDirectory) = 0 Then AttachmentList.AddItem Data.Files.Item(I): Mime = True: AttachmentList.ListIndex = AttachmentList.ListCount - 1
Next I
End Sub
'***************************************************************
'Routine for arraving Data
'***************************************************************
Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048
On Error Resume Next
'A Socket is open
If Sock > 0 Then
'Receive up to 2048 chars
Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
If Bytes > 0 Then
ServerResponse = Mid$(MsgBuffer, 1, Bytes)
DataArrival = DataArrival & ServerResponse & vbCrLf
'Scrolls down the Textbox
DataArrival.SelStart = Len(DataArrival)
If bTrans Then
'Checks if the Response code is correct
If ResponseCode = Left$(MsgBuffer, 3) Then
m_iStage = m_iStage + 1
Transmit m_iStage
Else
'If the Response Code is not right reset the connection
closesocket (Sock)
Call EndWinsock
Sock = 0
Process = "The Server responds with an unexpected Response Code!"
Exit Sub
End If
End If
ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
closesocket (Sock)
Call EndWinsock
Sock = 0
End If
End If
Refresh
End Sub
Private Sub delattach_Click()
If AttachmentList.ListCount = 0 Or AttachmentList.ListIndex = -1 Then Exit Sub
tmpIndex = AttachmentList.ListIndex
AttachmentList.RemoveItem (AttachmentList.ListIndex)
If AttachmentList.ListCount = 0 Then Mime = False: Attachment.ToolTipText = "Drag & Drop your attachments here" Else If AttachmentList.ListIndex = 0 Then AttachmentList.ListIndex = tmpIndex Else AttachmentList.ListIndex = tmpIndex - 1
End Sub
Sub DisableX(frm As Form)
Dim hMenu As Long
Dim nCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
nCount = GetMenuItemCount(hMenu)
'Get rid of the Close menu and its separator
Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or MF_BYPOSITION)
'Make sure the screen updates
'our change
DrawMenuBar frm.hWnd
End Sub
Private Sub Exit_Click()
On Error Resume Next
Call Startrek
closesocket Sock
Call EndWinsock
End
End Sub
Private Sub Form_Load()
Call DisableX(Me)
End Sub
Function IsConnected2Internet() As Boolean
On Error Resume Next
'IsConnected = InternetGetConnectedState(0&, 0&) 'Doesn't work with older versions of Wininit.dll
If MyIP = "127.0.0.1" Or MyIP = "" Then IsConnected2Internet = False Else IsConnected2Internet = True
End Function
Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Form1.hWnd
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter & "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next A
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.flags = OFN_HIDEREADONLY Or OFN_CREATEPROMPT
A = GetSaveFileName(ofn)
If (A) Then
SaveDialog = Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1)
Else
SaveDialog = ""
End If
End Function
'***************************************************************
'Routine for sending a MIME Attachment
'***************************************************************
Private Sub SendMimeAttachment()
Dim FileIn As Long
Dim temp As Variant
Dim s As Variant
Dim TempArray() As Byte
Dim Encoded() As Byte
Dim strFile As String
Dim strFile1 As String * 32768
For IAT = 0 To AttachmentList.ListCount - 1
path = AttachmentList.List(IAT)
Mimefilename = Trim$(Right$(path, Len(path) - InStrRev(path, "\")))
'Gets the next free filenumber
FileIn = FreeFile
'Preparing the Mime Header
temp = vbCrLf & "--NextMimePart" & vbCrLf
temp = temp & "Content-Type: application/octet-stream; name=Mimefilename" & vbCrLf
temp = temp & "Content-Transfer-Encoding: base64" & vbCrLf
temp = temp & "Content-Disposition: attachment; filename=" & Chr$(34) & Mimefilename & Chr$(34) & vbCrLf
WinsockSendData (temp & vbCrLf)
'Open Base64 Input File
Open path For Binary Access Read As FileIn
If GetSetting(App.Title, "Settings", "Too big", "") <> "True" Then
If LOF(FileIn) > 2097152 Then
fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100
Setu = MsgBox("The current file is " & fSize & " MB of size, extracting from it could take a few minutes, Click Yes to go ahead, No to skip it or Cancel if you don't want to get this message again", vbYesNoCancel)
If Setu = vbYes Then GoTo Cont
If Setu = vbNo Then Close (FileIn): GoTo Anoth Else SaveSetting App.Title, "Settings", "Too big", "True"
End If
End If
Cont:
frm2.Visible = True
Process = "Loading """ & AttachmentList.List(IAT) & """"
Do While Not EOF(FileIn)
If LOF(FileIn) = 0 Then GoTo Anoth
Get FileIn, , strFile1
strFile = strFile & Mid$(strFile1, 1, Len(strFile1) - (Loc(FileIn) - LOF(FileIn)))
strFile1 = ""
DoEvents
frm2.Width = (3300 / 100) * (Len(strFile) * 50 / LOF(FileIn))
lblpcent = Int(Len(strFile) * 50 / LOF(FileIn)) & "%"
If Cancelflag Then Close FileIn: Exit Sub
Loop
Close FileIn
If strFile = "" Then Exit Sub
objBase64.Str2ByteArray strFile, TempArray
objBase64.EncodeB64 TempArray, Encoded
objBase64.Span 76, Encoded, TempArray
strFile = ""
s = StrConv(TempArray, vbUnicode)
For I = 1 To Len(s) Step 8192
ss = Trim$(Mid$(s, I, 8192))
tmpServerSpeed = 150 'milliseconds
Start = timeGetTime
Do
DoEvents
Loop Until timeGetTime >= Start + tmpServerSpeed * 20
WinsockSendData (ss)
frm2.Width = 1650 + (3300 / 100) * ((I + Len(ss)) * 50 / Len(s))
lblpcent = 50 + Int((I + Len(ss)) * 50 / Len(s)) & "%"
Process = "Sending " & Mimefilename & "... " & I + Len(ss) & " Bytes from " & Len(s)
DoEvents
Next I
'Send the last part of the MIME Body
Anoth:
s = ""
Next IAT
WinsockSendData (vbCrLf & "--NextMimePart--" & vbCrLf)
WinsockSendData (vbCrLf & "." & vbCrLf)
End Sub
'***************************************************************
'Routine for connecting to the server
'***************************************************************
Private Sub SendMimeConnect_Click()
' Little Error check
If Tobox = "" Or InStr(Tobox, "@") = 0 Then
MsgBox "To: Is not correct!"
Exit Sub
End If
'Check for internet connection
If IsConnected = False Then
If MsgBox("No Internet connection has been detected, check for Update anyway?", vbYesNo) = vbNo Then Exit Sub
End If
'Connect to server, port 25 (SMTP)
Sock = ConnectSock(MailServer, 25, DataArrival.hWnd)
'If an error occured close the connection and
'send an error message to the text window
If Sock = SOCKET_ERROR Then
Process = "Cannot Connect to " & MailServer & GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
Process = "Connected to " & MailServer
bTrans = True
m_iStage = 0
DataArrival = ""
ResponseCode = 220
Call WaitForResponse
End Sub
'***************************************************************
'Routine for sending a MIME txt
'***************************************************************
Sub SendMimetxt(txtFrom, txtTo, txtSubjekt, txtMail)
Dim strToSend As String
Dim strDataToSend As String
If Mime Then
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf
'Do not change this Headers
strDataToSend = strDataToSend & "Mime-Version: 1.0" & vbCrLf
strDataToSend = strDataToSend & "Content-Type: multipart/mixed; boundary=NextMimePart" & vbCrLf
strDataToSend = strDataToSend & "Content-Transfer-Encoding: 7bit" & vbCrLf
strDataToSend = strDataToSend & "This is a multi-part message in MIME format." & vbCrLf & vbCrLf
strDataToSend = strDataToSend & "--NextMimePart" & vbCrLf & vbCrLf
'Header plus Message
strDataToSend = strDataToSend & Trim$(Mailtxt)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
'Send the Mime Header and the Message
'send message body in steps in case it is too large
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
'Call Attachment Routine
SendMimeAttachment
Else
'Send the E-Mail without Attachment
strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf & vbCrLf
strDataToSend = strDataToSend & Trim$(txtMail)
'The following line is necessary in order to be able to send
'a dot on a single line without confusing the server
'(Very Important, otherwise the email might get truncated)
strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)
'send message body in steps in case it is too large
For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)
frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I
'Send Data and finish it!
WinsockSendData (vbCrLf & "." & vbCrLf)
End If
End Sub
Sub Startrek()
On Error Resume Next
Dim Rate As Integer
Dim Rate2 As Integer
If WindowState <> 0 Then Exit Sub 'Windowstate = 0
Caption = "End Transmission"
GotoVal = (Height / 12)
Rate = 50 'Initial value
For Gointo = 1 To GotoVal
Spd = Timer
Rate2 = Rate / 2
Height = Height - Rate
Top = Top + Rate2 '(Screen.Height - Height) \ 2
DoEvents
Width = Width - Rate
Left = Left + Rate2 '(Screen.Width - Width) \ 2
DoEvents
If Width <= 2000 Then Exit For
Rate = (Timer - Spd) * 10000
Next Gointo
WindowState = 1 'Minimize before disappearing
End Sub
Private Sub Tobox_Change()
arrRecipients = Split(Tobox, ",")
End Sub
'***************************************************************
'Sends the E-Mail
'***************************************************************
Private Sub Transmit(iStage As Integer)
Dim Helo As String
Dim pos As Integer
Select Case m_iStage
Case 1
Helo = Frombox
pos = Len(Helo) - InStr(Helo, "@")
Helo = Right$(Helo, pos)
ResponseCode = 250
WinsockSendData ("HELO " & Helo & vbCrLf)
Call WaitForResponse
Case 2
ResponseCode = 250
WinsockSendData ("MAIL FROM: <" & Trim$(Frombox) & ">" & vbCrLf)
Call WaitForResponse
Case 3
ResponseCode = 250
WinsockSendData ("RCPT TO: <" & Trim$(arrRecipients(CurrentE)) & ">" & vbCrLf)
Call WaitForResponse
Case 4
ResponseCode = 354
WinsockSendData ("DATA" & vbCrLf)
Call WaitForResponse
Case 5
' Calls the routine to send the Header
ResponseCode = 250
Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt)
Call WaitForResponse
'Finish the E-Mail sending process
Case 6
ResponseCode = 221
WinsockSendData ("QUIT" & vbCrLf)
Call WaitForResponse
Process = "email terkirim uy!"
frm2.Width = 3300
lblpcent = "100%"
DataArrival = ""
m_iStage = 0
If arrRecipients(CurrentE + 1) <> "" Then
CurrentE = CurrentE + 1
SendMimeConnect_Click
Else
bTrans = False
CurrentE = 0
End If
End Select
End Sub
'**************************************************************
'NEW! Waits until time out, while waiting for response
'**************************************************************
Private Sub WaitForResponse()
Dim Start As Long
Dim Tmr As Long
'Works with an Api Declaration because it's more presice
Start = timeGetTime
While Bytes > 0
Tmr = timeGetTime - Start
DoEvents
If Tmr > 20000 Then
Process = "SMTP service error, timed out while waiting for response"
End If
Wend
End Sub
Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer
Dim MsgBuffer As String * 8192
MsgBuffer = DatatoSend
RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)
If RC = SOCKET_ERROR Then
Process = "Cannot Send Request." & Str$(WSAGetLastError()) & _
GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If
End Sub
Langganan:
Postingan (Atom)