misc.bas

VB做滴邮件收发系统,喜欢的朋友可以下载看看学习参考哈

Attribute VB_Name = "Misc"

'--------------------------------------------------------------------------

Option Explicit

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As Any, ByVal lsString As Any, ByVal lplFilename As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Mails() As Mail

Public Type Attachments
    Name    As String
    Data()  As String
End Type

Public Type Mail
    Header           As String
    from             As String
    To               As String
    Date             As String
    Subject          As String
    Message          As String 'Plain Text Message
    HTMLMessage      As String 'HTML Message Part
    Size             As Long
    AttachedFiles    As Integer
    Attachments() As Attachments
End Type

Public strlines()          As String
Public strLine()           As String
Public tmpAttachmntStr     As String
Public AttachmentCounter   As Integer

'Declarations for very fast String Array Routines
Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (dest As Any, Source As Any, _
        ByVal numBytes As Long)
Declare Sub ZeroMemory Lib "kernel32" Alias _
        "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)

'Base64 Class
Public pbBuffer1() As Byte
Public pbBuffer2() As Byte
Public ptSpan()    As String

'Class for the multi language support
Global cLanguage As New clsLanguagePack

'Prevent the showing of the right click Internet Explorer window
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    
Public Const WM_RBUTTONUP = &H205
Public Const WH_MOUSE = 7

Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
    
Public gLngMouseHook As Long
    
Public Function MouseHookProc(ByVal nCode As Long, ByVal wParam As Long, mhs As MOUSEHOOKSTRUCT) As Long
Dim strBuffer As String
Dim strClassName As String
Dim lngResult As Long

If (nCode >= 0 And wParam = WM_RBUTTONUP) Then

        'Preinitialize string
        strBuffer = Space(255)
        
       ' lngBufferLen = Len(strBuffer)
        
        'This is the string that holds the class name that we are looking for
        strClassName = "Internet Explorer_Server"
        
        'Debug.Print strClassName
        
        'Get the classname for the Window that has been clicked, making sure something is returned
        'If the function returns 0, it has failed
        lngResult = GetClassName(mhs.hwnd, strBuffer, Len(strBuffer))
                
        'Debug.Print Left$(strBuffer, lngResult)
                
        If lngResult > 0 Then

            'Check to see if the class of the window we clicked on is the same as above
            If Left$(strBuffer, lngResult) = strClassName Then
                
                'Value is the same. Squash the command
                MouseHookProc = 1
                
                Exit Function
                
            End If
            
        End If

    End If

MouseHookProc = CallNextHookEx(gLngMouseHook, nCode, wParam, mhs)
End Function

Public Function CheckExistence(Pclist As ComboBox, Data As String) As Boolean
Dim Counter As Integer

For Counter = 0 To Pclist.ListCount
    If Pclist.List(Counter) = Data Then
        CheckExistence = True
        Exit Function
    End If
Next Counter

End Function

Function SaveIni(KeySection As String, strKey As String, KeyValue As String)

  Dim lngResult As Long
  Dim strFilename

    strFilename = App.Path & "\Pop3Popper.ini" 'Declare your ini file !
    lngResult = WritePrivateProfileString(KeySection, strKey, KeyValue, strFilename)

    SaveIni = lngResult

End Function

Function LoadIni(KeySection As String, strKey As String)
    
    Dim lngResult As Long
    Dim strFilename As String
    Dim strResult As String * 100
    Dim KeyValue As String
    
    strFilename = App.Path & "\Pop3Popper.ini" 'Declare your ini file !
    
    lngResult = GetPrivateProfileString(KeySection, _
                strKey, "", strResult, Len(strResult), _
                strFilename)
    
    If lngResult = 0 Then
        'An error has occurred
        LoadIni = ""
    Else
        KeyValue = Trim(strResult)
        KeyValue = Replace(KeyValue, Chr(0), "")
        LoadIni = KeyValue
    End If
    
End Function

'Glue several lines together that belong together
Public Function UnfoldArray(fromLine As Long, toLine As Long, ByRef FoldedArray() As String) As String()
Dim Counter As Integer, UCounter As Integer
Dim strHeader As String
Dim TempArray() As String

