Essential VBA

Send email

Sub SendEmail()
'   Remember to check Outlook Object Library:
'   Press Alt+F11 to open VBA-editor
'   Select "Tools" - "References - VBAProject" - "Microsoft Outlook 12.0 Object Library"
'   Frank Tetsche 2010 08 15

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    Dim strbody As String

    strbody = "Email content first line" & Chr(13) & "Email content next line" & _
              vbNewLine & "Third line"   

    With OutMail
        .To = "Recievers email"
        .CC = ""
        .BCC = ""
'        .SentOnBehalfOfName = "Senders email"
        .Subject = ""
        .Body = strbody
'        .Attachments.Add ("Path and file name") ' Must be complete path

        .Display   'or use .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Import csv-files


Sub Input_From_CSV_Flexible()

' Frank Tetsche 2010 11 07
' In this macro, you have to specify witch separator, decimal separator an the name of the import file

    Dim file_name As String
    Dim fnum As Integer
    Dim whole_file As String
    Dim lines As Variant
    Dim one_line As Variant
    Dim num_rows As Long
    Dim num_cols As Long
    Dim the_array() As String
    Dim R As Long
    Dim C As Long
    Dim tallet As Variant
    Dim separator As String
    
   ' Enter separators, the name of the import file and what sheet to import to.

    separator = ";" ' You can also set the separator to ","
    decimal_separator = "."
    file_name = "C:\Inputfile.csv"
    Sheets("CSVInput").Select
    
    Cells.Select
    Selection.ClearContents
    Range("A1").Select

    ' Load the file.
    fnum = FreeFile
    Open file_name For Input As fnum
    whole_file = Input$(LOF(fnum), #fnum)
    Close fnum

    ' Break the file into lines.
    lines = Split(whole_file, vbCrLf)

    ' Dimension the array.
    num_rows = UBound(lines)
    one_line = Split(lines(0), separator)
    num_cols = UBound(one_line)
    
    If decimal_separator = "," Then
    
        ReDim the_array(num_rows, num_cols) As String
    
        ' Copy the data into the array.
        For R = 0 To num_rows - 1
            one_line = Split(lines(R), separator)
            For C = 0 To num_cols
                the_array(R, C) = one_line(C)
                midlertidig = the_array(R, C)
                tallet = Split(midlertidig, ".")
                If midlertidig <> "" Then
                    If tallet(0) <> midlertidig Then
                        Cells(R + 1, C + 1) = tallet(0) & "." & tallet(1)
                    Else
                        Cells(R + 1, C + 1) = tallet
                    End If
                End If
            Next C
        Next R
    
    Else
        ReDim the_array(num_rows, num_cols)
    
        ' Copy the data into the array.
        For R = 0 To num_rows - 1
            one_line = Split(lines(R), separator)
            For C = 0 To num_cols
                the_array(R, C) = one_line(C)
                Cells(R + 1, C + 1) = the_array(R, C)
            Next C
        Next R
    End If

End Sub


Export csv-files


Sub Semikolonsepareretfil()
  ' Select the range you want to export to csv before you run the macro.
'   Frank Tetsche 2010 08 15

  Dim newrange As Range
  Dim cell As Range
  Dim filename As Variant
  Dim linie As String
  linie = ""
  Dim bredde, taller, taller2 As Integer
       
      Set newrange = Intersect(Selection, ActiveSheet.UsedRange)
      
      filename = "c:\MyExportFile.txt"
      
      Close #1   'standard practice, close before opening
      
      Open filename For Output As 1
      
      bredde = Selection.Columns.Count
      
      taller = 0
      taller2 = 0
      
      For Each cell In newrange     'newrange
        
            If taller = 0 Then
            
                If taller2 = 0 Then
                    linie = cell.Text
                    taller2 = 1
                Else
                    Print #1, linie
                    linie = cell.Text
                End If
                
            Else
               linie = linie & "; " & cell.Text
            End If
                   
        taller = (taller + 1) Mod bredde
       
      Next cell
      Print #1, linie
      Close #1
End Sub


Print to PDF


Public Sub ConvertToPDF()

'   Frank Tetsche 2010 08 15
    
    Dim objDistiller As Object
    Dim strADB_FileName As String
    Dim strPSFileName As String
    Dim strFilename As String

    'Remember printer
    GlPrinter = Application.ActivePrinter

    Set objDistiller = CreateObject("Pdfdistiller.PdfDistiller")

    Application.ActivePrinter = "Adobe PDF på Ne03:"
    strFilename = "C:\Test " & Format(Date, "yyyy mm dd ") & "kl " & Format(Time, "hh mm")
    strPSFileName = strFilename & ".ps"
    strADB_FileName = strFilename & ".pdf"
    strlogFileName = strFilename & ".log"
    
    'create postscript file
'    Options.PrintBackground = False
    ActiveWindow.SelectedSheets.PrintOut copies:=1, printtofile:=True, prtofilename:=strPSFileName

    'convert postscript file to pdf
    objDistiller.FileToPDF strPSFileName, strADB_FileName, ""

    'delete postscript file
    Kill strPSFileName
    Kill strlogFileName

'    objDistiller.Quit
    Set objDistiller = Nothing

    'Get back to using the original printer
    Application.ActivePrinter = GlPrinter

End Sub

Save as values


Sub CopyValuesToAnotherWorkbook()

    ' Frank Tetsche 2010 08 16
    
'   Here you have to specify which file, you want to copy to.

    yourfile = "Values.xlsx" 'Range("A1")
    yourpath = "C:\"   'Range("A2")

    yourworkbook = ThisWorkbook.Name
    yourcurrentsheet = ActiveSheet.Name
    
    Workbooks.Open Filename:=yourpath & yourfile

    Sheets("Sheet1").Select
    Cells.Select
    Selection.ClearContents ' or just Clear
    
    Windows(yourworkbook).Activate

    Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Range("A1").Select
    
    Windows(yourfile).Activate
    Sheets("Sheet1").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
    
    ActiveWorkbook.Save
    ActiveWorkbook.Close

    Sheets(yourcurrentsheet).Select

End Sub