Board logo

標題: [發問] excel VBA 如何在word檔開啟狀態下順利寫入word的表格 [打印本頁]
作者: pipi1968    時間: 2017-1-2 00:40     標題: excel VBA 如何在word檔開啟狀態下順利寫入word的表格

我想利用excel VBA 作一個表單輸入資料後，要資料寫入word的表格，
我的作法是1.先檢查word檔是否開啟，如果已開啟，去執行101程序
　　　　　2.如果未開啟，則開啟word檔後去執行101程序
　　　　　3.如果是新専案，則從資料夾複製空白専案管為新専案進度表後，去執行101程序
目前2. 3.都可以順利執行
但是1.會出現錯誤如下圖，也就是當word檔開啟狀態下，無法正常執行
[attach]26276[/attach]

麻煩各位先進指導一下，如何克服這個問題
謝謝

程式碼如下：
  1. Function IsFileOpen(strFile As String) As Boolean
  2.     Dim iFile As Integer
  3.     Dim iErr As Integer
  4.    
  5.     On Error Resume Next
  6.     iFile = FreeFile()
  7.     Open strFile For Input Lock Read As #iFile  '以鎖定方式開啟，開啟指定檔案後直接關閉檔案
  8.     Close iFile
  9.    
  10.     iErr = Err  '將錯誤號碼帶入iErr變數中，然後依照數字即可得知檔案狀態
  11.     On Error GoTo 0
  12.     Select Case iErr
  13.         Case 0
  14.             IsFileOpen = False
  15.         Case 70
  16.             IsFileOpen = True
  17.         Case 53
  18.             MsgBox "找不到檔案，將建立空白進度管制表！"
  19.             IsFileOpen = False
  20.         Case 76
  21.             MsgBox "找不到路徑，請再確認！"
  22.             IsFileOpen = False
  23.     End Select
  24. End Function

  26. Sub CheckFile()
  27.     Dim strPath As String
  28.     Dim strFile As String
  29.     Dim strWordFile As String
  30.    
  31.     Set wordApp = CreateObject("Word.Application")
  32.     Set fs = CreateObject("Scripting.FileSystemObject")
  33.    
  34.     strFile = "北區1.docx"
  35.     strPath = "D:\My Documents\Temp\"
  36.     strWordFile = strPath & strFile
  37.    
  38.    
  39.     If IsFileOpen(strWordFile) Then
  40.         GoTo 101
  41.     ElseIf fs.FileExists(strWordFile) Then
  42.         Set wordDoc = wordApp.Documents.Open(strWordFile)
  43.         wordApp.Visible = True
  44.         wordDoc.Activate
  45.         GoTo 101
  46.     Else
  47.         FileCopy strPath & "空白案件進度管控表.docx", strWordFile
  48.         Set wordDoc = wordApp.Documents.Open(strWordFile)
  49.         wordApp.Visible = True
  50.         wordDoc.Activate
  51.         GoTo 101
  52.         'MsgBox ("檔案不存在！")
  53.         'Exit Sub
  54.     End If
  55.         
  56. 101:
  57.     With wordDoc.Tables(1)
  58.         .Cell(6, 2) = Replace(.Cell(6, 2), Chr(13), "") & "、這是測試"
  59.         
  60.     '取得word的日(時)數，重新計算總工作時數
  61.         If InStr(.Cell(6, 3), "日") = 0 And InStr(.Cell(6, 3), "小時") = 0 Then
  62.             WorkHours = 0
  63.             GoTo 102
  64.         Else
  65.             xString = .Cell(6, 3)
  66.             xtemp = Split(xString, "日")
  67.             hours = Val(xtemp(0)) * 8
  68.             xtemp = Split(xtemp(1), "小時")
  69.             WorkHours = hours + Val(xtemp(0))
  70.         End If
  71. 102:
  72.         '加新增時數:預計增加4.5小時
  73.         WorkHours = WorkHours + 4.5
  74.         '計算日數(每8小時為1日)
  75.         days = Int(WorkHours / 8)
  76.         '計算剩餘小時
  77.         hours = WorkHours - days * 8

  79.         '寫回word表格
  80.         .Cell(6, 3) = days & "日" & hours & "小時"

  82.     End With
  83.     'wordDoc.Close '關閉該Word文件檔
  84.     'wordApp.Quit '結束Word應用程式
  85.     'Set wordDoc = Nothing   '釋放物件變數wordDoc
  86.     'Set wordApp = Nothing   '釋放物件變數wordApp

  88. End Sub
