1.先開啟了連接程序的EXCEL檔案,然后運行程序的時候,程序會運行得比正常慢50倍還不止.
2.如果在程序運行的時候關閉此EXCEL檔案,那麼就出現錯誤:
執行階段錯誤’-2147467259(80004005)’:
用於檢視連結Microsoft Excel工作表的連接已經消失.
3.程序運行之后,很多時候都會引起，在開啟所有EXCEL檔案的時候,不能看到表格中的內容.這時只有在先開啟一個EXCEL程式(開始－程式集-EXCEL)，再來開啟EXCEL檔案，才可以看到內容。
4.有時在我結束了執行程式後，開啟連接程式的excel檔案時，會說被我的電腦鎖定，選擇“只讀”或“通知”。但是我已經結束了執行，怎麼還會被鎖定呢。
5.如果我要連接的檔案在服務器上。而我只有只讀的權限，當我在運行程式的時候，有一臺具有讀取權限的電腦開啟此excel檔案時，會不會只具有只讀的權限了。實在太多了，高手快點幫幫我。
2.如果在程序運行的時候關閉此EXCEL檔案,那麼就出現錯誤:
執行階段錯誤’-2147467259(80004005)’:
用於檢視連結Microsoft Excel工作表的連接已經消失.
3.程序運行之后,很多時候都會引起，在開啟所有EXCEL檔案的時候,不能看到表格中的內容.這時只有在先開啟一個EXCEL程式(開始－程式集-EXCEL)，再來開啟EXCEL檔案，才可以看到內容。
4.有時在我結束了執行程式後，開啟連接程式的excel檔案時，會說被我的電腦鎖定，選擇“只讀”或“通知”。但是我已經結束了執行，怎麼還會被鎖定呢。
5.如果我要連接的檔案在服務器上。而我只有只讀的權限，當我在運行程式的時候，有一臺具有讀取權限的電腦開啟此excel檔案時，會不會只具有只讀的權限了。實在太多了，高手快點幫幫我。
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks.Open("E:\报表\售货机销售走势图.xls") '打开已经存在的Excel工作薄文件
Set xlSheet = xlBook.Worksheets("原始数据")
xlApp.Visible = True
接下来再一个问题一个问题的说:
1,在程序运行前,EXCEL不要打开,不然在最后存的时候会出错,而且如果程序还在运行,你关了EXCEL,那也是肯定要出错的.
2.只有加上这句话xlApp.Visible = True EXCEL才能被看见.
3. xlBook.SaveAs FileName:="E:\报表\" & myMonth & "月" & myday & "日售货机销售走势图.XLS "
DoEvents
List1.AddItem "---------------------------------------------", 0
List1.AddItem "生成完毕", 0
List1.AddItem myMonth & "月" & myday & "日售货机销售走势图", 0
List1.AddItem "---------------------------------------------", 0
DoEvents
xlApp.Quit '关闭Excel
最后记得把Excel关了
目的:根據文本框中的"編號",從數據庫中查找相關記錄.並列出無相關記錄的"編號"
注:文本框為多個編號.
作法:
1.6個label控件.label2與label4顯示的是數量.caption分別為
label1 輸入尋找編號：
label2 0
label3 顯示無EVA的編號：
label4 0
2.兩個text,設置MultiLine=true,ScrollBars=3.
text1的用來給用戶輸入"編號",text2用來顯示未找到記錄的編號.
3.三個按扭.name和caption為:
Command1 尋找
Command2 清除
Command3 整理
4.一個MSFlexGrid控件 name:MSFgrid 屬性:
cols=5
rows=1
fixedcols=1
fixedrows=1
ScrollBars=2
代碼:
Option Explicit
Dim AA As Integer
Dim BB As Integer
Dim Conn As New ADODB.Connection
Dim Rs As New ADODB.RecordsetConst EM_GETLINECOUNT = &HBA
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 RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)Sub TB_GetLine(ByVal hwnd As Long, ByVal whichLine As Long, Line As String) ' 快速读取TextBox第N行的数据
Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long
lc = SendMessage(hwnd, EM_LINEINDEX, whichLine, ByVal 0&)
length = SendMessage(hwnd, EM_LINELENGTH, lc, ByVal 0&)
If length > 0 Then
ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2)
Call SendMessage(hwnd, EM_GETLINE, whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If
End Sub
Private Sub Command1_Click()
Dim i As Integer
Dim linecount As Integer, Line As String, l As Integer, lsttxt As String, strtxt As String
Screen.MousePointer = vbHourglass
Text2 = ""
strtxt = Text1
Call replace(Text1, "*", "%")
With MSFGrid
.Rows = 1
linecount = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0) '文本框中總行數
For l = 0 To linecount - 1
Call TB_GetLine(Text1.hwnd, l, Line)
If Line <> "" Then
Call Link_Excel(Line) '查找
End If
Next
Label5.Caption = .Rows - 1
If .Rows > 1 Then '設置超鏈接的顏色
.Col = 1
For i = 1 To .Rows - 1
.row = i
.CellForeColor = &HC00000
Next i
End If
End With
Text1 = strtxt
Call replace(Text2, "%", "*")
Screen.MousePointer = vbDefault
End SubPublic Sub Link_Excel(Line) '用select語句查詢記錄
Dim Intcell As Integer
With MSFGrid
Rs.Open "select [文件編號],[新零件編號],[日期],[供應商] from [evano] where 新零件編號 like '" & Line & "%'", Conn, adOpenStatic, adLockReadOnly
If Rs.EOF = True Or Rs.BOF = True Then
Text2 = Text2 & Line & vbCrLf
Else
Rs.MoveFirst
Do While Not Rs.EOF
.Rows = .Rows + 1
.TextMatrix(.Rows - 1, 0) = .Rows - 1
For Intcell = 1 To .Cols - 1 '將符合條件的記錄顯示在MSFlexGrid中
If IsNull(Rs.Fields(Intcell - 1).Value) Then
.TextMatrix(.Rows - 1, Intcell) = ""
Else
.TextMatrix(.Rows - 1, Intcell) = Rs.Fields(Intcell - 1).Value
End If
Next
Rs.MoveNext
Loop
End If
.Refresh
End With
Rs.CloseEnd SubPrivate Sub Command2_Click() '清除所有
Text1 = ""
Text2 = ""
MSFGrid.Rows = 1
Label5.Caption = 0
End SubPrivate Sub Command3_Click() '整理,將text1中的空行,和每行的前后空格去掉
Dim Arr() As String, str As String, j As Long'去掉空行與每行中的前后空格
Arr = Split(Text1.Text, vbCrLf)
For j = LBound(Arr) To UBound(Arr)
If Val(Arr(j)) > 0 Then
str = str & Trim(Arr(j)) & vbCrLf
End If
Next
Text1.Text = str
If Right(Text1, 2) = vbCrLf Then
Text1 = Left(str, Len(str) - 2)
End If
If Text1 = "" Then
MsgBox "請輸入正確物料編號："
Exit Sub
End If
End SubPrivate Sub Form_Load()
Dim msg As String
With MSFGrid
.TextMatrix(0, 0) = "ID"
.TextMatrix(0, 1) = "EVA NO."
.TextMatrix(0, 2) = "新零件編號"
.TextMatrix(0, 3) = "日期"
.TextMatrix(0, 4) = "供應商"
.ColWidth(0) = 300
.ColWidth(1) = 1150
.ColWidth(2) = 2000
.ColWidth(3) = 1000
.ColWidth(4) = 1150
.ColAlignment(2) = 2
.ColAlignment(3) = 2
End With
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\\sm-server\DATA\PUB\ENG\EVA (確認清單)\零件確認批準書索引 (version 1).xls;Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""End SubPrivate Sub Form_Unload(Cancel As Integer)
Conn.Close
End SubPrivate Sub MSFGrid_Click() '設置連接,當點擊在第一欄時,出現連接文檔.
Dim strlp As String, strlp2 As String
Dim strdir As String
With MSFGrid
If .Col = 1 Then
strlp = .TextMatrix(.row, .Col)
Select Case Left$(strlp, 5) '根據目錄設置連接路徑
Case "EVA20"
strlp2 = "EVA-00"
Case "EVA01"
strlp2 = "EVA-01"
Case "EVA02"
strlp2 = "EVA-02"
Case "EVA03"
strlp2 = "EVA-03"
Case "EVA04"
strlp2 = "EVA-04"
Case "EVA05"
strlp2 = "EVA-05"
End Select
strdir = Dir("\\sm-server\DATA\PUB\ENG\EVA (確認清單)\" & strlp2 & "\*" & Mid(strlp, 7) & ".pdf")
If strdir = "" Then
MsgBox "無連接文件"
Else
strlp2 = "\\sm-server\DATA\PUB\ENG\EVA (確認清單)\" & strlp2 & "\" & strdir
Shell "Rundll32.exe url.dll,FileProtocolHandler " & strlp2, 1
.CellForeColor = &H80&
End If
End If
End WithEnd SubPrivate Sub Text1_Change()
If Trim(Text1) <> "" Then
Label3.Caption = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0)
Else
Label3.Caption = 0
End If
End SubPrivate Sub Text1_Click()Dim p As Integer, p2 As Integer
Dim Intcr As Integer, intcr2 As Integer
Dim Inttop As Integer
Dim intStart As Integer
Dim Strline As StringIf Trim(Text1) = "" Or MSFGrid.Rows < 2 Then Exit Sub
If Text1.SelStart = 0 Then
intStart = 1
Else
intStart = Text1.SelStart
End If
p = InStrRev(Text1, vbCrLf, intStart, vbBinaryCompare)
p2 = InStr(p + 1, Text1, vbCrLf, vbBinaryCompare)If p = 0 And p2 = 0 Then
Strline = Text1
ElseIf p = 0 Then
Strline = Mid(Text1, 1, p2 - 1)
ElseIf p2 = 0 Then
Strline = Mid(Text1, p + 2, Len(Text1))
Else
Strline = Mid(Text1, p + 2, p2 - p - 2)
End If
With MSFGrid
For Intcr = 1 To .Rows - 1
For intcr2 = 1 To .Cols - 1
.row = Intcr
.Col = intcr2
.CellBackColor = &H80000009
Next
Next
For Intcr = 1 To .Rows - 1
If .TextMatrix(Intcr, 2) Like Strline & "*" Then
If Inttop = 0 Then
Inttop = Intcr
End If
For intcr2 = 1 To .Cols - 1
.Col = intcr2
.row = Intcr
.CellBackColor = &HFFC0C0
Next
End If
Next
If Inttop <> 0 Then
.TopRow = Inttop
ElseIf Text1.SelLength < 1 Then
MsgBox "沒有此編號的確認信息.", vbOKOnly
End If
End With
End Sub
Private Sub Text2_Change()
If Trim(Text2) <> "" Then
Label4.Caption = SendMessage(Text2.hwnd, EM_GETLINECOUNT, 0, 0)
If Right(Text2, 2) = vbCrLf Then
Label4 = Label4 - 1
End If
Else
Label4.Caption = 0
End If
End Sub
Private Sub replace(ObjT As TextBox, Sbefore, Safter) '替換過程"*","%"
Static Intp As IntegerIntp = InStr(Intp + 1, ObjT.Text, Sbefore, vbTextCompare) '查找字符
While Intp > 0
ObjT.SelStart = Intp - 1
ObjT.SelLength = 1
ObjT.SelText = Safter '賦值,替換選中的字符
Intp = ObjT.SelStart + 1
Intp = InStr(Intp, ObjT.Text, Sbefore, vbTextCompare)
WendEnd Sub
現在就是這個最麻煩了
1.我開啟程式(我只有只讀權限),別人就只能用只讀來開啟此excel檔案了.
2.別人開啟了此excel檔案,我就不能運行程式了.
這該怎麼辦呢?
現在就是這個最麻煩了
1.我開啟程式(我只有只讀權限),別人就只能用只讀來開啟此excel檔案了.
2.別人開啟了此excel檔案,我就不能運行程式了.
這該怎麼辦呢?