I have created a PowerPoint to display 5 random words from a .txt file following this excellent tutorial.
The problem is, the words in my .txt file are Spanish, so have accents on them. When PowerPoint displays them, they look corrupt. For example Perú looks like Perð.
This is my code:
Public myArray, Word1, Word2, Word3, Word4, Word5
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.Presentation.SlideShowSettings.StartingSlide Then
Randomize
Label1.Caption = ""
Label2.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label5.Caption = ""
Dim path
path = ActivePresentation.path & "\palabras.txt"
Open path For Input As #1
filecontent = Input(LOF(1), #1)
Close #1
myArray = Split(filecontent, vbCrLf)
End If
End Sub
Private Sub CommandButton1_Click()
Word1 = Int((UBound(myArray)) * Rnd)
Word2 = Int((UBound(myArray)) * Rnd)
Word3 = Int((UBound(myArray)) * Rnd)
Word4 = Int((UBound(myArray)) * Rnd)
Word5 = Int((UBound(myArray)) * Rnd)
Do While Word1 = Word2
Word2 = Int((UBound(myArray)) * Rnd)
Loop
Label1.Caption = myArray(Word1)
Label2.Caption = myArray(Word2)
Label3.Caption = myArray(Word3)
Label4.Caption = myArray(Word4)
Label5.Caption = myArray(Word5)
End Sub
I know the end of it is messy too, I didn't know how to get it so that Word3, 4 and 5 didn't repeat. It's my first time using VBA.
Can anyone help?
Files
VBA and COM use Unicode internally. But when interacting with the Windows API VBA uses ANSI as Windows 9x didn't have Unicode API calls.
The Open statement is depreciated. It will be calling Windows' CreateFileA. Using the FileSystemObject. https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/openastextstream-method
Make sure you specify Unicode when opening the file.
OR set your non Unicode settings to Spanish or something.
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fso, f, ts
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile "test1.txt" ' Create a file.
Set f = fso.GetFile("test1.txt")
Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
ts.Write "Hello World"
ts.Close
Set ts = f.OpenAsTextStream(ForReading, TristateUseDefault)
TextStreamTest = ts.ReadLine
ts.Close
From Help.
Set TS = CreateObject("Scripting.FileSystemObject").GetFile("test1.txt").OpenAsTextStream(1, -1)
x = ts.readall
Related
My code gives me error from
If Dir(Pth, vbArchive) <> vbNullString Then
I havent been able to find the error - Can someone help me what is wrong with the code? Is it supposed to say USERPROFILE, or am i supposed to write something else?
Sub Opgave8()
Dim sh As Worksheet
Dim Pth As String
Application.ScreenUpdating = False
' Create default desktop path using windows user id
user_id = Environ$("USERPROFILE")
' Create full path
file_name$ = "\AdminExport.csv"
Pth = Environ$("USERPROFILE") & "\Desktop\" & FileName
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
If Dir(Pth, vbArchive) <> vbNullString Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If
If overwrite_question = vbYes Then
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
There are a few issues in your code. I don't understand why you are getting an error message, but if you fix your issues, you are in a better position of finding the main problem.
Put Option Explicit at the top. If you do that, you will not do mistakes like setting the variable file_name$ but reading from the variable FileName.
You are building a path with double backslashes. Perhaps not a big thing and it'll probably work. Add a Debug.Print Pth just before your troublesome If. Press Ctrl-G to show the debug pane and study the output. Does the printed file path exist?
Don't use vbNullString. Test with abc <> "" instead.
I will post my solution to this question, but maybe others have found a better way.
I wanted to obtain the number of pages in a pdf document using VBA.
I reviewed similar [vba] and [acrobat] questions, but I did not find a stand alone solution. After reviewing other posts, Adobe Acrobat's SDK, and the VBA object browser, I learned enough to piece together this solution.
I am running Excel 2013 and Adobe Acrobat 9.0 Pro.
I understand its ok to answer my own question.
This solution works when Excel 2013 Professional and Adobe Acrobat 9.0 Pro are installed.
You will need to enable the Adobe object model: Tools -> References -> Acrobat checkbox selected.
Adobe's SDK has limited documentation on the GetNumPages method.
'with Adobe Acrobat 9 Professional installed
'with Tools -> References -> Acrobat checkbox selected
Sub AcrobatGetNumPages()
Dim AcroDoc As Object
Set AcroDoc = New AcroPDDoc
AcroDoc.Open ("C:\Users\Public\Lorem ipsum.pdf") 'update file location
PageNum = AcroDoc.GetNumPages
MsgBox PageNum
AcroDoc.Close
End Sub
Inspired from : https://www.extendoffice.com/documents/excel/5330-excel-vba-pdf-page-count.html
I created the function below. I do not have Adob accrobat pro installed.
Sub Test()
Dim vFolder, vFileName
vFolder = "D:\Test Count Pages In PDF File\"
'vFolder = "D:\Test Count Pages In PDF File\" '--> fine for both forms (with or without PathSeparator)
vFileName = "My File.pdf"
Debug.Print fNumberOfPages_in_PDF_File(vFolder, vFileName)
End Sub
Function fNumberOfPages_in_PDF_File(vFolder, vFileName)
Dim xStr As String
Dim xFileNum As Long
Dim RegExp As Object
'--- Number of Pages =0 if the file is not a PDF file
If Not vFileName Like "*.pdf" Then
fNumberOfPages_in_PDF_File = 0
Exit Function
End If
'--- Add PathSeparator ("\") if it does not exist
If Right(vFolder, 1) <> Application.PathSeparator Then
vFolder = vFolder & Application.PathSeparator
End If
'--- Count the number of pages in Pdf File
xStr = ""
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (vFolder & vFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
fNumberOfPages_in_PDF_File = RegExp.Execute(xStr).Count
End Function
Option Explicit
Public PDFDoc As AcroPDDoc, PDFPage As Object, A3&, A4&
Sub Main()
Dim fso As FileSystemObject, fld As Folder, filePDF As File, fileName$, i&, Arr()
Set fso = New FileSystemObject
Set PDFDoc = New AcroPDDoc
Set fld = fso.GetFolder(ThisWorkbook.Path)
ReDim Arr(1 To 1000, 1 To 4)
For Each filePDF In fld.Files
Application.Calculation = xlCalculationManual
fileName = filePDF.Name
If Right(fileName, 4) = ".pdf" Then
CountPagesPDF (ThisWorkbook.Path & "\" & fileName)
i = i + 1
Arr(i, 1) = fileName
Arr(i, 2) = A3 + A4
Arr(i, 3) = A3
Arr(i, 4) = A4
End If
Next
Range("A3:D" & Cells.Rows.Count).Clear
Range("A3:D" & (i + 1)) = Arr
Set PDFPage = Nothing
Set PDFDoc = Nothing
Set fso = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub
Sub CountPagesPDF(FullFileName$)
Dim j&, n&, x, y
A3 = 0
A4 = 0
PDFDoc.Open (FullFileName)
n = PDFDoc.GetNumPages
Application.Calculation = xlCalculationManual
For j = 0 To n - 1
Set PDFPage = PDFDoc.AcquirePage(j)
x = PDFPage.GetSize().x
y = PDFPage.GetSize().y
If x + y > 1500 Then A3 = A3 + 1 Else A4 = A4 + 1
Next
Application.Calculation = xlCalculationAutomatic
PDFDoc.Close
End Sub
I am trying to compare files by objects to find dublicate. I have 2900 files in folder and i need to check them all. In other words I have to run compare methods 2900*2900 times and every time when comparing two file I need to open and close 1 of those. If there is a way to work with Corel files not to open them? or is it posible to get metadata\metadata.xml from Corel VBA files to check and compare some parametrs from it such as Objects(shapes) count?
I am in despered...
I am using this logic system
Private Sub CommandButton1_Click()
Dim Folder As String
MousePointer = fmMousePointerHourGlass
Folder = BrowseForFolderDlg("o:\", "Select Source Folder", GetWindowHandle("ThunderDFrame", Me.Caption))
tb_inputFolder.text = Folder
End Sub
Private Sub CommandButton2_Click()
Dim fso As Object
Dim objFolder As Object
Dim objFileList As Object
Dim vFile, vFile1 As Variant
Dim inputFolder As String, outputFolder As String
inputFolder = tb_inputFolder.text 'input folder
If (inputFolder = "") Then
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(inputFolder)
Set objFileList = objFolder.Files
Dim currentFile As String
Dim dunFiles() As String
Dim arrLength As Integer
ReDim Preserve dunFiles(1)
arrLength = 1
dunFiles(0) = ""
For Each vFile In objFileList
Dim doc As Document, doc1 As Document, buf As String
Dim fName As String
fName = (Left(vFile.name, Len(vFile.name) - 4))
buf = Right(vFile.path, 3)
If (buf = "cdr" And findArrayElement(dunFiles, arrLength, vFile.name) = -1) Then
Set doc = OpenDocument(vFile.path) 'document opend
dunFiles(arrLength - 1) = vFile.name
ReDim Preserve dunFiles((arrLength + 1))
arrLength = arrLength + 1
For Each vFile1 In objFileList
buf = Right(vFile1.path, 3)
If (vFile1.name = currentFile Or findArrayElement(dunFiles, arrLength, vFile1.name) <> -1 Or buf <> "cdr") Then
GoTo nextElement
End If
'Set doc1 = OpenDocument(vFile1.path) 'document opend
Dim res As Variant
res = writeFile(doc.FileName + " VS " + vFile1.name + " " + Str(Now), doc.FilePath + "compare.log")
If (compareDocs(doc, vFile1.path)) Then
dunFiles(arrLength - 1) = fName + "_" + vFile1.name
ReDim Preserve dunFiles((arrLength + 1))
arrLength = arrLength + 1
Dim name As String
name = vFile.ParentFolder.path + "\" + fName + "_" + vFile1.name
Name vFile1.path As name
res = writeFile(vFile.ParentFolder.path + "\" + fName + " the same as " + name, doc.FilePath + "rename.log")
End If
'doc1.Close
nextElement:
Next vFile1
doc.Close
End If
' doc.Close 'close document
Next vFile
lb_info.Caption = "Finished! Press exit"
End Sub
Private Function findArrayElement(inputArray() As String, inputLen As Integer, element As String)
Dim e As String
Dim i As Integer
findArrayElement = -1
For i = 0 To inputLen - 1
If (inputArray(i) = element) Then
findArrayElement = i
Exit Function
End If
Next i
End Function
Private Function compareDocs(doc As Document, path2 As String)
Dim doc1 As Document
Dim e1 As Shape, e2 As Shape, elements() As String
Dim sameShapesCount As Integer
sameShapesCount = 0
ReDim elements(1) As String
elements(0) = ""
Set doc1 = OpenDocument(path2) 'document opend
compareDocs = False
lb_info.Caption = "Comapre " + doc.FullFileName + " with " + path2
For Each e1 In doc.SelectableShapes
e1.UngroupAll
Next e1
For Each e2 In doc1.SelectableShapes
e2.UngroupAll
Next e2
If (doc.SelectableShapes.Count <> doc1.SelectableShapes.Count) Then
doc1.Close
Exit Function
End If
For Each e1 In doc.SelectableShapes
'If (findArrayElement(elements, (UBound(elements) + 1), Str(e1.StaticID)) = -1) Then
'ReDim Preserve elements(UBound(elements) + 1) As String
'elements(UBound(elements)) = e1.StaticID
For Each e2 In doc1.SelectableShapes
If (findArrayElement(elements, (UBound(elements) + 1), "2_" + Str(e2.StaticID)) = -1) Then
If (e1.CompareTo(e2, cdrCompareShapeType, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareFillType, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutline, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutlineColor, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutlineWidth, cdrCompareEquals)) Then
'If (e1.CompareTo(e2, cdrCompareShapeHeight, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareFil, cdrCompareEquals)) Then
'If (e1.CompareTo(e2, cdrCompareShapeWidth, cdrCompareEquals)) Then
ReDim Preserve elements(UBound(elements) + 1) As String
elements(UBound(elements)) = "2_" + Str(e2.StaticID)
sameShapesCount = sameShapesCount + 1
GoTo nextElement1
'End If
End If
'End If
End If
End If
End If
End If
End If
End If
Next e2
'End If
nextElement1:
Next e1
If (doc.SelectableShapes.Count = sameShapesCount) Then
compareDocs = True
End If
doc1.Close
End Function
Private Function writeFile(text As String, path As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
If Not Dir(path, vbDirectory) = vbNullString Then
Set oFile = fso.OpenTextFile(path, 8)
Else
Set oFile = fso.CreateTextFile(path, 0)
End If
oFile.WriteLine text
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Function
The main problem is that the "open process" can last up to few minutes and to check 2k corel fiels I need a YEAR
In a first pass, open each file once.
Go over the data you care about -- object count or whatever -- that must be equal.
From this data, build a hash -- a pseudo-random value that combines information from each of them.
Build a table that maps from the hash to a set of draw files that match the hash.
Now you only have to compare files which have a the same hash value, not every pair of files. A well designed hash and data to feed it should reduce your collision rate to nearly zero.
This should speed up your program by a factor of 1000 to 3000 or so.
To ensure that the hash/collision works well, your first pass should just hash and print out the lists of collisions.
Sort the list by filesize. Only compare files that are similar in size. You can use dir to generate a sorted list by size.
You only need to open each file once. Hash each file (maybe an alphabetically list of object names). Store and sort and dupes are the same objects.
You can use excel if it's a one off, or a recordset if you need to do it in code.
I want to remove some words that aren't in a separate list from an excel list.
Someone gave me an example with Find/Replace, but i need the exact opposite, meaning that i want to keep the words in the list and remove the other. Also if a word is removed, I would have more than 1 space so i would need to remove multiple spaces.
Can anyone give me an example?
Thanks,
Sebastian
EDIT
Initial cell contents: word1 word2 word3 word4
Cell contents after script: word2 word4
My list contains: word2, word4, word7, ...
This works:
Sub words()
Dim whitelist() As Variant
Dim listToScreen As Variant
Dim screenedList As String
Dim itsInTheWhitelist As Boolean
Dim i As Long
Dim j As Long
' Words to keep
whitelist = Array("word2", "word4", "word7")
' Input old cell contents, split into array using space delimiter
listToScreen = Split(Range("A1").Value, " ")
screenedList = ""
For i = LBound(listToScreen) To UBound(listToScreen)
' Is the current word in the whitelist?
itsInTheWhitelist = False
For j = LBound(whitelist) To UBound(whitelist)
If listToScreen(i) = whitelist(j) Then
itsInTheWhitelist = True
Exit For
End If
Next j
If itsInTheWhitelist = True Then
' Add it to the screened list, with space delimiter if required
If Not screenedList = "" Then
screenedList = screenedList & " "
End If
screenedList = screenedList & listToScreen(i)
End If
Next i
'Output new cell contents
Range("A2").Value = screenedList
End Sub
Using a Scripting.Dictionary and a RegExp will cost two references, but will avoid a N*N loop:
' needs ref to Microsoft Scripting Runtime,
' Microsoft VBScript Regular Expressions 5.5
Option Explicit
Sub frsAttempt()
Dim sInp As String: sInp = "word1 word2 word3 word4"
Dim aInp As Variant: aInp = Split(sInp)
Dim sExp As String: sExp = "word2 word4"
Dim sLst As String: sLst = "word2, word4, word7"
Dim aLst As Variant: aLst = Split(sLst, ", ")
Dim dicGoodWords As New Dictionary
Dim nIdx
For nIdx = 0 To UBound(aLst)
dicGoodWords(aLst(nIdx)) = 0
Next
For nIdx = 0 To UBound(aInp)
If Not dicGoodWords.Exists(aInp(nIdx)) Then
aInp(nIdx) = ""
End If
Next
Dim sRes As String: sRes = Join(aInp)
Dim reCleanWS As New RegExp
reCleanWS.Global = True
reCleanWS.Pattern = "\s+"
sRes = Trim(reCleanWS.Replace(sRes, " "))
Debug.Print sExp
Debug.Print sRes
Debug.Print sRes = sExp
End Sub
Output:
word2 word4
word2 word4
True
The dictionary could be filled from a WorkSheet's column.
This code will read a line from a text file:
set file = CreateObject("Scripting.FileSystemObject").OpenTextFile("c:\number.txt", 1)
text = file.ReadLine
MsgBox text
How can I make it read repeatedly one line after another from the same file? I guess, I should use a loop here, right? I need it to read the first line from the file at the first iteration, the second line at the second iteration, the third one at the third and so on till all the lines have been read. How can I do it?
Important addition: I need the code to operate on each line one by one - not all at once!
Use the ReadAll() method:
text = file.ReadAll
(Might be of interest: FileSystemObject Sample Code)
With a loop:
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, MyFile, FileName, TextLine
Set fso = CreateObject("Scripting.FileSystemObject")
FileName = "c:\testfile.txt"
Set MyFile = fso.OpenTextFile(FileName, ForReading)
'' Read from the file
Do While MyFile.AtEndOfStream <> True
TextLine = MyFile.ReadLine
'' Do stuff to TextLine
Loop
MyFile.Close
If for some reason you want to use the in-built VBA file handling routines, you would use code like this:
Sub ReadAFileLineByLine()
Dim InStream As Integer
InStream = FreeFile()
Open "C:/tmp/fastsynchtoquesttry_quest.txt" For Input As InStream
Dim CurrLine As String
Do While True
Line Input #InStream, CurrLine
' do stuff to CurrLine
If EOF(InStream) Then Exit Do
Loop
Close #InStream
End Sub
You can add a reference* to the Windows Script Host Object Model, it will help you with the FileSystemObject Object, because you can then say:
Dim fs As FileSystemObject
Dim f As TextStream
Which will allow you to use intellisense to see the various properties and the Object Browser to explore the library.
* In the code window, choose Tools, References and tick the box beside the library you want.
I wrote a VBA routine that reads a text file and insert a new slide for each sentence in the text.
First, in slide #1, add a button that calls the macro named "generate"
Source code goes:
Const DEFAULT_SLIDE = 1 ' the slide to copy the layout style from
Const MARGIN = 50 ' margin of the generated textbox
Sub generate()
Dim txtFile As String ' text file name
Dim fileNo As Integer ' file handle
Dim buffer As String ' temporary string buffer
Dim sentence() As String ' the main array to save sentences
Dim i, total As Integer
Dim myLayout As CustomLayout
Dim mySlide As Slide
Dim myShape As Shape
Dim myWidth, myHeight As Integer 'slide width and height
txtFile = "text2sample.txt"
txtFile = ActivePresentation.Path & "\" & txtFile 'textfile should be in the same Dir as this ppt
If Len(Dir$(txtFile)) = 0 Then
MsgBox txtFile & " file not found."
Exit Sub
End If
'Initialize array
ReDim sentence(0)
'get file handle number
fileNo = FreeFile()
Open txtFile For Input As #fileNo
i = 0
Do While Not EOF(fileNo)
Line Input #fileNo, buffer 'read & save sentences line by line
ReDim Preserve sentence(i + 1) ' increase 1 more array
sentence(i) = LTrim(RTrim(buffer))
i = i + 1
Loop
Close #fileNo
total = i
Randomize ' for random color
With ActivePresentation.PageSetup
myWidth = .SlideWidth - MARGIN 'get width and height
myHeight = .SlideHeight - MARGIN
End With
For i = 0 To total
Set myLayout = ActivePresentation.Slides(DEFAULT_SLIDE).CustomLayout
'add a slide like slide #1
Set mySlide = ActivePresentation.Slides.AddSlide(DEFAULT_SLIDE + 1 + i, myLayout)
'add a textbox with margin
Set myShape = ActivePresentation.Slides(DEFAULT_SLIDE + 1 + i).Shapes. _
AddTextbox(msoTextOrientationHorizontal, MARGIN, MARGIN, myWidth, myHeight)
With myShape
'add a sentence
.TextFrame.TextRange.Text = sentence(i)
.TextFrame.TextRange.Font.Size = 60
' color 255 is too bright. Pick a less bright color (200)
.TextFrame.TextRange.Font.Color.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.Font.Shadow = msoTrue
' If you want to change the color of the shape
'.Fill.ForeColor.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
'.Fill.BackColor.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
'.Fill.Solid
End With
'add a textbox for slideshow progress ex) 1/100
Set myShape = ActivePresentation.Slides(DEFAULT_SLIDE + 1 + i).Shapes. _
AddTextbox(msoTextOrientationHorizontal, 0, 0, 150, 20)
With myShape
.TextFrame.TextRange.Text = "( " & i & " /" & total & " )"
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.Font.Color.RGB = RGB(100, 100, 100)
End With
Next
MsgBox total & " Slides were added.", vbInformation
End Sub
Download file:
http://konahn.tistory.com/attachment/cfile8.uf#2175154C573D3BC02A2DFA.pptm