Posts by P1g5purt

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  EMailAttachments
End Sub
 
 
 
Sub EMailAttachments()
Dim objol As New Outlook.Application
Dim objmail As MailItem
Dim strSubject, strRecipient, strCC As String
Dim arrRecipients()
Dim arrCC()
 
'VARIABLES
strFullFileName = Application.GetOpenFilename
strSubject = "TEST"
strRecipient = "emailaddress"
 
'CREATE INSTANCE
Set objol = New Outlook.Application
Set objmail = objol.CreateItem(olMailItem)
 
    With objmail
        .To = strRecipient
        .CC = strCC
        .Subject = strSubject
        .HTMLBody = "<B>Bold Text</B>" & "<br> Standard text" 
        .NoAging = True
        .Display
    End With
 
    'RELEASE MEMORY
    Set objmail = Nothing
    Set objol = Nothing
    'EFFECTIVELY TRICKING EXCEL - YES HAS BEEN CLICKED
    SendKeys "%{s}", True 'SEND THE E-MAIL WITHOUT PROMPTS
 
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 EMailAttachments
End Sub
 
 
 
Sub EMailAttachments()
Dim objol As New Outlook.Application
Dim objmail As MailItem
Dim strSubject, strRecipient, strCC As String
Dim arrRecipients()
Dim arrCC()
 
'VARIABLES
strFullFileName = Application.GetOpenFilename
strSubject = "TEST"
strRecipient = "emailaddress"
 
'CREATE INSTANCE
Set objol = New Outlook.Application
Set objmail = objol.CreateItem(olMailItem)
    
    With objmail
        .To = strRecipient
        .CC = strCC
        .Subject = strSubject
        .HTMLBody = "<B>Bold Text</B>" & "<br> Standard text" 
        .NoAging = True
        .Display
    End With
    
    'RELEASE MEMORY
    Set objmail = Nothing
    Set objol = Nothing
    'EFFECTIVELY TRICKING EXCEL - YES HAS BEEN CLICKED
    SendKeys "%{s}", True 'SEND THE E-MAIL WITHOUT PROMPTS
    
End Sub

Dim VBComp As VBIDE.VBComponent
    Dim FromVBProject As VBIDE.VBProject
    Dim ToVBProject As VBIDE.VBProject
    Dim FName As String
    Dim CompName As String
    Dim S As String
    Dim SlashPos As Long
    Dim ExtPos As Long
    Dim TempVBComp As VBIDE.VBComponent
 
    Set FromVBProject = Application.Workbooks("TestFile.xls").VBProject
    Set ToVBProject = Application.Workbooks("TargetFile.xls").VBProject
    ModuleName = "mdlSecurity"

Sub SaveToPdf
 
Dim rngValues as Range
Dim rngR as Range
 
Set rngValues = Sheet1.[rngValues]
 
For Each rngR In rngValues
 
  Sheet1.Range("B11").Formula = rngR.Value
  Call ThisWorkbook.Run_SaveToPDF_Unit_1
 
Nexr rngR
 
End Sub

Sub FormatSections()


Dim rngStartCell As Range
Dim intNumCols As Integer


Set rngStartCell = Sheet1.Range("a2")
dblref = Sheet1.Range("a2")
intNumCols = 6


Do While ActiveCell <> ""
'RESET COUNTER
I = 0


Do While ActiveCell.Offset(I, 0) = dblref
Range(rngStartCell, ActiveCell.Offset(I, intNumCols)).Select
dblref = ActiveCell.Offset(I, 0).Value
I = I + 1
Loop


'FORMAT THE RANGE WITH BORDERS
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
End With


'MOVE START POINT
Set rngStartCell = rngStartCell.Offset(I)
rngStartCell.Activate
dblref = ActiveCell.Value


Loop


End Sub

Private Sub Workbook_Open()
Dim strLink As String
Dim booCreateLink As Boolean


booCreateLink = True


strLink = "H:\HOME\timc\EXCEL\BAD_DEBT_REPORTS\FY2007\BAD_DEBT_2007.XLS"




arrLink = ActiveWorkbook.LinkSources
If Not IsEmpty(arrLink) Then
    For I = 1 To UBound(arrLink)
        If arrLink(I) = strLink Then
            booCreateLink = False
        End If
    Next I


End If


If booCreateLink = True Then
'CREATE LINK CODE
End If


End Sub

Sub QueryDataBase()




Dim strPCTo As String
Dim strPCFrom As String
Dim rngQueries As Range


Set rngQueries = Sheet2.Range("Queries") '  Your list of post codes to be queried


For i = 1 To rngQueries.Rows.Count


    strPCFrom = rngQueries(i, 0) 'Assuming your list of queries is in two columns From, To
    strPCTo = rngQueries(i, 1)
    
    Range("F9").Select
    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DBQ=C:\DOCUMENTS AND SETTINGS\ROSS8\MY DOCUMENTS\london_sector_time_distances_access97.mdb;DefaultDir=C:\DOCUMENTS AND SETTINGS" _
        ), Array( _
        "\ROSS8\MY DOCUMENTS;Driver={Driver do Microsoft Access (*.mdb)};DriverId=281;FIL=MS Access;MaxBufferSize=2048;MaxScanRows=8;Pag" _
        ), Array("eTimeout=5;SafeTransactions=0;Threads=3;UserCommitSync=Yes;")), _
        Destination:=Range("F9"))
        .CommandText = Array("SELECT Time_Distance.`From`, Time_Distance.To, Time_Distance.Time" & Chr(13) & "" & Chr(10) & "FROM Time_Distance Time_Distance" & Chr(13) & "" & Chr(10) & "WHERE (Time_Distance.From=" & strPCFrom & ") AND (Time_Distance.To=" & strPCTo & ")" & Chr(13) & "" & Chr(10) & "ORDER BY Time_Distance.Time")
        .Name = "Query from DP_2"
        .Refresh BackgroundQuery:=False
    End With


'COPY THE RESULT
Range("F9").Copy
rngQueries(i, 2).PasteSpecial Paste:=xlValues


Next i


End Sub