Overclock.net › Forums › Software, Programming and Coding › Coding and Programming › Visual Basic Code Help / Macro Troubles
New Posts  All Forums:Forum Nav:

Visual Basic Code Help / Macro Troubles

post #1 of 6
Thread Starter 
To start I'll give you some background information on my problem. I am using MS Outlook 2007 and am in the process of creating a macro, the purpose of which is to print the attachments of emails and then move the email to a specific folder. I have followed the thread at
http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/A_2924-Automatically-Printing-Saving-Emails-Attachments-in-Outlook.html

But with no avail. I have the "TestMacro" sub working and showing up in the macro list but not that "PrintAttaches" sub. Can anyone see anything wrong with the code? Or have any insight to where I am going wrong.

Any help would be appreciated smile.gif

My code:
Code:
Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, ByVal lpKeyName As String, _
        ByVal lpDefault As String, ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
    Optional bolPrintMsg As Boolean, _
    Optional bolSaveMsg As Boolean, _
    Optional bolPrintAtt As Boolean, _
    Optional bolSaveAtt As Boolean, _
    Optional bolInsertLink As Boolean, _
    Optional strAttFileTypes As String, _
    Optional strFolderPath As String, _
    Optional varMsgFormat As OlSaveAsType, _
    Optional strPrinter As String)
   
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strMyPath As String, _
        strExtension As String, _
        strFileName As String, _
        strOriginalPrinter As String, _
        strLinkText As String, _
        strRootFolder As String, _
        strTempFolder As String, _
        varFileType As Variant, _
        intCount As Integer, _
        intIndex As Integer, _
        arrFileTypes As Variant

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFolder = Environ("TEMP") & "\"
    
    If strAttFileTypes = "" Then
        arrFileTypes = Array("*")
    Else
        arrFileTypes = Split(strAttFileTypes, ",")
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strPrinter <> "" Then
            strOriginalPrinter = GetDefaultPrinter()
            SetDefaultPrinter strPrinter
        End If
    End If
    
    If bolSaveMsg Or bolSaveAtt Then
        If strFolderPath = "" Then
            strRootFolder = Environ("USERPROFILE") & "\My Documents\"
        Else
            strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
        End If
    End If
    
    If bolSaveMsg Then
        Select Case varMsgFormat
            Case olHTML
                strExtension = ".html"
            Case olMSG
                strExtension = ".msg"
            Case olRTF
                strExtension = ".rtf"
            Case olDoc
                strExtension = ".doc"
            Case olTXT
                strExtension = ".txt"
            Case Else
                strExtension = ".msg"
        End Select
        Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, IIf(varMsgFormat <> 0, varMsgFormat, olMSG)
    End If
        
    For intIndex = Item.Attachments.Count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        'Print the attachments if requested'
        If bolPrintAtt Then
            If olkAttachment.Type <> olEmbeddeditem Then
                For Each strFileType In arrFileTypes
                    If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
                        olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                        ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
                    End If
                Next
            End If
        End If
        'Save the attachments if requested'
        If bolSaveAtt Then
            strFileName = olkAttachment.FileName
            intCount = 0
            Do While True
                strMyPath = strRootFolder & strFileName
                If objFSO.FileExists(strMyPath) Then
                    intCount = intCount + 1
                    strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strMyPath
            If bolInsertLink Then
                If Item.BodyFormat = olFormatHTML Then
                    strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                Else
                    strLinkText = strLinkText & strMyPath & vbCrLf
                End If
                olkAttachment.Delete
            End If
        End If
    Next
    
    If bolPrintMsg Then
        Item.PrintOut
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
    
    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
        Else
            Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
        End If
        Item.Save
    End If

    'Addition for Ksquared_au'
    Item.UnRead = False
    'You must edit the path on the next line'
    Item.Move OpenOutlookFolder("Personal Folders\Company ABC\Printed")

    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub


Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function


Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub PrintAttaches(Item As Outlook.MailItem)
        MessageAndAttachmentProcessor Item, False, False, True, True, False, ".doc, .docx", "C:\Documents and Settings\Administrator\Desktop", , "KODAK ESP 5200 Series AiO"
End Sub

Sub TestMacro()
    MsgBox "Macros are enabled."
End Sub

Edit: When debugged, the code brings back an error on "GetDefaultPrinter()", the error reads: Compile Error: sub or function not defined
Edited by L.J - 5/14/13 at 6:16am
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
post #2 of 6
I did this once myself. It wasn't fun.

But biggest problem you'll face is that everytime you move an e-mail, the existing e-mails in that folder will re-index. So if you're moving email[1] then what was email[2] becomes email[1].

As for your GetDefaultPrinter() error, check line 47. You're calling a non-existent sub (basically as the error states).

Also, why have you got a couple of Win32 APIs in your code? What are you using GetProfileString and ShellExecute for? VBA has in build methods that can negate the need for ShellExecute (as well as supports other Office object types should you need to link your routine into Word or Excel (and I can't recall off hand what GetProfileString does). While you can use Win32 APIs in VBA, I wouldn't recommend it (I've crashed Office countless times while playing around with embedding chatrooms inside Word documents via Winsock APIs laugher.gif)
post #3 of 6
Thread Starter 
Okay you just blew my mind a little, I am a complete newbie when it comes to coding in VB so I have no idea what has been done and why in the code. I simply copied the code from the link I mentioned in the TS.

Haha I understand that its calling something that doesn't exist. The question is actually, why? The code seems to work for others on the thread linked in the TS. So why isn't mine? :S
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
post #4 of 6
Quote:
Originally Posted by L.J View Post

Okay you just blew my mind a little, I am a complete newbie when it comes to coding in VB so I have no idea what has been done and why in the code. I simply copied the code from the link I mentioned in the TS.

Haha I understand that its calling something that doesn't exist. The question is actually, why? The code seems to work for others on the thread linked in the TS. So why isn't mine? :S

They have that function in their code:
Code:
Function GetDefaultPrinter() As String
    Dim strPrinter As String, _
        intReturn As Integer
    strPrinter = Space(255)
    intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
    If intReturn Then
        strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
    End If
    GetDefaultPrinter = strPrinter
End Function

Is there a chance that you missed that out when copy/pasting the code?
post #5 of 6
Thread Starter 
Oh yes, I have no idea how I could possible have missed that piece of code. I thought I used the "Select all" function underneath the code section :S

I shall make the adjustment and re-post the results :S
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
Skynet HQ
(13 items)
 
  
CPUMotherboardGraphicsRAM
AMD Athlon X2 Dual Core 2.70GHz Asus M3N-78 PRO ATI XFX 5770 5GB Corsair DDR2 
OSMonitorKeyboardPower
Windows 7 Ultimate 2x 23" LG Flatrons Logitech MX3100 850w PSU 
CaseMouse
X-Blade Gaming Case Logitech MX1100 
  hide details  
Reply
post #6 of 6
Quote:
Originally Posted by L.J View Post

Oh yes, I have no idea how I could possible have missed that piece of code. I thought I used the "Select all" function underneath the code section :S

I shall make the adjustment and re-post the results :S

Easily done. I've lost count of the number of times I've copy/paste failed laugher.gif
If I were you, I'd have a quick scan through to make sure you've not missed anything else thumb.gif
New Posts  All Forums:Forum Nav:
  Return Home
  Back to Forum: Coding and Programming
Overclock.net › Forums › Software, Programming and Coding › Coding and Programming › Visual Basic Code Help / Macro Troubles