System Neden Hantallaştı

Katılım
9 Mart 2005
Mesajlar
5
İyi günler dileğiyle
Hocam Makrolarla bir proğram oluşturdum. Þimdi çalıştırıyorum bilgisayarımın canına okuyor.
Girişte AutoOpen var, formlarım var, Auto Close'de var bunların kodlarını tek tek inceledim ama hiç hata veren kod görmedim. başka bir olaydan dolayı olabilirmi? Hocam Kodlarım kafayı bozmak içten değil ben döngülerden şüpeleniyorum

'Wav dosyasını çalıştırmak için
Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'SeriNumarasını çalıştırmak için
Declare Function GetVolumeInformationA Lib "Kernel32" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, pMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
'Dosya çalıştırıldığında kendiliğinden çalışacak ilk makro
Sub auto_open()
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Worksheets("MDGiris").Range("D3") = Worksheets("MDGiris").Range("D3") + 1
Application.CommandBars("Standard").Visible = False
Application.CommandBars("Formatting").Visible = False
Application.CommandBars("Drawing").Visible = False
ActiveWorkbook.DisplayDrawingObjects = xlPlaceholders
ActiveSheet.DisplayAutomaticPageBreaks = False
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayOutline = False
.DisplayZeros = False
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = False
End With
With Application
.DisplayFormulaBar = False
.DisplayStatusBar = False
.DisplayCommentIndicator = 0
.ShowWindowsInTaskbar = False
End With
On Error Resume Next
Set eskimenu = CommandBars("worksheet Menu bar").Controls
For Each menuogesi In eskimenu
menuogesi.Visible = False
Next
CommandBars("Kendimenum").Delete
Dim Ctrl As Office.CommandBarControl
Set YenimenuCubugu = CommandBars.Add(Name:="Kendimenum", Position:=msoBarTop, MenuBar:=True, temporary:=True)
With YenimenuCubugu
.Visible = True
.Protection = msoBarNoMove
End With
' ******* FORMLAR **************
Set KONTROL = YenimenuCubugu.Controls.Add(Type:=msoControlPopup, ID:=1)
With KONTROL
.Caption = "<<<<<<<<<<<<<<<<<<<<<<<<<< MD-HASTANE PROÐRAMI Mustafa DELİBAL MDKurum@mynet.Com Cep : 0 543 682 4343 >>>>>>>>>>>>>>>>>>>>>>>>> "
End With
Dim SerialNumber As Long
GetVolumeInformationA "C:\", vbNullString, 0, _
SerialNumber, 0, 0, vbNullString, 0
Range("E3").Value = SerialNumber
Range("D1").Select
MDMenu.Show
End Sub

Sub Auto_close()
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Range("C3:C4,D4,E3:H4").Select
Selection.ClearContents
Range("C6").Select
With ActiveWindow
.DisplayGridlines = True
.DisplayHeadings = True
.DisplayOutline = True
.DisplayZeros = True
.DisplayWorkbookTabs = True
End With
ActiveSheet.DisplayAutomaticPageBreaks = True
With Application
.DisplayFormulaBar = True
.DisplayStatusBar = True
.ShowWindowsInTaskbar = True
End With
Application.CommandBars("Standard").Visible = True
Application.CommandBars("Formatting").Visible = True
On Error Resume Next
Set eskimenu = CommandBars("worksheet Menu bar").Controls
For Each menuogesi In eskimenu
menuogesi.Visible = True
Next
CommandBars("Kendimenum").Delete
ActiveWindow.Close False
End Sub

MDMenu Formunun Kodları

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Const WS_BORDER = &H800000
Private Const GWL_STYLE = (-16)

Private Sub UserForm_Initialize()
On Error GoTo hata
Windows("MDHastane.xls").Activate
On Error Resume Next
Sheets("MDGiris").Select
swflogo.Movie = ("C:\MDHastane\Art\MDLogo.swf")
Dim lngFormHwnd As Long, lngFormStyle As Long
Me.BorderStyle = fmBorderStyleNone
If Application.Version < 9 Then
lngFormHwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
lngFormHwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
lngFormStyle = GetWindowLong(lngFormHwnd, GWL_STYLE)
lngFormStyle = lngFormStyle And Not WS_BORDER
SetWindowLong lngFormHwnd, GWL_STYLE, lngFormStyle
DrawMenuBar lngFormHwnd
Lbornek.ControlSource = "E3"
hata:
End Sub

