I have got this far but when I set the value for 'Folder' it is empty and the 'FolderPath' is "F:\Video Clips" what am I doing wrong
Function GetFileLength(FolderPath As String, FileName As String) As Date
'
' Get the run time of a audio/video file
'
' Set Up
Dim Shell As Object
Dim Folder As Object
Dim File As Object
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(FolderPath)
'Set Folder = Shell.Namespace("F:\Video Clips")
Set File = Folder.ParseName(FileName)
' Get time
If LCase(Right(FileName, 3)) = "avi" Then
GetFileLength = Folder.GetDetailsOf(File, 27)
Else
GetFileLength = ""
End If
End Function
Try it with the data type variant for the folder path in your function. Also have a look at the documentation of Namespace.
Function GetFileLength(FolderPath As Variant, FileName As String) As Date
'
' Get the run time of a audio/video file
'
' Set Up
Dim Shell As Object
Dim Folder As Object
Dim File As Object
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(FolderPath)
'Set Folder = Shell.Namespace("F:\Video Clips")
Set File = Folder.ParseName(FileName)
' Get time
If LCase(Right(FileName, 3)) = "avi" Then
GetFileLength = Folder.GetDetailsOf(File, 27)
Else
GetFileLength = ""
End If
End Function
PS Another bug you have is that the else condition GetFileLength = "" will fail because a string is not a date. Maybe you should use GetFileLength = CDate(0) or whatever you think is appropriate.
Related
I have been attempting to replace Office OLE in a vb6 application with LibreOffice.
I have had some success, however, I am falling short trying to search for text, then create a cursor based on the text that was found, then insert an image at that cursors point in the document.
I have been able to piece together working code that will allow me to search for text, replace text and insert an image, however, I cannot seem to figure out how to create a cursor that will allow me to insert an image at the pace where the text is that I have found . In the provided example, the [PICTUREPLACEHOLDER] text in the document.
Has anyone ever done this before and do they have any suggestions how I can create a cursor that will allow me to specify where the image will be inserted.
I have included the code for the VB6 test app so you can see the source code to see how its currently working.
Any suggestions would be very much appreciated.
Please Note - this is experimental code - very rough and ready - not final code by a long shot - just trying to figure out how this works with LibreOffice Writer.
To run this, you will need to create an empty vb6 app with a button.
You also need LibreOffice installed.
Many thanks
Rod.
Sub firstOOoProc()
Dim oSM 'Root object for accessing OpenOffice from VB
Dim oDesk, oDoc As Object 'First objects from the API
Dim arg() 'Ignore it for the moment !
'Instanciate OOo : this line is mandatory with VB for OOo API
Set oSM = CreateObject("com.sun.star.ServiceManager")
'Create the first and most important service
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Dim oProvider As Object
Set oProvider = oSM.createInstance("com.sun.star.graphic.GraphicProvider")
'Open an existing doc (pay attention to the syntax for first argument)
Set oDoc = oDesk.loadComponentFromURL("file:///c:/dev/ooo/testfile.doc", "_blank", 0, arg())
' now - replace some text in the document
Dim Txt
Txt = oDoc.GetText
Dim TextCursor
TextCursor = Txt.CreateTextCursor
' attempt to replace some text
Dim SearchDescriptor
Dim Replace
Replace = oDoc.createReplaceDescriptor
Replace.SearchString = "[TESTDATA1]"
Replace.ReplaceString = "THIS IS A TEST"
oDoc.replaceAll Replace
Dim searchCrtiteria
SearchDescriptor = oDoc.createReplaceDescriptor
' Now - attempt try to replace some text with an image
SearchDescriptor.setSearchString ("[PICTUREPLACEHOLDER]")
SearchDescriptor.SearchRegularExpression = False
Dim Found
Found = oDoc.findFirst(SearchDescriptor)
' create cursor to know where to insert the image
Dim oCurs As Object
Set thing = oDoc.GetCurrentController
Set oCurs = thing.GetViewCursor
' make hte call to insert an image from a file into the document
InsertImage oDoc, oCurs, "file:///c:/dev/ooo/imagefilename.jpg", oProvider
'Save the doc
Call oDoc.storeToURL("file:///c:/dev/ooo/test2.sxw", arg())
'Close the doc
oDoc.Close (True)
Set oDoc = Nothing
oDesk.Terminate
Set oDesk = Nothing
Set oSM = Nothing
End Sub
Function createStruct(strTypeName)
Set classSize = objCoreReflection.forName(strTypeName)
Dim aStruct
classSize.CreateObject aStruct
Set createStruct = aStruct
End Function
Sub InsertImage(ByRef oDoc As Object, ByRef oCurs As Object, sURL As String, ByRef oProvider As Object)
' Init variables and instance object
Dim oShape As Object
Dim oGraph As Object
Set oShape = oDoc.createInstance("com.sun.star.drawing.GraphicObjectShape")
Set oGraph = oDoc.createInstance("com.sun.star.text.GraphicObject")
'Set oProvider = serviceManager.CreateInstance("com.sun.star.graphic.GraphicProvider")
' Add shape to document
oDoc.getDrawPage.Add oShape
' Set property path of picture
Dim oProps(0) As Object
Set oProps(0) = MakePropertyValue("URL", sURL)
' Get size from picture to load
Dim oSize100thMM
Dim lHeight As Long
Dim lWidth As Long
Set oSize100thMM = RecommendGraphSize(oProvider.queryGraphicDescriptor(oProps))
If Not oSize100thMM Is Nothing Then
lHeight = oSize100thMM.Height
lWidth = oSize100thMM.Width
End If
' Set size and path property to shape
oShape.graphic = oProvider.queryGraphic(oProps)
' Copy shape in graphic object and set anchor type
oGraph.graphic = oShape.graphic
oGraph.AnchorType = 1 'com.sun.star.Text.TextContentAnchorType.AS_CHARACTER
' Remove shape and resize graphix
Dim oText As Object
Set oText = oCurs.GetText
oText.insertTextContent oCurs, oGraph, False
oDoc.getDrawPage.Remove oShape
If lHeight > 0 And lWidth > 0 Then
Dim oSize
oSize = oGraph.Size
oSize.Height = lHeight * 500
oSize.Width = lWidth * 500
oGraph.Size = oSize
End If
End Sub
'
'Converts a Ms Windows local pathname in URL (RFC 1738)
'Todo : UNC pathnames, more character conversions
'
Public Function ConvertToUrl(strFile) As String
strFile = Replace(strFile, "\", "/")
strFile = Replace(strFile, ":", "|")
strFile = Replace(strFile, " ", "%20")
strFile = "file:///" + strFile
ConvertToUrl = strFile
End Function
'
'Creates a sequence of com.sun.star.beans.PropertyValue s
'
Public Function MakePropertyValue(cName, uValue) As Object
Dim oStruct, oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set oStruct = oServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
oStruct.Name = cName
oStruct.Value = uValue
Set MakePropertyValue = oStruct
End Function
'
'A simple shortcut to create a service
'
Public Function CreateUnoService(strServiceName) As Object
Dim oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set CreateUnoService = oServiceManager.createInstance(strServiceName)
End Function
Public Function RecommendGraphSize(oGraph)
Dim oSize
Dim lMaxW As Double
Dim lMaxH As Double
lMaxW = 6.75 * 2540
lMaxH = 9.5 & 2540
If IsNull(oGraph) Or IsEmpty(oGraph) Then
Exit Function
End If
oSize = oGraph.Size100thMM
If oSize.Height = 0 Or oSize.Width = 0 Then
oSize.Height = oGraph.SizePixel.Height * 2540# * Screen.TwipsPerPixelY() '/ 1440
oSize.Width = oGraph.SizePixel.Width * 2540# * Screen.TwipsPerPixelX() '/ 1440
End If
If oSize.Height = 0 Or oSize.Width = 0 Then
Exit Function
End If
If oSize.Width > lMaxW Then
oSize.Height = oSizeHeight * lMax / oSize.Width
oSize.Width = lMaxW
End If
If oSize.Height > lMaxH Then
oSize.Width = oSize.Width * lMaxH / oSize.Height
oSize.Height = lMaxH
End If
RecommendGraphSize = oSize
End Function
Private Sub Command1_Click()
firstOOoProc
End Sub
The content of the testFile.Doc file is as shown below:
This is a test File
[TESTDATA1]
[PICTUREPLACEHOLDER]
It looks like you need to move the view cursor to the found location.
Found = oDoc.findFirst(SearchDescriptor)
oVC = oDoc.getCurrentController().getViewCursor()
oVC.gotoRange(Found, False)
oVC.setString("")
I am trying to get the local file path to an open document.
When I use the Path function I get a web path if the document is in my OneDrive folder.
I think the problem is that the file exists in 2 places:
C:\Users\myloginname\OneDrive\Documents\Project\Samples
AND
https://d.docs.live.net/xxxxxxxxxxxx/Documents/Project/Samples
When I try to use the Dir function with the web "path" I get error 52 "Bad file name or number".
How can I get the local path?
The function below will return the local name of a FullName given to it as argument.
Function LocalFullName(ByVal Ffn As String) As String
' 294
' this is part of the URL address before the file's code name
' e.g. https://d.docs.live.net/2abce27df5c02e2f/ ....
Const DriveID As String = ".live.net"
Dim Fun() As String ' function return value
Dim n As Integer ' index of Fun
Dim Sp() As String ' split array of Ffn
Dim i As Integer ' loop counter: index of Sp
Sp = Split(Ffn, "/")
For i = 1 To UBound(Sp)
If InStr(1, Sp(i), DriveID, vbTextCompare) Then Exit For
Next i
If i > UBound(Sp) Then
LocalFullName = Ffn
Else
ReDim Fun(1 To UBound(Sp))
For i = i + 2 To UBound(Sp)
n = n + 1
Fun(n) = Sp(i)
Next i
ReDim Preserve Fun(1 To n)
LocalFullName = Join(Fun, Application.PathSeparator)
End If
End Function
If you need to use the name for saving the drive must be added. The snipper below shows how to call the function and add the drive letter.
Sub Snippet()
' 294
Const DriveID As String = "D:\"
Dim Wb As Workbook
Set Wb = ThisWorkbook
Debug.Print DriveID & LocalFullName(Wb.FullName)
End Sub
I ended up using this as I only wanted the folder path.
Also, it's kind of a choose-your-poison when using hard-coded text, but I worry that ".live.net" might change. Of course, so could "\OneDrive\" so there ya go.
Private Function Local_Workbook_Path(ByRef doc As Document) As String
Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String
'Check if it looks like a OneDrive location
If InStr(1, doc.path, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
Local_Workbook_Path = Replace(doc.path, "/", "\")
'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Trim OneDrive designators
For Ctr = 1 To 4
Local_Workbook_Path = Mid(Local_Workbook_Path, InStr(Local_Workbook_Path, "\") + 1)
Next
'Construct the name
Local_Workbook_Path = UserProfilePath & "\OneDrive\" & Local_Workbook_Path
Local_Workbook_Path = Replace(Local_Workbook_Path, "%20", " ")
Else
Local_Workbook_Path = doc.path
End If
End Function
I have two calendars, one is mine and the other is shared. Both are opened in outlook as below.
How can i get selected apointment calendar's email adress?
I saw AppointmentItem has GetOrganizer to find who created the appointment but I don't find any method or property about the user of the calendar in witch the appointment is...
So I tried Application.ActiveExplorer.CurrentFolder to get the selected folder and then get the AdressEntry but I can't get the folder's store because it's a shared calendar (and then folder.store returns null).
Following Dmitry's advices there, I did :
Dim appointment_item As Outlook.AppointmentItem
Dim PR_MAILBOX_OWNER_ENTRYID as String
Dim mapiFolder As Outlook.MAPIFolder
Dim folderStore As Outlook.Store
Dim mailOwnerEntryId As String
Dim entryAddress As Outlook.AddressEntry
Dim smtpAdress As String
PR_MAILBOX_OWNER_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x661B0102"
appointment_item = Application.ActiveExplorer.Selection.Item(1)
mapiFolder = appointment_item.Parent
folderStore = mapiFolder.Store
mailOwnerEntryId = folderStore.PropertyAccessor.GetProperty(PR_MAILBOX_OWNER_ENTRYID)
entryAddress = Application.Session.GetAddressEntryFromID(mailOwnerEntryId)
smtpAdress = entryAddress.GetExchangeUser.PrimarySmtpAddress
MsgBox(smtpAdress)
The issue is i can't get .Store of a shared folder as written here in the MS Documentation.
This property returns a Store object except in the case where the Folder is a shared folder (returned by NameSpace.GetSharedDefaultFolder). In this case, one user has delegated access to a default folder to another user; a call to Folder.Store will return Null.
I finally found a way to do it, this topic helped me.
The code below, parses the shared folder storeID to get the shared folder SMTP address.
Public Sub test()
Dim smtpAddress As String
Dim selectedItem As Outlook.Folder
smtpAddress = ""
TryGetSmtpAddress(Application.ActiveExplorer.Selection.Item(1).Parent, smtpAddress)
End Sub
Public Shared Function TryGetSmtpAddress(ByVal folder As MAPIFolder, ByRef smtpAddress As String) As Boolean
smtpAddress = "default"
Dim storeId = HexToBytes(folder.StoreID)
If BitConverter.ToUInt64(storeId, 4) <> &H1A10E50510BBA138UL OrElse BitConverter.ToUInt64(storeId, 12) <> &HC2562A2B0008BBA1UL Then
Return False
End If
Dim indexDn = Array.IndexOf(storeId, CByte(&H0), 60) + 1
Dim indexV3Block = Array.IndexOf(storeId, CByte(&H0), indexDn) + 1
If BitConverter.ToUInt32(storeId, indexV3Block) <> &HF43246E9UL Then
Return False
End If
Dim offsetSmtpAddress = BitConverter.ToUInt32(storeId, indexV3Block + 12)
smtpAddress = BytesToUnicode(storeId, indexV3Block + CInt(offsetSmtpAddress))
Return True
End Function
Private Shared Function HexToBytes(ByVal input As String) As Byte()
Dim bytesLength = input.Length / 2
Dim bytes = New Byte(bytesLength - 1) {}
For i = 0 To bytesLength - 1
bytes(i) = Convert.ToByte(input.Substring(i * 2, 2), 16)
Next
Return bytes
End Function
Private Shared Function BytesToUnicode(ByVal value As Byte(), ByVal startIndex As Integer) As String
Dim charsLength = (value.Length - startIndex) / 2
Dim chars = New Char(charsLength - 1) {}
For i = 0 To charsLength - 1
Dim c = CSharpImpl.__Assign(chars(i), BitConverter.ToChar(value, startIndex + i * 2))
If c = vbNullChar Then
Return New String(chars, 0, i)
End If
Next
Return New String(chars)
End Function
Private Class CSharpImpl
<Obsolete("Please refactor calling code to use normal Visual Basic assignment")>
Shared Function __Assign(Of T)(ByRef target As T, value As T) As T
target = value
Return value
End Function
End Class
It may be possible to get to the top of the folder tree of a shared calendar the long way, without built-in shortcuts.
Tested on my own calendar, not a shared calendar.
Option Explicit
Sub appointment_sourceFolder()
' VBA code
Dim obj_item As Object
Dim appointment_item As AppointmentItem
Dim parentOfAppointment As Variant
Dim parentParentFolder As Folder
Dim sourceFolder As Folder
Set obj_item = ActiveExplorer.Selection.Item(1)
If obj_item.Class <> olAppointment Then Exit Sub
Set appointment_item = obj_item
' Recurring appointment leads to
' the parent of the recurring appointment item then the calendar folder.
' Single appointment leads to
' the calendar folder then the mailbox name.
Set parentOfAppointment = appointment_item.Parent
Set parentParentFolder = parentOfAppointment.Parent
Debug.Print vbCr & " parentParentFolder: " & parentParentFolder.Name
Set sourceFolder = parentParentFolder
' Error bypass for a specific purpose
On Error Resume Next
' If parentParentFolder is the shared calendar,
' walking up one folder is the mailbox.
' If parentParentFolder is the mailbox,
' walking up one folder is an error that is bypassed,
' so no change in sourceFolder.
' Assumption:
' The shared calendar is directly under the mailbox
' otherwise add more Set sourceFolder = sourceFolder.Parent
Set sourceFolder = sourceFolder.Parent
' Return to normal error handling immediately
On Error GoTo 0
Debug.Print " sourceFolder should be smtp address: " & sourceFolder
'MsgBox " sourceFolder should be smtp address: " & sourceFolder
End Sub
I have vb.net code that was given to me by a coworker that works in VB.net, but it doesn't work in VBA. I'm using that piece of code in a VBA file. Is there a way to change the syntax to work in VBA, or run it in VB.net from VBA or something. Or is there a completely different way to accomplish this all together? I haven't had any luck trying to change the code or searching for an answer yet.
Sub UpdateTVGData()
Dim vPath As String = GetPath("PR.G.ZMDPPL.TVG")
End Sub
Function GetPath(ByVal vFIle As String) As String
Dim Path As String
Dim files() As String = System.IO.Directory.GetFiles("\\sw100313\ZMD_Archives", vFIle + ".*", IO.SearchOption.AllDirectories)
Dim sortcrit(files.Length - 1) As Integer
Dim i As Integer
For i = 0 To files.Length - 1
sortcrit(i) = Val(Mid(files(i), Len(files(i)) - 6, 4))
Next i
System.Array.Sort(sortcrit, files)
Path = files(files.Length - 1)
Path = Left(Path, 35)
'clean up
files = Nothing
sortcrit = Nothing
Return Path
End Function
I'm trying to use the Dir() function to pick the correct folder based on the other posts I've seen here, but I'm getting "" for the value of foldnm on the first iteration. If I use shell and the same file path, I can open the folder, so I don't think the path is the problem.
Sub get_file()
File_pth = "explorer.exe \\sw100313.w10\ZMD_Archives"
ctr = 1
max_folder_val = 0
foldnm = Dir(File_pth, vbDirectory)
Do While foldnm <> ""
Mid(fileName, Len(fileName)-6, 4)
ctr = ctr + 1
foldnm = Dir()
If Mid(foldnm, Len(foldnm)-6, 4) > max_folder_val Then
max_folder = foldnm
max_folder_val= Mid(foldnm, Len(foldnm)-6, 4)
End If
Loop
End Sub
I want to copy an HTML file from one location to another using VB.net.
When i use any of the three FileCopy, System.IO.File.Copy, My.Computer.FileSystem.CopyFile
it copies only the file and not the "filename_files" folder which contain its associated images and scripts.
What i want to do programatically is copy a.html to another location as b.html
when i do that and open b.html it opens it without any images and scripts.
Pls help
You can use following two methods that collectively can copy folder that that includes scripts and images thus, with built-in method FileCopy copy your HTML file, and using below methods, copy your required folder.
I found the first method that returns an array of files in a given path at here
Public Function FileList(Mask As String) As String()
Dim sWkg As String
Dim sAns() As String
Dim lCtr As Long
ReDim sAns(0) As String
sWkg = Dir(Mask, vbNormal)
Do While Len(sWkg)
If sAns(0) = "" Then
sAns(0) = sWkg
Else
lCtr = UBound(sAns) + 1
ReDim Preserve sAns(lCtr) As String
sAns(lCtr) = sWkg
End If
sWkg = Dir
Loop
FileList = sAns
End Function
Now using the above method, and the below method, you can copy folder by specifying Source and Target paths. The method will return boolean value specifying whether folder was copied or not.
Public Function FolderCopy(ByVal SourceFolder As String, ByVal TargetFolder As String) As Boolean
Dim flist() As String
Dim sURL As String = New String(SourceFolder)
Dim tURL As String = New String(TargetFolder)
Dim i As Integer
Dim slashpos As Long
If Not Directory.Exists(tURL) Then
slashpos = InStrRev(sURL, "\") 'Get position of last occurrence if '\' in given path
If slashpos <> sURL.Length Then 'Check if URL does not have slash at its end
sURL = sURL & "\" 'Add slash at URL end
End If
flist = FileList(sURL)
slashpos = InStrRev(tURL, "\") 'Get position of last occurrence if '\' in given path
If slashpos = tURL.Length Then
tURL = tURL.Substring(0, tURL.Length - 1)
End If
slashpos = InStrRev(tURL, "\")
Try
Directory.CreateDirectory(tURL)
For i = 0 To flist.Length - 1
FileCopy(sURL & flist(i), tURL & "\" & flist(i))
Next
FolderCopy = True
Catch ex As Exception
FolderCopy = False
End Try
Else
FolderCopy = False
End If
End Function
Make sure that you include Imports System.IO at the beginning of the class before using FolderCopy method, and note that both these methods are required to be included.
' copy all files and subdirectories from the
' specified source to the specified destination.
Private Sub RecursiveCopyFiles( ByVal sourceDir As String, ByVal destDir As String, _
ByVal fRecursive As Boolean)
Dim i As Integer
Dim posSep As Integer
Dim sDir As String
Dim aDirs() As String
Dim sFile As String
Dim aFiles() As String
' Add trailing separators to the supplied paths if they don't exist.
If Not sourceDir.EndsWith(System.IO.Path.DirectorySeparatorChar.ToString()) Then
sourceDir &= System.IO.Path.DirectorySeparatorChar
End If
If Not destDir.EndsWith(System.IO.Path.DirectorySeparatorChar.ToString()) Then
destDir &= System.IO.Path.DirectorySeparatorChar
End If
' Recursive switch to continue drilling down into dir structure.
If fRecursive Then
' Get a list of directories from the current parent.
aDirs = System.IO.Directory.GetDirectories(sourceDir)
For i = 0 To aDirs.GetUpperBound(0)
' Get the position of the last separator in the current path.
posSep = aDirs(i).LastIndexOf("\")
' Get the path of the source directory.
sDir = aDirs(i).Substring((posSep + 1), aDirs(i).Length -(posSep + 1))
' Create the new directory in the destination directory.
System.IO.Directory.CreateDirectory(destDir + sDir)
' Since we are in recursive mode, copy the children also
RecursiveCopyFiles(aDirs(i), (destDir + sDir), fRecursive)
Next
End If
' Get the files from the current parent.
aFiles = System.IO.Directory.GetFiles(sourceDir)
' Copy all files.
For i = 0 To aFiles.GetUpperBound(0)
' Get the position of the trailing separator.
posSep = aFiles(i).LastIndexOf("\")
' Get the full path of the source file.
sFile = aFiles(i).Substring((posSep + 1), aFiles(i).Length - (posSep+ 1))
' Copy the file.
System.IO.File.Copy(aFiles(i), destDir + sFile)
Next i
End Sub