📄 dwgin.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{F0D2F211-CCB0-11D0-A316-00AA00688B10}#1.0#0"; "MSDATLST.OCX"
Object = "{6307A290-67B8-11D0-8744-0000C06B6F77}#2.0#0"; "DWGTHU~1.OCX"
Begin VB.Form dwgin
Caption = "AUTOCAD图导入"
ClientHeight = 5430
ClientLeft = 60
ClientTop = 450
ClientWidth = 10110
Icon = "dwgin.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5430
ScaleWidth = 10110
StartUpPosition = 2 '屏幕中心
Begin VB.TextBox userPassword
Height = 390
Left = 4440
TabIndex = 14
Top = 4680
Width = 2175
End
Begin VB.CommandButton viewbutton
Caption = "详图"
Height = 375
Left = 9120
TabIndex = 16
Top = 3840
Width = 735
End
Begin VB.TextBox nametxt
Enabled = 0 'False
Height = 375
Left = 240
TabIndex = 12
Top = 2640
Width = 6255
End
Begin VB.Frame Frame2
Caption = "磁盘信息"
Height = 1455
Left = 240
TabIndex = 7
Top = 3120
Width = 6375
Begin VB.Label Label4
Caption = "存储磁盘: "
Height = 255
Left = 240
TabIndex = 11
Top = 360
Width = 6015
End
Begin VB.Label Label5
Caption = "可用空间: "
Height = 255
Left = 240
TabIndex = 9
Top = 1080
Width = 6015
End
Begin VB.Label Label3
Caption = "总大小: "
Height = 255
Left = 240
TabIndex = 8
Top = 720
Width = 6015
End
End
Begin VB.CommandButton exitbutton
Caption = "退出"
Height = 375
Left = 9120
TabIndex = 6
Top = 4680
Width = 735
End
Begin VB.CommandButton okbutton
Caption = "保存"
Height = 375
Left = 8160
TabIndex = 5
Top = 4680
Width = 735
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 6000
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Frame Frame1
Caption = "文件信息"
Height = 1455
Left = 240
TabIndex = 2
Top = 840
Width = 6375
Begin VB.Label Label6
Caption = "修改时间:"
Height = 255
Left = 240
TabIndex = 10
Top = 1080
Width = 6015
End
Begin VB.Label Label2
Caption = "文件名称:"
Height = 255
Left = 240
TabIndex = 4
Top = 720
Width = 6015
End
Begin VB.Label Label1
Caption = "文件大小: "
Height = 255
Left = 240
TabIndex = 3
Top = 360
Width = 6015
End
End
Begin VB.CommandButton findbutton
Caption = "查找"
Height = 375
Left = 7200
TabIndex = 1
Top = 4680
Width = 735
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 375
Left = 240
TabIndex = 0
Top = 360
Width = 6375
End
Begin MSDataListLib.DataCombo UserNameCombo
Height = 330
Left = 1080
TabIndex = 18
Top = 4800
Width = 2055
_ExtentX = 3625
_ExtentY = 582
_Version = 393216
Text = ""
End
Begin DWGTHUMBNAILLib.DwgThumbnail DwgThumbnail1
Height = 2895
Left = 6840
TabIndex = 21
Top = 480
Width = 3135
_Version = 131072
_ExtentX = 5530
_ExtentY = 5106
_StockProps = 225
BorderStyle = 1
End
Begin VB.Label Label11
Caption = "管理员密码"
Height = 255
Left = 3480
TabIndex = 20
Top = 4800
Width = 1335
End
Begin VB.Label Label10
Caption = "管理帐号"
Height = 375
Left = 240
TabIndex = 19
Top = 4800
Width = 1455
End
Begin VB.Label Label8
Caption = "输入文件名称"
Height = 255
Left = 240
TabIndex = 15
Top = 120
Width = 1815
End
Begin VB.Label Label7
Caption = "存储文件名称"
Height = 255
Left = 240
TabIndex = 13
Top = 2400
Width = 1455
End
Begin VB.Label Label9
Caption = "预览图"
Height = 255
Left = 6840
TabIndex = 17
Top = 120
Width = 1695
End
End
Attribute VB_Name = "dwgin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public copyfile As String
Public showfile As String
Public Fso As New FileSystemObject
Public savedrive As String
Public savedir As String
Public savesubdir As String
Public savename As String
Public file As file
Public fold As Folder
Public Drive As Drive
Public Root As Folder
Public savefile As String
Dim rsUSER As New ADODB.Recordset
Dim sqluser As String
Dim rsadmin As New ADODB.Recordset
Private Sub DwgThumbnail1_Click()
If savesubdir <> "\autocad\" Then 'DWG文件导入了，就更新预览图
MsgBox "非CAD图纸,不显示！", vbInformation '非CAD图纸,不显示，退出
Exit Sub
End If
viewprint.Show
If Fso.FileExists(showfile) = True Then
viewprint.DwgViewX1.DrawingFile = showfile
Else
copyfile = App.path & "\test.dwg"
viewprint.DwgViewX1.DrawingFile = showfile
End If
End Sub
Private Sub OKButton_Click()
Dim copyflag As String
If Trim(copyfile) = Empty Then
MsgBox lpCaption & "未选择输入文件!", vbOKOnly + vbInformation, "文件导入"
Exit Sub
End If
If Fso.FileExists(copyfile) = False Then
MsgBox lpCaption & "所选文件不存在!", vbOKOnly + vbInformation, "文件导入"
Exit Sub
End If
savedrive = Fso.GetDriveName(App.path)
If Fso.GetDrive(savedrive).FreeSpace < Fso.GetFile(copyfile).Size Then
MsgBox "目标驱动器空间不足！", vbCritical '目标驱动器空间不够，退出
Exit Sub
End If
savedir = App.path & savesubdir
If Fso.FolderExists(savedir) = False Then
Fso.CreateFolder savedir
End If
savefile = savedir & savename
If Fso.FileExists(savefile) = True Then
If MsgBox(savename & "文件已存在,不能导入,是否强行导入?", vbCritical + vbYesNo, "危险导入行为") = vbNo Then
Unload Me
Exit Sub
Else
sqluser = "SELECT * FROM adminstrator where key = '" & Trim(userPassword.Text) & "' AND Admin = '" & Trim(UserNameCombo.Text) & "' "
Set rsadmin = cn.Execute(sqluser)
If rsadmin.EOF Then
MsgBox "非管理员不得强行导入，退出！", vbCritical, "管理员密码错误" '退出
Unload Me
rsadmin.Close
Set rsadmin = Nothing
Exit Sub
End If
rsadmin.Close
Set rsadmin = Nothing
End If
End If
Fso.copyfile copyfile, savefile, True
MsgBox "文件导入完毕!", vbInformation + vbOKOnly, "文件导入Success"
If savesubdir = "\autocad\" Then 'DWG文件导入了，就更新预览图
dwgmanager.DwgThumbnail1.DwgFileName = savefile
dwgmanager.autocadText = savename
End If
If savesubdir = "\acrobat\" Then 'pdf文件导入了，就更新acroText内容
dwgmanager.acroText = savename
End If
If savesubdir = "\gg\" Then '更改文件导入了，就更新modText内容
dwgmanager.modText = savename
End If
Unload Me
End Sub
Private Sub findbutton_Click()
Dim copyfilename As String
Dim copyfilesize As String
'将 Cancel 设置成 True。
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
CommonDialog1.ShowOpen
copyfile = Trim(CommonDialog1.FileName)
If copyfile <> Empty Then
Text1.Text = copyfile
copyfilename = Dir(copyfile)
copyfilesize = FileLen(copyfile)
Set file = Fso.GetFile(copyfile)
nametxt.Text = savename
Frame1.Caption = "文件信息"
Label1.Caption = "文件大小: " & copyfilesize & " Byte " & Format(copyfilesize / 2 ^ 20, "0.00") & " M "
Label2.Caption = "文件名称: " & copyfilename
Label6.Caption = "修改时间: " & file.DateLastModified
showfile = copyfile
DwgThumbnail1.DwgFileName = showfile
End If
ErrHandler:
'用户按了“取消”按钮。
Exit Sub
End Sub
Private Sub exitbutton_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim driveno As String
MakeCenter dwgin
sqluser = "select * from adminstrator"
Call rsUSER.Open(sqluser, cn, adOpenKeyset, adLockOptimistic, -1)
Set UserNameCombo.RowSource = rsUSER
UserNameCombo.BoundColumn = "UseID"
UserNameCombo.ListField = "Admin"
UserNameCombo.BoundText = "1"
Frame2.Caption = App.Title + "的安装" + Frame2.Caption
driveno = Fso.GetDriveName(App.path)
Set Drive = Fso.GetDrive(driveno)
Label4.Caption = Label4.Caption & driveno & "\"
Label3.Caption = Label3.Caption & Drive.TotalSize & " Byte " & Format(Drive.TotalSize / 2 ^ 20, "0.00") & " M "
Label5.Caption = Label5.Caption & Drive.FreeSpace & " Byte " & Format(Drive.FreeSpace / 2 ^ 20, "0.00") & " M "
copyfile = App.path & "\test.dwg"
End Sub
Private Sub viewbutton_Click()
If savesubdir <> "\autocad\" Then 'DWG文件导入了，就更新预览图
MsgBox "非CAD图纸,不显示！", vbInformation '非CAD图纸,不显示，退出
Exit Sub
End If
viewprint.Show
If Fso.FileExists(showfile) = True Then
viewprint.DwgViewX1.DrawingFile = showfile
Else
showfile = App.path & "\test.dwg"
viewprint.DwgViewX1.DrawingFile = showfile
End If
End Sub
Private Sub userPassword_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = 13 Then OKButton_Click
End Sub
Private Sub UserNameCombo_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = 13 Then userPassword.SetFocus
End Sub
Private Sub Form_Unload(Cancel As Integer)
rsUSER.Close
Unload Me
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -