I think I've stumbled upon a bug in Excel - I'd really like to verify it with someone else though.
The bug occurs when reading the Workbook.VBProject.HelpFile property when the workbook has been opened with the opening application's .AutomationSecurity property set to ForceDisable. In that case this string property returns a (probably) malformed Unicode string, which VBA in turn displays with question marks. Running StrConv(..., vbUnicode) on it makes it readable again, but it sometimes looses the last character this way; this might indicate that the unicode string is indeed malformed or such, and that VBA therefore tries to convert it first and fails.
Steps to reproduce this behaviour:
Create a new Excel workbook
Go to it's VBA project (Alt-F11)
Add a new code module and add some code to it (like e.g. Dim a As Long)
Enter the project's properties (menu Tools... properties)
Enter "description" as Project description and "abc.hlp" as Help file name
Save the workbook as a .xlsb or .xlsm
Close the workbook
Create a new Excel workbook
Go to it's VBA project (Alt-F11)
Add a fresh new code module
Paste the code below in it
Adjust the path on the 1st line so it points to the file you created above
Run the Test routine
The code to use:
Const csFilePath As String = "<path to your test workbook>"
Sub TestSecurity(testType As String, secondExcel As Application, security As MsoAutomationSecurity)
Dim theWorkbook As Workbook
secondExcel.AutomationSecurity = security
Set theWorkbook = secondExcel.Workbooks.Open(csFilePath)
Call MsgBox(testType & " - helpfile: " & theWorkbook.VBProject.HelpFile)
Call MsgBox(testType & " - helpfile converted: " & StrConv(theWorkbook.VBProject.HelpFile, vbUnicode))
Call MsgBox(testType & " - description: " & theWorkbook.VBProject.Description)
Call theWorkbook.Close(False)
End Sub
Sub Test()
Dim secondExcel As Excel.Application
Set secondExcel = New Excel.Application
Dim oldSecurity As MsoAutomationSecurity
oldSecurity = secondExcel.AutomationSecurity
Call TestSecurity("enabled macros", secondExcel, msoAutomationSecurityLow)
Call TestSecurity("disabled macros", secondExcel, msoAutomationSecurityForceDisable)
secondExcel.AutomationSecurity = oldSecurity
Call secondExcel.Quit
Set secondExcel = Nothing
End Sub
Conclusion when working from Excel 2010:
.Description is always readable, no matter what (so it's not like all string properties behave this way)
xlsb and xlsm files result in an unreadable .HelpFile only when macros are disabled
xls files result in an unreadable .HelpFile in all cases (!)
It might be even weirder than that, since I swear I once even saw the questionmarks-version pop up in the VBE GUI when looking at such a project's properties, though I'm unable to reproduce that now.
I realize this is an edge case if ever there was one (except for the .xls treatment though), so it might just have been overlooked by Microsoft's QA department, but for my current project I have to get this working properly and consistently across Excel versions and workbook formats...
Could anyone else test this as well to verify my Excel installation isn't hosed? Preferably also with another Excel version, to see if that makes a difference?
Hopefully this won't get to be a tumbleweed like some of my other posts here :) Maybe "Tumbleweed generator" might be a nice badge to add...
UPDATE
I've expanded the list of properties to test just to see what else I could find, and of all the VBProject's properties (BuildFileName, Description, Filename, HelpContextID, HelpFile, Mode, Name, Protection and Type) only .HelpFile has this problem of being mangled when macros are off.
UPDATE 2
Porting the sample code to Word 2010 and running that exhibits exactly the same behaviour - the .HelpFile property is malformed when macros are disabled. Seems like the code responsible for this is Office-wide, probably in a shared VBA library module (as was to be expected TBH).
UPDATE 3
Just tested it on Excel 2007 and 2003, and both contain this bug as well. I haven't got an Excel XP installation to test it out on, but I can safely say that this issue already has a long history :)
I've messed with the underlying binary representation of the strings in question, and found out that the .HelpFile string property indeed returns a malformed string.
The BSTR representation (underwater binary representation for VB(A) strings) returned by the .HelpFile property lists the string size in the 4 bytes in front of the string, but the following content is filled with the ASCII representation and not the Unicode (UTF16) representation as VBA expects.
Parsing the content of the BSTR returned and deciding for ourselves which format is most likely used fixes this issue in some circumstances. Another issue is unfortunately at play here as well: it only works for even-length strings... Odd-length strings get their last character chopped off, their BSTR size is reported one short, and the ASCII representation just doesn't include the last character either... In that case, the string cannot be recovered fully.
The following code is the example code in the question augmented with this fix. The same usage instructions apply to it as for the original sample code. The RecoverString function performs the needed magic to, well, recover the string ;) DumpMem returns a 50-byte memory dump of the string you pass to it; use this one to see how the memory is layed out exactly for the passed-in string.
Const csFilePath As String = "<path to your test workbook>"
Private Declare Sub CopyMemoryByte Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Byte, ByVal Source As Long, ByVal Length As Integer)
Private Declare Sub CopyMemoryWord Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Integer, ByVal Source As Long, ByVal Length As Integer)
Private Declare Sub CopyMemoryDWord Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Function DumpMem(text As String) As String
Dim textAddress As LongPtr
textAddress = StrPtr(text)
Dim dump As String
Dim offset As Long
For offset = -4 To 50
Dim nextByte As Byte
Call CopyMemoryByte(nextByte, textAddress + offset, 1)
dump = dump & Right("00" & Hex(nextByte), 2) & " "
Next
DumpMem = dump
End Function
Function RecoverString(text As String) As String
Dim textAddress As LongPtr
textAddress = StrPtr(text)
If textAddress <> 0 Then
Dim textSize As Long
Call CopyMemoryDWord(textSize, textAddress - 4, 4)
Dim recovered As String
Dim foundNulls As Boolean
foundNulls = False
Dim offset As Long
For offset = 0 To textSize - 1
Dim nextByte As Byte
Call CopyMemoryByte(nextByte, textAddress + offset, 1)
recovered = recovered & Chr(CLng(nextByte) + IIf(nextByte < 0, &H80, 0))
If nextByte = 0 Then
foundNulls = True
End If
Next
Dim isNotUnicode As Boolean
isNotUnicode = isNotUnicode Mod 2 = 1
If foundNulls And Not isNotUnicode Then
recovered = ""
For offset = 0 To textSize - 1 Step 2
Dim nextWord As Integer
Call CopyMemoryWord(nextWord, textAddress + offset, 2)
recovered = recovered & ChrW(CLng(nextWord) + IIf(nextWord < 0, &H8000, 0))
Next
End If
End If
RecoverString = recovered
End Function
Sub TestSecurity(testType As String, secondExcel As Application, security As MsoAutomationSecurity)
Dim theWorkbook As Workbook
secondExcel.AutomationSecurity = security
Set theWorkbook = secondExcel.Workbooks.Open(csFilePath)
Call MsgBox(testType & " - helpfile: " & theWorkbook.VBProject.HelpFile & " - " & RecoverString(theWorkbook.VBProject.HelpFile))
Call MsgBox(testType & " - description: " & theWorkbook.VBProject.Description & " - " & RecoverString(theWorkbook.VBProject.Description))
Call theWorkbook.Close(False)
End Sub
Sub Test()
Dim secondExcel As Excel.Application
Set secondExcel = New Excel.Application
Dim oldSecurity As MsoAutomationSecurity
oldSecurity = secondExcel.AutomationSecurity
Call TestSecurity("disabled macros", secondExcel, msoAutomationSecurityForceDisable)
Call TestSecurity("enabled macros", secondExcel, msoAutomationSecurityLow)
secondExcel.AutomationSecurity = oldSecurity
Call secondExcel.Quit
Set secondExcel = Nothing
End Sub
Related
I have successfully coded some VBA macros for work which basically create a data file, feed it to a program and post-treat the output from this program.
My issue is that the program installation path is hard coded in the macro and the installation may vary accross my colleagues computers.
The first thing I thought is that I can gather from everyone the different installation directories and test for all of them in the code. Hopefully, one of them will work. But it doesn't feel that clean.
So my other idea was to somehow get the installation directory in the code. I thought it would be possible as in Windows, if I right click on a shortcut, I can ask to open the file's directory. What I'm basically looking for is an equivalent in VBA of this right click action in Windows. And that's where I'm stuck.
From what I found, Windows API may get the job done but that's really out of what I know about VBA.
The API FindExecutable seemed not too far from what I wanted but I still can't manage to use it right. So far, I can only get the program running if I already know its directory.
Could you give me some pointers ? Thanks.
Here's another method for you to try. Note that you might see a black box pop up for a moment, that's normal.
Function GetInstallDirectory(appName As String) As String
Dim retVal As String
retVal = Split(CreateObject("WScript.Shell").Exec("CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)").StdOut.ReadAll, vbCrLf)(2)
GetInstallDirectory = Left$(retVal, InStrRev(retVal, "\"))
End Function
It's not as clean as using API but should get the trick done.
Summary:
retVal = Split(CreateObject("WScript.Shell").Exec("CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)").StdOut.ReadAll, vbCrLf)(1)
"CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)" is a command that works in CMD to loop through files rooted at a defined path. We use the wildcard with the appName variable to test for the program we want. (more info on FOR /R here) Here, we have created the CMD application using a Shell object (WScript.Shell) and Executed the command prompt CMD passing arguments to it directly after. The /C switch means that we want to pass a command to CMD and then close the window immediately after it's processed.
We then use .StdOut.ReadAll to read all of the output from that command via the Standard Output stream.
Next, we wrap that in a Split() method and split the output on vbCrLf (Carriage return & Line feed) so that we have a single dimension array with each line of the output. Because the command outputs each hit on a new line in CMD this is ideal.
The output looks something like this:
C:\Users\MM\Documents>(ECHO C:\Program Files\Microsoft
Office\Office14\EXCEL.EXE ) C:\Program Files\Microsoft
Office\Office14\EXCEL.EXE
C:\Users\MM\Documents>(ECHO
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.4763\EXCEL.EXE
)
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.4763\EXCEL.EXE
C:\Users\olearysa\Documents>(ECHO
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.7015\EXCEL.EXE
)
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.7015\EXCEL.EXE
We're only interested in the third line of the output (the first line is actually blank), so we can access that index of the array directly by using (2) after it (because arrays are zero-indexed by default)
Finally, we only want the path so we use a combination of Left$() (which will return n amount of characters from the left of a string) and InStrRev() (which returns the position of a substring starting from the end and moving backwards). This means we can specify everything from the left until the first occurrence of \ when searching backwards through the string.
Give this a try, assuming you know the name of the .exe:
#If Win64 Then
Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#Else
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#End If
Const SYS_OUT_OF_MEM As Long = &H0
Const ERROR_FILE_NOT_FOUND As Long = &H2
Const ERROR_PATH_NOT_FOUND As Long = &H3
Const ERROR_BAD_FORMAT As Long = &HB
Const NO_ASSOC_FILE As Long = &H1F
Const MIN_SUCCESS_LNG As Long = &H20
Const MAX_PATH As Long = &H104
Const USR_NULL As String = "NULL"
Const S_DIR As String = "C:\" '// Change as required (drive that .exe will be on)
Function GetInstallDirectory(ByVal usProgName As String) As String
Dim fRetPath As String * MAX_PATH
Dim fRetLng As Long
fRetLng = FindExecutable(usProgName, S_DIR, fRetPath)
If fRetLng >= MIN_SUCCESS_LNG Then
GetInstallDirectory = Left$(Trim$(fRetPath), InStrRev(Trim$(fRetPath), "\"))
End If
End Function
Example of how to use, let's try looking for Excel:
Sub ExampleUse()
Dim x As String
x = "EXCEL.EXE"
Debug.Print GetInstallDirectory(x)
End Sub
Output (on my machine anyway) is
C:\Program Files\Microsoft Office\Office14\
Assuming you are working on PC only and the people are working with their own copies and not a shared network copy. I would recommend the following.
Create a Sheet called 'Config', place the path with the exe in there, and then hide it.
Use use FileScriptingObject ('Tools' > 'References' > 'Microsoft Scripting Runtime') to see if the path in 'Config' exists
If it does not, ask the user for the location using a 'open file dialog box' and remember that in the 'Config' Sheet for next time.
The below code may help as a pointer.
Dim FSO As New FileSystemObject
Private Function GetFilePath() As String
Dim FlDlg As FileDialog
Dim StrPath As String
Set FlDlg = Application.FileDialog(msoFileDialogOpen)
With FlDlg
.Filters.Clear
.Filters.Add "Executable Files", "*.exe"
.AllowMultiSelect = False
.ButtonName = "Select"
.Title = "Select the executable"
.Show
If .SelectedItems.Count <> 0 Then GetFilePath = .SelectedItems(1)
End With
Set FlDlg = Nothing
End Function
Private Function FileExists(ByVal StrPath As String) As Boolean
FileExists = FSO.FileExists(StrPath)
End Function
I have a problem referencing a windows object in VBA. it throws the following error: "Error 5 (Invalid procedure call or argument). I cannot find the cause, because I see no programming error.
Public Sub TestWindowhandle()
Dim lResult As Long
Dim objShell, wins, winn
Dim IE_Count As Long, i As Long, This_PID As Long
On Error GoTo TestWindowhandle_Error
Set objShell = CreateObject("Shell.Application")
Set wins = objShell.Windows
IE_Count = wins.Count
For i = 0 To (IE_Count - 1)
Set winn = wins.Item(i)
Next i
On Error GoTo 0
Exit Sub
TestWindowhandle_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in line " & Erl & " in procedure TestWindowhandle of Module Module1"
Stop
End Sub
Something odd with that interface, it seems to only work with a copy of the control variable so:
Set winn = wins.Item(i + 0)
or
Set winn = wins.Item((i))
I believe here is what is happening.
The Item method accepts a Variant parameter.
When calling an external method that accepts a Variant parameter, VB likes to create and pass Variants that provide the value by reference - that is, with the VT_BYREF flag set.
However VB does not set this flag when sending out intermediate results (temporaries, not stored in a variable), which makes sense because even if the called method updates the value, no one will be able to see it.
So when you call .Item(i), VB sends out a Variant of type VT_I4 | VT_BYREF, and when you call .Item(i + 0), a Variant of type VT_I4 is dispatched, without the VT_BYREF.
In most situations the difference is not significant because VARIANT-aware methods should be able to cope with either. However this particular method does different things depending on exactly which VT_ it receives, and because of this it is explicitly willing to reject any VT_s other than the three accepted ones. So in order to call it you need to trick VB into removing the byref flag.
Interestingly, when you declare the variable as Variant, VB still dispatches a VT_VARIANT | VT_BYREF, but the method seems to support this situation and correctly resolves to the pointed-to inner Variant that has the non-reference type of VT_I4.
Note this has nothing to do with VB's ByVal/ByRef - this is about the internal structure of the VARIANT data type.
This searches for the end of a file name removes it's current file type of .docm and converts it to a .docx. Works great.
ActiveDocument.SaveAs2 Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1), WdSaveFormat.wdFormatXMLDocument
However, I noticed a little bug. If there is a . in the file name, it finds that first and obviously creates a file that is incorrect.
For example:
TestFileV1.2AlexTest.docm
Becomes the file
TestFileV.2AlextTest Where the new file type is a .2ALEXTEST file.
Kind of a funny error, but still a bug none the less.
Best course of action for validation?
Thanks!
Try the VBA.Strings.Split() function, which splits a string into an array.
Split the File name on '.' and the last element in the array will be your extension:
Public Function GetExtension(FileName As String) As String
'Returns a file's extension
' This does not go to the filesystem and get the file:
' The function parses out the string after the last '.'
' Useful for situations where a file does not yet exist
' Nigel Heffernan Excellerando.Blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'Print GetExtension("C:\Temp\data.txt1.docx")
'Returns docx
Dim arrayX() As String
Dim iLast As Integer
arrayX = Split(FileName, ".")
iLast = UBound(arrayX)
GetExtension = arrayX(iLast)
Erase arrayX
End Function
If you don't care about readability, the quick-and-dirty answer is:
strExt = Split(strFile, ".")(UBound(Split(strFile, ".")))
However... I think you're looking for something more sophisticated than a string parser to extract the file extension.
Are you actually looking to validate the file extension?
I'm not coding up a registry lookup for the ShellExt application command to open your file, but I had a closely-related issue to yours a year or two ago, when I needed to populate a file dialog's filter list with a list of arbitrary file extensions.
It doesn't 'validate' as such, but unknown extensions will return a string containing 'unknown file type', and you can test for that:
VBA and the Registry: Returning a File Type from a File Extension
Public Function GetExtensionType(strExt As String) As String
' Return a file extension type descriptor, if the OS knows it
' Parses out the string after the last "." and reads the registry
' GetExtensionType("txt") Returns 'Text Document'
' GetExtensionType("SystemORA.user.config") 'XML Configuration File'
' GetExtensionType("Phishy.vbs") 'VBScript Script File'
' Nigel Heffernan Excellerando.Blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
On Error GoTo ErrSub
Dim strType As String
Dim strTyp1 As String
Dim strTyp2 As String
strExt = Trim(strExt)
' Set a default return: if an error is raised, return this value
GetExtensionType = Trim(strExt & " (unknown file type)")
strExt = Split(strExt, ".")(UBound(Split(strExt, "."))) '
If strExt = "" Then
Exit Function
End If
With CreateObject("WScript.Shell")
' This will go to error if there's no key for strExt in HKCR
strTyp1 = .RegRead("HKCR." & strExt & "\")
If strTyp1 = "" Then
strType = strExt & " File"
Else
' This value isn't very readable, eg: Access.ACCDEFile.14
' But we can use it to retrieve a descriptive string:
strTyp2 = .RegRead("HKCR\" & strTyp1 & "\")
If strTyp2 = "" Then
' So we didn't get a descriptive string:
' Parse some readability out of strType1:
strType = strTyp1
strType = Replace(strType, "File", " File")
strType = Replace(strType, ".", " ")
Else
strType = strTyp2
End If
End If
End With
If strType <> "" Then
GetExtensionType = strType
End If
ExitSub:
Exit Function
ErrSub:
Resume ExitSub
End Function
I made it error-tolerant but I didn't bother idiot-proofing it because someone, somewhere, is building a better idiot; and it's entirely possible that the user was actually right insofar as there really are files called that, and my system didn't have a registry entry for the file type in question.
There is an obvious source of errors in the code: GetExtensionType("docx") will give you 'Microsoft Word Document' on an English-Language workstation. If your user base are working with other languages and locales, they will see the descriptive name 'Microsoft Word Document' in their chosen language; and any validation logic you've coded up will fail to match that string (unless, of course, your string literals are internationalised in a conditional compiler block).
So any validation against a predefined application name or file type needs to be at the language-independent layer of the registry, using 'strTyp1' from the root instead of the locale-dependent strings passed into 'strTyp2'.
Use the FileSystemObject from the Scripting Runtime - it has a .GetBaseName() method to extract the basename from a file path:
'Early bound (reference to Microsoft Scripting Runtime):
Dim fso As New FileSystemObject
ActiveDocument.SaveAs2 fso.GetBaseName(ActiveDocument.Name), WdSaveFormat.wdFormatXMLDocument
'Late bound:
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
ActiveDocument.SaveAs2 fso.GetBaseName(ActiveDocument.Name), WdSaveFormat.wdFormatXMLDocument
You can also retrieve the extension with the .GetExtensionName() method, the path with .GetParentFolderName(), and the drive letter with GetDriveName() (which also works with UNC paths).
If you need to find the registered name of the extension in the current Windows install, you can either use the registry method #Nile answered with or an API call to AssocQueryStringA:
Const ASSOCSTR_FRIENDLYDOCNAME = 3
Private Declare Function AssocQueryString Lib "shlwapi.dll" _
Alias "AssocQueryStringA" ( _
ByRef Flags As Long, _
ByVal str As Long, _
ByVal pszAssoc As String, _
ByVal pszExtra As String, _
ByVal pszOut As String, _
ByRef pcchOut As Long) As Long
Sub Main()
Dim buffer As String
buffer = String$(255, " ")
Dim hresult As Long
hresult = AssocQueryString(0, ASSOCSTR_FRIENDLYDOCNAME, ".docm", _
vbNullString, buffer, 255)
If hresult = 0 Then
'Should be something like "Microsoft Word Macro-Enabled Document"
Debug.Print Trim$(buffer)
End If
End Sub
Note that you can also retrieve addition information about the associated file type by passing different values for the str parameter. See the ASSOCSTR enumeration.
I have been creating reports by copying some charts and data from an excel document into a word document. I am pasting into a content control, so i use ChartObject.CopyPicture in excel and ContentControl.Range.Paste in word. This is done in a loop:
Set ws = ThisWorkbook.Worksheets("Charts")
With ws
For Each cc In wordDocument.ContentControls
If cc.Range.InlineShapes.Count > 0 Then
scaleHeight = cc.Range.InlineShapes(1).scaleHeight
scaleWidth = cc.Range.InlineShapes(1).scaleWidth
cc.Range.InlineShapes(1).Delete
.ChartObjects(cc.Tag).CopyPicture Appearance:=xlScreen, Format:=xlPicture
cc.Range.Paste
cc.Range.InlineShapes(1).scaleHeight = scaleHeight
cc.Range.InlineShapes(1).scaleWidth = scaleWidth
ElseIf ...
Next cc
End With
Creating these reports using Office 2007 yielded files that were around 6MB, but creating them (using the same worksheet and document) in Office 2010 yields a file that is around 10 times as large.
After unzipping the docx, I found that the extra size comes from emf files that correspond to charts that are pasted in using VBA. Where they range from 360 to 900 KB before, they are 5-18 MB. And the graphics are not visibly better.
Even further, it seems to be related to the Chart Style. I created a new spreadsheet and inserted 7 data points and a corresponding 2D pie chart. With the default style, it copied as a 79 KB emf, and with style 26 it copies as a 10 MB emf. When I was using Office 2007, the chart would copy as a 700 KB emf. This is the code:
Sub CopyAndPaste()
ThisWorkbook.Worksheets("Charts").ChartObjects("Chart 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
GetObject(, Class:="Word.Application").ActiveDocument.Range.Paste
End Sub
I am able to CopyPicture with the format xlBitmap, and while that is somewhat smaller, it is larger than the emf generated by Office 2007 and noticeably poorer quality. Are there any other options for reducing the file size? Ideally, I would like to produce a file with the same resolution for the charts as I did using Office 2007. Is there any way that uses VBA only (without modifying the charts in the spreadsheet)? Any way I can easily copy as an object without linking the documents?
"It's an older code, sir, but it checks out."
It's an old question and I have an even older (possible) solution: you can compress your .EMF files as .EMZ by gzipping it. This will reduce your file size while keeping the image quality.
On VB6 I used zlib.dll and the code below. I renamed the function names to english but I kept all comments in portuguese:
Option Explicit
' Declaração das interfaces com a ZLIB
Private Declare Function gzopen Lib "zlib.dll" (ByVal file As String, ByVal mode As String) As Long
Private Declare Function gzwrite Lib "zlib.dll" (ByVal file As Long, ByRef uncompr As Byte, ByVal uncomprLen As Long) As Long
Private Declare Function gzclose Lib "zlib.dll" (ByVal file As Long) As Long
Private Declare Function Compress Lib "zlib.dll" Alias "compress" (ByRef dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long) As Long
Private Declare Function Uncompress Lib "zlib.dll" Alias "uncompress" (ByRef dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long) As Long
' Ler o conteúdo de um arquivo
Public Function FileRead(ByVal strNomeArquivo As String) As Byte()
Dim intHandle As Integer
Dim lngTamanho As Long
Dim bytConteudo() As Byte
On Error GoTo FileReadError
' Abrir o documento indicado
intHandle = FreeFile
Open strNomeArquivo For Binary Access Read As intHandle
' Obter o tamanho do arquivo
lngTamanho = LOF(intHandle)
ReDim bytConteudo(lngTamanho)
' Obter o conteúdo e liberar o arquivo
Get intHandle, , bytConteudo()
Close intHandle
FileRead = bytConteudo
On Error GoTo 0
Exit Function
FileReadError:
objLogger.GravarEvento "modZLib.FileRead: " & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro
End Function
'Compactar um arquivo com o padrão gzip
Public Sub FileCompress(ByVal strArquivoOrigem As String, ByVal strArquivoDestino As String)
Dim gzFile As Long
Dim bytConteudo() As Byte
On Error GoTo FileCompressError
' Ler o conteúdo do arquivo
bytConteudo = FileRead(strArquivoOrigem)
' Compactar o conteúdo
gzFile = gzopen(strArquivoDestino, "wb")
gzwrite gzFile, bytConteudo(0), UBound(bytConteudo)
gzclose gzFile
On Error GoTo 0
Exit Sub
FileCompressError:
objLogger.GravarEvento "modZLib.FileCompress:" & Err.Description & " (" & Err.Number & " - " & Err.Source & ")", logTipoEvento.Erro
End Sub
I've dealt with something like this before
Instead of using
Document.Range.Paste
Try Using
Document.Range.PasteSpecial DataType:= wdPasteMetafilePicture
or
Document.Range.PasteSpecial DataType:= wdPasteShape
This will paste the chart as a picture or drawing as opposed to an embedded excel object
Equivelant to using "Paste Special..." from the menu.
Other DataTypes are available
http://msdn.microsoft.com/en-us/library/office/aa220339(v=office.11).aspx
This is possibly happening because the .emf files are getting scaled incorrectly. Using PNG may resolve the size issue (as mentioned in the comments above), but will still be an issue because they will not be vector images.
If you use AddPicture to add images to your file, then the following page shows a solution wherein you can change the scale and reduce filesize from whatever default is being used. So it might solve your issue.
http://social.msdn.microsoft.com/Forums/en-US/f1c9c753-77fd-4c17-9ca8-02908debca5d/emf-file-added-using-the-addpicture-method-looks-bigger-in-excel-20072010-vs-excel-2003?forum=exceldev
I want to store a unicode string in a flat file on a windows box from an excel/vba macro. The macro converts normal string to unicode representation, need to store it in a file and retrieve later.
As mentioned, you can use the Microsoft Scripting Runtime (scrrun.dll). I have posted some examples below. Some people also like the native file IO features. There is an extensive (and fairly comprehensive thread) thread here: http://www.xtremevbtalk.com/showthread.php?t=123814
However for Unicode files it's probably the least painful to use Textstreams:)
Public Sub StringToTextFile(ByVal path As String, ByVal value As String)
'Requires reference to scrrun.dll
Dim fso As Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Set fso = New Scripting.FileSystemObject
Set ts = fso.CreateTextFile(path, False, True)
ts.Write value
ts.Close
End Sub
Public Sub LazyMansWay(ByVal path As String, ByVal value As String)
'Reference counting will cause the objects to be destroyed. The termination
'events of the classes will cause the connections to be closed.
CreateObject("Scripting.FileSystemObject").CreateTextFile(path, False, True).Write value
End Sub
Add a reference to "Microsoft Scripting Runtime" COM component (scrrun.dll).
It has all the classes (specifically FileSystemObject/TextStream) to create/read/write files.
The best solution I could figure is read the string in to a byte array and write each byte to a binary file
Private Function WriteBinaryFile(ByRef szData As String)
Dim bytData() As Byte
Dim lCount As Long
bytData = szData
Open PwdFileName For Binary As #1
For lCount = LBound(bytData) To UBound(bytData)
Put #1, , bytData(lCount)
Next lCount
Close #1
End Function
Read it back by opening the file in binary mode and reading each byte into a byte array and then converting it to a string.
Sub ReadBinaryFile(ByRef gszData As String)
Dim aryBytes() As Byte
Dim bytInput As Byte
Dim intFileNumber
Dim intFilePos
intFileNumber = FreeFile
Open PwdFileName For Binary As #intFileNumber
intFilePos = 1
Do
Get #intFileNumber, intFilePos, bytInput
If EOF(intFileNumber) = True Then Exit Do
ReDim Preserve aryBytes(intFilePos - 1)
aryBytes(UBound(aryBytes)) = bytInput
intFilePos = intFilePos + 1
Loop While EOF(intFileNumber) = False
Close #intFileNumber
gszData = aryBytes
End Sub