对于导航栏，如何进行默认 折叠处理。

ytyyutianyun

每次打开文档， 导航栏都是默认展开方式
如图

如何， 每次打开文档， 导航栏都是默认折叠方式
如图所示

谢谢

amesman

点击视图-》文档结构图，去掉勾选即可。。。。。。

ytyyutianyun

amesman 发表于 2013-7-30 23:23
点击视图-》文档结构图，去掉勾选即可。。。。。。

并不是去掉导航图，而是默认折叠处理

ytyyutianyun

能否解决呢，谢谢

zhanglei1371

摸索了很长时间，请教了守柔版主，用api达到了目的，代码如下：
Const VK_1 = 49
Const KEYEVENTF_KEYUP = &H2
Const INPUT_MOUSE = 0
Const INPUT_KEYBOARD = 1
Const INPUT_HARDWARE = 2
Private Const MOUSEEVENTF_MOVE = &H1      '移动鼠标
Private Const MOUSEEVENTF_LEFTDOWN = &H2      ' 模拟鼠标左键按下
Private Const MOUSEEVENTF_LEFTUP = &H4   '模拟鼠标左键抬起
Private Const MOUSEEVENTF_RIGHTDOWN = &H8   '模拟鼠标右键按下
Private Const MOUSEEVENTF_RIGHTUP = &H10   ' 模拟鼠标右键抬起
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20   '模拟鼠标中键按下
Private Const MOUSEEVENTF_MIDDLEUP = &H40     '模拟鼠标中键抬起
Private Const MOUSEEVENTF_ABSOLUTE = &H8000    '标示是否采用绝对坐标
Private Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As GENERALINPUT, ByVal cbSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal Y As Long) As Long
Private Type POINTAPI
    x As Long
    Y As Long
End Type
Private Type MOUSEINPUT
  dx As Long
  dy As Long
  mouseData As Long
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
Private Type KEYBDINPUT
  wVk As Integer
  wScan As Integer
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
Private Type HARDWAREINPUT
  uMsg As Long
  wParamL As Integer
  wParamH As Integer
End Type
Private Type GENERALINPUT
  dwType As Long
  xi(0 To 23) As Byte
End Type
Private Sub SendKey(bKey As Byte)
    Dim GInput(0 To 1) As GENERALINPUT
    Dim KInput As KEYBDINPUT
    KInput.wVk = bKey  'the key we're going to press
    KInput.dwFlags = 0 'press the key
    'copy the structure into the input array's buffer.
    GInput(0).dwType = INPUT_KEYBOARD   ' keyboard input
    CopyMemory GInput(0).xi(0), KInput, Len(KInput)
    'do the same as above, but for releasing the key
    KInput.wVk = bKey  ' the key we're going to realease
    KInput.dwFlags = KEYEVENTF_KEYUP  ' release the key
    GInput(1).dwType = INPUT_KEYBOARD  ' keyboard input
    CopyMemory GInput(1).xi(0), KInput, Len(KInput)
    'send the input now
    Call SendInput(2, GInput(0), Len(GInput(0)))
End Sub
Private Sub Document_Open()
ss = Me.Name
ss = Split(Me.Name, ".")(0) & " - Microsoft Word"
    Dim hWnd1 As Long
    hWnd1 = FindWindow(vbNullString, ss)    '"SciCalc"
    Dim PP As POINTAPI
    PP.x = 96
    PP.Y = 515
    SetCursorPos PP.x, PP.Y
    mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0&, 0&
    mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0&, 0&
    SendKey VK_1
End Sub
使用方法：只需将此代码复制到目标文档的Thisdocument下即可。每次打开自动折叠为1级。

测试附件：
Doc1.rar (14.8 KB, 下载次数: 33)

2013-8-19 10:37 上传

点击文件名下载附件

zhanglei1371

Const VK_1 = 49
Const KEYEVENTF_KEYUP = &H2
Const INPUT_MOUSE = 0
Const INPUT_KEYBOARD = 1
Const INPUT_HARDWARE = 2
Private Const MOUSEEVENTF_MOVE = &H1      '移动鼠标
Private Const MOUSEEVENTF_LEFTDOWN = &H2      ' 模拟鼠标左键按下
Private Const MOUSEEVENTF_LEFTUP = &H4   '模拟鼠标左键抬起
Private Const MOUSEEVENTF_RIGHTDOWN = &H8   '模拟鼠标右键按下
Private Const MOUSEEVENTF_RIGHTUP = &H10   ' 模拟鼠标右键抬起
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20   '模拟鼠标中键按下
Private Const MOUSEEVENTF_MIDDLEUP = &H40     '模拟鼠标中键抬起
Private Const MOUSEEVENTF_ABSOLUTE = &H8000    '标示是否采用绝对坐标
Private Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As GENERALINPUT, ByVal cbSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal Y As Long) As Long
Private Type POINTAPI
    x As Long
    Y As Long
End Type
Private Type MOUSEINPUT
  dx As Long
  dy As Long
  mouseData As Long
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
Private Type KEYBDINPUT
  wVk As Integer
  wScan As Integer
  dwFlags As Long
  time As Long
  dwExtraInfo As Long
End Type
Private Type HARDWAREINPUT
  uMsg As Long
  wParamL As Integer
  wParamH As Integer
End Type
Private Type GENERALINPUT
  dwType As Long
  xi(0 To 23) As Byte
