Access交流中心

北京 | 上海 | 天津 | 重庆 | 广州 | 深圳 | 珠海 | 汕头 | 佛山 | 中山 | 东莞 | 南京 | 苏州 | 无锡 | 常州 | 南通 | 扬州 | 徐州 | 杭州 | 温州 | 宁波 | 台州 | 福州 | 厦门 | 泉州 | 龙岩 | 合肥 | 芜湖 | 成都 | 遂宁 | 长沙 | 株洲 | 湘潭 | 武汉 | 南昌 | 济南 | 青岛 | 烟台 | 潍坊 | 淄博 | 济宁 | 太原 | 郑州 | 石家庄 | 保定 | 唐山 | 西安 | 大连 | 沈阳 | 长春 | 昆明 | 兰州 | 哈尔滨 | 佳木斯 | 南宁 | 桂林 | 海口 | 贵阳 | 西宁 | 乌鲁木齐 | 包头 |

运行Access VBA程序时不时出现错误

陈诺  发表于:2021-04-15 16:01:40  
复制

Access VBA程序,在Access Runtime 2016, SQL express 2017下运行窗体frmGI, 时不时会出现下面的提示信息,一般关掉Access VBA程序重新打开就正常。

The expression On Click you entered as the event property setting produced the following error: System resource exceed.

* The expression may not result in the name of a macro, the name of user-defined function, or [Event Procedure].

* There may have been an error evaluation the function, event, or macro.


frmGI窗体代码如下:

Private Function openrecord(str1 As String, record As ADODB.Recordset)
  'Set record = New ADODB.Recordset
  'record.Open str1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
  
  'Dim conn As ADODB.Connection
  'Dim connStr As String
  Set conn = New ADODB.Connection
  
  Set record = New ADODB.Recordset
  
  connStr = "Provider=SQLOLEDB.1;User ID=’用户名‘;Password=’密码‘;Initial Catalog=‘数据库名称’;Data Source='SQL服务器‘"
   
  If conn.State <> adStateOpen Then
     conn.Open connStr
  End If
  
  record.CursorLocation = adUseClient
  record.Open str1, connStr, adOpenKeyset, adLockOptimistic
   
End Function


Private Sub cmdConfirm_Click()
On Error GoTo err_s
Dim Rst As DAO.Recordset
Dim strsql As String
Dim strQueryName As String

strQueryName = ”GI_Temp_Crosstab_Total“   
strsql = "select * from " & strQueryName
Set Rst = CurrentDb().OpenRecordset(strsql, dbOpenDynaset, dbReadOnly)

If Rst.Fields.Count > 15 Then
   MsgBox "请确保不超过14列,否则超出A4纸张页面,无法打印", vbInformation + vbOKOnly, "Attention"
   Exit Sub
End If

Dim string2 As String
'Dim string3 As String
Dim record3 As ADODB.Recordset
Dim record4 As ADODB.Recordset
Dim record10 As ADODB.Recordset
'Dim slArrray() As String
Me.Label28.Caption = Format(Date, "yyyy.mm.dd") & "    " & Format(Time, "hh:mm:ss")

openrecord "select * from GI_Temp", record3
Do Until record3.EOF
   string2 = "update tblMatlReq set [Open Qty] = [Open Qty] -" & record3("GIQty") & ",[SKU Qty Withdrawn] = [SKU Qty Withdrawn] +" & record3("GIQty") & ",[GIQty]=[GIQty]+ " & record3("GIQty") & ",[GI Date]=getdate() where [Open Qty]>0 and id=" & record3("id")
   openrecord string2, record4
   record3.MoveNext
Loop

openrecord "select * from GI ", record10
record3.MoveFirst
Do Until record3.EOF
   record10.AddNew
   record10("ID") = record3("ID")
   record10("GI_ID") = Replace(Replace(Replace(Me.Label28.Caption, ".", ""), " ", ""), ":", "")
   record10("Work ctr") = record3("Work ctr")
   record10("Material Description") = record3("Material Description")
   record10("Material") = record3("Material")
   record10("GrV") = record3("GrV")
   record10("Order") = record3("Order")
   record10("GIQty") = record3("GIQty")
   record10("GI Date") = Now()
   record10("User name") = strCurrentUserName
   record10.Update
   record3.MoveNext
