View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Helmut Helmut is offline
external usenet poster
 
Posts: 111
Default filename in "Subject" in email

Hi,
May I bother you once more with this and give you the three 'subs' and maybe
you can show me the 'fix'....thanks.

=============sub1========
Sub ToCAV()
'
' Macro1 Macro
' Macro recorded 25/07/2006 by IT1
'

'Sort by ID

Application.Run "'" & ActiveWorkbook.Name & "'!Sort_by_ID"

Sheets("ToCAVM").Visible = True
Sheets("ToCAVM").Select
ActiveSheet.Unprotect

Cells.Select
Selection.Copy

Sheets("ToCAV").Visible = True
Sheets("ToCAV").Select
ActiveSheet.Unprotect

Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

'Format colum G for Date as dd/mm/yyyy
Columns("G:G").Select
Range("G1").Activate
Selection.NumberFormat = "mm/dd/yyyy"

'Delete rows with '0' value in column 'C'

Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim StartRow As Long
Dim EndRow As Long

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView

With ActiveSheet
.DisplayPageBreaks = False
StartRow = 1
EndRow = .Cells(.Rows.Count, "C").End(xlUp).Row

For Lrow = EndRow To StartRow Step -1

If IsError(.Cells(Lrow, "C").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "C").Value = "0" Then .Rows(Lrow).Delete
'This will delete each row with the Value "0" in Column A,
case sensitive.

End If
Next
End With

ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

'2 Generate CSV File and Save to CAV-Files
'-----------------------------------------
'FOR GENERIC


Application.Run "'" & ActiveWorkbook.Name & "'!DoTheExport"
Application.Run "'" & ActiveWorkbook.Name &
"'!Mail_Selection_Outlook_Body"


'Close the ToCAV worksheet and go to START
Sheets("ToCAV").Visible = False
Sheets("ToCAVM").Visible = False
Application.Run "'" & ActiveWorkbook.Name & "'!Set_Month"


End Sub

===========sub2================
Public Sub DoTheExport()

'save 'file as' 'mesnumMMYYYY.CSV'

Dim Fname As Variant

'FOR GENERIC
Fname = Application.GetSaveAsFilename("c:\MESSER\" &
Range("mesnum").Value & "_" & Replace(Range("filedate").Value, "/", "") &
".csv")

' FOR SHEKEL-SERVER
' Fname = Application.GetSaveAsFilename("\\Cav-new\FILES\" &
Range("mesnum").Value & "_" & Replace(Range("filedate").Value, "/", "") &
".csv")


If Fname = False Then
MsgBox "You didn't select a file"
Exit Sub
End If

'Running the Public Sub below
ExportToTextFile CStr(Fname), ",", False

End Sub

Public Sub ExportToTextFile(Fname As String, _
Sep As String, SelectionOnly As Boolean)

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String


Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If

Open Fname For Output Access Write As #FNum

For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Text
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum

End Sub
Sub Mail_Selection_Outlook_Body()
' You must add a reference to the Microsoft outlook Library
' Don't forget to copy the function RangetoHTML in the module.

Dim sh As Worksheet
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

'To send the selection use this example (NB: this only works if the
sheet is unprotected)
'Set sh = ActiveSheet
'Set rng = Selection

'unprotect "START"
Sheets("START").Select
ActiveSheet.Unprotect
Cells.Select
Selection.EntireRow.Hidden = False
Selection.EntireColumn.Hidden = False
Range("A1000").Select

'If you know the sheet/range then use this two lines
Set sh = Sheets("START")
Set rng = sh.Range("çåãù")

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "
.CC = ""
.BCC = "
.Subject = Fname & "_" & " òëùéå á \\Cav_New\Files"
.HTMLBody = RangetoHTML(sh, rng)
.Send 'or use .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True


'hide rows and columns to show only menu
Sheets("START").Visible = True
Sheets("START").Select
ActiveSheet.Unprotect
Cells.Select
Selection.EntireRow.Hidden = False
Selection.EntireColumn.Hidden = False
Range("hidecolumn1").Select
Selection.EntireColumn.Hidden = True
Range("hiderows1").Select
Selection.EntireRow.Hidden = True
Range("hiderows2").Select
Selection.EntireRow.Hidden = True
Range("hiderows4").Select
Selection.EntireRow.Hidden = True
Range("hidecolumn5").Select
Selection.EntireColumn.Hidden = True
Range("A1").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub



"stevebriz" wrote:

I have had this happen before....just delcare in the declaration
section. it should solve you problem