quote.frm

Knowledge manager。Storing articles,quotes..and managing them We have used a third party component A

      Left            =   120
      OleObjectBlob   =   "quote.frx":4AFCD
      TabIndex        =   6
      Top             =   1350
      Width           =   735
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel4 
      Height          =   225
      Left            =   120
      OleObjectBlob   =   "quote.frx":4B031
      TabIndex        =   7
      Top             =   2190
      Width           =   885
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel5 
      Height          =   375
      Left            =   9045
      OleObjectBlob   =   "quote.frx":4B099
      TabIndex        =   11
      Top             =   690
      Width           =   2535
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel7 
      Height          =   255
      Left            =   120
      OleObjectBlob   =   "quote.frx":4B0FD
      TabIndex        =   18
      Top             =   1785
      Width           =   870
   End
   Begin ACTIVESKINLibCtl.SkinLabel SkinLabel9 
      Height          =   270
      Left            =   1245
      OleObjectBlob   =   "quote.frx":4B165
      TabIndex        =   21
      Top             =   570
      Width           =   3750
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Check1_Click()
Dim k As Integer
k = 0
 If Check1.Value = 1 Then
    While k < List1.ListCount
        List1.Selected(k) = True
        k = k + 1
    Wend
 End If
 
 If Check1.Value = 0 Then
    While k < List1.ListCount
        List1.Selected(k) = False
        k = k + 1
    Wend
 End If
 
End Sub

Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = 45 Then
   
         combo1.AddItem InputBox("Enter the Category", "Category"), combo1.ListCount
         combo1.ListIndex = combo1.ListCount - 1
         
   
   End If
End Sub

'Private Sub Combo1_KeyPress(KeyAscii As Integer)
 '     MsgBox keyasscii
'End Sub

Private Sub Command1_Click()

If txtquote.Text = "" Or txttitle.Text = "" Then
    MsgBox "Please enter the tile and quote it cannot be blank"
    Exit Sub
End If


Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(App.Path + "\quotesmanager.mdb")
Set rs = db.OpenRecordset("select * from quotemaster")
rs.AddNew
rs.Fields(0) = txttitle
rs.Fields(1) = UCase(Trim(combo1.Text))
rs.Fields(2) = txtquote

If txtauthor = "" Then
    txtauthor = "   "
End If
rs.Fields(4) = txtauthor
If txtmsg = "" Then
    txtmsg = "   "
End If

rs.Fields(5) = txtmsg
rs.Update
rs.Close
db.Close
MsgBox "Quote successfully added"
End Sub

Private Sub Command2_Click()
Form2.Show vbModal
End Sub

Private Sub Command3_Click()
Dim varemail As String
Dim i As Integer
If txtquote = "" Or txttitle = "" Then
   MsgBox "Title and quote cannot be blank"
   Exit Sub
End If
If txtsubject = "" Then
   txtsubject = "Good thought"
End If
  
'MsgBox List1.ListCount
i = 0
While i <> List1.ListCount
 If List1.Selected(i) = True Then
       
    varemail = returnsinglestring("select email from email  where name = '" & List1.List(List1.ListIndex) & "'")
    sendMail txtquote, txtsubject, varemail
    
 End If
 i = i + 1
Wend
'sendMail txtquote, txtsubject, varemail
MsgBox "Mail successfully send"
End Sub

Private Sub Command4_Click()

combo1.ListIndex = 0
txtquote = ""
txttitle = ""
txtmsg = ""
txtauthor = " "
End Sub

Private Sub Command5_Click()
 ' Display the address book and update upon return.
   ' Call CopyNamestoMsgBuffer(Me, False)
    'Form1.MAPIMessages1.AddressEditFieldCount
    

        
    'Call UpdateRecips(Me)
    Form3.Show vbModal
   
End Sub



Private Sub Form_Load()
Skin1.ApplySkin hWnd
populatecombo "select distinct category from quotemaster order by category", combo1
populatelist "select * from email order by name", List1
 
