Ordner per Inpubox angeben

  • Outlook

Es gibt 3 Antworten in diesem Thema. Der letzte Beitrag () ist von robkel.

    Ordner per Inpubox angeben

    Hallo, ich habe mit Hilfe der Community folgenden Code gefunden und auf meine Anforderungen angepasst:

    Brainfuck-Quellcode

    1. ' Lieferantenangebote
    3. Option Explicit
    5. '-------------------------------------------------------------
    6. ' OPTIONS
    7. '-------------------------------------------------------------
    8. 'Email format:
    9. ' MSG = Outlook msg format (incl. attachments, embedded objects etc.)., TXT = plain text
    10. Private Const EXM_OPT_MAILFORMAT As String = "MSG"
    11. 'Date format of filename
    12. Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd_hh.nn.ss"
    13. 'Build filename; placeholders: <DATE> for date, <SENDER> for sender's name, <RECEIVER> for receiver, <SUBJECT> for subject
    14. Private Const EXM_OPT_FILENAME_BUILD As String = "<DATE>_<SUBJECT>"
    15. 'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
    16. Private Const EXM_OPT_USEBROWSER As Boolean = False
    17. 'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE)
    18. Private Const EXM_OPT_TARGETFOLDER As String = "F:\104 Marketing\Angebote\FGH I\"
    19. 'Maximum number of emails to be selected & exported. Please don't use a huge number as this will cause
    20. 'performance and maybe other issues. Recommended is a value between 5 and 20.
    21. Private Const EXM_OPT_MAX_NO As Integer = 1
    22. 'Email subject prefixes (such us "RE:", "FW:" etc.) to be removed. Please note that this is a
    23. 'RegEx expression, google for "regex" for further information. For instance "\s" means blank " ".
    24. Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
    25. '-------------------------------------------------------------
    27. '-------------------------------------------------------------
    28. ' TRANSLATIONS
    29. '-------------------------------------------------------------
    30. '-- English
    31. 'Const EXM_007 = "Script terminated"
    32. 'Const EXM_013 = "Selected Outlook item is not an e-mail"
    33. 'Const EXM_014 = "File already exists"
    34. '-- German
    35. Private Const EXM_001 As String = "Die E-Mail wurde erfolgreich abgelegt."
    36. Private Const EXM_002 As String = "Die E-Mail konnte nicht abgelegt werden, Grund:"
    37. Private Const EXM_003 As String = "Ausgewählter Pfad:"
    38. Private Const EXM_004 As String = "E-Mail(s) ausgewählt und erfolgreich abgelegt."
    39. Private Const EXM_005 As String = "<FREE>"
    40. Private Const EXM_006 As String = "<FREE>"
    41. Private Const EXM_007 As String = "Script abgebrochen"
    42. Private Const EXM_008 As String = "Fehler aufgetreten: Sie haben mehr als [LIMIT_SELECTED_ITEMS] E-Mails ausgewählt. Die Aktion wurde beendet."
    43. Private Const EXM_009 As String = "Es wurde keine E-Mail ausgewählt."
    44. Private Const EXM_010 As String = "Es ist ein Fehler aufgetreten: es war keine Email im Fokus, so dass die Ablage nicht erfolgen konnte."
    45. Private Const EXM_011 As String = "Es ist ein Fehler aufgetreten:"
    46. Private Const EXM_012 As String = "Die Aktion wurde beendet."
    47. Private Const EXM_013 As String = "Ausgewähltes Outlook-Dokument ist keine E-Mail"
    48. Private Const EXM_014 As String = "Datei existiert bereits"
    49. Private Const EXM_015 As String = "<FREE>"
    50. Private Const EXM_016 As String = "Bitte wählen Sie den Ordner zum Exportieren:"
    51. Private Const EXM_017 As String = "Fehler beim Exportieren aufgetreten"
    52. Private Const EXM_018 As String = "Export erfolgreich"
    53. Private Const EXM_019 As String = "Bei [NO_OF_FAILURES] E-Mail(s) ist ein Fehler aufgetreten:"
    54. Private Const EXM_020 As String = "[NO_OF_SELECTED_ITEMS] E-Mail(s) wurden ausgewählt und [NO_OF_SUCCESS_ITEMS] E-Mail(s) erfolgreich abgelegt."
    55. '-------------------------------------------------------------
    57. '-------------------------------------
    58. 'For browse folder
    59. '-------------------------------------
    60. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
    61. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
    62. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    63. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
    64. Private Const BIF_RETURNONLYFSDIRS = 1
    65. Private Const MAX_PATH = 260
    66. Private Type BrowseInfo
    68. hwndOwner As Long
    69. pIDLRoot As Long
    70. pszDisplayName As Long
    71. lpszTitle As Long
    72. ulFlags As Long
    73. lpfnCallback As Long
    74. lParam As Long
    75. iImage As Long
    76. End Type
    78. Public Sub Lieferantenangebote()
    80. Const PROCNAME As String = "Lieferantenangebote"
    82. On Error GoTo ErrorHandler
    85. Dim obj As Object
    86. Dim Sel As Outlook.Selection
    87. Dim DoSave As Boolean
    88. Dim NewSubject As String
    90. If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    91. Set obj = Application.ActiveInspector.CurrentItem
    92. Else
    93. Set Sel = Application.ActiveExplorer.Selection
    94. If Sel.Count Then
    95. Set obj = Sel(1)
    96. DoSave = True
    97. End If
    98. End If
    99. If Not obj Is Nothing Then
    100. NewSubject = InputBox("Kundenangebotsnummer:", obj.Subject, obj.Subject)
    101. If NewSubject <> "" Then
    102. obj.Subject = NewSubject
    103. If DoSave Then
    104. obj.Save
    105. End If
    106. End If
    107. End If
    120. Dim myExplorer As Outlook.Explorer
    121. Dim myfolder As Outlook.MAPIFolder
    122. Dim myItem As Object
    123. Dim olSelection As Selection
    124. Dim strBackupPath As String
    125. Dim intCountAll As Integer
    126. Dim intCountFailures As Integer
    127. Dim strStatusMsg As String
    128. Dim vSuccess As Variant
    129. Dim strTemp1 As String
    130. Dim strTemp2 As String
    131. Dim strErrorMsg As String
    132. ' Dim strkunde As String
    133. '-------------------------------------
    134. 'Get target drive
    135. '-------------------------------------
    138. If (EXM_OPT_USEBROWSER = True) Then
    139. strBackupPath = GetFileDir
    140. If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
    141. strErrorMsg = Mid(strBackupPath, 16, 9999)
    142. Error 5004
    143. End If
    144. Else
    145. strBackupPath = EXM_OPT_TARGETFOLDER
    146. End If
    147. If strBackupPath = "" Then GoTo ExitScript
    148. If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
    153. '-------------------------------------
    154. 'Process according to what is in the focus: an opened e-mail or a folder with selected e-mails.
    155. 'Case 2 would also work for opened e-mail, however it does not always work (for instance if
    156. ' an e-mail is saved on the file system and being opened from there).
    157. '-------------------------------------
    159. Set myExplorer = Application.ActiveExplorer
    160. Set myfolder = myExplorer.CurrentFolder
    161. If myfolder Is Nothing Then Error 5001
    162. If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
    164. 'Stop if more than x emails selected
    165. If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
    167. 'No email selected at all?
    168. If myExplorer.Selection.Count = 0 Then Error 5003
    170. Set olSelection = myExplorer.Selection
    171. intCountAll = 0
    172. intCountFailures = 0
    173. For Each myItem In olSelection
    174. intCountAll = intCountAll + 1
    175. vSuccess = ProcessEmail(myItem, strBackupPath)
    176. If (Not vSuccess = True) Then
    177. Select Case intCountFailures
    178. Case 0: strStatusMsg = vSuccess
    179. Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
    180. Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
    181. End Select
    182. intCountFailures = intCountFailures + 1
    183. End If
    184. Next
    185. If intCountFailures = 0 Then
    186. strStatusMsg = intCountAll & " " & EXM_004
    187. End If
    190. 'Final Message
    191. If (intCountFailures = 0) Then 'No failure occurred
    192. MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
    193. ElseIf (intCountAll = 1) Then 'Only one email was selected and a failure occurred
    194. MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    195. Else 'More than one email was selected and at least one failure occurred
    196. strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
    197. strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
    198. strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
    199. MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
    200. & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    201. End If
    203. ExitScript:
    204. Exit Sub
    205. ErrorHandler:
    206. Select Case Err.Number
    207. Case 5001: 'Not an email
    208. MsgBox EXM_010, 64, EXM_007
    209. Case 5002:
    210. MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64, EXM_007
    211. Case 5003:
    212. MsgBox EXM_009, 64, EXM_007
    213. Case 5004:
    214. MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48, EXM_007
    215. Case Else:
    216. MsgBox EXM_011 & Chr(10) & Chr(10) _
    217. & Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_012, 48, EXM_007
    218. End Select
    219. Resume ExitScript
    220. End Sub
    222. Private Function ProcessEmail(myItem As Object, strBackupPath As String) As Variant
    223. 'Saves the e-mail on the drive by using the provided path.
    224. 'Returns TRUE if successful, and FALSE otherwise.
    226. Const PROCNAME As String = "ProcessEmail"
    228. On Error GoTo ErrorHandler
    230. Dim myMailItem As MailItem
    231. Dim strDate As String
    232. Dim strSender As String
    233. Dim strReceiver As String
    234. Dim strSubject As String
    235. Dim strFinalFileName As String
    236. Dim strFullPath As String
    237. Dim strkunde As String
    238. Dim vExtConst As Variant
    239. Dim vTemp As String
    240. Dim strErrorMsg As String
    243. If TypeOf myItem Is MailItem Then
    244. Set myMailItem = myItem
    245. Else
    246. Error 1001
    247. End If
    249. 'Set filename
    250. strDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    251. strSender = myMailItem.SenderName
    252. strReceiver = myMailItem.To 'All receiver, semikolon separated string
    253. If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    254. strSubject = myMailItem.Subject
    255. strFinalFileName = EXM_OPT_FILENAME_BUILD
    256. strFinalFileName = Replace(strFinalFileName, "<DATE>", strDate)
    257. strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    258. strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    259. strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    260. strFinalFileName = CleanString(strFinalFileName)
    263. If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
    264. strErrorMsg = Mid(strFinalFileName, 16, 9999)
    265. Error 1003
    266. End If
    267. strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    268. strFullPath = strBackupPath & strFinalFileName
    270. 'Save as msg or txt?
    271. Select Case UCase(EXM_OPT_MAILFORMAT)
    272. Case "MSG":
    273. strFullPath = strFullPath & ".msg"
    274. vExtConst = olMSG
    275. Case Else:
    276. strFullPath = strFullPath & ".txt"
    277. vExtConst = olTXT
    278. End Select
    279. 'File already exists?
    280. If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
    281. Error 1002
    282. End If
    284. 'Save file
    285. myMailItem.SaveAs strFullPath, vExtConst
    287. ' Mail löschen
    288. ' myMailItem.Delete
    290. ' In Ordner verschieben
    291. Dim Test As Outlook.Application
    292. Dim Konto As Outlook.NameSpace
    293. Dim Zielordner As Outlook.MAPIFolder
    294. Dim Zielordner1 As Outlook.MAPIFolder
    295. Dim Auswahl As Outlook.Selection
    296. Dim Anzahl As Integer
    298. Set Test = CreateObject("Outlook.Application")
    299. Set Zielordner = Application.Session.Folders("robert.keller@pft-riesa.de")
    300. ' Set Konto = Test.GetNamespace("MAPI")
    301. ' Set Zielordner = Konto.GetDefaultFolder(olFolderInbox)
    302. Set Zielordner1 = Zielordner.Folders("Lieferantenangebote")
    304. Set Auswahl = Test.ActiveExplorer.Selection
    306. For Anzahl = 1 To Auswahl.Count
    307. Auswahl.Item(Anzahl).Move Zielordner1
    308. Next Anzahl
    312. 'Return true as everything was successful
    313. ProcessEmail = True
    315. ExitScript:
    316. Exit Function
    317. ErrorHandler:
    318. Select Case Err.Number
    319. Case 1001: 'Not an email
    320. ProcessEmail = EXM_013
    321. Case 1002:
    322. ProcessEmail = EXM_014
    323. Case 1003:
    324. ProcessEmail = strErrorMsg
    325. Case Else:
    326. ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    327. End Select
    328. Resume ExitScript
    329. End Function
    331. Private Function CleanString(strData As String) As String
    333. Const PROCNAME As String = "CleanString"
    335. On Error GoTo ErrorHandler
    337. 'Instantiate RegEx
    338. Dim objRegExp As Object
    339. Set objRegExp = CreateObject("VBScript.RegExp")
    340. objRegExp.Global = True
    342. 'Cut out strings we don't like
    343. objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
    344. strData = objRegExp.Replace(strData, "")
    346. 'Replace and cut out invalid strings.
    347. strData = Replace(strData, Chr(9), "_")
    348. strData = Replace(strData, Chr(10), "_")
    349. strData = Replace(strData, Chr(13), "_")
    350. objRegExp.Pattern = "[/\\*]"
    351. strData = objRegExp.Replace(strData, "-")
    352. objRegExp.Pattern = "[""]"
    353. strData = objRegExp.Replace(strData, "'")
    354. objRegExp.Pattern = "[:?<>\|]"
    355. strData = objRegExp.Replace(strData, "")
    357. 'Replace multiple chars by 1 char
    358. objRegExp.Pattern = "\s+"
    359. strData = objRegExp.Replace(strData, " ")
    360. objRegExp.Pattern = "_+"
    361. strData = objRegExp.Replace(strData, "_")
    362. objRegExp.Pattern = "-+"
    363. strData = objRegExp.Replace(strData, "-")
    364. objRegExp.Pattern = "'+"
    365. strData = objRegExp.Replace(strData, "'")
    367. 'Trim
    368. strData = Trim(strData)
    370. 'Return result
    371. CleanString = strData
    374. ExitScript:
    375. Exit Function
    376. ErrorHandler:
    377. CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    378. Resume ExitScript
    379. End Function
    381. Private Function GetFileDir() As String
    383. Const PROCNAME As String = "GetFileDir"
    385. On Error GoTo ErrorHandler
    387. Dim ret As String
    388. Dim lpIDList As Long
    389. Dim sPath As String
    390. Dim udtBI As BrowseInfo
    391. Dim RdStrings() As String
    392. Dim nNewFiles As Long
    394. 'Show a browse-for-folder form:
    395. With udtBI
    396. .lpszTitle = lstrcat(EXM_016, "")
    397. .ulFlags = BIF_RETURNONLYFSDIRS
    398. End With
    400. lpIDList = SHBrowseForFolder(udtBI)
    401. If lpIDList = 0 Then Exit Function
    403. 'Get the selected folder.
    404. sPath = String$(MAX_PATH, 0)
    405. SHGetPathFromIDList lpIDList, sPath
    406. CoTaskMemFree lpIDList
    408. 'Strip Nulls
    409. If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)
    411. 'Return Dir
    412. GetFileDir = sPath
    414. ExitScript:
    415. Exit Function
    416. ErrorHandler:
    417. GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    418. Resume ExitScript
    419. End Function
    421. Option Explicit


    Dieser Code legt mir E-Mails (hier Lieferantenangebote) samt Anhang in einem vorher definierten Pfad ab. Nun möchte ich diesen Pfad noch erweiteren. Nach Anwahl einer E-Mail und ausführen des Makros soll eine Inputbox erscheinen, die mich nach der Lieferantennummer fragt, also z.B. "123456". Nun soll im angegebenen festem Pfad der Ordner "123456" erstellt werden und darin die E-Mail abgelegt werden. Wenn der Ordner bereits vorhanden ist, soll natürlich kein neuer Ordner erstellt werden und die E-Mail in diesem vohandenen Ordner abgelegt werden.

    Option, kein Muss: Die Nummern sind immer 6-stellig, manchmal mit Nullen am Anfang, also z.B. 001234 oder 068145 oder 123456. Die Nullen am Anfang möchte ich gern bei Eingabe in der Inpubox weglassen. Nach Eingabe soll nun geprüft werden, ob die eingegebene Zahl 6-stellig ist, falls nicht, sollen entsprechend Nullen vorn angestellt werden.

    Ich hoffe auf eure tatkräftige Unterstützung.

    Willkommen im Forum.
    Ok, wozu brauchen wir 400 Zeilen ungespoilerten Code, wenn es effektiv nicht um den geht? Du willst ne InputBox:

    Visual Basic-Quellcode

    1. Dim Text As String
    2. Text = InputBox("Titel/Aufforderung")

    Du willst prüfen, ob ein Ordner schon vorhanden ist:

    Visual Basic-Quellcode

    1. If Dir(Pfad) <> "" Then OrdnerExistiert

    Führende Nullen bei einem 6-zeichigen Text:

    Visual Basic-Quellcode

    1. If Len(Text) < 6 Then Text = String(6 - Len(Text), "0") & Text


    btw: Bitte korrekte CodeTags verwenden, also [vb], da sonst alles ... falsch dargestellt wird.
    Dieser Beitrag wurde bereits 5 mal editiert, zuletzt von „VaporiZed“, mal wieder aus Grammatikgründen.

    Aufgrund spontaner Selbsteintrübung sind all meine Glaskugeln beim Hersteller. Lasst mich daher bitte nicht den Spekulatiusbackmodus wechseln.

    VaporiZed schrieb:

    If Len(Text) < 6 Then Text = String(6 - Len(Text), "0") & Text
    Vorschlag:

    Visual Basic-Quellcode

    1. Text = Format(Val(Text),"000000")
    Vieleicht vorher noch die Eingabe auf Zahlen überprüfen:

    Visual Basic-Quellcode

    1. If IsNumeric(Text) Then
    2. Text = Format(Val(Text),"000000")
    3. Else
    4. MsgBox "nicht numerische Eingabe!
    5. End If
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „petaod“ ()

Facebook
Telefonspende