Hello everyone!
I have a problem which i'm afraid I can't solve myself. Could you help
me please? Googling hasn't helped.
I have written/botched together the following in MS Excel 2002:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
If CBool(GetUserName(strBuffer, lngLen)) Then
UserNameWindows = Left$(strBuffer, lngLen - 1)
Else
UserNameWindows = ""
End If
End Function
Sub ExportPDF()
Dim WordDoc As Object, objWord As Variant, ProjectNumber As String, IsPandI As Boolean, Suffix As String, NameOfFile As String, CurrentUser As String
CurrentUser = UserNameWindows
'Test to see if a Worksheet is open'.
On Error Resume Next
Set wsheet = Sheets("Tabelle1")
If wsheet Is Nothing Then 'Doesn't exist
MsgBox "Das Macro kann ohne Tabelle nicht ausgeführt werden!", vbCritical, "ExportPDF Error"
Set wsheet = Nothing
Exit Sub
Else 'Does exist
Set wsheet = Nothing
On Error GoTo 0
End If
'Reset cursor position on worksheet
Cells(1, 1).Select
'Check the title of the first column. If there's nothing then stop
If Selection = "" Then
MsgBox "Das Macro kann nur mit Listen aus Saperion ausgeführt werden!", vbCritical, "ExportPDF Error"
Exit Sub
End If
'Fire up Microsloth Word
Set appWD = CreateObject("word.Application")
appWD.Visible = False
'Open a brand spanking new Word document
Set WordDoc = appWD.Documents.Add
'Change the page orientation of the Word document
With WordDoc
.PageSetup.Orientation = 1
End With
'Copy the table from Excel...
ActiveSheet.UsedRange.Select
ActiveSheet.UsedRange.Activate
Selection.Copy
'...and paste it ito Word (in the correct way)
appWD.Selection.Paste
'Ask the user for a projectnumber, set a jump point in case the answer is empty
Help:
ProjectNumber = InputBox("Bitte Projektnummer eingeben:", "ExportRTF Frage")
If ProjectNumber = "" Then GoTo Help
If Cells(1, 1) = "P&I No." Or Cells(1, 1) = "R&I Buchstabe" Then
IsPandI = True
Suffix = "_Mit_R&I"
Else
IsPandI = False
Suffix = "_Ohne_R&I"
End If
'Build the filename and show the user
NameOfFile = "G:\Home\" & CurrentUser & "\desktop.ileaf\" & ProjectNumber & Suffix & ".rtf"
MsgBox "Aktuelle Tabelle wird als " & NameOfFile & " gespeichert."
'Save the document in the correct place
With WordDoc
.SaveAs FileName:=NameOfFile, FileFormat:= _
wdFormatRTF, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
.Close
End With
'Muahahaha kill word and wrap up loose ends
appWD.Quit
Set WordDoc = Nothing
Set appWD = Nothing
End Sub
Now the problem I have is that when I run this macro, the resulting
RTF document needs to be repaired if I open it in Word again and try to "save as" ("data integrity error (type 4) 1". However, if I do exactly the same actions as in the macro by hand and select "Save as" from the file menu in Word, the file saves perfectly without needing repair.
Could somebody please tell me how to fix this?
Thank you very much for your time and any help you can give me!
John
Bookmarks