End Sub
Public Sub formshow(varcategory As String, vartitle As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(App.Path + "\quotesmanager.mdb")
Set rs = db.OpenRecordset("select * from quotemaster where category = '" & varcategory & "' and title = '" & vartitle & "' ")
rs.MoveFirst
txttitle = rs.Fields(0)
combo1.Text = rs.Fields(1)
txtquote = rs.Fields(2)
txtauthor = IIf(IsNull(rs.Fields(4)), " ", rs.Fields(4))
txtmsg = IIf(IsNull(rs.Fields(5)), " ", rs.Fields(5))
rs.Close
db.Close

End Sub
Sub Outlook_Contacts()

    Dim ADOConn As ADODB.Connection
    Dim ADORS As ADODB.Recordset
    Dim strConn As String

    Set ADOConn = New ADODB.Connection
    Set ADORS = New ADODB.Recordset

    With ADOConn
        'Change the Connection String below to the correct settings
        .ConnectionString = "Provider=Microsoft.JET.OLEDB.4.0;Exchange 4.0;MAPILEVEL=Outlook Address Book\;PROFILE=sabir;TABLETYPE=1;DATABASE=c:\programfiles\Outlook Express"
        .Open
    End With

    With ADORS
        Set .ActiveConnection = ADOConn
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open "Select * from [Contacts]"
        .MoveFirst
        'As a test just itterate thru the first contact
        Dim i As Long
        For i = 0 To ADORS.Fields.Count - 1
            Debug.Print ADORS(i).Name + vbTab + Format(ADORS(i).Value)
        Next i
        .Close
    End With

    Set ADORS = Nothing

    ADOConn.Close
    Set ADOConn = Nothing

End Sub

Function sendMail(Msg As String, subj As String, email As String)
   ' THIS WILL OPEN YOUR DEFAULT EMAIL PROGRAM WITH THE CONTENT ENTERED IN THIS FUNCTION
   ' THE EMAIL PROGRAM MIGHT ASK IF YOU WANT TO SEND THE MESSAGE
   ' THIS BEHAVIOUR CAN BE SUPRESSED BY THE EMAIL PROGRAM ITSELF (OPTIONAL)
   
   ' THE MESSAGE ORIGINATOR WILL BE SET BY YOUR UNDERLYING EMAIL SYSTEM AUTOMATICALLY AND
   ' IS READONLY AT RUNTIME
   
   'MAPI CONSTANTS
   Const SESSION_SIGNON = 1
   Const MESSAGE_COMPOSE = 6
   Const ATTACHTYPE_DATA = 0
   Const RECIPTYPE_TO = 1
   Const RECIPTYPE_CC = 2
   Const MESSAGE_RESOLVENAME = 13
   Const MESSAGE_SEND = 3
   Const SESSION_SIGNOFF = 2

   'On Error GoTo errorHandler
   
   ' OPEN A MAPI SESSION
   MAPISession1.Action = SESSION_SIGNON
   MAPIMessages1.SessionID = MAPISession1.SessionID

   ' START A NEW MESSAGE
   MAPIMessages1.Action = MESSAGE_COMPOSE

   ' SUBJECT OF THE MESSAGE
   MAPIMessages1.MsgSubject = subj
      
   ' MESSAGE BODY
   MAPIMessages1.MsgNoteText = Msg

   ' SET THE RECIPIENT
   ' RECIPIENT NUMBER 1
   MAPIMessages1.RecipIndex = 0
   MAPIMessages1.RecipType = RECIPTYPE_TO
   MAPIMessages1.RecipDisplayName = email
   
'   ' RECIPIENT NUMBER 2
'   MAPIMessages1.RecipIndex = 1
'   MAPIMessages1.RecipType = RECIPTYPE_TO
'   MAPIMessages1.RecipDisplayName = "EMAIL ADDRESS FOR 2. RECIPIENT IN TO LINE"
'
'   ' RECIPIENT NUMBER 3
'   MAPIMessages1.RecipIndex = 2
'   MAPIMessages1.RecipType = RECIPTYPE_CC
'   MAPIMessages1.RecipDisplayName = "EMAIL ADDRESS FOR 3. RECIPIENT IN CC LINE"
'
'   ' RECIPIENT NUMBER 4
'   MAPIMessages1.RecipIndex = 3
'   MAPIMessages1.RecipType = RECIPTYPE_CC
'   MAPIMessages1.RecipDisplayName = "EMAIL ADDRESS FOR 4. RECIPIENT IN CC LINE"

   ' MESSAGE_RESOLVENAME MAKES SURE YOU ENTERED A VALID EMAIL ADDRESS
   ' PUTS IT IN MAPIMessages1.RecipAddress
   ' A TRAPPABLE ERROR WILL OCCUR WHEN EMAIL IS NOT VALID
   MAPIMessages1.Action = MESSAGE_RESOLVENAME
   
   ' SEND THE MESSAGE
   MAPIMessages1.Action = MESSAGE_SEND

   ' CLOSE MAPI MAIL SESSION
   MAPISession1.Action = SESSION_SIGNOFF
   Exit Function
   
errorHandler:
    MsgBox "message cannot be send sorry..."
End Function


Private Sub List1_DblClick()
 MsgBox returnsinglestring("select email from email  where name = '" & List1.List(List1.ListIndex) & "'"), , "Email address"
End Sub

Private Sub txttitle_KeyDown(KeyCode As Integer, Shift As Integer)
       If KeyCode = 113 Then
       
             Form2.Show vbModal
             
       End If
End Sub