I am trying to define and call a function from a subroutine. When I run the subroutine, I get "Compiler error: Sub or function not defined". Why is this happening?
The function I am trying to call is th GetImageHeight below, but the same happens with any of the other functions.
I understand that such questions get asked frequently, and the cause is usually the OP doing something stupid. I searched for similar questions, but I still don't get it.
The function below is largely copied from this page
Here the code:
Function FileExists(FilePath As String) As Boolean
On Error Resume Next
If Len(FilePath) > 0 Then
If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
End If
On Error GoTo 0
End Function
Function IsValidImageFormat(FilePath As String) As Boolean
Dim imageFormats As Variant
Dim i As Integer
imageFormats = Array(".bmp", ".jpg", ".gif", ".tif", ".png")
For i = LBound(imageFormats) To UBound(imageFormats)
If InStr(1, UCase(FilePath), UCase(imageFormats(i)), vbTextCompare) > 0 Then
IsValidImageFormat = True
Exit Function
End If
Next I
End Function
Sub DeleteImages()
Dim ThisImage As InlineShape
Dim Height As Double
Dim Width As Double
Dim TotalCount As Integer
Dim Count As Integer
Dim Source As String
Dim ImageHeightPx As Double
Dim ImageWidthPx As Double
Dim ImagePath As String
Dim ImageName As String
Dim FileName As String
ImagePath = "C:\Users\User\Image\"
FileName = Mid(ActiveDocument.Name, 1, InStr(1, ActiveDocument.Name, ".") - 1)
Set myStyle = ActiveDocument.Styles.Add(Name:="Replaced Image", Type:=wdStyleTypeCharacter)
TotalCount = ActiveDocument.InlineShapes.Count
ImageCount = 1
For Each ThisImage In ActiveDocument.InlineShapes
ImageName = FileName & "_IMG_" & Trim(Str(ImageCount))
MsgBox ImageName
ThisImage.Select
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Style = "Replaced Image"
Selection.TypeText Text:="[[[ " & ImageName & " ]]]"
ImageHeightPx = GetImageHeight(ImagePath & ImageName & ".png")
ImageWidthPx = GetImageWidth(ImagePath & ImageName & ".png")
MsgBox "Height: " & Str(ImageHeightPx)
MsgBox "Width: " & Str(ImageWidthPx)
ImageCount = ImageCount + 1
Next ThisImage
End Sub
Function GetImageHeight(ImagePath As String) As Variant
Dim imgHeight As Integer
Dim wia As Object
If FileExists(ImagePath) = False Then Exit Function
If IsValidImageFormat(ImagePath) = False Then Exit Function
On Error Resume Next
Set wia = CreateObject("WIA.ImageFile")
If wia Is Nothing Then Exit Function
On Error GoTo 0
wia.LoadFile ImagePath
imgHeight = wia.Height
Set wia = Nothing
GetImageHeight = imgHeight
End Function
Function GetImageWidth(ImagePath As String) As Variant
Dim imgWidth As Integer
Dim wia As Object
If FileExists(ImagePath) = False Then Exit Function
If IsValidImageFormat(ImagePath) = False Then Exit Function
On Error Resume Next
Set wia = CreateObject("WIA.ImageFile")
If wia Is Nothing Then Exit Function
On Error GoTo 0
wia.LoadFile ImagePath
imgWidth = wia.Width
Set wia = Nothing
GetImageWidth = imgWidth
End Function
Edits: replaced screenshot with code.
check, you have copied FileExists() and IsValidImageFormat() from source sample into your module.
check, you have selected WIA library for the project
To add WIA 2.0 library:
Click Components from the Project menu (or press Ctrl-T).
Scroll down and select Microsoft Windows Image Acquisition Library
v2.0 by placing a checkmark in front of it. Of the three new controls
that appear on in the Toolbox.
Related
I am trying to split pdf, based on the pages where it finds ".pdf" however when I try to save the pdf with a dynamic string variable, it do not save the pdf but when I write hardcode file path it output the pdf. do not know what is going on here.
the following code is not finished yet I am stuck in creating new pdf with deleted pages:
Function Extract_PDF()
Dim aApp As Acrobat.CAcroApp
Dim av_Doc As Acrobat.CAcroAVDoc
Dim pdf_Doc As Acrobat.CAcroPDDoc '
Dim newPDFdoc As Acrobat.CAcroPDDoc
Dim Sel_Text As Acrobat.CAcroPDTextSelect
Dim i As Long, j As Long
Dim pageNum, Content
Dim pageContent As Acrobat.CAcroHiliteList
Dim found As Boolean
Dim foundPage As Integer
Dim PDF_Path As String
Dim pdfName As String
Dim folerPath As String
Dim FileExplorer As FileDialog
Set FileExplorer = Application.FileDialog(msoFileDialogFilePicker)
With FileExplorer
.AllowMultiSelect = False
.InitialFileName = ActiveDocument.Path
.Filters.Clear
.Filters.Add "PDF File", "*.pdf"
If .Show = -1 Then
PDF_Path = .SelectedItems.Item(1)
Else
PagesLB = "Catch me Next Time ;)"
PDF_Path = ""
Exit Function
End If
End With
Set aApp = CreateObject("AcroExch.App")
Set av_Doc = CreateObject("AcroExch.AVDoc")
If av_Doc.Open(PDF_Path, vbNull) <> True Then Exit Function
While av_Doc Is Nothing
Set av_Doc = aApp.GetActiveDoc
Wend
av_Doc.BringToFront
aApp.Show
Set pdf_Doc = av_Doc.GetPDDoc
For i = pdf_Doc.GetNumPages - 1 To 0 Step -1
Set pageNum = pdf_Doc.AcquirePage(i)
Set pageContent = CreateObject("AcroExch.HiliteList")
If pageContent.Add(0, 9000) <> True Then Exit Function
Set Sel_Text = pageNum.CreatePageHilite(pageContent)
Content = ""
found = False
For j = 0 To Sel_Text.GetNumText - 1
Content = Content & Sel_Text.GetText(j)
If InStr(1, Content, ".pdf") > 0 Then
found = True
foundPage = i
pdfName = Content
Exit For
End If
Next j
If found Then
PDF_Path = Left(PDF_Path, InStrRev(PDF_Path, "\")) & ValidWBName(pdfName)
Set newPDFdoc = CreateObject("AcroExch.PDDoc")
Set newPDFdoc = av_Doc.GetPDDoc
If newPDFdoc.DeletePages(0, i - 1) = False Then
Debug.Print "Failed"
Else
Debug.Print "done"
End If
If newPDFdoc.Save(PDSaveFull, PDF_Path) = False Then
Debug.Print "Failed to save pdf "
Else
Debug.Print "Saved"
End If
newPDFdoc.Close
End If
Next i
av_Doc.Close False
aApp.Exit
Set av_Doc = Nothing
Set pdf_Doc = Nothing
Set aApp = Nothing
End Function
ValidWBName:
Function ValidWBName(agr As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Pattern = "[\\/:\*\?""<>\|]"
.Global = True
ValidWBName = .Replace(agr, "")
End With
End Function
in above function when it finds the word pdf it try to create a new instance of pdf and remove previous pages.
If found Then
PDF_Path = Left(PDF_Path, InStrRev(PDF_Path, "\")) & ValidWBName(pdfName)
Set newPDFdoc = CreateObject("AcroExch.PDDoc")
Set newPDFdoc = av_Doc.GetPDDoc
If newPDFdoc.DeletePages(0, i - 1) = False Then
Debug.Print "Failed"
Else
Debug.Print "done"
End If
If newPDFdoc.Save(PDSaveFull, PDF_Path) = False Then
Debug.Print "Failed to save pdf "
Else
Debug.Print "Saved"
End If
newPDFdoc.Close
End If
this line "Failed to save pdf"
If newPDFdoc.Save(PDSaveFull, PDF_Path) = False Then
but when I write hardcode path it create the pdf
If newPDFdoc.Save(PDSaveFull, "C:\Users\MBA\Desktop\PDF Project 2\Murdoch_Michael__Hilary_PIA_19.pdf") = False Then
the culprit HAD to be in ValidWBName() function, which didn't handle all possible not allowed chars for a valid file name
since it came out vbCr char was one of them, you could change it as follows:
Function ValidWBName(agr As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Pattern = "[\\/:\*\?""<>\|" & Chr(13) & "]" ' <-- added vbCr
.Global = True
ValidWBName = .Replace(agr, "")
End With
End Function
I'm trying to limit the following code to only columns 6 and 7, but it works for the entire sheet.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lOld As Long
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 6 _
Or Target.Column = 7 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lOld = Len(oldVal)
If Left(newVal, lOld) = oldVal Then
Target.Value = newVal
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
End If
If newVal = "" Then
'do nothing
Else
lOld = Len(oldVal)
If Left(newVal, lOld) = oldVal Then
Target.Value = newVal
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
You have code duplicated both inside your test for INTERSECT and later outside that test. There are some tests for column outside, so I'm not sure why it's triggering anyway... There also seems to be an extra End If I can't figure out so I'm not sure how it was even executing.
I've rewritten removing superfluous nested Ifs and whatnot. I've added comments mostly just to help me out while I was rewriting, but they may serve useful for future edits.
This code runs only for cells of type xlCellTypeAllValidation in columns 6 and 7. If you don't need to limit to just xlCellTypeAllValidation cells, then remove that from the main If test.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lOld As Long
'Exit routine if more than one cell was changed
If Target.Count > 1 Then GoTo exitHandler
'Shut off errors, and attempt to grab xlCellTypeAllValidation cells
'If no cells are of type xlCellTypeAllValidation then exit routine
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo exitHandler
'If the cell changed is xlCellTypeAllValidation AND in columns 6 or 7 Then run code
If Not Intersect(Target, rngDV) Is Nothing AND (Target.Column = 6 OR Target.Column = 7) Then
'Shut off events
Application.EnableEvents = False
'Capture old and new values to variables
newVal = Target.Value
Application.Undo
oldVal = Target.Value
'undo the undo
Target.Value = newVal
'If the cell used to hold a value and it was changed to a new value (not null)
If oldVal <> "" AND newVal <> "" Then
'Test to see if the change didn't affect the contents of the cell
lOld = Len(oldVal)
If Left(newVal, lOld) = oldVal Then
Target.Value = newVal
Else 'They've truly changed the content, so bring in the old content and append the new with a comma
Target.Value = oldVal & ", " & newVal
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
I wrote a script where I add a signature from an htm file in the appData ... signature folder to a newly opened email.
My question is - how do i modify this VBA script to add that signature in a way so Outlook knows its a signature and the signature might be changed by a user via gui.
I assume it may have something to do with setting a "_MailAutoSig" bookmark, is that right?
Script looks like this and works so far:
Dim WithEvents m_objMail As Outlook.MailItem
Dim LODGIT_SUBJECT_IDENTIFIERS() As String
Private Sub Application_ItemLoad(ByVal Item As Object)
'MsgBox "Application_ItemLoad"
Select Case Item.Class
Case olMail
Set m_objMail = Item
End Select
End Sub
Private Sub m_objMail_Open(Cancel As Boolean)
'string array containing lodgit email subject identifiers (beginning string!!! of email subject)
LODGIT_SUBJECT_IDENTIFIERS = Split("Angebot von Bödele Alpenhotel,Angebot von,bestätigt Ihre Reservierung,Rechnung Nr.,Stornogutschrift für die Rechnung,Ausstehende Zahlung", ",")
Dim Application As Object
Dim oOutApp As Object, oOutMail As Object
Dim strbody As String, FixedHtmlBody As String
Dim Ret
Set Application = CreateObject("Outlook.Application")
'Change only Mysig.htm to the name of your signature
' C:\Users\nicole\AppData\Roaming\Microsoft\Signatures
Ret = Environ("appdata") & _
"\Microsoft\Signatures\AH Andrea kurz.htm"
If Ret = False Then Exit Sub
'~~> Use the function to fix image paths in the htm file
FixedHtmlBody = FixHtmlBody(Ret)
'CHECK FOR LODGIT IDENTIFIER
If myInStr(m_objMail.Subject, LODGIT_SUBJECT_IDENTIFIERS()) Then
Debug.Print "E-Mail as from Lodgit identified"
Dim str As String
Dim a As Object
str = Replace(m_objMail.Body, vbCrLf, "<br>")
str = Replace(str, vbNewLine, "<br>")
m_objMail.HTMLBody = "<html><body><span style='font-size:11.0pt;font-family:""Times New Roman"" '>" & str & "</span>" & FixedHtmlBody & "</body></html>"
End If
End Sub
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "-Dateien"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> To cater for spaces in signature file name
'FullPath = Replace(FullPath, " ", "%20")
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, "AH%20Andrea%20kurz-Dateien", FullPath)
'FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
'~~> Gets File Name from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End Function
'check if str contains on of the elements of a str array
Public Function myInStr(myString As String, a() As String) As Boolean
For Each elem In a
If InStr(1, myString, elem, vbTextCompare) <> 0 Then
myInStr = True
Exit Function
End If
Next
myInStr = False
End Function
Outlook looks for the "_MailAutoSig" bookmark. This needs to be done with Word Object Model, not by setting the HTMLBody property. Something along the lines:
wdStory = 6
wdMove = 0
Set objBkm = Nothing
Set objDoc = Inspector.WordEditor
Set objSel = objDoc.Application.Selection
'remember the cursor position
set cursorRange = objDoc.Range
cursorRange.Start = objSel.Start
cursorRange.End = objSel.End
If objDoc.Bookmarks.Exists("_MailAutoSig") Then
'replace old signature
Debug.Print "old signature found"
set objBkm = objDoc.Bookmarks("_MailAutoSig")
objBkm.Select
objDoc.Windows(1).Selection.Delete
ElseIf objDoc.Bookmarks.Exists("_MailOriginal") Then
' is there the original email? (_MailOriginal)
set objBkm = objDoc.Bookmarks("_MailOriginal")
objSel.Start = objBkm.Start-2 'give room for the line break before. It includes the line
objSel.End = objBkm.Start-2
Else
'insert at the end of the email
objSel.EndOf wdStory, wdMove
End If
'start bookmark
set bkmStart = objDoc.Bookmarks.Add("_tempStart", objSel.Range)
'end bookmark
set bkmEnd = objDoc.Bookmarks.Add("_tempEnd", objSel.Range)
bkmEnd.End = bkmEnd.End + 1
bkmEnd.Start = bkmEnd.Start + 1
objSel.Text = " "
set objBkm = objDoc.Bookmarks.Add("_MailAutoSig", bkmStart.Range)
objBkm.Range.insertFile "c:\Users\<user>\AppData\Roaming\Microsoft\Signatures\test.htm", , false, false, false
objBkm.Range.InsertParagraphBefore
objBkm.End = bkmEnd.Start - 1 'since we added 1 above for bkmEnd
objSel.Start = cursorRange.Start
objSel.End = cursorRange.End
bkmStart.Delete
bkmEnd.Delete
I am getting error as Compile Error: Argument Not Optional when running vba code pointing towards the line. MsgBox (RemoveFirstChar)
Code:
Sub test()
Dim Currworkbook As Workbook
Dim CurrWKSHT As Worksheet
Dim Filename As String
Dim BCName As String
Dim Str As String
FFolder = "C:\user"
CurrLoc = "File3"
If CurrrLoc = "File3" Then
CurrLoc = FFolder & "\" & CurrLoc
Set FSobj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set FFolderObj = FSobj.GetFolder(CurrLoc)
If Err.Number > 0 Then
'
End If
For Each BCObj In FFolderObj.Files
'BCName = Right(BCObj.Name, (Len(BCObj.Name) - InStrRev(BCObj.Name, "\", 1)))
If IsNumeric(Left(BCObj.Name, 4)) <> True Then
Call RemoveFirstChar(BCObj.Name)
'Str = RemoveFirstChar
MsgBox (RemoveFirstChar) '--->Error: Compile Error: Argument Not Optional
Else
MsgBox (BCObj.Name)
End If
Next
End If
End Sub
Public Function RemoveFirstChar(RemFstChar As String) As String
Dim TempString As String
TempString = RemFstChar
If Left(RemFstChar, 1) = "1" Then
If Len(RemFstChar) > 1 Then
TempString = Right(RemFstChar, Len(RemFstChar) - 1)
End If
End If
RemoveFirstChar = TempString
End Function
RemoveFirstChar is a user defined function that requires a non-optional string as a parameter.
Public Function RemoveFirstChar(RemFstChar As String) As String
....
End Function
I think you want to get rid of the Call RemoveFirstChar(BCObj.Name) then use,
MsgBox RemoveFirstChar(BCObj.Name)
I have a VBA code that pulls images and inserts in Excel file based on cell value in column A. But in my P drive, from where it pulls images, I have images that end with ' -TH ' and I want to exclude them. i.e. I have image in P drive, that named as "CITY-B" and the other one as "CITY-B-TH". And when I type 'CITY'(this is how I need the name to be typed in excel), I want it to insert the one without "TH". How can i do that?
Private Sub Worksheet_Change(ByVal Target As Range)
If (Split(Target.Address, "$")(1) <> "A") Then Exit Sub
Call Inser_Image(Target)
End Sub
Private Sub Inser_Image(Ac_Cells As Range)
Dim myRng As Range
Dim Mycell As Range
Dim St As String
Dim myPath As String
Dim My_Pic As Shape
Dim My_File As String
Dim Ac_cell As Range
myPath = Sheet1.Cells(1, 5).Value
If Len(myPath) > 3 Then
If Right(myPath, 1) <> "\" Then
myPath = myPath + "\"
End If
End If
For Each Ac_cell In Ac_Cells
For Each My_Pic In Sheet1.Shapes
If My_Pic.Left = Ac_cell.Offset(0, 1).Left And My_Pic.Top = Ac_cell.Offset(0, 1).Top Then
My_Pic.Delete
Exit For
End If
Next
St = Trim(Ac_cell.Value)
If Len(St) > 4 Then
If LCase(Left(St, 4)) = "http" Then
Call Insert_Picture(St, Ac_cell.Offset(0, 1))
GoTo Nextse1
End If
End If
myPath = "P:\"
If Right(myPath, 1) <> "\" Then myPath = myPath + "\"
If Not (Dir(myPath + St)) = "" Then
My_File = St
Else
My_File = Find_File(myPath, St)
End If
If My_File > " " Then
Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))
End If
Application.ScreenUpdating = True
Nextse1:
Next
End Sub
Sub Insert_Picture(thePath As String, theRange As Range)
On Error GoTo Err3
Dim myPict As Shape
Sheet1.Shapes.AddPicture thePath, True, True, theRange.Left, theRange.Top, theRange.Width, theRange.Height
Set myPict = Sheet1.Shapes(Sheet1.Shapes.Count)
With myPict
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
End With
Set myPict = Nothing
Exit Sub
Err3:
MsgBox Err.Description
End Sub
Function Find_File(thePath As String, F_N As String) As String
file = Dir(thePath)
Do Until file = ""
If Len(file) < Len(F_N) Then GoTo EXT_N1
If LCase(Left(file, Len(F_N))) = LCase(F_N) Then
Find_File = file
Exit Function
End If
EXT_N1:
file = Dir()
Loop
Find_File = ""
End Function
Put the EndsWith function in your code. (I included a starts with if it helps down the road) and use it like this:
If My_File > " " Then
If EndsWith(My_File,"-TH") Then
else
Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))
End If
End If
Public Function EndsWith(str As String, ending As String) As Boolean
Dim endingLen As Integer
endingLen = Len(ending)
EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function
Public Function StartsWith(str As String, start As String) As Boolean
Dim startLen As Integer
startLen = Len(start)
StartsWith = (Left(Trim(UCase(str)), startLen) = UCase(start))
End Function
Use InStr to search in the filename your pattern "-TH"
Dim pos As Integer
pos = InStr("find the comma, in the string", ",")