WORD VBA - Obtain windows login name

R

Richard

Hi

I have a document opened from a centrally located template which I want to
automatically save to the users Sharepoint folder.

The path for Sharepoint is:

http://sharepoint/personal/LOGINNAME/.....

Any ideas as to how to obtain the users windows login name?

Many thanks
 
R

Richard

Hi
In addition for some reason SaveAs keeps opening the save as dialog, rather
than saving to specified folder & filename

strDocname = "C:\Documents and settings\My Documents\NewDoc.doc"
ActiveDocument.SaveAs FileName:= strDocName

Comes up with the Save As Dialog with different path & 'Document1' as
potential file name.

Do I need to associate another reference?
 
G

Graham Mayor

SaveAs when called from the SaveAs button/menu will only run your macro if
your macro is named FileSaveAs e.g.

Sub FileSaveAs()
strDocname = "C:\Documents and settings\My Documents\NewDoc.doc"
ActiveDocument.SaveAs FileName:= strDocName
End Sub

The path in question would have to exist and all the documents saved with
SaveAs from the template containing the macro would be saved with the same
filename in the same folder (which is perhaps not the best of plans).

If you want to locate the My Documents folder for a given user then you
would need to call the following function from your modified macro e.g.

Sub FileSaveAs()
Dim strDocName As String
strDocName = SpecFolder(CSIDL_PERSONAL) & "\NewDoc.doc"
ActiveDocument.SaveAs FileName:=strDocName
End Sub

If you want to display the dialog with the above name and path selected then

Sub FileSaveAs()
Dim strDocName As String
strDocName = SpecFolder(CSIDL_PERSONAL) & "\NewDoc.doc"
With Dialogs(wdDialogFileSaveAs)
.name = strDocName
.Show
End With
End Sub

If you want the Windows log-in name you can get it with

Dim sUser as String
sUser = Environ$("UserName")
MsgBox sUser

''''''''''''''''''''''''''''''''''''

Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Public Const CSIDL_PERSONAL = &H5
Public Const MAX_PATH = 260
Public Const NOERROR = 0

Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
 
R

Richard

Thank you Graham

Original code, not called from a button, but from other procedures:
====================

Sub DocSave()
Unprotect
Set rngTable = ActiveDocument.Tables(3).Rows(2).Cells(2).Range
YPFamName = UCase(Left(rngTable.Text, Len(rngTable.Text) - 2))
Protect

strDocPath = ActiveDocument.Path
If strDocPath = "" Then
intAnswer = MsgBox("Do you want to save this document now?" &
Chr(10) & "You will need to save with a suitable name ", vbYesNo)
If intAnswer = 6 Then
On Error Resume Next
'save document
YPFamName = YPFamName & ".doc"
DocName = "http://sharepoint/personal/" & UserNameWindows &
"/main/" & YPFamName

ActiveDocument.SaveAs FileName:=DocName

On Error GoTo 0
End If
End If


End Sub
============================================

This always threw up the Save As dialog, rather than just doing the save as
coded.

I have tried your suggestions as below

=============================================

Sub FileSaveAs()
'DocName = "http://sharepoint/personal/webb_rp/main/test.doc"
'DocName = "C:\Documents and settings\My documents\Test.doc"
DocName = specfolder(CSIDL_PERSONAL) & "test.doc"
ActiveDocument.SaveAs FileName:=DocName
End Sub

==========================================

You can see I have tried 3 locations.

The first two throw up the Save As Dialog
The last comes up with an error CISDL_PERSONAL - Variable not defined

Using Office XP (WORD 2002 SP3)

Gently tearing my hair out!

Sharepoint seems to cause all sorts of aggravation, so I turned off its
integration with WORD & the first two then operated fine! The variable error
remains on the CISDL_PERSONAL

So it seems now I need the code to turn Sharepoint Integration off & on!
Many thanks for your trouble
 
G

Graham Mayor

The SpecFolder function has to be present before you can call upon it. I
listed the Specfolder function in my previous reply, but will repeat it
below. Create a new moule and copy the following function into it.
http://www.gmayor.com/installing_macro.htm

Option Explicit
Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Public Const CSIDL_PERSONAL = &H5
Public Const MAX_PATH = 260
Public Const NOERROR = 0

Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function

You should declare your variables. I know nothing about Sharepoint access,
but the following works as far as it goes.

Option Explicit
Sub DocSave()
Dim rngTable As Range
Dim YPFamName As String
Dim strDocPath As String
Dim intAnswer As String
Dim docName As String
Dim userNameWindows As String
userNameWindows = Environ$("UserName")
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
Set rngTable = ActiveDocument.Tables(3).Rows(2).Cells(2).Range
YPFamName = UCase(Left(rngTable.Text, Len(rngTable.Text) - 2))
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True,
Password:=""
strDocPath = ActiveDocument.Path
If Len(strDocPath) = 0 Then
intAnswer = MsgBox("Do you want to save this document now?" _
& Chr(10) & "You will need to save with a suitable name ",
vbYesNo)
If intAnswer = vbYes Then
On Error Resume Next
'save document
YPFamName = YPFamName & ".doc"
docName = "http://sharepoint/personal/" _
& userNameWindows & "/main/" & YPFamName
' ActiveDocument.SaveAs FileName:=docName
MsgBox docName
On Error GoTo 0
End If
End If
End Sub

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
 
G

Graham Mayor

That should have read create a new MODULE :(

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>


Graham Mayor said:
The SpecFolder function has to be present before you can call upon it. I
listed the Specfolder function in my previous reply, but will repeat it
below. Create a new moule and copy the following function into it.
http://www.gmayor.com/installing_macro.htm

Option Explicit
Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Public Const CSIDL_PERSONAL = &H5
Public Const MAX_PATH = 260
Public Const NOERROR = 0

Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function

You should declare your variables. I know nothing about Sharepoint access,
but the following works as far as it goes.

Option Explicit
Sub DocSave()
Dim rngTable As Range
Dim YPFamName As String
Dim strDocPath As String
Dim intAnswer As String
Dim docName As String
Dim userNameWindows As String
userNameWindows = Environ$("UserName")
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
Set rngTable = ActiveDocument.Tables(3).Rows(2).Cells(2).Range
YPFamName = UCase(Left(rngTable.Text, Len(rngTable.Text) - 2))
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True,
Password:=""
strDocPath = ActiveDocument.Path
If Len(strDocPath) = 0 Then
intAnswer = MsgBox("Do you want to save this document now?" _
& Chr(10) & "You will need to save with a suitable name ",
vbYesNo)
If intAnswer = vbYes Then
On Error Resume Next
'save document
YPFamName = YPFamName & ".doc"
docName = "http://sharepoint/personal/" _
& userNameWindows & "/main/" & YPFamName
' ActiveDocument.SaveAs FileName:=docName
MsgBox docName
On Error GoTo 0
End If
End If
End Sub

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Click to expand...
 
R

Richard

Many thanks Graham

Will see how I get on.
--
Richard


Graham Mayor said:
That should have read create a new MODULE :(

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Sub projects added as read only in Master file which are saved on sharepoint 1
Incorporating the User Profile location into a document template path 1
Template location changes from user to user 0
How can I save directly into the same folder every time in Office 365 / Windows 10? 0
Windows forces me to use one drive 1
Confusion over where user templates are stored in Word 1
Word VBA - Want to test if Full Name is NOT Present in document 0
Embedded Excel into Word with Tables 0

Top