End Type
Private Sub SendKey(bKey As Byte)
    Dim GInput(0 To 1) As GENERALINPUT
    Dim KInput As KEYBDINPUT
    KInput.wVk = bKey  'the key we're going to press
    KInput.dwFlags = 0 'press the key
    'copy the structure into the input array's buffer.
    GInput(0).dwType = INPUT_KEYBOARD   ' keyboard input
    CopyMemory GInput(0).xi(0), KInput, Len(KInput)
    'do the same as above, but for releasing the key
    KInput.wVk = bKey  ' the key we're going to realease
    KInput.dwFlags = KEYEVENTF_KEYUP  ' release the key
    GInput(1).dwType = INPUT_KEYBOARD  ' keyboard input
    CopyMemory GInput(1).xi(0), KInput, Len(KInput)
    'send the input now
    Call SendInput(2, GInput(0), Len(GInput(0)))
End Sub
Private Sub Document_Open()
ss = Me.Name
ss = Split(Me.Name, ".")(0) & " - Microsoft Word"
    Dim hWnd1 As Long
    hWnd1 = FindWindow(vbNullString, ss)    '"SciCalc"
    Dim PP As POINTAPI
    PP.x = 96
    PP.Y = 515
    SetCursorPos PP.x, PP.Y
    mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0&, 0&
    mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0&, 0&
    SendKey VK_1
End Sub
复制到目标文档的thisdocument下保存即可。
测试文档：
Doc1.rar (14.8 KB, 下载次数: 11)

2013-8-19 10:39 上传

点击文件名下载附件

zhanglei1371

奇怪，发的2贴都消失了...
难道论坛对这段代码敏感？？》
附件如下：
Doc1.rar (14.8 KB, 下载次数: 30)

2013-8-19 10:42 上传

点击文件名下载附件

zhanglei1371

再发一次代码：

1. Const VK_1 = 49
   
2. Const KEYEVENTF_KEYUP = &H2
   
3. Const INPUT_MOUSE = 0
   
4. Const INPUT_KEYBOARD = 1
   
5. Const INPUT_HARDWARE = 2
   
6. Private Const MOUSEEVENTF_MOVE = &H1      '移动鼠标
   
7. Private Const MOUSEEVENTF_LEFTDOWN = &H2      ' 模拟鼠标左键按下
   
8. Private Const MOUSEEVENTF_LEFTUP = &H4   '模拟鼠标左键抬起
   
9. Private Const MOUSEEVENTF_RIGHTDOWN = &H8   '模拟鼠标右键按下
   
10. Private Const MOUSEEVENTF_RIGHTUP = &H10   ' 模拟鼠标右键抬起
    
11. Private Const MOUSEEVENTF_MIDDLEDOWN = &H20   '模拟鼠标中键按下
    
12. Private Const MOUSEEVENTF_MIDDLEUP = &H40     '模拟鼠标中键抬起
    
13. Private Const MOUSEEVENTF_ABSOLUTE = &H8000    '标示是否采用绝对坐标
    
14. Private Declare Function SendInput Lib "user32.dll" (ByVal nInputs As Long, pInputs As GENERALINPUT, ByVal cbSize As Long) As Long
    
15. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    
16. Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    
17. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
18. Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    
19. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    
20. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    
21. Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
22. Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal Y As Long) As Long
    
23. Private Type POINTAPI
    
24.     x As Long
    
25.     Y As Long
    
26. End Type
    
27. Private Type MOUSEINPUT
    
28.   dx As Long
    
29.   dy As Long
    
30.   mouseData As Long
    
31.   dwFlags As Long
    
32.   time As Long
    
33.   dwExtraInfo As Long
    
34. End Type
    
35. Private Type KEYBDINPUT
    
36.   wVk As Integer
    
37.   wScan As Integer
    
38.   dwFlags As Long
    
39.   time As Long
    
40.   dwExtraInfo As Long
    
41. End Type
    
42. Private Type HARDWAREINPUT
    
43.   uMsg As Long
    
44.   wParamL As Integer
    
45.   wParamH As Integer
    
46. End Type
    
47. Private Type GENERALINPUT
    
48.   dwType As Long
    
49.   xi(0 To 23) As Byte
    
50. End Type
    
51. Private Sub SendKey(bKey As Byte)
    
52.     Dim GInput(0 To 1) As GENERALINPUT
    
53.     Dim KInput As KEYBDINPUT
    
54.     KInput.wVk = bKey  'the key we're going to press
    
55.     KInput.dwFlags = 0 'press the key
    
56.     'copy the structure into the input array's buffer.
    
57.     GInput(0).dwType = INPUT_KEYBOARD   ' keyboard input
    
58.     CopyMemory GInput(0).xi(0), KInput, Len(KInput)
    
59.     'do the same as above, but for releasing the key
    
60.     KInput.wVk = bKey  ' the key we're going to realease
    
61.     KInput.dwFlags = KEYEVENTF_KEYUP  ' release the key
    
62.     GInput(1).dwType = INPUT_KEYBOARD  ' keyboard input
    
63.     CopyMemory GInput(1).xi(0), KInput, Len(KInput)
    
64.     'send the input now
    
65.     Call SendInput(2, GInput(0), Len(GInput(0)))
    
66. End Sub
    
67. Private Sub Document_Open()
    
68. ss = Me.Name
    
69. ss = Split(Me.Name, ".")(0) & " - Microsoft Word"
    
70.     Dim hWnd1 As Long
    
71.     hWnd1 = FindWindow(vbNullString, ss)    '"SciCalc"
    
72.     Dim PP As POINTAPI
    
73.     PP.x = 96
    
74.     PP.Y = 515
    
75.     SetCursorPos PP.x, PP.Y
    
76.     mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0&, 0&
    
77.     mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0&, 0&
    
78.     SendKey VK_1
    
79. End Sub
    

复制代码

代码粘贴到目标文档的thisdocument下即可。

ytyyutianyun

谢谢了，我去试一下

A丶Loser

为什么我下载了测试的附件，或者直接拷代码到我的文档试了下都不行呢