Private Sub cmdtamam_Click()
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Range("E4").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[-1]C="""","""",""MD-""&ROUNDDOWN(((R[-1]C/4050015)/10),0)*10)"
Range("C6:D7").Select
Range("F4").Value = Txtsifre.Text
If Range("E4").Value <> Range("F4").Value Then
baslik = " YANLIÞ ÞİFREYE GİRDİNİZ TEKRAR DENEYİNİZ "
aciklama = "Eğer şifrenizi unutmuşsanız veya karıştırıyorsanız fazla uğraşmadan" + Chr(13)
aciklama = aciklama + "Beni arayınız, eğer şifre almadıysanız Tanıtım Sürümünü kullanınız," + Chr(13)
aciklama = aciklama + "BU PROÐRAMI ÇOÐALTMAK, DAÐITMAK veya DEÐİÞTİRMEK S E R B E S T T İ R" + Chr(13)
aciklama = aciklama + " Mustafa DELİBAL İlçe Milli Eğitim Müdürlüğü KIRÞEHİR-AKPINAR" + Chr(13)
aciklama = aciklama + "İş Tel:0 386 4122226 Cep Tel: 0 543 682 4343 HAYIRLI İÞLER DİLEÐİYLE " + Chr(13)
MsgBox aciklama, , baslik
Application.Run "MDHastane.xls!Auto_close"
Else
MsgBox "ÞİFRENİZ DOÐRULANDI HAYIRLI İÞLER", , "BAÞARILAR"
Sheets("MDGiris").Select
Range("C3:C4,D4,E3:H4").Select
Selection.ClearContents
Range("C6").Select
Sheets("MDGiris").Select
Range("E10").Select
Unload MDMenu
End If
End Sub
Private Sub cmdtanitim_Click()
On Error GoTo hata
ChDir "C:\WINDOWS\HELP"
Workbooks.Open(Filename:="C:\WINDOWS\HELP\MDHast.xls").RunAutoMacros Which _
:=xlAutoOpen
Range("A1:A2").Select
Selection.Copy
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Windows("MDHast.xls").Activate
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Range("D4").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[-1]C[-1]="""","""",IF(R[-1]C="""","""",IF(R[-1]C[-1]>R[-1]C,R[-1]C[-1],R[-1]C)))"
If Range("D4").Value > Range("C4").Value Then
baslik = " ÜZGÜNÜM TANITIMI KULLANIM HAKKINIZ BİTMİÞTİR"
aciklama = aciklama + "ÇOÐALTMAK, DAÐITMAK veya DEÐİÞTİRMEK S E R B E S T T İ R " + Chr(13)
aciklama = aciklama + "Mustafa DELİBAL İlçe Milli Eğitim Müdürlüğü KIRÞEHİR-AKPINAR" + Chr(13)
aciklama = aciklama + "Telİş:0 386 4122226 Cep:0 543 682 4343 HAYIRLI İÞLER DİLEÐİYLE " + Chr(13)
MsgBox aciklama, , baslik
Application.Run "Auto_Close"
hata:
baslik = " YÜKLEMEDE EKSİK DOSYA VAR TAMAMLAYINIZ"
aciklama = aciklama + "Mustafa DELİBAL İlçe Milli Eğitim Müdürlüğü KIRÞEHİR-AKPINAR" + Chr(13)
aciklama = aciklama + "Telİş:0 386 4122226 Cep:0 543 682 4343 HAYIRLI İÞLER DİLEÐİYLE " + Chr(13)
MsgBox aciklama, , baslik
Application.Run "Auto_Close"
Exit Sub
Else
MsgBox "TANITIM PROÐRAM KULLANMAKTASINIZ", , "BAÞARILAR"
Windows("MDHastane.xls").Activate
Sheets("MDGiris").Select
Range("C3:C4,D4,E3:H4").Select
Selection.ClearContents
Range("C6").Select
Sheets("MDGiris").Select
Range("E10").Select
Unload MDMenu
End If
End Sub
Private Sub UserForm_Error(ByVal Number As Integer, ByVal Description As MSForms.ReturnString, ByVal SCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, ByVal CancelDisplay As MSForms.ReturnBoolean)
Application.Run "MDHastane.xls!Auto_close"
End Sub
Private Sub Cmdkapat_Click()
Application.Run "MDHastane.xls!auto_close"
End Sub
Private Sub txtsifre_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Txtsifre.BackColor = &HFFFFFF
End Sub
 
Üst