Elimineren van verboden karakters in twee strings

[keb]

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:

'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

 

[OctaFish]

Waarom zou je dat willen? Ook al kan de functie korter? Wat denk je er mee te winnen?

 

[Bram65]

Zelf gebruik ik hiervoor 1 string
Tekens welke niet in de string ToegestaneTekens voorkomen, worden verwijderd uit de string MijnStr

   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

 

[snb]

alleen kleine en hoofdletters toegestaan:

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

 

[JEC.]

Function repChars(c As String) As String
 With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "[\\/:\*\?""<>\|]"
   repChars = .Replace(c, "")
 End With
End Function