複製代碼
word檔附件
[attach]26277[/attach]
作者: pipi1968    時間: 2017-1-5 19:32

本帖最後由 pipi1968 於 2017-1-5 19:33 編輯

已解決了
上網查了好久，終於OK了
提供給需要的人參考
  1. Function IsFileOpen(strFile As String) As Boolean
  2.     Dim iFile As Integer
  3.     Dim iErr As Integer
  4.    
  5.     On Error Resume Next
  6.     iFile = FreeFile()
  7.     Open strFile For Input Lock Read As #iFile  '以鎖定方式開啟，開啟指定檔案後直接關閉檔案
  8.     Close iFile
  9.    
  10.     iErr = Err  '將錯誤號碼帶入iErr變數中，然後依照數字即可得知檔案狀態
  11.     On Error GoTo 0
  12.     Select Case iErr
  13.         Case 0
  14.             IsFileOpen = False
  15.         Case 70
  16.             IsFileOpen = True
  17.         Case 53
  18.             MsgBox "找不到檔案，將建立空白進度管制表！"
  19.             IsFileOpen = False
  20.         Case 76
  21.             MsgBox "找不到路徑，請再確認！"
  22.             IsFileOpen = False
  23.     End Select
  24. End Function

  26. Sub CheckFile()
  27.     Dim strPath As String
  28.     Dim strFile As String
  29.     Dim strWordFile As String
  30.     Dim wordDoc As Object

  32.     Set wordApp = CreateObject("Word.Application")
  33.     Set fs = CreateObject("Scripting.FileSystemObject")
  34.      
  35.     strFile = "北區1.docx"
  36.     strPath = "D:\My Documents\Temp\"
  37.     strWordFile = strPath & strFile
  38.    
  39.    
  40.     If IsFileOpen(strWordFile) Then
  41.       Set wordDoc = GetObject(strWordFile)
  42.       Application.Visible = True
  43.       GoTo 101
  44.     ElseIf fs.FileExists(strWordFile) Then
  45.         Set wordDoc = wordApp.Documents.Open(strWordFile)
  46.         wordApp.Visible = True
  47.         wordDoc.Activate
  48.         GoTo 101
  49.     Else
  50.         FileCopy strPath & "空白案件進度管控表.docx", strWordFile
  51.         Set wordDoc = wordApp.Documents.Open(strWordFile)
  52.         wordApp.Visible = True
  53.         wordDoc.Activate
  54.         GoTo 101
  55.         'MsgBox ("檔案不存在！")
  56.         'Exit Sub
  57.     End If
  58.         
  59. 101:
  60.     With wordDoc.Tables(1)
  61.         .Cell(6, 2) = Replace(.Cell(6, 2), Chr(13), "") & "、這是測試"
  62.         
  63.     '取得word的日(時)數，重新計算總工作時數
  64.         If InStr(.Cell(6, 3), "日") = 0 And InStr(.Cell(6, 3), "小時") = 0 Then
  65.             WorkHours = 0
  66.             GoTo 102
  67.         Else
  68.             xString = .Cell(6, 3)
  69.             xtemp = Split(xString, "日")
  70.             hours = Val(xtemp(0)) * 8
  71.             xtemp = Split(xtemp(1), "小時")
  72.             WorkHours = hours + Val(xtemp(0))
  73.         End If
  74. 102:
  75.         '加新增時數:預計增加4.5小時
  76.         WorkHours = WorkHours + 4.5
  77.         '計算日數(每8小時為1日)
  78.         days = Int(WorkHours / 8)
  79.         '計算剩餘小時
  80.         hours = WorkHours - days * 8

  82.         '寫回word表格
  83.         .Cell(6, 3) = days & "日" & hours & "小時"

  85.     End With
  86.     'wordDoc.Close '關閉該Word文件檔
  87.     'wordApp.Quit '結束Word應用程式
  88.     'Set wordDoc = Nothing   '釋放物件變數wordDoc
  89.     'Set wordApp = Nothing   '釋放物件變數wordApp

  91. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)