Elimineren van verboden karakters in twee strings

  • Onderwerp starter Onderwerp starter keb
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.

keb

Gebruiker
Lid geworden
20 feb 2011
Berichten
153
Ik wil e-mails opslaan met de filenaam "Datum Afzender Onderwerp.msg"
Zowel de afzender als onderwerp wil ik controleren op verboden karakters en vervolgens aanvullen/verkorten tot 20 karakters.
Kan ik deze controle met één subroutine doen?

Graag suggesties.

Hier mijn voorbeeld van het hele programma:
Code:
'status per 14 december 2023
Private Sub Commandbutton1_Click()
'Ref.: https://www.slipstick.com/developer/code-samples/save-selected-message-file/

    Dim myItem As Object
    Dim olMail As Outlook.MailItem
    Dim Selection As Selection
    
    Dim strSender As String 'Names will be shortened of extented to fix number of characters and checked on forbidden characters
    Dim strDate As String
    Dim strPath As String  'Will be picked up from a listbox
    Dim strSubject As String 'Subject will be shortened of extented to fix number of characters and checked on forbidden characters
    Dim sName As String

    strPath = ListBox2.List(ListBox2.ListIndex, 1)
    'MsgBox strPath
    

    'Action with loop for all selected e-mails
    Set myNamespace = Application.GetNamespace("MAPI")
    Set Selection = Application.ActiveExplorer.Selection
    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            strSubject = oMail.Subject
            ReplaceCharsForFileName strSubject, "-"
            strSubject = Left(oMail.Subject & String(20, "_"), 20)
            
            strSender = oMail.Sendername
            ReplaceCharsForFileName strSender, "-"
            strSender = Left(oMail.Sender & String(20, "_"), 20)
            
            dtDate = oMail.ReceivedTime
            strDate = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "-hhnn", vbUseSystemDayOfWeek, vbUseSystem)
                                  
            Debug.Print strPath & strDate & " " & strSender & " " & strSubject & ".msg"
            oMail.SaveAs strPath & strDate & " " & strSender & " " & strSubject & ".msg", olMSG
            End If
      
        'Delete the selected e-mail
        'olMail.Delete
        
        Next  'Next mail
        
        Userform1.hide
        
End Sub

'================================================================
Public Sub ReplaceCharsForFileName(strSender As String, sChr As String)
  strSender = Replace(strSender, "'", sChr)
  strSender = Replace(strSender, "*", sChr)
  strSender = Replace(strSender, "/", sChr)
  strSender = Replace(strSender, "\", sChr)
  strSender = Replace(strSender, ":", sChr)
  strSender = Replace(strSender, "?", sChr)
  strSender = Replace(strSender, Chr(34), sChr)
  strSender = Replace(strSender, "<", sChr)
  strSender = Replace(strSender, ">", sChr)
  strSender = Replace(strSender, "|", sChr)
  strSender = Replace(strSender, "&", sChr)
End Sub

'================================================================
Private Sub UserForm_Initialize()
    'Read setup file/parameters for dropbox
    file = "D:\Setup.csv"
    i = 0
    Userform1.ListBox2.Clear
    Open file For Input As #1
    Do Until EOF(1)
        Line Input #1, strLine: 'Debug.Print strLine
        i = i + 1
        ListBox2.AddItem
        ListBox2.List(i - 1, 0) = Split(strLine, ";")(0)
        ListBox2.List(i - 1, 1) = Split(strLine, ";")(1)
    Loop
    Close #1
End Sub
 
Waarom zou je dat willen? Ook al kan de functie korter? Wat denk je er mee te winnen?
 
Zelf gebruik ik hiervoor 1 string
Tekens welke niet in de string ToegestaneTekens voorkomen, worden verwijderd uit de string MijnStr

Code:
   ToegstaneTekens = "' áéíóúýÁÉÍÓÚÝâêîôûÂÊÎÔÛãñõÃÑÕäëïöüÿÄËÏÖÜŸ/\()[]1234567890abcdefghijklmnopqrstuvwxyz"

   For X = 1 To Len(MijnStr)                                                                                            
      If InStr(UCase(ToegstaneTekens), UCase(Mid(MijnStr, X, 1))) > 0 Then
         strCheckPath = strCheckPath & Mid(MijnStr, X, 1)
        Else
         strCheckPath = strCheckPath & " "                                                                             
      End If
   Next X
 
alleen kleine en hoofdletters toegestaan:

CSS:
Private Sub Commandbutton1_Click()
  For Each it In ActiveExplorer.Selection
    If it.MessageClass = "IPM.Note" Then
      c00 = it.Subject & it.Sendername

      For j = 1 To Len(c00)
        If Mid(c00, j, 1) Like "[!a-z !A-Z]" Then c00 = Replace(c00, Mid(c00, j, 1), "")
      Next
                                
      it.SaveAs ListBox2 & Format(it.ReceivedTime, "yyyymmdd_hhmm_") & Left(c00 & Space(20), 20) & ".msg", olMSG
    End If
  Next
      
   Userform1.Hide
End Sub
 
Laatst bewerkt:
Code:
Function repChars(c As String) As String
 With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "[\\/:\*\?""<>\|]"
   repChars = .Replace(c, "")
 End With
End Function
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan