This is the code I have so far:
REM ***** BASIC *****
Option Explicit
rem-----------------------------------------------------------------------
REM----
Sub Main
Dim YearNm As Long, DayCol As Long, DayRow As Long
Dim DataSheet As Object, oSheet As Object
Dim SelDate As Date
Dim oDoc As String, oSelection As String
Set DataSheet = ThisComponent.CurrentController.ActiveSheet
oDoc = ThisComponent
oSelection = ThisComponent.CurrentSelection
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Private Sub Worksheet_Change(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1))
'If Not Intersect(Target, Dim oSheet as Object[n]oSheet = `
'`ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("AH6:AH29")) Is Nothing Then
If Not Intersect(Target,Range("AH6:AH29")) Is Nothing Then
'("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ThisComponent.ActiveSheet[n}ThisComponent.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))ed Date
'Range("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCell = ThisComponent.CurrentController.ThisComponent.ActiveSheet.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))as Date)
Range("AH5") = oSelection
'
YearNm = [ScYear]
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNM & "")
Active
End If
'
DayRow = Tatget.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) + 1 'Dtermine Column for Data Sheet
DataSheet.Cells(DayRow, DayCol).Value = Target.Value
End If
End Sub
Private Sub Sheet()
CurrentController.setThisComponent.CurrentController.ActiveSheet(vSheet);ionChange(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("B6:AF29")) Is Nothing Then
If IsDate(Target.Value) = False Then Exit Sub
SlDate = Target.Value 'Selected Date
YearNm = [ScYear]
ThisComponent.CurrentControlller.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CcurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(("AH5")).Value = SelDate
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
'
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
Activate
End If
DayRow = Target.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) +1 'Determine Column for Data Sheet
ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.Activesheet[n]oSheet.getCellRangeByName($1)ByName(ByName(("AH6:AH29")).Value = DataSheet.ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =
ThisComponent.Currentcontroller.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName((DataSheet).getCellByPosition((6,DayCol), DataSheet.Cells(29, DayCol)), $3)).Value
End If
End Sub]
Basically what I need to happen is this: when a new day is selected, the value in cell "AH5" change to the selected date long version, "month day, year".
Thank you in advance.
I am trying to convert visual basic to open office.
Related
I managed to adapt a vba macro (which I also found here) and got it running. So when the macro is started a file dialog asks me for the source file and the output gives me the word count of this file into cell "A1".
Public Sub word_counter()
Dim objWord As Object, objDocument As Object
Dim strText As String
Dim lngIndex As Long
Dim cellrange As String
Dim intChoice As Integer
Dim strPath As String
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Set objDocument = objWord.documents.Open(strPath)
strText = objDocument.Content.Text
objDocument.Close SaveChanges:=False
For lngIndex = 0 To 31
strText = Replace(strText, Chr$(lngIndex), Space$(1))
Next
Do While CBool(InStr(1, strText, Space$(2)))
strText = Replace(strText, Space$(2), Space$(1))
Loop
Sheets("calc tool").Select
Range("A1") = UBound(Split(strText, Space$(1)))
objWord.Quit
Set objDocument = Nothing
Set objWord = Nothing
End Sub
Now i want to add the filename to the output as text in cell "A2" right next to the word count of this file.
A1: 1234 A2: filename.docx
I tried to add the solution described in the SOF question 12687536
here!
The results were disappointing and i ran into compiling errors or run time error '91'
This was one of my solutions which didn't work out.
Public Sub word_count()
Dim objWord As Object, objDocument As Object
Dim strText As String
Dim lngIndex As Long
Dim cellrange As String
Dim intChoice As Integer
Dim strPath As String
Dim filename As String
Dim cell As Range
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Set objDocument = objWord.documents.Open(strPath)
strText = objDocument.Content.Text
objDocument.Close SaveChanges:=False
For lngIndex = 0 To 31
strText = Replace(strText, Chr$(lngIndex), Space$(1))
Next
Do While CBool(InStr(1, strText, Space$(2)))
strText = Replace(strText, Space$(2), Space$(1))
Loop
Sheets("calc tool").Select
Range("A1") = UBound(Split(strText, Space$(1)))
filename = Application.GetOpenFilename
cell = Application.Range("A2")
cell.Value = filename
objWord.Quit
Set objDocument = Nothing
Set objWord = Nothing
End Sub
Any idea how to make this work?
You have to select a sheet before you can use Range().
Thus change
cell = Application.Range("A2")
cell.Value = filename
to
Range("A2") = filename
or better
Application.ActiveSheet.Range("A2").Value = filename
and you write the filename into the cell A2 in your active sheet.
I have to save a lot of dxf files from Solidworks to use for a CNC machine.
I'm looking for help to create a macro to save each configuration of the part as the top view of a part as a .dxf in the same location as the Solidworks file is saved.
I have found two macros which I kind of need to be combined together.
The first one saves all configurations separately as part files
The second one saves a part as a dxf of the top view.
It would be much appreciated if anyone could help me
first macro:
' Macro created by Jeff Parker CSWP/MCP 12/30/02
'
' Rev.1 = Added completion message box. Also verified SolidWorks 2005 compatabliity.
'
' Rev.2 = Fixed macro for x64 bits machines (changed folder browse codes). Also verified SolidWorks 2014 compatabliity.
' (BY: Deepak Gupta www.gupta9665.com 07/26/14)
' Folder Browse Codes: http://www.cpearson.com/excel/browsefolder.aspx
'
' Rev.3 = Fixed macro for Weldment part configuration names having <As Machined> and <As Welded>. Also verified SolidWorks 2016 compatabliity.
' (BY: Deepak Gupta www.gupta9665.com 01/14/16)
'
' DISCLAIMER:
' * These macros are provided free of charge for personal use and/or reference.
' * These macros may be freely distributed, provided the original copyright
' notices remain unchanged and intact.
' * All macros were written to work with SolidWorks 2005.
' * These macros, and corresponding files, are provided as is.
' * There are no warranties, expressed or implied, that these macros will perform
' as indicated, perform to users expectations, or complete a specific task.
' * These macros will change the current SolidWorks document. Use these macros at
' your own risk. Back up your data before using this macro on any SolidWorks
' document.
'
' ******************************************************************************
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Annotation As Object
Dim Gtol As Object
Dim DatumTag As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Dim ConfigNamesArray As Variant
Dim ConfigNameMain As Variant
Dim ConfigName As Variant
Dim NewName As String
Dim PartName As String
Dim OpenName As String
Dim CurrentConfigName As Variant
Dim fileerror As Long
Dim filewarning As Long
Dim OrigConfigName As Variant
Dim Location As Variant
Dim ModLoc As String
Dim MassProps As Variant
Dim Mass As Variant
Dim MassError As Long
Dim ConfigCount As Long
Dim MassPropArrayTest As Long
Dim CustomPropNamesArray As Variant
Dim CustomPropName As Variant
Dim PartSourceName As String
Dim PartSourcePath As String
Dim status As Boolean
Sub main()
Set swApp = Application.SldWorks 'Connect to SolidWorks session
Set Part = swApp.ActiveDoc 'Set Part variable to active doc
If Part Is Nothing Then Exit Sub
ConfigCount = Part.GetConfigurationCount 'Get number of configurations
PartSourceName = Part.GetTitle 'Get name of original part file that contains configurations
If Part.GetType <> swDocPART Then 'Check to see if current document is a part
MsgBox "Only Allowed on Parts, Please open a part and try again.", vbOKOnly, "Error" ' Display error message"
Exit Sub ' Exit this program
ElseIf ConfigCount = 1 Then
MsgBox "Must have at least two configurations before starting macro.", vbOKOnly, "Error" ' Display error message"
Exit Sub ' Exit this program
Else
GoTo Rip
End If
Rip: 'RIP sub section
frmLocation.Show 'Show form
Location = frmLocation.txtPath.Text 'Get user selected location
'---Check to see if location has last backslash---
ModLoc = Right(Location, 1)
If ModLoc <> "\" Then
Location = Location & "\"
End If
ConfigNamesArray = Part.GetConfigurationNames 'Populate the array with all config names
OrigConfigName = ConfigNamesArray(0) 'Get current configuration
For i = 0 To UBound(ConfigNamesArray)
ConfigName = ConfigNamesArray(i) 'Assign next config name to ConfigName variable
Part.ShowConfiguration2 (ConfigName) 'Set next config as current
ConfigName = Replace((Replace(ConfigName, "<As Machined>", "")), "<As Welded>", "")
NewName = Location & ConfigName & ".sldprt" 'Create path
Part.SaveAsSilent NewName, True 'Save as current config name
Next i
PartSourcePath = Part.GetPathName
swApp.CloseDoc PartSourceName 'Close the source file to conserve memory for program
Set Part = Nothing 'Clear part variable
For j = 0 To UBound(ConfigNamesArray)
ConfigNameMain = ConfigNamesArray(j) 'Populate ConfigNameMain with current name
ConfigNameMain = Replace((Replace(ConfigNameMain, "<As Machined>", "")), "<As Welded>", "")
OpenName = Location & ConfigNameMain & ".sldprt" 'Set location of file to open
fileerror = swFileNotFoundError 'Default system error message
filewarning = swFileSaveWarning_NeedsRebuild 'Default warning message
swApp.OpenDoc6 OpenName, 1, 0, "", fileerror, filewarning 'Open saved configuration file
Set Part = swApp.ActiveDoc 'Set newly opened file as current
Part.DeleteDesignTable 'Delete design table if present
For k = 0 To UBound(ConfigNamesArray) 'Delete all configurations from new file
ConfigName = ConfigNamesArray(k)
Part.DeleteConfiguration2 (ConfigName)
Next k
Part.EditConfiguration3 ConfigNameMain, "Default", "", "", 0 'Rename leftover config to default
Part.ViewZoomtofit2 'Make part zoom to fit so icon looks good
Part.Save2 (True) 'Save newly modified part
Set Part = Nothing 'Clear Part variable
swApp.CloseDoc ConfigNameMain & ".sldprt" 'Close current part
Next j
swApp.OpenDoc6 PartSourcePath, 1, 0, "", fileerror, filewarning 'Open original source file
Set Part = swApp.ActiveDoc 'Set original part as current
Part.ShowConfiguration2 (OrigConfigName) 'Set original part to original status
MsgBox "Here is where you can find your files: " & Chr(13) & Location, vbInformation, "Configuration Rip Success!"
Location = "" 'Clear location variable
End Sub 'Close program
second macro:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim sModelName As String
Dim sPathName As String
Dim varAlignment As Variant
Dim dataAlignment(11) As Double
Dim varViews As Variant
Dim dataViews(0) As String
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swPart = swModel
sModelName = swModel.GetPathName
sPathName = Left(sModelName, Len(sModelName) - 6) & "dxf"
dataAlignment(0) = 0#
dataAlignment(1) = 0#
dataAlignment(2) = 0#
dataAlignment(3) = 1#
dataAlignment(4) = 0#
dataAlignment(5) = 0#
dataAlignment(6) = 0#
dataAlignment(7) = 0#
dataAlignment(8) = -1#
dataAlignment(9) = 0#
dataAlignment(10) = 1#
dataAlignment(11) = 0#
varAlignment = dataAlignment
dataViews(0) = "*Top"
varViews = dataViews
swPart.ExportToDWG2 sPathName, sModelName, swExportToDWG_e.swExportToDWG_ExportAnnotationViews, True, varAlignment, False, False, 0, varViews
End Sub
Try the following codes which exports each configuration of the active part as DXF.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim sModelName As String
Dim sPathName As String
Dim vConfNameArr As Variant
Dim i As Long
Dim sConfigName As String
Dim bRebuild As Boolean
Dim swPart As SldWorks.PartDoc
Dim nFileName As String
Dim varAlignment As Variant
Dim dataAlignment(11) As Double
Dim varViews As Variant
Dim dataViews(0) As String
Sub Main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' Is document active?
If swModel Is Nothing Then
swApp.SendMsgToUser2 "A Sheet Metal Part must be open.", swMbWarning, swMbOk
Exit Sub
End If
' Is it a part document?
If swModel.GetType <> SwConst.swDocPART Then
swApp.SendMsgToUser2 "A Sheet Metal Part must be open.", swMbWarning, swMbOk
Exit Sub
End If
sModelName = swModel.GetPathName
sPathName = Left(sModelName, InStrRev(sModelName, "\"))
vConfNameArr = swModel.GetConfigurationNames
For i = 0 To UBound(vConfNameArr)
sConfigName = vConfNameArr(i)
If Not UCase(sConfigName) Like "*FLAT*" Then
swModel.ShowConfiguration2 (sConfigName)
bRebuild = swModel.ForceRebuild3(False)
nFileName = sPathName & sConfigName & ".DXF"
Set swPart = swModel
dataAlignment(0) = 0#
dataAlignment(1) = 0#
dataAlignment(2) = 0#
dataAlignment(3) = 0#
dataAlignment(4) = 0#
dataAlignment(5) = 0#
dataAlignment(6) = 0#
dataAlignment(7) = 0#
dataAlignment(8) = 0#
dataAlignment(9) = 0#
dataAlignment(10) = 0#
dataAlignment(11) = 0#
varAlignment = dataAlignment
dataViews(0) = "*Top"
varViews = dataViews
'Export Top View
swPart.ExportToDWG2 nFileName, sModelName, 3, True, varAlignment, False, False, 0, varViews
End If
Next i
End Sub
How to select spreadsheets one after another in Libre Office to perform some action in them?
In excel vba the following code worked, but it does not work in LibreOffice
Dim wb as Workbook
Dim ws as Worksheet
Set wb = ActiveWorkbook
For Each ws in wb.Worksheets
'Do something here
End if
Next
Could anyone help me with that?
First of all get the oSheets object (which is what is called Worksheets in Excel) of ThisComponent (which is what is called ActiveWorkbook in Excel)
Sub sheetProcessing()
Dim oSheets As Variant, oSheet As Variant
Dim i As Long
' By Sheet index
oSheets = ThisComponent.getSheets()
For i = 0 To oSheets.getCount() - 1
oSheet = oSheets.getByIndex(i)
Print oSheet.getName() & " - " & oSheet.getCellByPosition(0, 0).getString()
Next i
' Or by Element Names
Dim oElementNames As Variant
oElementNames = oSheets.getElementNames()
For i = LBound(oElementNames) To UBound(oElementNames)
oSheet = oSheets.getByName(oElementNames(i))
Print oSheet.getName() & " - " & oSheet.getCellByPosition(0, 0).getString()
Next i
' Or easiest
For Each oSheet In oSheets
Print oSheet.getName() & " - " & oSheet.getCellByPosition(0, 0).getString()
Next oSheet
End Sub
I use the following code assigned to a CommandButton to automatically attach the workbook to an email so users can send it out. Is there a way to attach the workbook without the code, so the people receiving the email do not have the full code, but the sender keeps it in their copy? (The recipients only need to see the data, they do not interact with the form, but the sender interacts with it several times a day.) When I save the Workbook as .xlsx, it gives me an yes/no/help MsgBox that I would like to avoid during the sending - to keep it as a "one-click" operation.
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
Option Explicit
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
FileExtStr = ".xlsm"
Application.DisplayAlerts = False
' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr
Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.Close False
'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
'.To = "noone#noone.com"
'.CC = ""
.BCC = ""
.From = "noone#noone.com"
.Subject = "Test - " & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & "-email" & ".xlsx"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
To send a single worksheet with the vba code removed, I've used this:
Option Explicit
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim sh As Worksheet
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Dim wb As Workbook
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
'Or if you want to copy more then one sheet use:
'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in Destwb to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Destwb.Worksheets(1).Select
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
Application.DisplayAlerts = False
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "noone#noone.com"
'.CC = ""
'.BCC = ""
.From = "noone#noone.com"
.Subject = "Test-" & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
I'm trying to export one of my queries to email using VBA in a table format. Similar to when you go to external data and click and E-Mail and it adds an attachment to outlook. Except I want it in the body. I put the following code in a button.
I found and made some changes to some code. This is what I have.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 4) As String
Dim aRow(1 To 4) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part"
aHead(2) = "Description"
aHead(3) = "Qty"
aHead(4) = "Price"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th> <th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From qry_email"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Part")
aRow(2) = rec("Description")
aRow(3) = rec("Qty")
aRow(4) = rec("Price")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "email#email.com"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
When I run the code, I get a "Run-time error '3061' too few parameters. Expected 1."
If i click debug i get this highlighted in yellow. Anybody help would be greatly appreciated!
Edit
I tried a different approach which actually gave me the list in the body of the email. But it does it for the whole table instead of just the one record I want. This is what the SQL looks like of the query.
SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price
FROM tblePMParts
WHERE (((tblePMParts.WOID)=[Forms]![fmremail]![Text1]));
How would I go about adding the WHERE to the code below.
Private Sub Command4_Click()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strQry As String
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts; "
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Please Quote the Following!"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.Body = olItem.Body & rec("[Part#]") & " - " & rec("PartDescription") & " - " & rec("Qty") & " - " & rec("Price")
rec.MoveNext
Next intLoop
End If
MsgBox "Completed Export"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
I got it working. Here is the code in case anybody needs it.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part#"
aHead(2) = "Description"
aHead(3) = "Qty"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)=" & [Forms]![fmremail]![Text1] & "));"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("[Part#]")
aRow(2) = rec("PartDescription")
aRow(3) = rec("Qty")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "Email"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
Somewhere in your code, put a line that says
X = [Forms]![fmremail]![Text1]
Put a breakpoint in your code (hopefully you know how to do that?) on that line. When the code breaks, press F8 to step to the next line, and then type ?X in the Immediate Window. Or you can just hover your mouse over the line with the break point. The point is, you need to see what your code thinks [Forms]![fmremail]![Text1] is equal to. If it's null, you have a problem with your reference. In that case, you may need to add ".Value" or ".Text" to the end of it.
Another thing to check is your datatype for WOID. if it's text, you need to surround it with single quotes.
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)='" & [Forms]![fmremail]![Text1] & "'));"