The vbscript works fine in a .vbs file.
Of course, when I run the vbscript code in a .vbs file, I uncomment the 'msgbox lines.
When I load the following file, I get an error message on line 42 with no additional explanation.
Any suggestions would be much appreciated.
If I solve this problem, I'm going to create a menu that will invoke PDF files, .mp3 audio files, and .mp4 video files
Here's the code I've created thus far:
<html>
<head>
<title>My HTML application</title>
<HTA:APPLICATION
APPLICATIONNAME="My HTML application"
ID="MyHTMLapplication"
VERSION="1.0"/>
</head>
<script language="VBScript">
Sub Window_OnLoad
'This method will be called when the application loads
'Add your code here
' copyright JSWARE
'FileExt.vbs.
'-- File extension default program Class.
'-- send a file extension to Function and Get path of default program.
Dim CE, txtExt, htmlExt, zipExt, pdfExt, mp4Ext
Set CE = New ClsExt
txtExt = CE.GetDefaultProgram("txt")
'MsgBox "TXT" & vbcrlf & txtExt
htmlExt = CE.GetDefaultProgram("html")
'MsgBox "HTML" & vbcrlf & htmlExt
htmlExt = CE.GetDefaultProgram("zip")
'MsgBox "ZIP" & vbcrlf & htmlExt
pdfExt = CE.GetDefaultProgram("pdf")
'MsgBox "XYZ" & vbcrlf & pdfExt
mp4Ext = CE.GetDefaultProgram("mp4")
'MsgBox "mp4" & vbcrlf & mp4Ext
Set CE = Nothing
'_______________ START ClsExt Class ____________________________
Class ClsExt
Private SH, CK1, CK, s1, s2, sType
Private Sub Class_Initialize()
CK = "\Shell\Open\Command\"
CK1 = "\Shell\Opennew\Command\"
Set SH = CreateObject("WScript.Shell")
End Sub
Private Sub Class_Terminate()
Set SH = Nothing
End Sub
Public Function GetDefaultProgram(sExt)
If left(sExt, 1) <> "." Then
sExt = "." & sExt
End If
On Error Resume Next
Err.clear
sType = SH.RegRead("HKCR\" & sExt & "\") '--look up ext in HKCR to Get file type (ex.: "txtfile")
If (Err.number <> 0) or (len(sType) = 0) Then
GetDefaultProgram = ""
Exit Function
End If
s1 = SH.RegRead("HKCR\" & sType & CK) '--Shell\open\command or.....
If (Err.number = 0) and (len(s1) <> 0) Then
s2 = Stripit(s1)
GetDefaultProgram = s2
Exit Function
End If
Err.clear
s1 = SH.RegRead("HKCR\" & sType & CK1) '--shell\opennew\command.
If (Err.number = 0) and (len(s1) <> 0) Then
s2 = Stripit(s1)
GetDefaultProgram = s2
Exit Function
End If
Err.clear
s1 = SH.RegRead("HKCR\" & sExt & CK)
If (Err.number = 0) and (len(s1) <> 0) Then
s2 = Stripit(s1)
GetDefaultProgram = s2
Exit Function
End If
GetDefaultProgram = "" '--If none of these checks have found anything return "".
End Function
Private Function Stripit(sp) '--clean up default program string.
Dim ept, sf
On Error Resume Next
ept = instr(1, sp, "exe", 1) '--find End of exe path.
If ept <> 0 Then
sf = left(sp, ept + 2)
Else
ept = instr(1, sp, "com", 1)
If ept <> 0 Then
sf = left(sp, ept + 2)
End If
End If
If left(sf, 1) = chr(34) Then '--take off any quotes or spaces.
sf = right(sf, (len(sf) - 1))
End If
sf = trim(sf)
Stripit = sf
End Function
End Class
'Set wmp = CreateObject("WMPlayer.OCX")
'wmp.openPlayer("E:\svr1\K\data\Steinberg Nisan\AV\2013-04-15_\VID_20130415_171550_FIXED_.mp4")
'wmp.openPlayer(".\VID_20130415_191439_FIXED_.mp4")
End Sub
</script>
<body bgcolor="white">
<!--Add your controls here-->
<br /><br />
<font size="7">
<b><u>Table of Contents: Index to Folder </b></u></font>
<br /><br />
<!--{{InsertControlsHere}}-Do not remove this line-->
</body>
</html>
You can not declare a class inside a sub, and you have Class ClsExt inside Sub Window_OnLoad
Related
Taken dis codes from random sites using for extract the text content in Slide and Notes section from PPT slides. But the output file given as a NOTEPAD. I want the o/p file as a word document. Can anyone to help on this? Thanks to you in advance
P.S. I express my gratitude those who created these codes and simplify my work.
Option Explicit
Sub ExportNotesText()
Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long
' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")
' did user cancel?
If strFileName = "" Then
Exit Sub
End If
' is the path valid? crude but effective test: try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _ & "Please try again."
Exit Sub
End If
Close #intFileNum ' temporarily
' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
strNotesText = strNotesText & "======================================" & vbCrLf
strNotesText = strNotesText & "Slide" & oSl.SlideIndex & vbCrLf
strNotesText = strNotesText & SlideText(oSl) & vbCrLf
strNotesText = strNotesText & NotesText(oSl) & vbCrLf
Next oSl
' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum
' show what we've done
lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub
Function SlideText(oSl As Slide) As String
Dim oSh As Shape
Dim osld As Slide
Dim strNotesText As String
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
SlideText = SlideText & oSh.Name & ":" & " " & oSh.TextFrame.TextRange & vbCrLf
End If
End If
Next oSh
End Function
Function NotesText(oSl As Slide) As String
Dim oSh As Shape
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
NotesText = oSh.TextFrame.TextRange.Text
End If
End If
End If
Next oSh
End Function
For Example:
Sub Demo()
'Note: A VBA Reference to Word is required.
'See under Tools|References
Dim WdApp As New Word.Application, wdDoc As Word.Document
Dim Sld As Slide, Shp As Shape
Set wdDoc = WdApp.Documents.Add
For Each Sld In ActivePresentation.Slides
With Sld
For Each Shp In .NotesPage.Shapes
With Shp
If .PlaceholderFormat.Type = ppPlaceholderBody Then
If .HasTextFrame Then
If .TextFrame.HasText Then
wdDoc.Range.InsertAfter vbCr & Sld.SlideIndex & ": " & .TextFrame.TextRange.Text
End If
End If
End If
End With
Next
For Each Shp In .Shapes
With Shp
If .HasTextFrame Then
If .TextFrame.HasText Then
wdDoc.Range.InsertAfter vbCr & .Name & ": " & .TextFrame.TextRange.Text
End If
End If
End With
Next
End With
Next
WdApp.Visible = True: wdDoc.Activate
Set wdDoc = Nothing: Set WdApp = Nothing
End Sub
In LibreOffice is it possible to get bookmark that is inserted in the text?
With the code below I can get the list of all the bookmarks I have available, but I just wanted the ones that are actually inserted in the text.
XBookmarksSupplier xBookmarksSupplier =
UnoRuntime.queryInterface(XBookmarksSupplier.class,
xCurrentComponent); XNameAccess xNamedBookmarks =
xBookmarksSupplier.getBookmarks();
Hope this helps:
Sub MyBookmarks
Dim oBookmarks As Variant
Dim oElementNames As Variant
Dim oBookmark As Variant
Dim oTextFields As Variant
Dim oEnum As Variant
Dim oTextField As Variant
Dim sSourceName As String
Dim i As Long, j As Long
Dim sResult As String
Rem First step - collect Bookmarks
oBookmarks = ThisComponent.getBookmarks()
oElementNames = oBookmarks.getElementNames()
Rem Create list of Bookmarks to count Text Fields with it
ReDim oBookmark(LBound(oElementNames) To UBound(oElementNames))
For i = LBound(oElementNames) To UBound(oElementNames)
oBookmark(i) = Array(oElementNames(i),0)
Next i
Rem Enumerate Text Fields
oTextFields = ThisComponent.getTextFields()
oEnum = oTextFields.createEnumeration()
Do While oEnum.hasMoreElements()
oTextField = oEnum.nextElement()
sSourceName = oTextField.SourceName
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(0) = sSourceName Then
oBookmark(i)(1) = oBookmark(i)(1) + 1
Exit For
EndIf
Next i
Loop
Rem Show results
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) > 0 Then
sResult = sResult + oBookmark(i)(0) + " (" + oBookmark(i)(1) + ")" + Chr(10)
EndIf
Next i
If Len(sResult) > 0 Then
sResult = Left(sResult, Len(sResult)-1)
MsgBox("The text of the document uses Bookmarks:" + Chr(10) + sResult, MB_ICONINFORMATION, "Used Bookmarks")
Else
MsgBox("No Bookmarks are used in the text of the document", MB_ICONEXCLAMATION, "No Bookmarks")
EndIf
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) = 0 Then
sResult = sResult + oBookmark(i)(0) + ", "
EndIf
Next i
If Len(sResult) > 0 Then
MsgBox("Bookmarks that are not used in the text of the document:" + Chr(10) + Left(sResult, Len(sResult)-2), MB_ICONINFORMATION, "Not Used Bookmarks")
EndIf
End Sub
I have this form to enter new data to a table.
I would like to warn the user when he is entering an invoice number that already exist. Here is the code I have but its not working:
Private Sub CommandButton1_Click()
Dim L As Long
Dim Code As String
Dim TextBox2 As Long
Dim valFormula As String
valFormula = "=COUNTIFS($F12:$F1702,F1702,$D12:$D1702,D1702)=1"
If MsgBox("Confirm?", vbYesNo, "Confirming new invoice") = vbYes Then
With Worksheets("FACTURE")
L = Sheets("FACTURE").Range("D65535").End(xlUp).Row + 1 'Pour placer le nouvel enregistrement _ la premi_re ligne de tableau non vide
End With
With Me
Range("D" & L).Validation
.Add Type:=xlValidateCustom, _
AlertStyle:=xlValidAlertWarning, _
Formula1:="=COUNTIFS($F12:$F1702,F1702,$D12:$D1702,D1702)=1"
.InputTitle = ""
.ErrorTitle = "Duplicate alert"
.InputMessage = ""
.ErrorMessage = "This invoice number already exist. Continue?"
Range("B" & L).Value = .ComboBox2 & .ComboBox3
Range("C" & L).Value = (Now)
Range("D" & L).Value = .TextBox2
Range("E" & L).Value = .TextBox3
Range("F" & L).Value = .TextBox4
Range("G" & L).Value = .TextBox5
Range("K" & L).Value = .ComboBox1
Range("L" & L).Value = .ComboBox2
Range("M" & L).Value = .ComboBox3
Range("N" & L).Value = .TextBox9
Range("O" & L).Value = .TextBox10
Range("R" & L).Value = .TextBox39
Range("P" & L).Value = .TextBox40
Range("C" & L).Interior.ColorIndex = 0
If .OptionButton1 Then
FormatCell Range("B" & L), xlThemeColorAccent3
ElseIf .OptionButton2 Then
FormatCell Range("B" & L), xlThemeColorAccent1
ElseIf .OptionButton3 Then
FormatCell Range("B" & L), xlThemeColorAccent4
Else
FormatCell Range("B" & L), xlThemeColorAccent2
End If
End With
End If
End Sub
Any advice?
As Comintern suggested, use Find() method of Range object, with code like:
Set f = rngToSerachIn.Find(what:=factureNo, LookIn:=xlValues, lookat:=xlWhole)
where
f is a range variable where to store the range with the searched value
rngToSerachIn is the range where to search the value
factureNo is the value to search for
furthermore it seems to me your invoices will be stored in rows from 12 downwards, so it could be useful to write a generic function to get first empty cell in a given column of a given worksheet ranging from a certain row
Since it'd be a good practice to demand specific tasks to Sub/Function to improve both code readability and maintenance, you could do that for:
getting first empty row after last non empty one starting from a given row in a given column of a given worksheet
validating invoice number
filling worksheet ranges
formatting invoice cell
as follows:
Option Explicit
Private Sub CommandButton1_Click()
Dim L As Long
Dim factureWs As Worksheet
If MsgBox("Confirm?", vbYesNo, "Confirming new invoice") = vbNo Then Exit Sub
Set factureWs = Worksheets("FACTURE") '<--| set the worksheet you want to work with
L = GetLastNonEmptyRow(factureWs, "D", 12) + 1 '<--| get passed worksheet first empty row after last non empty one in column "D" from row 12 (included)
If L > 12 Then If Not CheckDuplicate(Me.TextBox2, factureWs.Range("D12:D" & L - 1)) Then Exit Sub '<--| exit if duplicated non accepted by the user
FillRanges factureWs, L '<--| fill worksheet ranges with userfom controls values
FormatInvoice factureWs.Range("B" & L) '<--| color invoice cell depending on option buttons values
End Sub
Function GetLastNonEmptyRow(ws As Worksheet, colIndex As String, firstRow As Long) As Long
Dim lastRow As Long
With ws
lastRow = .Cells(.Rows.Count, colIndex).End(xlUp).row ' <--| get last non empty row in given column
If lastRow = 1 Then If IsEmpty(.Range(colIndex & 1)) Then lastRow = 0 '<--| handle the case of an empty column
If lastRow < firstRow Then lastRow = firstRow - 1 '<--| handle the case the last non empty row is above the first passed one
End With
GetLastNonEmptyRow = lastRow
End Function
Function CheckDuplicate(factureNo As String, rng As Range) As Boolean
Dim f As Range
Set f = rng.Find(what:=factureNo, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
CheckDuplicate = MsgBox("This invoice number already exist!" & vbCrLf & vbCrLf & "Continue?", vbExclamation + vbYesNo, "Duplicate alert") = vbYes
Else
CheckDuplicate = True
End If
End Function
Sub FormatInvoice(rng As Range)
Dim thColor As XlThemeColor
With Me
Select Case True
Case .OptionButton1
thColor = xlThemeColorAccent3
Case .OptionButton2
thColor = xlThemeColorAccent1
Case .OptionButton3
thColor = xlThemeColorAccent4
Case Else
thColor = xlThemeColorAccent2
End Select
End With
FormatCell rng, thColor
End Sub
Sub FillRanges(ws As Worksheet, L As Long)
With ws
.Range("C" & L).Value = (Now)
.Range("D" & L).Value = Me.TextBox2
.Range("E" & L).Value = Me.TextBox3
.Range("F" & L).Value = Me.TextBox4
.Range("G" & L).Value = Me.TextBox5
.Range("K" & L).Value = Me.ComboBox1
.Range("L" & L).Value = Me.ComboBox2
.Range("M" & L).Value = Me.ComboBox3
.Range("N" & L).Value = Me.TextBox9
.Range("O" & L).Value = Me.TextBox10
.Range("R" & L).Value = Me.TextBox39
.Range("P" & L).Value = Me.TextBox40
End With
End Sub
you may find it useful and follow this pattern in your subsequent coding
I am struggling with the above error when trying to write the Visual Basic code for a 2010 Access Form. I am trying to get ensure that the associate and the Team Lead get the same email. When I first wrote the code, it worked initially. I have since added an "issue date" to the form, but not to the email. I attempted to add the issue date to the Script, but that did not work. I have since removed both the issue date from the form and the script. Any help would appreciated:
Private Sub cmdEmail_Click()
Dim objOutlook As Object
Dim objMailItem As Object
Const olMailItem As Integer = 0
Dim objMailItem1 As Object
Const olMailItem1 As Integer = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
Set objMailItem1 = objOutlook.CreateItem(olMailItem1)
Dim strPathAttach As String
On Error GoTo err_Error_handler
'set receipient, you can use a DLookup() to retrieve your associate Email address
objMailItem.To = DLookup("Email_ID", "dbo_Noble_Associates", "[Fullname]='" & Me.cboAssociate & "'")
objMailItem1.To = DLookup("Email_ID", "dbo_TeamLeads$", "[Fullname]='" & Me.txtTeamLead & "'")
'set subject with text and Form values
objMailItem.Subject = "Attendance Violation " & Me.cboAssociate
objMailItem1.Subject = "Attendance Violation " & Me.cboAssociate
'set body content with text and Form values etc.
objMailItem.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
objMailItem1.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
' display email
' objMailItem.Display
' sending mail automaticly
objMailItem.Send
objMailItem1.Send
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
exit_Error_handler:
On Error Resume Next
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
Exit Sub
err_Error_handler:
Select Case Err.Number
'trap error 287
Case 287
MsgBox "Canceled by user.", vbInformation
Case Else
MsgBox "Error " & Err.Number & " " & Err.Description
End Select
Resume exit_Error_handler
End Sub
Private Sub CheckEmail_Click()
End Sub
Private Sub cmdSaveandNew_Click()
If Me.txtOccurrence_Date & "" = "" Then
MsgBox "Please enter the date."
Me.txtOccurrence_Date.SetFocus
Exit Sub
ElseIf Me.cboAssociate & "" = "" Then
MsgBox "Please select the associate's name."
Me.cboAssociate.SetFocus
Exit Sub
ElseIf Me.txtPoints & "" = "" Then
MsgBox "Please enter the number of Points."
Me.txtPoints.SetFocus
Exit Sub
End If
If Me.CheckEmail = True Then
cmdEmail_Click
End If
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmd_Cancel_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cboassociate_AfterUpdate()
Me.txtTeamLead.Value = Me.cboAssociate.Column(1)
End Sub
Private Sub cboFullname_AfterUpdate()
Me.txtCurrentpoints.Value = Me.cbofullname.Column(1)
End Sub
Private Sub CboType_AfterUpdate()
Me.txtPoints.Value = Me.CboType.Column(1)
End Sub
I am open to any suggestions.
Has anyone been able to download email that contains attachment with CDO in vb6?
Can you help me with an example?
I'm still not sure where you want to retrieve email from but here is some code for retrieving email from an Exchange server. I did this as an experiment to learn some methods I would need on another project so it is not production quality but should get you started. This code is dependent on an Exchange client already being setup on the computer this is running on.
This function creates a session and logs in:
Function Util_CreateSessionAndLogon(Optional LogOnName As Variant) As Boolean
On Error GoTo err_CreateSessionAndLogon
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False
Util_CreateSessionAndLogon = True
Exit Function
err_CreateSessionAndLogon:
Util_CreateSessionAndLogon = False
Exit Function
End Function
This function get information on items in the inbox and demonstrates some of the available properties.
Public Function GetMessageInfo(ByRef msgArray() As String) As Long
Dim objInboxFolder As Folder ' Folder object
Dim objInMessages As mapi.Messages ' Messages collection
Dim objMessage As Message ' Message object
Dim InfoRtnString
Dim i As Long
Dim lngMsgCount As Long
InfoRtnString = ""
If objSession Is Nothing Then
If Util_CreateSessionAndLogon = False Then
Err.Raise 429, "IBS_MAPI_CLASS", "Unable to create MAPI session object."
Exit Function
End If
End If
Set objInboxFolder = objSession.Inbox
Set objInMessages = objInboxFolder.Messages
lngMsgCount = objInMessages.Count
ReDim msgArray(0) 'initalize the array
For Each objMessage In objInMessages
If i / lngMsgCount * 100 > 100 Then
RaiseEvent PercentDone(100)
Else
RaiseEvent PercentDone(i / lngMsgCount * 100)
End If
InfoRtnString = ""
i = i + 1
ReDim Preserve msgArray(i)
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.ID
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Subject
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Sender
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.TimeSent
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.TimeReceived
InfoRtnString = InfoRtnString & Chr$(0) & "" 'objMessage.Text
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Unread
InfoRtnString = InfoRtnString & Chr$(0) & objMessage.Attachments.Count
msgArray(i) = InfoRtnString
DoEvents
Next
GetMessageInfo = i
End Function
This function demonstrates getting attachments from a message.
Function GetAttachments(msgID As String, lstBox As ListBox) As Boolean
Dim objMessage As Message ' Messages object
Dim AttchName As String
Dim i As Integer
Dim x As Long
If objSession Is Nothing Then
x = Util_CreateSessionAndLogon()
End If
Set objMessage = objSession.GetMessage(msgID)
For i = 1 To objMessage.Attachments.Count
Select Case objMessage.Attachments.Item(i).Type
Case Is = 1 'contents of a file
AttchName = objMessage.Attachments.Item(i).Name
If Trim$(AttchName) = "" Then
lstBox.AddItem "Could not read"
Else
lstBox.AddItem AttchName
End If
lstBox.ItemData(lstBox.NewIndex) = i
Case Is = 2 'link to a file
lstBox.AddItem objMessage.Attachments.Item(i).Name
lstBox.ItemData(lstBox.NewIndex) = i
Case Is = 1 'OLE object
Case Is = 4 'embedded object
lstBox.AddItem "Embedded Object"
lstBox.ItemData(lstBox.NewIndex) = i
End Select
Next i
GetAttachments = True
End Function