How do I save email (msg)?
This code creates a daily folder structure and saves email attachments but not the email itself.
Option Explicit
Public Sub saveAttachtoDisk(itm As Outlook.mailitem)
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
' Check for folder and create if needed
If Len(Dir("C:\Temp\" & Year(Date), vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date)
End If
If Len(Dir("C:\Temp\" & Year(Date) & "\" & Month(Date), _
vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date) & "\" & Month(Date)
End If
If Len(Dir("C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date), _
vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
End If
For Each objAtt In itm.Attachments
objAtt.SaveAsFile SaveFolder & "\" & Format(Date, "yyyymmdd") & "_" & _
objAtt.DisplayName
Next
Set objAtt = Nothing
End Sub
Try
Dim FileName As String
FileName = Format(Date, "yyyymmdd") & "_" & objAtt.DisplayName
itm.SaveAs SaveFolder & "\" & FileName & ".msg", olMsg
Also Replace invalid characters with empty strings, here I'm using Regex
For Each objAtt In itm.Attachments
Dim FileName As String
FileName = Format(Date, "yyyymmdd") & "_" & objAtt.DisplayName
objAtt.SaveAsFile SaveFolder & "\" & FileName
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Pattern = "[^\w\#-]"
.IgnoreCase = True
.Global = True
End With
FileName = RegEx.Replace(FileName, " ")
itm.SaveAs SaveFolder & "\" & FileName & ".msg", olMsg
Next
Now test your code with Selection.item(1)
Public Sub Test_Rule()
Dim olMsg As Outlook.mailitem
Set olMsg = ActiveExplorer.Selection.Item(1)
saveAttachtoDisk olMsg
End Sub
Call itm.SaveAs(..., olMsg) to save in the MSG format
Related
I have multiple inputs in columns from which I need to create table for each column which has headers, Create connection using power query, Using these connections I need to add to the power query, and export it to sheet2. I have attached sample excel sheet for reference. Below is the half code for the same, I am not pro in vba if any one could help in solving the same. Here is the link for the same which I need to automate.
data set
Option Explicit
Public Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject
Dim tableobjects As ListObject
Dim sName As String
Dim sFormula As String
Dim wq As WorkbookQuery
Dim bExists As Boolean
Dim vbAnswer As VbMsgBoxResult
Dim vbDataModel As VbMsgBoxResult
Dim i As Long
Dim j As Long
Dim k, l As Long
Dim dStart As Double
Dim dTime As Double
Dim CellAddr As String
Dim CellValue As String
Dim RangeAddr As String
Dim Temp As String
Dim TotalNumberInputs As Integer
Dim answer As Integer
Dim TableExists As Boolean
Dim ListObj As ListObject
Repeat:
TotalNumberInputs = InputBox("Enter the total inputs", "input int number")
If TotalNumberInputs = 0 Then
MsgBox "Invalid Input!!!"
answer = MsgBox("Invalid Input!!! Do you want to continue Macro?", vbQuestion + vbYesNo + vbDefaultButton2, "Next step")
If answer = vbYes Then
GoTo Repeat
Else
Exit Sub
End If
End If
'Set variables
dStart = Timer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'Check of table exist or else create table
For k = 1 To TotalNumberInputs
ws.Cells(1, k).Select
CellAddr = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False)
CellValue = Cells(1, l).Value ' "Table" & (k + "0") ' Selection.Value
On Error Resume Next
Set ListObj = ActiveSheet.ListObjects(CellValue)
On Error GoTo 0
If ListObj Is Nothing Then
Range(CellAddr).Select
Range(Selection, Selection.End(xlDown)).Select
RangeAddr = Selection.Address
Range(RangeAddr).Activate
ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=Range(RangeAddr), LinkSource:=False, XlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium28").Name = CellValue
Else
'If the table does exist clear filter from column C
' ActiveSheet.ListObjects(CellValue).Range.AutoFilter Field:=3
End If
Next k
l = 1
'Loop sheets and tables
' For Each ws In ActiveWorkbook.Worksheets
For Each lo In ws.ListObjects ' For j = 1 To TotalNumberInputs ' For Each lo In ws.ListObjects
sName = lo.Name ' ws.Cells(1, l).Value ' lo.Name
l = l + 1
sFormula = "Excel.CurrentWorkbook(){[Name=""" & sName & """]}[Content]"
'Check if query exists
bExists = False
For Each wq In wb.Queries
If InStr(1, wq.Formula, sFormula) > 0 Then
bExists = True
End If
Next wq
'Add query if it does not exist
If bExists = False Then
' Add a Query
wb.Queries.Add Name:=sName, Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Excel.CurrentWorkbook(){[Name=""" & sName & """]}[Content]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Source,{{""" & sName & """, type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type"""
'Add connection
wb.Connections.Add2 Name:="Query - " & sName, _
Description:="Connection to the '" & sName & "' query in the workbook.", _
ConnectionString:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & sName & ";Extended Properties=""""", _
CommandText:="SELECT * FROM [" & sName & "]", _
lCmdtype:=2, _
CreateModelConnection:=False, _
ImportRelationships:=False
'Count connections
i = i + 1
End If
Next lo ' Next j ' Next lo
'Next ws
'Calc run time
dTime = Timer - dStart
MsgBox i & " connections have been created in " & Format(dTime, "0.0") & " seconds.", vbOKOnly, "Process Complete"
End Sub
I need to run a VBScript that changes the structure of a CSV file. To keep it simple I'm only using 3 data fields but there is a lot more. In a production environment I will have a CSV file with hundreds of lines.
The problem is everything is in double quotes. The end result can sometimes be no quotes or single quotes or sometimes a mix of all three.
I have absolutely no idea how I should approach this and was looking for some guidance. This looks like a job for RegexReplace but because it's mixed I'm not sure how to start this. After the file has been modified I have to right over top of the original file.
CSV Example:
"apple";"12";"xyz"
"somereallylongword";"7687";"theredfox"
Pattern
"%1";%2;'%3'
Desired Result
"apple";12;'xyz'
"somereallylongword";7687;'theredfox'
What I'm trying to achieve is to be able to make a new pattern type. In my example:
"%1" - I keep the original double quotes.
%2 - Remove the double quotes.
'%3' - Replace the double quotes with single quotes.
Any insight would be greatly appreciated.
You can read the CSV file using ADODB:
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Dim objConnection
Dim objRecordset
Dim sCSVFolder
Dim sCSVFile
Dim sValue
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
sCSVFolder = "C:\CSV_Folder\"
sCSVFile = "your_csv_file.csv"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sCSVFolder & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited"""
objRecordset.Open "SELECT * FROM " & sCSVFile, _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
Do Until objRecordset.EOF
' Modify and write fields to new text file here
sValue = objRecordset.Fields.Item("FieldName")
objRecordset.MoveNext
Loop
This way you let ADO handle reading the data and removing the double-quotes and you can manipulate the data easily as a Recordset.
Just give a try for this code by replacing the path of your CSV file and tell me how it works on your side ?
Option Explicit
Dim Data
Call ForceCScriptExecution()
Data = ReadFile("C:\Test\Test.csv")
wscript.echo "Before Replacing"
wscript.echo String(50,"-")
wscript.echo Data
wscript.echo String(50,"-")
wscript.echo "After Replacing"
wscript.echo String(50,"-")
wscript.echo Search_Replace(Data)
wscript.echo String(50,"-")
wscript.sleep 20000
'-----------------------------------------------
Function Search_Replace(Data)
Dim oRegExp,strPattern1,strPattern2
Dim strReplace1,strReplace2,strResult1,strResult2
strPattern1 = ";(\x22)(\S+\w+)(\x22);"
strReplace1 = ";$2;"
strPattern2 = "[;]\x22([^\x22]+)\x22"
strReplace2 = ";'$1'"
Set oRegExp = New RegExp
oRegExp.Global = True
oRegExp.IgnoreCase = True
oRegExp.Pattern = strPattern1
strResult1 = oRegExp.Replace(Data,strReplace1)
oRegExp.Pattern = strPattern2
strResult2 = oRegExp.Replace(strResult1,strReplace2)
Search_Replace = strResult2
End Function
'-----------------------------------------------
Function ReadFile(path)
Const ForReading = 1
Dim objFSO,objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(path,ForReading)
ReadFile = objFile.ReadAll
objFile.Close
End Function
'----------------------------------------------
Sub ForceCScriptExecution()
Dim Arg, Str, cmd, Title
Title = "Search and Replace using RegExp by Hackoo 2019"
cmd = "CMD /C Title " & Title &" & color 0A & Mode 80,30 & "
If Not LCase( Right( WScript.FullName, 12 ) ) = "\cscript.exe" Then
For Each Arg In WScript.Arguments
If InStr( Arg, " " ) Then Arg = """" & Arg & """"
Str = Str & " " & Arg
Next
CreateObject( "WScript.Shell" ).Run _
cmd & "cscript //nologo """ & _
WScript.ScriptFullName & _
""" " & Str
WScript.Quit
End If
End Sub
'-----------------------------------------------
Edit : Batch Script Code
You can do it easily with a batch script without using Regex :
#echo off
Title Edit CSV File
Set "Input_CSV_File=C:\Test\Test.csv"
Set "OutPut_CSV_File=C:\Test\OutPut_Test.csv"
If Exist "%OutPut_CSV_File%" Del "%OutPut_CSV_File%"
#for /f "tokens=1,2,3 delims=;" %%a in ('Type "%Input_CSV_File%"') Do (
echo "%%~a";%%~b;'%%~c'
echo "%%~a";%%~b;'%%~c'>>"%OutPut_CSV_File%"
)
TimeOut /T 5 /NoBreak>nul
If Exist "%OutPut_CSV_File%" Notepad "%OutPut_CSV_File%" & Exit
I need to find files in a folder, and I have 3 cases on files naming:
DI0425522.pdf
AL-DN-DI0425523.pdf
AL-DN-DI0425524-2016-11-17_1108.pdf
I can handle the first and the second case, but I need to find the third too. the last 16 characters of the 3. filename can variate, so I think to use RegExp to match it, then copy all files in another folder.
the string is stored in an excel cell, but only with "DI#######" naming
DI0425522 (A2 cell)
DI0425523 (A3 cell)
DI0425524 (A4 cell)
This is the code, but it doesn't work: it shows error 438 "object doesn't support this property or method" on the If Dir(Source & "\DI\" & "AL-DN-" & ValoreCella & regex & ".Pdf") <> "" Then line
Sub cerca()
Dim T As Variant
Dim D As Variant
T = VBA.Format(VBA.Time, "hh.mm.ss")
D = VBA.Format(VBA.Date, "yyyy.MM.dd")
Dim Ricercatore As Variant
Ricercatore = Cells(1, 3)
Dim Source As String
Dim Dest As String
Source = "\\it-s-bolo02\WORKGROUP\Comune\000_0_______ COMUNE 2011\15_TECNICO\AAA - RICERCA DDT\ALSS\DDT"
Dest = "\\it-s-bolo02\WORKGROUP\Comune\000_0_______ COMUNE 2011\15_TECNICO\AAA - RICERCA DDT\ALSS\Ricerca\Ricerca " & D & " " & T & " " & Ricercatore
MkDir Dest
Dim ValoreCella As Variant, r As Long, DDTmancanti As Variant
r = 2
Do Until Cells(r, 1) = ""
ValoreCella = Cells(r, 1)
If Dir(Source & "\DI\" & ValoreCella & ".Pdf") <> "" Then
FileCopy Source & "\DI\" & ValoreCella & ".Pdf", Dest & "\" & ValoreCella & ".Pdf"
Else
If Dir(Source & "\DI\" & "AL-DN-" & ValoreCella & ".Pdf") <> "" Then
FileCopy Source & "\DI\" & "AL-DN-" & ValoreCella & ".Pdf", Dest & "\" & "AL-DN-" & ValoreCella & ".Pdf"
Else
Dim regex As Object, str As String
Set regex = CreateObject("VBScript.RegExp")
str = "-([0-9]*)-([0-9]*)-([0-9]*)_([0-9]*)"
With regex
.Pattern = str
.Global = True
End With
If Dir(Source & "\DI\" & "AL-DN-" & ValoreCella & regex & ".Pdf") <> "" Then
FileCopy Source & "\DI\" & "AL-DN-" & ValoreCella & regex & ".Pdf", Dest & "\" & "AL-DN-" & ValoreCella & regex & ".Pdf"
Else
If Dir(Source & "\Altro\" & ValoreCella & ".Pdf") <> "" Then
FileCopy Source & "\Altro\" & ValoreCella & ".Pdf", Dest & "\" & ValoreCella & ".Pdf"
Else
DDTmancanti = DDTmancanti & ValoreCella & vbCrLf
End If
End If
End If
End If
r = r + 1
Loop
Dim FF As Long
FF = FreeFile
Open (Dest & "\" & "0 - DDT_mancanti.txt") For Output As #FF
Write #FF, DDTmancanti
Close #FF
MsgBox "Operazione eseguita"
Shell "explorer.exe " + Dest, vbNormalFocus
End Sub
Thanks for help
A RegExp is an object and it doesn't have a default property, so you can't just concatenate it into a string and use it like a wildcard. If you need to find a matching file with Dir, you need to loop over the directory and test each resulting filename with the regular expression until you find a match. You can cut down on some of the extraneous matches by using wildcards in the Pathname argument for Dir - for example, Source & "\DI\*DI???????*.pdf" should eliminate most of them.
Also, because you can't use a "partial" regular expression with Dir, you'll need to build a regular expression that will match any of your file specs completely. This should work based on your example file names:
^(AL-DN-)?DI\d{7}(-\d{4}-\d{2}-\d{2}_\d{4})?\.pdf$
This simplifies your main loop quite a bit. Add a flag for whether or not a match was found, and exit early when you find a match. Something like this should be closer to what you need (untested):
'...
r = 2
With New RegExp
.Pattern = "^(AL-DN-)?DI\d{7}(-\d{4}-\d{2}-\d{2}_\d{4})?\.pdf$"
Do Until Cells(r, 1) = ""
Dim found As Boolean
ValoreCella = Cells(r, 1)
Dim current As String
current = Dir$(Source & "\DI\*DI???????*.pdf")
Do Until current = vbNullString
If .Test(current) Then 'Found the file.
FileCopy current, Dest & "\" & current
found = True
Exit Do
End If
current = Dir$()
Loop
If Not found Then DDTmancanti = DDTmancanti & ValoreCella & vbCrLf
found = False
r = r + 1
Loop
End With
Dim FF As Long
'...
I tried but doesn't work. Here your code with comments:
With New RegExp
.Pattern = "^(AL-DN-)?DI\d{7}(-\d{4}-\d{2}-\d{2}_\d{4})?\.pdf$"
Do Until Cells(r, 1) = ""
Dim found As Boolean
ValoreCella = Cells(r, 1)
Dim current As String
current = Dir$(Source & "\DI\*DI???????*.pdf")
Do Until current = vbNullString
If .Test(current) Then 'Found the file.
FileCopy current, Dest & "\" & current 'Error 53 File not found--> current var is the first file found without Source string, see image attached
found = True
Exit Do
End If
current = Dir$()
Loop
If Not found Then DDTmancanti = DDTmancanti & ValoreCella & vbCrLf
found = False
r = r + 1
Loop
End With
Dim FF As Long
I Tried this mod:
With New RegExp
.Pattern = "^(AL-DN-)?DI\d{7}(-\d{4}-\d{2}-\d{2}_\d{4})?\.pdf$"
Do Until Cells(r, 1) = ""
Dim found As Boolean
ValoreCella = Cells(r, 1)
Dim current As String
current = Dir$(Source & "\DI\*DI???????*.pdf")
Do Until current = vbNullString
If .Test(current) Then 'Found the file.
Dim SourceDI, DestDI As String
SourceDI = Source & "\DI\" & current
DestDI = Dest & "\" & current
FileCopy SourceDI, DestDI
found = True
Exit Do
End If
current = Dir$()
Loop
If Not found Then DDTmancanti = DDTmancanti & ValoreCella & vbCrLf
found = False
r = r + 1
Loop
End With
The file string is now correct, but there's not a test with ValoreCella value, so the code will return the first file found in folder, then stops
UPDATE:
I solve the problem without RegExp in this way:
'...
Do Until Cells(r, 1) = ""
ValoreCella = Cells(r, 1)
Dim current As String
current = Dir$(Source & "\DI\*" & ValoreCella & "*.pdf")
If current <> "" Then
FileCopy Source & "\DI\" & current, Dest & "\" & current
Else
DDTmancanti = DDTmancanti & ValoreCella & vbCrLf
End If
r = r + 1
Loop
'...
Thanks for your help
I am still very new to VB6 and VB Studio.
I want to get a list of all the Process ID's and the Usernames associated with those ID's
I am not using a form, as no GUI will be needed, but for testing purposes, I would like to output the list to a msgbox or notepad file.
This is what I have got so far, but it does not run in VB Studio. It does work as a VBS, but will not save as an exe with the error "Invalid Outside Procedure"
Option Explicit
Dim objWMIService, objProcess, colProcess
Dim strComputer, strList
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process")
For Each objProcess in colProcess
strList = strList & vbCr & _
objProcess.Name
Next
WSCript.Echo strList
WScript.Quit
Any help is appreciated
Add a Module to your project and use the code below. It writes the data out to a text file in the temp folder. From the Project>Properties menu make sure the "Startup Object" is Sub Main.
Option Explicit
Dim objWMIService As Object
Dim objProcess As Object
Dim colProcess As Object
Dim strComputer As String
Dim strUserName
Dim strUserDomain
Sub Main()
On Error GoTo eh
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery("Select * from Win32_Process")
Open "c:\temp\test.txt" For Output As #1
For Each objProcess In colProcess
objProcess.GetOwner strUserName, strUserDomain
Print #1, objProcess.Name & vbTab & strUserName
Next
Close #1
MsgBox ("Done")
Exit Sub
eh:
MsgBox (Error$)
End Sub
I'm trying to figure this out and I just cannot get it to work, I'm stuck please help.
I have a .txt file that will look something like this
Example:
GA117.50.0117.50.0117.50.0IL16.08.08.00.016.00.0IN284.09.4274.60.0284.00.0KY137.60.0137.60.0137.60.0TN170.30.0170.30.0170.30.0US725.417.4708.00.0725.40.0TOTAL725.417.4708.00.0725.40.0
What I'm trying to do in classic-asp is to get the letters/word in a dim (and add a str before the letters/word) and the numbers as the value for that dim but only to the first period and 1 more number to the right after the period and then continue to the next letter/word.
so the final outcome would look something like this:
dim strGA
dim strIL
dim strIN
dim strKY
dim strTN
dim strUS
dim strTOTAL
strGA=117.5
strIL=16.0
strIN=284.0
strKY=137.6
strTN=170.3
strUS=725.4
strTOTAL=725.4
Thank you so much for any help with this problem/question.
Consider the following example.
May need to change the pattern according to the variable names.
Dim strTest
strTest = "GA117.50.0117.50.0117.50.0IL16.08.08.00.016.00.0IN284.09.4274.60.0284.00.0KY137.60.0137.60.0137.60.0TN170.30.0170.30.0170.30.0US725.417.4708.00.0725.40.0TOTAL725.417.4708.00.0725.40.0"
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "([a-z]+)(\d+\.\d)"
Dim collMatches
Set collMatches = re.Execute(strTest)
Dim iMatch, strDims, strAssocs
For Each iMatch In collMatches
strDims = strDims & "Dim str" & iMatch.SubMatches(0) & vbCrLf
strAssocs = strAssocs & "str" & iMatch.SubMatches(0) & " = " & iMatch.SubMatches(1) & vbCrLf
Next
Dim strExec
strExec = strDims & vbCrLf & strAssocs
'Dump
Response.Write "Dump:<hr /><pre>" & strExec & "<pre>"
ExecuteGlobal strExec 'Execute the code
'Test
With Response
.Write "Executed:<hr />"
.Write "strGA: " & strGA & "<br />"
.Write "strIL: " & strIL & "<br />"
.Write "strIN: " & strIN & "<br />"
.Write "strKY: " & strKY & "<br />"
.Write "strTN: " & strTN & "<br />"
.Write "strUS: " & strUS & "<br />"
.Write "strTOTAL:" & strTOTAL & "<br />"
End With