-
Notifications
You must be signed in to change notification settings - Fork 139
/
Copy pathMainForm.frm
2000 lines (1748 loc) · 74.6 KB
/
MainForm.frm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.2#0"; "MSCOMCTL.OCX"
Begin VB.Form FrmMain
Caption = "Vb6Tkinter https://github.com/cdhigh"
ClientHeight = 8130
ClientLeft = 45
ClientTop = 675
ClientWidth = 12975
BeginProperty Font
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "MainForm.frx":0000
LinkTopic = "Form1"
ScaleHeight = 542
ScaleMode = 3 'Pixel
ScaleWidth = 865
StartUpPosition = 2 '屏幕中心
Begin VB.ComboBox cmbEditCombo
CausesValidation= 0 'False
Height = 345
ItemData = "MainForm.frx":058A
Left = 7560
List = "MainForm.frx":058C
TabIndex = 11
Text = "Combo1"
Top = 720
Visible = 0 'False
Width = 1095
End
Begin VB.ComboBox cmbEditList
Height = 345
ItemData = "MainForm.frx":058E
Left = 6360
List = "MainForm.frx":0590
Style = 2 'Dropdown List
TabIndex = 12
Top = 720
Visible = 0 'False
Width = 1095
End
Begin Vb6Tkinter.xpcmdbutton CmdRefsFormsList
Height = 495
Left = 120
TabIndex = 0
Top = 120
Width = 2295
_ExtentX = 4048
_ExtentY = 873
Caption = "Refresh Forms(&R)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSComctlLib.StatusBar stabar
Align = 2 'Align Bottom
Height = 377
Left = 0
TabIndex = 10
Top = 7748
Width = 12974
_ExtentX = 22886
_ExtentY = 661
Style = 1
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Bevel = 0
Object.Width = 2687
MinWidth = 2687
EndProperty
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.ComboBox cmbFrms
Height = 345
ItemData = "MainForm.frx":0592
Left = 120
List = "MainForm.frx":0594
Style = 2 'Dropdown List
TabIndex = 5
Top = 840
Width = 2415
End
Begin VB.TextBox TxtTips
BeginProperty Font
Name = "Courier New"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2775
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 7
Top = 4920
Width = 2415
End
Begin VB.ListBox LstComps
Height = 3210
Left = 120
TabIndex = 6
Top = 1200
Width = 2415
End
Begin Vb6Tkinter.GridOcx LstCfg
Height = 6855
Left = 2640
TabIndex = 8
Top = 840
Width = 6015
_ExtentX = 10610
_ExtentY = 12091
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.TextBox TxtCode
BeginProperty Font
Name = "Courier New"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 6855
Left = 8760
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 9
Top = 840
Width = 4095
End
Begin Vb6Tkinter.xpcmdbutton CmdGenCode
Height = 495
Left = 2760
TabIndex = 1
Top = 120
Width = 2295
_ExtentX = 4048
_ExtentY = 873
Caption = "Generate Code(&G)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Vb6Tkinter.xpcmdbutton CmdCopyToClipboard
Height = 495
Left = 5340
TabIndex = 2
Top = 120
Width = 2295
_ExtentX = 4048
_ExtentY = 873
Caption = "Copy to Clipboard(&C)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Vb6Tkinter.xpcmdbutton CmdSaveToFile
Height = 495
Left = 7950
TabIndex = 3
Top = 120
Width = 2295
_ExtentX = 4048
_ExtentY = 873
Caption = "Save to File(&F)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Vb6Tkinter.xpcmdbutton CmdQuit
Height = 495
Left = 10560
TabIndex = 4
Top = 120
Width = 2295
_ExtentX = 4048
_ExtentY = 873
Caption = "Quit(&Q)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Courier New"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Menu mnuFile
Caption = "File(&F)"
Begin VB.Menu mnuRefreshForms
Caption = "Refresh Forms(&R)"
Shortcut = ^R
End
Begin VB.Menu mnuSeparator1
Caption = "-"
End
Begin VB.Menu mnuGenCode
Caption = "Generate Code(&G)"
Shortcut = ^G
End
Begin VB.Menu mnuSeparator10
Caption = "-"
End
Begin VB.Menu mnuSaveToFile
Caption = "Save Code to File(&F)"
Begin VB.Menu mnuSaveAll
Caption = "Save All Code(&A)"
End
Begin VB.Menu mnuSaveUiOnly
Caption = "Save Class UI Only(&G)"
End
End
Begin VB.Menu mnuCopyToClipboard
Caption = "Copy Code To Clipboard(&C)"
Begin VB.Menu mnuCopyToClipAll
Caption = "Copy All Code(&A)"
End
Begin VB.Menu mnuCopyToClipUiOnly
Caption = "Copy Class UI Only(&G)"
End
End
Begin VB.Menu mnuSeparator2
Caption = "-"
End
Begin VB.Menu mnuAddProperty
Caption = "Add One Property(&P)"
End
Begin VB.Menu mnuSeparator3
Caption = "-"
End
Begin VB.Menu mnuQuit
Caption = "Quit(&Q)"
End
End
Begin VB.Menu mnuOptions
Caption = "Options(&O)"
Begin VB.Menu mnuV2andV3Code
Caption = "Compatible Code for Python 2.x/3.x(&C)"
End
Begin VB.Menu mnuUseTtk
Caption = "Use TTK Themed Library(&T)"
Checked = -1 'True
End
Begin VB.Menu mnuRelPos
Caption = "Use Relative Position(&R)"
Checked = -1 'True
End
Begin VB.Menu mnuI18n
Caption = "Support i18n(&I)"
End
Begin VB.Menu mnuUnicodePrefixU
Caption = "Add A Prefix 'u' to Unicode String(&U)"
End
Begin VB.Menu mnuSeparator5
Caption = "-"
End
Begin VB.Menu mnuPythonExe
Caption = "Set diretory of python.exe(&E)..."
End
End
Begin VB.Menu mnuTools
Caption = "Tools(&T)"
Begin VB.Menu mnuPreview
Caption = "Preview(&P)"
Enabled = 0 'False
Shortcut = {F5}
End
Begin VB.Menu mnuEncodeAFile
Caption = "Encode File to Base64(&B)"
End
Begin VB.Menu mnuSeparator6
Caption = "-"
End
Begin VB.Menu mnuCheckUpdate
Caption = "Check Update(&U)"
End
Begin VB.Menu mnuAbout
Caption = "About(&A)"
End
End
Begin VB.Menu mnuLanguage
Caption = "Language(&L)"
Begin VB.Menu mnuLng
Caption = "English(&E)"
Index = 0
End
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public mConnect As Connect
'2012.11.23，为了滚动条和列表框的绑定方便，将其修改为全局变量g_Comps，放在Common.bas中
'Private m_Comps() As Object '和LstComps行数一样多，对应各组件生成的实例
Private m_MainMenu As clsMenu '菜单对象
Private m_PrevCompIdx As Long
Private m_curFrm As Object
Private m_prevsf As String
Private m_nLngNum As Long ' 语言种类
Private m_HasCommonDialog As Boolean
Private m_saTmpFile() As String
Private m_TxtCodeExpanded As Boolean
Private m_TxtTipsExpanded As Boolean
Private m_BriefCaption As String
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Sub Form_Load()
Dim s As String
ReDim g_Comps(0) As Object
g_AppVerString = App.Major & "." & App.Minor & IIf(App.Revision > 0, "." & App.Revision, "")
g_DefaultFontName = ""
m_HasCommonDialog = False
m_TxtCodeExpanded = False
m_TxtTipsExpanded = False
ReDim m_saTmpFile(0) As String
'多语种支持
InitMultiLanguage
LstCfg.Redraw = False
LstCfg.Editable = True
LstCfg.EditType = EnterKey Or MouseDblClick Or F2Key
LstCfg.CheckBoxes = True
LstCfg.AddColumn "Property", 2260, lgAlignCenterCenter
LstCfg.AddColumn "Value", 3450, lgAlignCenterCenter
LstCfg.ColAlignment(0) = lgAlignLeftCenter
LstCfg.ColAlignment(1) = lgAlignLeftCenter
LstCfg.SelectBackColor = &HFCC597 'vbHighlight
LstCfg.Redraw = True
m_BriefCaption = "Vb6Tkinter v" & g_AppVerString
#If DebugVer Then
m_BriefCaption = m_BriefCaption & " [Debug Mode] "
#End If
Me.Caption = m_BriefCaption
mnuV2andV3Code.Checked = GetSetting(App.Title, "Settings", "V2andV3Code", "0") = "1"
mnuUseTtk.Checked = GetSetting(App.Title, "Settings", "UseTtk", "1") = "1"
mnuRelPos.Checked = GetSetting(App.Title, "Settings", "RelPos", "1") = "1"
mnuI18n.Checked = GetSetting(App.Title, "Settings", "i18n", "1") = "1"
mnuUnicodePrefixU.Checked = GetSetting(App.Title, "Settings", "UnicodePrefix", "0") = "1"
g_bUnicodePrefixU = mnuUnicodePrefixU.Checked
g_PythonExe = GetSetting(App.Title, "Settings", "PythonExe", "")
Set cmbEditList.Font = LstCfg.Font
Set cmbEditCombo.Font = LstCfg.Font
ResizeInit Me
CmdRefsFormsList_Click
End Sub
'多语种支持初始化
Private Sub InitMultiLanguage()
Dim I As Long, s As String, sa() As String
If Not LngFileExist() Then
m_nLngNum = 0
mnuLng(0).Checked = True
Exit Sub
End If
sa = GetAllLanguageName()
mnuLng(0).Caption = sa(0)
m_nLngNum = 1
For I = 1 To UBound(sa)
Load mnuLng(I)
mnuLng(I).Caption = sa(I)
m_nLngNum = m_nLngNum + 1
Next
'切换语言，注册表保存的语言优先，其次根据操作系统选择
s = GetSetting(App.Title, "Settings", "Language", "")
I = m_nLngNum
If Len(s) Then '选择之前保存的语言种类，如果存在的话
For I = 0 To m_nLngNum - 1
If mnuLng(I).Caption = s Then
ChangeLanguage (mnuLng(I).Caption)
mnuLng(I).Checked = True
Exit For
End If
Next
End If
'尝试判断操作系统语种
If I > m_nLngNum - 1 Then
I = GetSystemDefaultLCID()
If I = &H804 Or I = &H4 Or I = &H1004 Then
s = "简体中文"
ElseIf I = &H404 Or I = &HC04 Then
s = "繁體中文"
ElseIf I Mod 16 = 9 Then
s = "English"
Else '其他语言先按英语处理，待软件启动后用户再选择合适的语言
s = "English"
End If
For I = 0 To m_nLngNum - 1
If InStr(1, mnuLng(I).Caption, s) > 0 Then
ChangeLanguage (mnuLng(I).Caption)
mnuLng(I).Checked = True
Exit For
End If
Next
' 无法自动确认语种，默认选择第一个
If I > m_nLngNum - 1 Then
ChangeLanguage (mnuLng(0).Caption)
mnuLng(0).Checked = True
End If
End If
End Sub
Private Sub CmdQuit_Click()
mConnect.Hide
End Sub
Private Sub cmbFrms_Click()
Dim frm As Object
'查找到对应的窗体引用
Set m_curFrm = Nothing
If Len(cmbFrms.Text) Then
For Each frm In VbeInst.ActiveVBProject.VBComponents
If frm.Type = vbext_ct_VBForm And frm.Name = cmbFrms.Text Then
Set m_curFrm = frm
Exit For
End If
Next
End If
m_PrevCompIdx = -1
'将控件添加到列表
If Not ResetLstComps(m_curFrm) Then
LstComps.Clear
LstCfg.Clear
TxtTips.Text = L("l_TipHasNoControl", "Has no control on Form, please add at least one control on it.")
m_PrevCompIdx = -1
Else
LstComps.ListIndex = 0
LstComps_Click
End If
If LstComps.ListCount > 0 Then
CmdGenCode.Enabled = True
CmdCopyToClipboard.Enabled = True
CmdSaveToFile.Enabled = True
mnuSaveToFile.Enabled = True
mnuCopyToClipboard.Enabled = True
mnuAddProperty.Enabled = True
mnuGenCode.Enabled = True
Else
CmdGenCode.Enabled = False
CmdCopyToClipboard.Enabled = False
CmdSaveToFile.Enabled = False
mnuSaveToFile.Enabled = False
mnuCopyToClipboard.Enabled = False
mnuAddProperty.Enabled = False
mnuGenCode.Enabled = False
End If
End Sub
Private Sub CmdCopyToClipboard_Click()
Me.PopupMenu mnuCopyToClipboard
End Sub
'更新各个列表，创建对应的控件类实例, 返回False表示初始化失败，True表示成功
Private Function ResetLstComps(frm As Object) As Long
Dim Obj As Object, ObjClsModule As Object, I As Long, s As String, j As Long, idx As Long
Dim nScaleMode As Long, nScaleWidth As Long, nScaleHeight As Long
Dim CodeMember As Member, CodeMembers As Members, dMethods As New Dictionary
Dim ctlsIgnored As String
ResetLstComps = False
If frm Is Nothing Then Exit Function
LstComps.Clear
'Erase g_Comps
Set m_MainMenu = Nothing
'创建窗体实例做为列表第一项
ReDim g_Comps(0) As Object
Set g_Comps(0) = New clsForm
'因为ScaleX/ScaleY为窗体类独有方法，只能先在这里转换窗体大小为像素单位
nScaleWidth = Round(ScaleX(frm.Properties("ScaleWidth"), frm.Properties("ScaleMode"), vbPixels))
nScaleHeight = Round(ScaleY(frm.Properties("ScaleHeight"), frm.Properties("ScaleMode"), vbPixels))
g_Comps(0).InitConfig frm, nScaleWidth, nScaleHeight, dMethods
g_Comps(0).Name = WTOP
LstComps.AddItem g_Comps(0).Name & " (Form)"
I = 1
m_HasCommonDialog = False
'获取窗体的代码模块中所有的过程函数列表，保存为一个字典对象，传入各类模块，用于自动生成对应的bindcommand
If Not frm.CodeModule Is Nothing Then
Set CodeMembers = frm.CodeModule.Members
If Not CodeMembers Is Nothing Then
For Each CodeMember In CodeMembers
If CodeMember.Type = vbext_mt_Method Then
idx = InStrRev(CodeMember.Name, "_")
If idx > 1 Then
s = Left$(CodeMember.Name, idx - 1)
If dMethods.Exists(s) Then
dMethods.Item(s) = dMethods.Item(s) & "," & CodeMember.Name & "," '使用逗号做为分隔符方便查找
Else
dMethods.Item(s) = "," & CodeMember.Name & ","
End If
End If
End If
Next
End If
End If
'将控件添加到列表中
For Each Obj In frm.Designer.VBControls
CreateObj Obj, ObjClsModule '生成对应类模块实例
If Not ObjClsModule Is Nothing Then
'用于自动单位转换，需要在InitConfig之前设置这个值
ObjClsModule.ScaleMode = frm.Properties("ScaleMode")
'如果窗体存在菜单控件，则创建主菜单对象，主菜单控件将管理所有的菜单项
If Obj.ClassName = "Menu" And m_MainMenu Is Nothing Then
ReDim Preserve g_Comps(I) As Object
Set m_MainMenu = New clsMenu
Set g_Comps(I) = m_MainMenu
LstComps.AddItem m_MainMenu.Name & " (MainMenu)"
m_MainMenu.InitConfig
I = I + 1
End If
'添加控件到控件列表
ReDim Preserve g_Comps(I) As Object
Set g_Comps(I) = ObjClsModule
LstComps.AddItem Obj.Properties("Name") & " (" & Obj.ClassName & ")"
'初始化各控件对应的类模块对象
If Obj.Container Is frm.Designer Then
g_Comps(I).Parent = IIf(Obj.ClassName = "Menu", "MainMenu", WTOP)
g_Comps(I).InitConfig Obj, frm.Properties("ScaleWidth"), frm.Properties("ScaleHeight"), dMethods
ElseIf Obj.Container.ClassName = "Menu" Then '子菜单
g_Comps(I).Parent = Obj.Container.Properties("Name")
g_Comps(I).InitConfig Obj, 0, 0, dMethods
Else
On Error Resume Next
nScaleMode = Obj.Container.Properties("ScaleMode")
nScaleWidth = Obj.Container.Properties("ScaleWidth")
nScaleHeight = Obj.Container.Properties("ScaleHeight")
If Err.Number Then 'Frame和个别其他容器不支持ScaleWidth属性，则使用Width代替
nScaleMode = vbTwips
nScaleWidth = Me.ScaleX(Obj.Container.Properties("Width"), frm.Properties("ScaleMode"), vbTwips)
nScaleHeight = Me.ScaleY(Obj.Container.Properties("Height"), frm.Properties("ScaleMode"), vbTwips)
End If
Err.Clear
On Error GoTo 0
g_Comps(I).ScaleMode = nScaleMode
g_Comps(I).Parent = Obj.Container.Properties("Name")
g_Comps(I).InitConfig Obj, nScaleWidth, nScaleHeight, dMethods
End If
I = I + 1
ResetLstComps = True
ElseIf Obj.ClassName = "CommonDialog" Then
m_HasCommonDialog = True
ElseIf Len(ctlsIgnored) = 0 Or InStr(1, ctlsIgnored, Obj.ClassName & ",") <= 0 Then
If MsgBox(L_F("l_msgCtlNotSupport", "The addin not support '{0}' control (Name:{1}).\n\nIt will not be processed.\n\n'Ok' to continue.\n'Cancel' for ignoring controls of same type.", _
Obj.ClassName, Obj.Properties("Name")), vbInformation + vbOKCancel, App.Title) = vbCancel Then
ctlsIgnored = ctlsIgnored & Obj.ClassName & ","
End If
End If
Next 'frm.Designer.VBControls
'生成菜单的树形层次关系，为生成代码建立基础
CreateMenuHiberarchy
'整理Notebook和其各页签内控件的父子关系
ArrangeNotebookAndSubWidgets
'尝试自动将滚动条绑定到对应的控件
TryAssignScrollbar2Widgets
'正确设置ComboboxAdapter的TTK属性
For I = 1 To UBound(g_Comps)
If TypeName(g_Comps(I)) = "clsComboboxAdapter" Then g_Comps(I).TTK = mnuUseTtk.Checked
Next
End Function
'生成一个控件字符实例对象:输入ctlobj:控件对象，clsobj:对应的字符串对象
Private Function CreateObj(ByRef ctlobj As Object, ByRef clsobj As Object) As Object
Dim o As Object, sName As String, idx As Long
Select Case ctlobj.ClassName:
Case "Label"
Set clsobj = New clsLabel
Case "CommandButton"
Set clsobj = New clsButton
Case "TextBox"
If ctlobj.Properties("MultiLine") Then Set clsobj = New clsText Else Set clsobj = New clsEntry
Case "CheckBox"
Set clsobj = New clsCheckbutton
Case "OptionButton"
Set clsobj = New clsRadiobutton
Case "ComboBox"
Set clsobj = New clsComboboxAdapter
clsobj.TTK = mnuUseTtk.Checked
Case "ListBox"
Set clsobj = New clsListbox
Case "HScrollBar", "VScrollBar"
Set clsobj = New clsScrollbar
Case "Slider"
Set clsobj = New clsScale
Case "Frame"
'判断是否是TabStrip控件的一页
idx = InStr(2, ctlobj.Properties("Name"), "__Tab") '从2开始至少保证__Tab前有一个字符
If idx > 1 And Not m_curFrm Is Nothing Then
'循环查询是否有合适的TabStrip控件
Set clsobj = Nothing
sName = Left$(ctlobj.Properties("Name"), idx - 1)
For Each o In m_curFrm.Designer.VBControls
If o.ClassName = "TabStrip" And o.Properties("Name") = sName Then
Set clsobj = New clsNotebookTab '使用Tab类来代替Frame
Exit For
End If
Next
If clsobj Is Nothing Then Set clsobj = New clsLabelFrame '没有对应的TabStrip对象
Else
Set clsobj = New clsLabelFrame
End If
Case "PictureBox"
'判断是否是TabStrip控件的一页
idx = InStr(2, ctlobj.Properties("Name"), "__Tab") '从2开始至少保证__Tab前有一个字符
If idx > 1 And Not m_curFrm Is Nothing Then
'循环查询是否有合适的TabStrip控件
Set clsobj = Nothing
sName = Left$(ctlobj.Properties("Name"), idx - 1)
For Each o In m_curFrm.Designer.VBControls
If o.ClassName = "TabStrip" And o.Properties("Name") = sName Then
Set clsobj = New clsNotebookTab '使用Tab类来代替PictureBox
Exit For
End If
Next
If clsobj Is Nothing Then Set clsobj = New clsCanvas '没有对应的TabStrip对象
Else
Set clsobj = New clsCanvas
End If
Case "Menu"
Set clsobj = New clsMenuItem
Case "ProgressBar"
Set clsobj = New clsProgressBar '需要启用TTK才支持
mnuUseTtk.Checked = True
Case "TreeView"
Set clsobj = New clsTreeview '需要启用TTK才支持
mnuUseTtk.Checked = True
Case "TabStrip"
Set clsobj = New clsNotebook '需要启用TTK才支持
mnuUseTtk.Checked = True
Case "Line"
Set clsobj = New clsSeparator
mnuUseTtk.Checked = True
Case "StatusBar"
Set clsobj = New clsStatusbar
Case Else:
Set clsobj = Nothing
End Select
Set CreateObj = clsobj
End Function
'生成菜单的树形层次关系，为生成代码建立基础
'子类储存父类的名字，父类储存所有子类的引用
Private Sub CreateMenuHiberarchy()
Dim I As Long, j As Long
If Not m_MainMenu Is Nothing Then
For I = 0 To UBound(g_Comps)
If TypeName(g_Comps(I)) = "clsMenu" Then
'将所有的顶层菜单做为clsMenu的子控件
For j = 0 To UBound(g_Comps)
If TypeName(g_Comps(j)) = "clsMenuItem" And g_Comps(j).Parent = "MainMenu" Then
g_Comps(I).AddChild g_Comps(j)
End If
Next
ElseIf TypeName(g_Comps(I)) = "clsMenuItem" Then
'子菜单有可能还有子菜单
For j = 0 To UBound(g_Comps)
If TypeName(g_Comps(j)) = "clsMenuItem" And g_Comps(j).Parent = g_Comps(I).Name Then
g_Comps(I).AddChild g_Comps(j)
End If
Next
End If
Next
End If
End Sub
'整理选项卡控件和其内部控件的父子关系
Private Sub ArrangeNotebookAndSubWidgets()
Dim I As Long, j As Long, k As Long, L As Long, idx As Long, ctlNum As Long
Dim sTabName As String, sNbName As String, sTmp As String
If UBound(g_Comps) <= 0 Then ' 0固定为顶层窗体
Exit Sub
End If
ctlNum = UBound(g_Comps)
For I = 1 To ctlNum
If TypeName(g_Comps(I)) = "clsNotebookTab" Then
sTabName = g_Comps(I).Name
idx = InStr(2, sTabName, "__Tab")
If idx > 1 Then
sNbName = Left$(sTabName, idx - 1) ' Notebook控件名
For j = 1 To ctlNum
If TypeName(g_Comps(j)) = "clsNotebook" And g_Comps(j).Name = sNbName Then
'获取TAB号
sTmp = Right$(sTabName, 1)
If sTmp >= "1" And sTmp <= "9" Then '最多支持9个标签页
g_Comps(j).AddTab g_Comps(I), CLng(sTmp) ' 加入Notebook对象
g_Comps(I).EnableOutByMainForm = False
'此标签页内所有控件均有clsNotebookTab来接管，不再由主窗口输出代码
For k = 1 To ctlNum
If g_Comps(k).Parent = sTabName Then
g_Comps(k).EnableOutByMainForm = False
g_Comps(I).AddSubWidget g_Comps(k)
' 万一标签页内还有其他容器控件
If TypeName(g_Comps(k)) = "clsCanvas" Or TypeName(g_Comps(k)) = "clsLabelFrame" Then
For L = 1 To ctlNum
If g_Comps(L).Parent = g_Comps(k).Name Then
g_Comps(L).EnableOutByMainForm = False
g_Comps(I).AddSubWidget g_Comps(L)
End If
Next
End If
End If
Next
End If
End If
Next
End If
End If
Next
End Sub
'进行一些分析，尝试将滚动条自动绑定到合适的控件，不一定成功，而且可能误判，只算是尽力而为
Private Sub TryAssignScrollbar2Widgets()
Dim I As Long, ctlNum As Long, Obj As Object, o As Object, oName As String
Dim vX1 As Long, vY1 As Long, vX2 As Long, vY2 As Long
Dim oX1 As Long, oY1 As Long, oX2 As Long, oY2 As Long
Dim thresholdX1 As Long, thresholdY1 As Long
Dim thresholdX2 As Long, thresholdY2 As Long
Dim isWidgetScrl As Boolean, Assigned As Boolean
If UBound(g_Comps) <= 0 Or m_curFrm Is Nothing Then ' 0固定为顶层窗体
Exit Sub
End If
'水平方向和垂直方向都使用20个像素做为查找控件的门限
thresholdX1 = Round(ScaleX(20, vbPixels, m_curFrm.Properties("ScaleMode")))
thresholdY1 = Round(ScaleY(20, vbPixels, m_curFrm.Properties("ScaleMode")))
thresholdX2 = Round(ScaleX(5, vbPixels, m_curFrm.Properties("ScaleMode"))) '5个像素是允许控件和滚动条重叠的部分
thresholdY2 = Round(ScaleY(5, vbPixels, m_curFrm.Properties("ScaleMode")))
ctlNum = UBound(g_Comps)
For Each Obj In m_curFrm.Designer.VBControls
If Obj.ClassName = "HScrollBar" Then
'水平滚动条，则判断其上方有没有需要设置滚动条的控件
'vX1,vY1,vX2,vY2构成一个矩形，如果其他控件的左下角和右下角落在这个矩形内，则认为滚动条对应
vX1 = Obj.Properties("Left") - thresholdX1
If vX1 < 0 Then vX1 = 0
vY1 = Obj.Properties("Top") - thresholdY1
If vY1 < 0 Then vY1 = 0
vX2 = Obj.Properties("Left") + Obj.Properties("Width") + thresholdX1
vY2 = Obj.Properties("Top") + thresholdY2
Assigned = False
For Each o In m_curFrm.Designer.VBControls
If (o.Container Is Obj.Container) And _
InStr(1, "PictureBox,ListBox,TreeView,TextBox,", o.ClassName & ",") > 0 Then '只有这些控件可能需要滚动条
isWidgetScrl = True
If o.ClassName = "TextBox" Then '只有多行文本框才支持滚动
If Not o.Properties("MultiLine") Then
isWidgetScrl = False
End If
End If
If isWidgetScrl Then
oX1 = o.Properties("Left")
oY1 = o.Properties("Top") + o.Properties("Height")
oX2 = oX1 + o.Properties("Width")
oY2 = oY1
'第一行为左下角判断，第二行为右下角判断
If (oX1 >= vX1 And oX1 <= vX2 And oY1 >= vY1 And oY1 <= vY2) _
And (oX2 >= vX1 And oX2 <= vX2 And oY2 >= vY1 And oY2 <= vY2) Then
'设置控件的xscrollcommand属性
oName = o.Properties("Name")
For I = 1 To ctlNum
If g_Comps(I).Name = oName Then
g_Comps(I).SetSingleConfig ("xscrollcommand|" & Obj.Properties("Name") & ".set")
Assigned = True
Debug.Print oName & " assigned to " & Obj.Properties("name")
Exit For
End If
Next
End If
End If
End If
If Assigned Then
Exit For
End If
Next
ElseIf Obj.ClassName = "VScrollBar" Then
'垂直滚动条，则判断其左方有没有需要设置滚动条的控件
'vX1,vY1,vX2,vY2构成一个矩形，如果其他控件的右上角和右下角落在这个矩形内，则认为滚动条对应
vX1 = Obj.Properties("Left") - thresholdX1
If vX1 < 0 Then vX1 = 0
vY1 = Obj.Properties("Top") - thresholdY1
If vY1 < 0 Then vY1 = 0
vX2 = Obj.Properties("Left") + thresholdX2
vY2 = Obj.Properties("Top") + Obj.Properties("Height") + thresholdY1
Assigned = False
For Each o In m_curFrm.Designer.VBControls
If (o.Container Is Obj.Container) And _
InStr(1, "PictureBox,ListBox,TreeView,TextBox,", o.ClassName & ",") > 0 Then '只有这些控件可能需要滚动条
isWidgetScrl = True
If o.ClassName = "TextBox" Then '只有多行文本框才支持滚动
If Not o.Properties("MultiLine") Then
isWidgetScrl = False
End If
End If
If isWidgetScrl Then
oX1 = o.Properties("Left") + o.Properties("Width")
oY1 = o.Properties("Top")
oX2 = oX1
oY2 = oY1 + o.Properties("Height")
'第一行为右上角判断，第二行为右下角判断
If (oX1 >= vX1 And oX1 <= vX2 And oY1 >= vY1 And oY1 <= vY2) _
And (oX2 >= vX1 And oX2 <= vX2 And oY2 >= vY1 And oY2 <= vY2) Then
'设置控件的yscrollcommand属性
oName = o.Properties("Name")
For I = 1 To ctlNum
If g_Comps(I).Name = oName Then
g_Comps(I).SetSingleConfig ("yscrollcommand|" & Obj.Properties("Name") & ".set")
Debug.Print oName & " assigned to " & Obj.Properties("name")
Assigned = True
Exit For
End If
Next
End If
End If
End If
If Assigned Then
Exit For
End If
Next
End If
Next
End Sub
'创建代码
Private Sub CmdGenCode_Click()
Dim I As Long, cnt As Long, o As Object, sysImport As String
Dim strHead As New cStrBuilder, strOut As New cStrBuilder, strCmd As New cStrBuilder, strI18n As New cStrBuilder, strTmp As New cStrBuilder
Dim s As String, finalCode As String, sF As String
Dim OutOnlyV3 As Boolean, OutRelPos As Boolean, i18n As Boolean, usettk As Boolean
Dim bUnicodePrefix As Boolean '临时保存UNICODE前缀方式
Dim aCompsSorted() As Object '用于排序的代码输出
If LstComps.ListCount = 0 Or LstCfg.ItemCount = 0 Or m_curFrm Is Nothing Then
Exit Sub
End If
On Error Resume Next
s = m_curFrm.Name
If Err.Number Then
If MsgBox(L("l_msgGetAttrOfFrmFailed", "Failed in getting property of the form, please reopen the vb project and retry.\nRefresh list of forms now?"), vbInformation + vbYesNo) = vbYes Then
CmdRefsFormsList_Click
End If
Exit Sub
End If
Err.Clear
On Error GoTo 0
OutOnlyV3 = Not mnuV2andV3Code.Checked
OutRelPos = mnuRelPos.Checked
i18n = mnuI18n.Checked
usettk = mnuUseTtk.Checked
'绝对坐标BUG提示
' If Not OutRelPos And m_curFrm.Properties("ScaleMode") <> vbTwips Then
' '如果使用绝对坐标，则Frame控件仅支持vbTwips模式
' For Each o In m_curFrm.Designer.VBControls
' If o.ClassName = "Frame" Then
' MsgBox L("l_msgFrameNotSupportInAbs", "The control 'Frame' is not support when menu 'Use Relative Position' unchecked."), vbInformation
' Exit Sub
' End If
' Next
' End If
'
bUnicodePrefix = g_bUnicodePrefixU '先暂存，在函数最后恢复
If OutOnlyV3 Then
g_bUnicodePrefixU = False 'V3模式下不需要任何前缀
End If
'在输出代码前先更新一下当前显示的数据
UpdateCfgtoCls LstComps.ListIndex
sysImport = IIf(i18n, "import os, sys, gettext", "import os, sys")
If OutOnlyV3 Then '输出仅针对PYTHON 3.X的代码
strHead.Append "#!/usr/bin/env python3"
strHead.Append "#-*- coding:utf-8 -*-" & vbCrLf
strHead.Append sysImport
strHead.Append "from tkinter import *"
strHead.Append "from tkinter.font import Font"
If usettk Then strHead.Append "from tkinter.ttk import *"
strHead.Append "#Usage:showinfo/warning/error,askquestion/okcancel/yesno/retrycancel"