Loop

record10.Close
record3.Close
Set record10 = Nothing
Set record3 = Nothing

DoCmd.Close acForm, "frmGI"


'-------------------------------------------
'***打印表单***
DoCmd.OpenReport "rptGI, acViewPreview
DoCmd.PrintOut
DoCmd.Close acReport, "rptGI"
'-------------------------------------------


    
End Sub

 

Top
陈诺 发表于:2021-04-16 08:42:00

’出库清单不能超过15列。

strQueryName = ”GI_Temp_Crosstab_Total“   
strsql = "select * from " & strQueryName
Set Rst = CurrentDb().OpenRecordset(strsql, dbOpenDynaset, dbReadOnly)

If Rst.Fields.Count > 15 Then
   MsgBox "请确保不超过15列,否则超出A4纸张页面,无法打印", vbInformation + vbOKOnly, "Attention"
   Exit Sub
End If


‘ 打开临时出库表 GI_Temp

openrecord "select * from GI_Temp", record3


'根据出库信息,更新原来库存表
Do Until record3.EOF
   string2 = "update tblMatlReq set [Open Qty] = [Open Qty] -" & record3("GIQty") & ",[SKU Qty Withdrawn] = [SKU Qty Withdrawn] +" & record3("GIQty") & ",[GIQty]=[GIQty]+ " & record3("GIQty") & ",[GI Date]=getdate() where [Open Qty]>0 and id=" & record3("id")
   openrecord string2, record4
   record3.MoveNext
Loop


’将临时出库清单GI_Temp写入出库表GI

openrecord "select * from GI ", record10

record3.MoveFirst

Do Until record3.EOF

   record10.AddNew
   record10("ID") = record3("ID")
   record10("GI_ID") = Replace(Replace(Replace(Me.Label28.Caption, ".", ""), " ", ""), ":", "")
   record10("Work ctr") = record3("Work ctr")
   record10("Material Description") = record3("Material Description")
   record10("Material") = record3("Material")
   record10("GrV") = record3("GrV")
   record10("Order") = record3("Order")
   record10("GIQty") = record3("GIQty")
   record10("GI Date") = Now()
   record10("User name") = strCurrentUserName
   record10.Update
   record3.MoveNext
Loop

record10.Close
record3.Close
Set record10 = Nothing
Set record3 = Nothing

'打印保留在GI_Temp的出库清单GI_Temp_Crosstab_Total

DoCmd.OpenReport "rptGI, acViewPreview
DoCmd.PrintOut
DoCmd.Close acReport, "rptGI"


是不是哪个调用的资源没有及时释放?如何优化?谢谢。



西出阳关无故人 发表于:2021-04-19 16:53:44

我觉得,函数改为:

Private Function openrecord(str1 As String) As ADODB.Recordset

dim conn as new adodb.connection

dim rec as new adodb.recordset

'打开 conn,rec等等,你自己添加

set  openrecord=rec 

end function

然后

Private Sub cmdConfirm_Click()

...

Dim record3 As new ADODB.Recordset

set record3 = openrecord("select * from GI_Temp")'其他recordset同样泡制

...

end sub

就应该会解决问题.



西出阳关无故人 发表于:2021-04-19 17:07:39

另外

On Error GoTo err_s

语句好像被"GoTo"到一个不存在的标签"err_s"了.



西出阳关无故人 发表于:2021-04-20 08:40:53

最大的可疑点:

...

Do Until record3.EOF
   string2 = "update tblMatlReq set [Open Qty] = [Open Qty] -" & record3("GIQty") & ",[SKU Qty Withdrawn] = [SKU Qty Withdrawn] +" & record3("GIQty") & ",[GIQty]=[GIQty]+ " & record3("GIQty") & ",[GI Date]=getdate() where [Open Qty]>0 and id=" & record3("id")
   openrecord string2, record4'也许这里会导致问题的出现.改为  conn.execute string2 试试?

   record3.MoveNext
Loop

...



总记录:4篇  页次:1/1 9 1 :