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

    Häufig von mir verwendete Abkürzungen: CEs = control elements (Labels, Buttons, DGVs, ...) und tDS (typisiertes DataSet)
    Aufgrund spontaner Selbsteintrübung sind all meine Glaskugeln beim Hersteller. Lasst mich daher bitte nicht in den Spekulatiusmodus gehen.

    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“ ()