• Home
 · 
• Internet/HTML
 · 
• SendBugReport NEW ROUTINE ADDED

SendBugReport NEW ROUTINE ADDED

Do you ever want to have a easy possibility to get in contact with your users? Here it is! You just have to add the form to your projekt and config it before you compile your projekt! Your users just have to write their comment or bug report in a textbox and hit the send button. You will love this!
I ADDED A NEW ROUTINE TO PREVENT TIMEOUTS!!

Inputs
You must config it (before you compile it) with your personal data, like: E-Mail Adress E-Mail Server Subjekt Line ...etc. See the code section for more info's

Assumes
Just copy the code below and paste it in the notepad! Save it as SendBug.frm and and add it to your projekt...

Returns
It send an E-Mail after you hit the Send Button!

Side Effects
Mail me if you find any!

Rate SendBugReport NEW ROUTINE ADDED

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'Save it as SendBug.frm and compile it!
'-------------------8< Cut here ---------------------------------------
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
  BorderStyle   =  0 'Kein
  Caption     =  "Send Bug Report"
  ClientHeight  =  3195
  ClientLeft   =  0
  ClientTop    =  0
  ClientWidth   =  4680
  LinkTopic    =  "Form1"
  MaxButton    =  0  'False
  MinButton    =  0  'False
  ScaleHeight   =  3195
  ScaleWidth   =  4680
  StartUpPosition =  2 'Bildschirmmitte
  Begin MSWinsockLib.Winsock Winsock1 
   Left      =  120
   Top       =  120
   _ExtentX    =  741
   _ExtentY    =  741
   _Version    =  393216
  End
  Begin VB.CommandButton Exit 
   Caption     =  "Exit"
   Height     =  255
   Left      =  2280
   TabIndex    =  2
   Top       =  2880
   Width      =  2295
  End
  Begin VB.CommandButton Connect 
   Caption     =  "Send Bug Report"
   Height     =  255
   Left      =  120
   TabIndex    =  1
   Top       =  2880
   Width      =  2055
  End
  Begin VB.TextBox Bugreporttxt 
   Height     =  2655
   Left      =  120
   MultiLine    =  -1 'True
   TabIndex    =  0
   Top       =  120
   Width      =  4455
  End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private bTrans As Boolean
Private m_iStage As Integer
Private strData As String
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'CHANGE THIS SETTING LIKE YOU NEED IT
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Private Const mailserver As String = "your-mail-server.com"
Private Const Tobox As String = "[email protected]"
Private Const Frombox As String = "[email protected]"
Private Const Subject As String = "Heading of the E-Mail send to you!"

'***************************************************************
'Routine for connecting to the server
'***************************************************************
Private Sub Connect_Click()
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.LocalPort = 0
Winsock1.Protocol = sckTCPProtocol
Winsock1.Connect mailserver, "25"
bTrans = True
m_iStage = 0
strData = ""
Call WaitForResponse
End Sub
'***************************************************************
'Transmit the E-Mail
'***************************************************************
Private Sub Transmit(iStage As Integer)
Dim Helo As String, temp As String
Dim pos As Integer
Select Case m_iStage
Case 1:
Helo = Frombox
pos = Len(Helo) - InStr(Helo, "@")
Helo = Right$(Helo, pos)
Winsock1.SendData "HELO " & Helo & vbCrLf
strData = ""
Call WaitForResponse
Case 2:
Winsock1.SendData "MAIL FROM: <" & Trim(Frombox) & ">" & vbCrLf
Call WaitForResponse
Case 3:
Winsock1.SendData "RCPT TO: <" & Trim(Tobox) & ">" & vbCrLf
Call WaitForResponse
Case 4:
Winsock1.SendData "DATA" & vbCrLf
Call WaitForResponse
Case 5:
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'If you want additional Headers like Date,Message-Id,...etc. !
'simply add them below                   !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
temp = temp & "From: " & Frombox & vbNewLine
temp = temp & "To: " & Tobox & vbNewLine
temp = temp & "Subject: " & Subject & vbNewLine
'Header + Message
temp = temp & vbCrLf & Bugreporttxt.Text
'Send the Message & close connection
Winsock1.SendData temp
Winsock1.SendData vbCrLf & "." & vbCrLf
m_iStage = 0
bTrans = False
Call WaitForResponse
End Select
End Sub
'***************************************************************
'Routine for Winsock Errors
'***************************************************************
Private Sub Winsock1_Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Error:" & Description, vbOKOnly, "Winsock Error!" ' Show error message
If Winsock1.State <> sckClosed Then
Winsock1.Close
End If
End Sub
'***************************************************************
'Routine for arraving Data
'***************************************************************
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim messagesent As String

On Error Resume Next
Winsock1.GetData strData, vbString
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!If you have problems with sending the E-Mail, you should   !
'!activate the line below and add a Textbox txtStatus, to   !
'!see the Server's response                  !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'txtStatus.Text = txtStatus.Text & strData
If bTrans Then
m_iStage = m_iStage + 1
Transmit m_iStage
Else
  If Winsock1.State <> sckClosed Then Winsock1.Close
  messagesent = MsgBox("Bug report sent! Hit exit to end program.", vbOKOnly, "Bug Report")
End If
End Sub
'**************************************************************
'NEW! Waits until time out, while waiting for response
'**************************************************************
Sub WaitForResponse()
Dim Start As Long
Dim Tmr As Long
Start = Timer
While Len(strData) = 0
  Tmr = Timer - Start
  DoEvents ' Let System keep checking for incoming response
    
  'Wait 50 seconds for response
  If Tmr > 50 Then
    MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
    strData = ""
    End
  End If
Wend
End Sub
Private Sub Exit_Click()
On Error Resume Next
If Winsock1.State <> sckClosed Then Winsock1.Close
End
End Sub