Option Compare Database
Option Explicit

Function FileExist(FileFullPath As String) As Boolean
  Dim value As Boolean
  value = False
  If Dir(FileFullPath) <> "" Then
    value = True
  End If
  FileExist = value
End Function

Private Sub btnClose_Click()
    DoCmd.Close acReport, Me.Name
End Sub

Private Sub btnExportPDF_Click()
    
    Dim fileName As String
    Dim fldrPath As String
    Dim filePath As String
    Dim db As Database
    Dim rs As Recordset
    Dim ProjectName As String
    Dim answer As Integer
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qry_BOMReport")
    
    With rs
        fileName = fldrPath & !EquipmentID & "-" & !PartNumber & ".pdf"
        ProjectName = !ProjectName
        rs.Close
    End With
    
    If ProjectName = "BSS" Then
        fldrPath = "C:\QA\Project\BSS\"
    End If
    If ProjectName = "KBT" Then
        fldrPath = "C:\QA\Project\KBT\"
    End If
    
    filePath = fldrPath & fileName
    
    'check if file already exists
    If FileExist(filePath) Then
        answer = MsgBox(prompt:="PDF file already exists: " & vbNewLine & filePath & vbNewLine & vbNewLine & _
                        "Would you like to replace existing file?", Buttons:=vbYesNo, Title:="Existing PDF File")
        If answer = vbNo Then Exit Sub
    End If
    
    'On Error GoTo invalidFolderPath
    DoCmd.OutputTo objecttype:=acOutputReport, 

Select all Open in new window

Sub CategorizeMe()
    Dim olkItm As Object, olkCat As Outlook.Category, strCat As String
    
    strCat = InputBox("Enter Category")
    
    On Error Resume Next
    For Each olkItm In Application.ActiveExplorer.Selection
        If olkItm.Class = olMail Then
            olkItm.Categories = strCat
            olkItm.Save
            olkCat = Session.Categories.Item(strCat)
        End If
    Next
    On Error GoTo 0
    Set olkItm = Nothing
    Set olkCat = Nothing
End Sub

Select all Open in new window

Sub CopyRangeUniqueValues(FromWSheet As String, FromRange As String, ToWSheet As String, ToRange As String)
'Sub treats first cell in FromRange as a header label, and will copy it to ToRange even if it is duplicated in the list
Dim celHome As Range, rgDest As Range, rgSource As Range
Dim n As Long
Set celHome = ActiveCell
Set rgDest = Worksheets(ToWSheet).Range(ToRange)
Range(rgDest, rgDest.End(xlDown)).ClearContents

With Worksheets(FromWSheet)
    n = .UsedRange.Row + .UsedRange.Rows.Count - 1
    Set rgSource = .Range(FromRange & n)
End With

rgDest.Worksheet.Activate
rgSource.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rgDest, Unique:=True
Application.GoTo celHome

Select all Open in new window

Sub LoopFormula2(strwsName, strColflag, strCol As String, strColName As String, formula As String)

'Call LoopFormula2("ImportCC", "1", "D", "Test", "=clean(sheet1!G2*sheet1!I2)") 'example of formula
    Dim ws As Worksheet
    Set ws = Worksheets(strwsName)
    ws.Activate
     '==>Clear Destination Column
    Range(strCol & ":" & strCol).Clear
    UsedRows = ActiveSheet.UsedRange.Rows.count + ActiveSheet.UsedRange.Rows(1).Row - 1
    If strColflag = 1 Then
        Range(strCol & 1).Value = strColName
    End If
    '==>Clear Destination Column
    RightFormula = Replace(formula, "1048576", UsedRows)
    '==>ApplyFormula
    Range(Cells(2, strCol), Cells(UsedRows, strCol)).formula = RightFormula
    Range(Cells(2, strCol), Cells(UsedRows, strCol)).Value = Range(Cells(2, strCol), Cells(UsedRows, strCol)).Value
End Sub

Select all Open in new window

Option Explicit

Public Sub PrintDelete()
    Dim objOL                      As Outlook.Application
    Dim objMsg                     As Outlook.MailItem
    Dim objAttachments             As Outlook.Attachments
    Dim objSelection               As Outlook.Selection
    Dim i    

Select all Open in new window