PC Professionell 1999 October/PCpro_1999_10.ISO/Tools/wwmfix/Source/Module1.bas

BASIC Source File | 1998-07-28 | 8.5 KB | 259 lines

Attribute VB_Name = "Module1"
Option Explicit

Public Const Title = "MailFix"

Public Const MailFixIni = "MailFix.ini"
Public Const MailFixRoot = "MailFix.Root"

Public Const IniEntryMaxLen = 32000

Public Const SectName = "Name"
Public Const SectAdr = "Adresse"
Public Const SectSubj = "Betreff"
Public Const SectText = "Nachricht"

Public Const cMsgInvalidChar = "Der Name darf die Zeichen \ / : * ? '' < > | nicht enthalten!"

Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function fCreateShellLink Lib "vb5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long

Public Param() As String
Public LocOptIdx As Integer
Public NewLinkName As String
Public InvalidChars As String

Sub Main()
    InvalidChars = "\/:*?<>|" + Chr$(34)
    If Dir(App.Path + "\" + MailFixRoot) = "" Then
        GetParams
        CreateMail
    Else
        Form2.Caption = Title + " - Neue Verknⁿpfung erstellen"
        Form2.Show
    End If
End Sub

Sub MakeLink()
Dim StoragePath As String
Dim MailFixExePath As String
Dim LinkLocation As String
Dim rc As Long
    Randomize Timer
    Do
        StoragePath = App.Path + "\" + Right("0000000" + Hex(Rnd * (2 ^ 31)), 8)
    Loop Until Dir(StoragePath, vbDirectory) = ""
    MkDir StoragePath
    MailFixExePath = StoragePath + "\" + App.EXEName + ".exe"
    FileCopy App.Path + "\" + App.EXEName + ".exe", MailFixExePath
    If LocOptIdx Then 'Desktop
        LinkLocation = "..\..\desktop"
    Else 'Sendto
        LinkLocation = "..\..\sendto"
    End If
    rc = fCreateShellLink(LinkLocation, NewLinkName, MailFixExePath, "")
    End
End Sub

Sub CreateMail() '*** BEGINNE NEUE MAIL UND ZEIGE DIALOG
Dim i As Long
Dim DateiName As String
Dim DateiNameLang As String
Dim TempAnhangListe As String
    '*** Form vorbereiten
    ReadMailfixData
    Form1.Caption = Title + " - Nachricht erstellen"
    Form1.Show
    '*** Session er÷ffnen
    Form1.MAPISession1.SignOn
    With Form1.MAPIMessages1
        .SessionID = Form1.MAPISession1.SessionID
        '*** Neue Nachricht beginnen
        .Compose
        '*** Alle per DND ⁿbergebenen Dateien anhΣngen
         For i = 1 To UBound(Param)
             DateiName = Param(i) 'Name mit Pfad in Kurzformat
             DateiNameLang = Dir(DateiName) 'Name ohne Pfad im Langformat
             If Len(DateiNameLang) Then  'Nur Dateien erlauben
                .AttachmentIndex = i - 1    'Att.-Idx setzen
                .AttachmentPathName = DateiName  'Position der Datei auf Platte
                .AttachmentName = DateiNameLang  'Name fⁿr Anzeige in Mail
                TempAnhangListe = TempAnhangListe & i & ": " & DateiNameLang 'Liste fⁿr Dialog
                If i < UBound(Param) Then TempAnhangListe = TempAnhangListe & vbCr & vbLf
                .AttachmentType = mapData 'Typ festlegen: alle echte Dateien, keine LInks
             Else
                '*** Fehlermeldung, falls ein Verz. unter den Attachm. ist
                MsgBox "Verzeichnisse wie '" + Dir(DateiName, vbDirectory) + "'k÷nnen nicht an eine Nachricht angehΣngt werden.", vbExclamation, Title
            End If
        Next
        Form1.Anhang.Text = TempAnhangListe 'Att.-Liste an Dialog ⁿbergeben
    End With
    ChkSendButtonConditions
    '*** Danach Steuerⁿbergabe an den Dialog
    '*** nach Klick auf [SENDEN] geht bei SendMail weiter....

End Sub

Sub SendMail() '*** MAIL-DATEN ▄BERNEHMEN UND SENDEN
Dim MailAdresse As String
Dim MailName As String
    With Form1.MAPIMessages1
        '*** EmpfΣngerdaten in Obj. ⁿbernehmen
        .RecipType = mapToList '->TO:
        .AddressResolveUI = False
        MailAdresse = Trim(Form1.EmpfAdr.Text)
        MailName = Trim(Form1.EmpfName.Text)
        If MailName = "" Then 'Kein Name?
            .RecipDisplayName = MailAdresse  'Dann Adresse als Name verw.
        Else
            .RecipDisplayName = MailName '... sonst eben den Namen ⁿbern.
            If MailAdresse = "" Then 'Keine Adresse?
                .AddressResolveUI = True 'Dann vom Adressbuch auswerten lassen
                On Local Error GoTo ResolveError 'Evtl. Fehler ausweichen
                .ResolveName
                On Local Error GoTo 0
            Else
                .RecipAddress = MailAdresse 'Adresse war von Anw. gegeben
            End If
        End If
        .MsgSubject = Trim(Form1.Betreff.Text) 'Betreff ⁿbergeben und auch
        .MsgNoteText = Trim(Form1.Nachricht.Text) ' den Nachrichtentext
        '*** Ab damit und zwar direkt ohne zus. Dialog
        .Send False
        WriteMailfixData
        '*** Sitzung schlie▀en und Prg beenden
    End With
    End
ResolveError:
    Resume Next
End Sub

Sub ChkSendButtonConditions()
    With Form1
        .Command1(0).Enabled = Trim(.EmpfAdr.Text + .EmpfName.Text) <> ""
    End With
End Sub

Sub EndPrg()
        Form1.MAPISession1.SignOff
        End
End Sub

Sub GetParams()
ReDim Param(0) As String
Dim s As String
Dim i As Long
Dim a As Long
Dim e As Long
    s = Trim(Command) + " "
FindChar:
    i = i + 1
    If i > Len(s) Then GoTo FindDone
    If Mid(s, i, 1) = " " Then GoTo FindChar
    a = i
FindSpace:
    i = i + 1
    If i > Len(s) Then GoTo FindDone
    If Mid(s, i, 1) <> " " Then GoTo FindSpace
    e = i
    ReDim Preserve Param(1 + (UBound(Param))) As String
    Param(UBound(Param)) = Mid(s, a, e - a)
    GoTo FindChar
FindDone:
Debug.Print
For i = 1 To UBound(Param)
    Debug.Print "Param(" & i & ")='" & Param(i) & "'"
Next
End Sub

Function DecodeBackSlashStr(s1 As String) As String
Dim s2 As String
Dim c As String
Dim i As Long
Dim XlatFlag As Boolean
    For i = 1 To Len(s1)
        c = Mid(s1, i, 1)
        If XlatFlag Then
            Select Case UCase(c)
                'Case "\"
                    Rem --> bleibt "\"
                Case "N"
                    c = vbCr
                Case "L"
                    c = vbLf
            End Select
            XlatFlag = False
        Else
            XlatFlag = (c = "\")
        End If
        If Not XlatFlag Then s2 = s2 & c
    Next
    DecodeBackSlashStr = s2
End Function

Function EncodeBackSlashStr(s1 As String) As String
Dim s2 As String
Dim c As String
Dim i As Long
    For i = 1 To Len(s1)
        c = Mid(s1, i, 1)
        Select Case c
            Case vbLf
                c = "\L"
            Case vbCr
                c = "\N"
        End Select
        s2 = s2 + c
    Next
    EncodeBackSlashStr = s2
End Function

Public Sub WriteIni(SubSection As String, ByVal s As String)
Dim rc As Long
    rc = WritePrivateProfileString(Title, SubSection, s, App.Path + "\" + MailFixIni)
End Sub

Public Function ReadIni(SubSection As String) As String
Dim s As String
    s = Space(IniEntryMaxLen)
    ReadIni = Left(s, GetPrivateProfileString(Title, SubSection, "", s, Len(s), App.Path + "\" + MailFixIni))
End Function

Sub WriteMailfixData()
    WriteIni SectName, Form1.MAPIMessages1.RecipDisplayName
    WriteIni SectAdr, Form1.MAPIMessages1.RecipAddress
    WriteIni SectSubj, Form1.Betreff.Text
    WriteIni SectText, EncodeBackSlashStr(Form1.Nachricht.Text)
End Sub

Sub ReadMailfixData()
    Form1.EmpfName.Text = ReadIni(SectName)
    Form1.EmpfAdr.Text = ReadIni(SectAdr)
    Form1.Betreff.Text = ReadIni(SectSubj)
    Form1.Nachricht.Text = DecodeBackSlashStr(ReadIni(SectText))
End Sub

Function NewLinkNameOk() As Boolean
Dim i As Long
Dim rc As Boolean
    For i = 1 To Len(NewLinkName)
        If InStr(InvalidChars, Mid(NewLinkName, i, 1)) Then
            rc = True
            Exit For
        End If
    Next
NewLinkNameOk = Not rc
End Function

Public Sub ShowInfo()
    MsgBox Title + " - E-Mails einfach per Drag-n-Drop erstellen." + _
        vbCr + vbCr + "⌐ 1998 by Wolfgang Wirth" + vbCr + vbCr + _
        "'VerbesserungsvorschlΣge und konstruktive" + vbCr + _
        "Kritik sind mir immer willkommen!'" + vbCr + vbCr + _
        "E-Mail: [e-mail]" + vbCr + vbCr + _
        "Web: Perso.wanadoo.fr/wolfgang.wirth", 64, Title
End Sub