On Error GoTo error


'Extract only the Mime Headers
ReDim TempArray(toLine - fromLine)

For Counter = fromLine To toLine
    TempArray(UCounter) = FoldedArray(Counter)
    UCounter = UCounter + 1
Next

strHeader = Join(TempArray, vbCrLf)

'Hmm I try to unfold the Mail Header...
strHeader = Replace(strHeader, vbCrLf + Chr$(9), " ")
strHeader = Replace(strHeader, vbCrLf + Chr$(11), " ")
strHeader = Replace(strHeader, vbCrLf + Chr$(32), " ")
strHeader = Replace(strHeader, vbCrLf + Chr$(255), " ")

UnfoldArray = Split(strHeader, vbCrLf)

error:

End Function

'Returns the Line that contains a String (reversed for speed reasons)
Public Function RevfindEmptyLine(ByRef strLine() As String) As Long
Dim Counter As Long
Dim TmpLngt As Long
Dim TmpString As String

On Error GoTo error

TmpLngt = UBound(strLine)
Counter = TmpLngt


    Do
        Counter = Counter - 1
            
        TmpString = strLine(Counter + 1)
        
       
        
            If TmpString = "" Then
                RevfindEmptyLine = Counter + 1
                Exit Function
            
        End If
    
            
    Loop Until Counter = 0
    
error:
    RevfindEmptyLine = -1
End Function

'Finds a line that only contain one Crlf
Public Function findEmptyLine(intPosition As Long, ByRef strlines() As String) As Long

  Dim Counter As Long
  Dim TmpLngt As Long
  Dim strTemp As String

    On Error GoTo error

    If intPosition < 0 Then
        findEmptyLine = -1
        Exit Function
    End If

    TmpLngt = UBound(strlines)

    Do
        Counter = Counter + 1
        strTemp = strlines(intPosition + Counter - 1)
    Loop Until Counter = TmpLngt Or Len(strTemp) = 0

    If strlines(intPosition + Counter - 1) = "" Then
        findEmptyLine = intPosition + Counter - 1
      Else
error:
        findEmptyLine = -1
    End If

End Function

'Returns the Line of an array that contains a String
Public Function findLine(intPosition As Long, SearchStr As String, strlines() As String, Optional IgnoreInstrWord As Boolean) As Long

  Dim Counter As Long
  Dim TmpLngt As Long
  Dim TmpLngt2 As Long

    On Error GoTo error

    TmpLngt = UBound(strlines)
    Counter = Counter + intPosition

    If Counter >= TmpLngt Then
        GoTo error
    End If

    Do
        Counter = Counter + 1

        Select Case IgnoreInstrWord
            Case False
                TmpLngt2 = InStrWord(strlines(Counter - 1), SearchStr)
            Case True
                TmpLngt2 = InStr(strlines(Counter - 1), SearchStr)
        End Select
        

        If TmpLngt2 > 0 Then
            findLine = Counter - 1

            Exit Function
        End If

    Loop Until Counter = TmpLngt

error:
    findLine = -1

End Function

'Get the Value from an E-Mail Header
Public Function GetInfo(intPosition As Long, SearchStr As String, ByRef strlines() As String) As String

  Dim strTemp As String
  Dim strValue As String
  Dim Counter As Integer
  Dim StartPosi As Integer
  Dim Counter2 As Integer
  Dim strarray As String

    On Error GoTo error

    strarray = strlines(intPosition)
    StartPosi = InStr(LCase$(strarray), SearchStr) + Len(SearchStr)

    Do
        strValue = strValue + strTemp
        strTemp = Mid$(strarray, StartPosi + Counter, 1)
        Counter = Counter + 1
        Counter2 = Len(strarray)
    Loop Until strTemp = vbCrLf Or Counter = Counter2

    'Remove the ""
    If Left$(strValue, 1) = Chr$(34) Then strValue = Right$(strValue, Len(strValue) - 1)
    If Right$(strValue, 1) = Chr$(34) Then strValue = Left$(strValue, Len(strValue) - 1)