哎,自从搞了双屏幕,整个人都变傻了!!其实副屏幕上就是把显示在主屏幕上的产品以单据的方式显示,下面代码就是副屏幕的代码,pPrintContents就是单据~~
顾客反映每次到忙的时候,都会有卡机的情况发生~~,请大家帮我看下原因出在哪里?Private Sub Form_Load()
Call FindFile(sAdvtpicfolder)
ImgTimer.Interval = 10000
ImgTimer.Enabled = True
End SubPublic Function ViewReceipt(ByVal pPrintContents As Variant)
Dim iCtr As Integer
Dim Message As String
Dim sPrice As String
On Error GoTo ViewReceipt_Error:
If sViewSecScreenRept = "1" Then
ReptHeader.Caption = ""
txtDoubleScreen.Text = ""
sPrintContents = pPrintContents
For iPrintCount = 0 To UBound(sPrintContents, 2)
If iPrintCount = 0 Then
ReptHeader.Caption = sPrintContents(0, iPrintCount)
Else
txtDoubleScreen.Text = txtDoubleScreen.Text & vbCrLf & sPrintContents(0, iPrintCount)
End If
Next
With txtDoubleScreen
.SelStart = InStr(1, .Text, "SUBTOTAL") - 1
.SelLength = InStr(1, .Text, "Total Qty") - InStr(1, .Text, "SUBTOTAL") - 42
.SelBold = True
.SelFontSize = 16
.SelColor = &HFF&
End With
End If
Exit Function
ViewReceipt_Error:
WriteToLog "Error in ViewReceipt", Me.name & "_Init"
End FunctionPrivate Sub FindFile(MyPath As String)
Dim Myname As String
Dim dir_i() As String
Dim i, idir As Long
Dim jCtr As Integer
On Error GoTo FindFile_Error:
If MyPath = "0" Then Exit Sub
If Right(MyPath, 1) <> "\" Then MyPath = MyPath + "\"
Myname = Dir(MyPath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
jCtr = 1
ImageList.ListImages.Clear
Do While Myname <> ""
If Myname <> "." And Myname <> ".." Then
ImageList.ListImages.Add jCtr, "'" & jCtr & "'", LoadPicture(MyPath & Myname) 'added to imagelist
jCtr = jCtr + 1
End If
Myname = Dir
Loop
Exit Sub
FindFile_Error:
WriteToLog "Error in FindFile", Me.name & "_Init"
End SubPrivate Sub AddContents(ByVal pContents As String, Optional ByVal pType As String = "0")
iCounter = iCounter + 1
ReDim Preserve sPrintContents(1, iCounter)
sPrintContents(0, iCounter) = pContents
sPrintContents(1, iCounter) = pType
End SubPrivate Sub Pic_Resize()
If Pic = 0 Then Exit Sub
Pic.PaintPicture Pic, Pic.ScaleLeft, Pic.ScaleTop, Pic.ScaleWidth, Pic.ScaleHeight
End SubPrivate Sub LoadPicPicture()
Dim iCtr As Integer
On Error GoTo LoadErr:
If ImageList.ListImages.Count = 0 Then
ImgTimer.Enabled = False
Exit Sub
End If
If sImglist + 1 > ImageList.ListImages.Count Then
sImglist = 1
Else
sImglist = sImglist + 1
End If
Pic.Cls
Pic.Picture = ImageList.ListImages(sImglist).Picture
Call Pic_Resize
Exit Sub
LoadErr:
WriteToLog "Error in LoadPicPicture", Me.name & "_Init"
End Sub
顾客反映每次到忙的时候,都会有卡机的情况发生~~,请大家帮我看下原因出在哪里?Private Sub Form_Load()
Call FindFile(sAdvtpicfolder)
ImgTimer.Interval = 10000
ImgTimer.Enabled = True
End SubPublic Function ViewReceipt(ByVal pPrintContents As Variant)
Dim iCtr As Integer
Dim Message As String
Dim sPrice As String
On Error GoTo ViewReceipt_Error:
If sViewSecScreenRept = "1" Then
ReptHeader.Caption = ""
txtDoubleScreen.Text = ""
sPrintContents = pPrintContents
For iPrintCount = 0 To UBound(sPrintContents, 2)
If iPrintCount = 0 Then
ReptHeader.Caption = sPrintContents(0, iPrintCount)
Else
txtDoubleScreen.Text = txtDoubleScreen.Text & vbCrLf & sPrintContents(0, iPrintCount)
End If
Next
With txtDoubleScreen
.SelStart = InStr(1, .Text, "SUBTOTAL") - 1
.SelLength = InStr(1, .Text, "Total Qty") - InStr(1, .Text, "SUBTOTAL") - 42
.SelBold = True
.SelFontSize = 16
.SelColor = &HFF&
End With
End If
Exit Function
ViewReceipt_Error:
WriteToLog "Error in ViewReceipt", Me.name & "_Init"
End FunctionPrivate Sub FindFile(MyPath As String)
Dim Myname As String
Dim dir_i() As String
Dim i, idir As Long
Dim jCtr As Integer
On Error GoTo FindFile_Error:
If MyPath = "0" Then Exit Sub
If Right(MyPath, 1) <> "\" Then MyPath = MyPath + "\"
Myname = Dir(MyPath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
jCtr = 1
ImageList.ListImages.Clear
Do While Myname <> ""
If Myname <> "." And Myname <> ".." Then
ImageList.ListImages.Add jCtr, "'" & jCtr & "'", LoadPicture(MyPath & Myname) 'added to imagelist
jCtr = jCtr + 1
End If
Myname = Dir
Loop
Exit Sub
FindFile_Error:
WriteToLog "Error in FindFile", Me.name & "_Init"
End SubPrivate Sub AddContents(ByVal pContents As String, Optional ByVal pType As String = "0")
iCounter = iCounter + 1
ReDim Preserve sPrintContents(1, iCounter)
sPrintContents(0, iCounter) = pContents
sPrintContents(1, iCounter) = pType
End SubPrivate Sub Pic_Resize()
If Pic = 0 Then Exit Sub
Pic.PaintPicture Pic, Pic.ScaleLeft, Pic.ScaleTop, Pic.ScaleWidth, Pic.ScaleHeight
End SubPrivate Sub LoadPicPicture()
Dim iCtr As Integer
On Error GoTo LoadErr:
If ImageList.ListImages.Count = 0 Then
ImgTimer.Enabled = False
Exit Sub
End If
If sImglist + 1 > ImageList.ListImages.Count Then
sImglist = 1
Else
sImglist = sImglist + 1
End If
Pic.Cls
Pic.Picture = ImageList.ListImages(sImglist).Picture
Call Pic_Resize
Exit Sub
LoadErr:
WriteToLog "Error in LoadPicPicture", Me.name & "_Init"
End Sub
1。发一个监测/监视程序过去,看看忙的时候是多忙。客户没准可以提供这些
2。回到开发环境,模拟客户的流量。单屏幕测试我看你现在也有writetolog的,这个函数也可以用于检测时间。每个函数用了多长时间也写到log里面去。看你的代码估计就是在load picture和resize picture上面了。实在不成加doevents,这样用户感觉好点